Context Navigation

source: branches/publications/ORCHIDEE-ICE_SurfaceMassBalance/src_sechiba/routing.f90 @ 8398

Last change on this file since 8398 was 4281, checked in by josefine.ghattas, 7 years ago
Added comments and headings to sechiba_io_p module and subroutines The subrouine i22setvar_p was removed from sechiab_io_p. It was never used and it seems to contain errors. Change to use module sechiba_io_p directly to acces setvar_p interface. Removed sechiba_io module. The subroutines in here was never used. The module was only used to acces the module sechiba_io_p.
Property svn:keywords set to `Revision Date HeadURL Date Author Revision`
File size: 372.2 KB

Line
1	! =================================================================================================================================
2	! MODULE : routing
3	!
4	! CONTACT : orchidee-help _at_ ipsl.jussieu.fr
5	!
6	! LICENCE : IPSL (2006)
7	! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
8	!
9	!>\BRIEF This module routes the water over the continents into the oceans and computes the water
10	!! stored in floodplains or taken for irrigation.
11	!!
12	!!\n DESCRIPTION: None
13	!!
14	!! RECENT CHANGE(S): None
15	!!
16	!! REFERENCE(S) :
17	!!
18	!! SVN :
19	!! $HeadURL$
20	!! $Date$
21	!! $Revision$
22	!! \n
23	!_ ================================================================================================================================
24	!
25	!
26	! Histoire Salee
27	!---------------
28	! La douce riviere
29	! Sortant de son lit
30	! S'est jetee ma chere
31	! dans les bras mais oui
32	! du beau fleuve
33	!
34	! L'eau coule sous les ponts
35	! Et puis les flots s'emeuvent
36	! - N'etes vous pas au courant ?
37	! Il parait que la riviere
38	! Va devenir mer
39	! Roland Bacri
40	!
41
42
43	MODULE routing
44
45	USE ioipsl
46	USE xios_orchidee
47	USE ioipsl_para
48	USE constantes
49	USE constantes_soil
50	USE pft_parameters
51	USE sechiba_io_p
52	USE interpol_help
53	USE grid
54	USE mod_orchidee_para
55
56
57	IMPLICIT NONE
58	PRIVATE
59	PUBLIC :: routing_main, routing_initialize, routing_finalize, routing_clear
60
61	!! PARAMETERS
62	INTEGER(i_std), PARAMETER :: nbasmax=5 !! The maximum number of basins we wish to have per grid box (truncation of the model) (unitless)
63	INTEGER(i_std), SAVE :: nbvmax !! The maximum number of basins we can handle at any time during the generation of the maps (unitless)
64	!$OMP THREADPRIVATE(nbvmax)
65	REAL(r_std), PARAMETER :: slow_tcst_cwrr = 25.0 !! Property of the slow reservoir, when CWRR hydrology is activated (day/m)
66	REAL(r_std), PARAMETER :: fast_tcst_cwrr = 3.0 !! Property of the fast reservoir, when CWRR hydrology is activated (day/m)
67	REAL(r_std), PARAMETER :: stream_tcst_cwrr = 0.24 !! Property of the stream reservoir, when CWRR hydrology is activated (day/m)
68	REAL(r_std), PARAMETER :: flood_tcst_cwrr = 4.0 !! Property of the floodplains reservoir, when CWRR hydrology is activated (day/m)
69	REAL(r_std), PARAMETER :: swamp_cst_cwrr = 0.2 !! Fraction of the river transport that flows to the swamps, when CWRR hydrology is activated (unitless;0-1)
70	!
71	REAL(r_std), PARAMETER :: slow_tcst_chois = 25.0 !! Property of the slow reservoir, when Choisnel hydrology is activated (day/m)
72	REAL(r_std), PARAMETER :: fast_tcst_chois = 3.0 !! Property of the fast reservoir, when Choisnel hydrology is activated (day/m)
73	REAL(r_std), PARAMETER :: stream_tcst_chois = 0.24 !! Property of the stream reservoir, when Choisnel hydrology is activated (day/m)
74	REAL(r_std), PARAMETER :: flood_tcst_chois = 4.0 !! Property of the floodplains reservoir, when Choisnel hydrology is activated (day/m)
75	REAL(r_std), PARAMETER :: swamp_cst_chois = 0.2 !! Fraction of the river transport that flows to the swamps, when Choisnel hydrology is activated (unitless;0-1)
76	!
77	REAL(r_std), SAVE :: fast_tcst !! Property of the fast reservoir, (day/m)
78	!$OMP THREADPRIVATE(fast_tcst)
79	REAL(r_std), SAVE :: slow_tcst !! Property of the slow reservoir, (day/m)
80	!$OMP THREADPRIVATE(slow_tcst)
81	REAL(r_std), SAVE :: stream_tcst !! Property of the stream reservoir, (day/m)
82	!$OMP THREADPRIVATE(stream_tcst)
83	REAL(r_std), SAVE :: flood_tcst !! Property of the floodplains reservoir, (day/m)
84	!$OMP THREADPRIVATE(flood_tcst)
85	REAL(r_std), SAVE :: swamp_cst !! Fraction of the river transport that flows to the swamps (unitless;0-1)
86	!$OMP THREADPRIVATE(swamp_cst)
87	!
88	! Relation between volume and fraction of floodplains
89	!
90	REAL(r_std), SAVE :: beta = 2.0 !! Parameter to fix the shape of the floodplain (>1 for convex edges, <1 for concave edges) (unitless)
91	!$OMP THREADPRIVATE(beta)
92	REAL(r_std), SAVE :: betap = 0.5 !! Ratio of the basin surface intercepted by ponds and the maximum surface of ponds (unitless;0-1)
93	!$OMP THREADPRIVATE(betap)
94	REAL(r_std), SAVE :: floodcri = 2000.0 !! Potential height for which all the basin is flooded (mm)
95	!$OMP THREADPRIVATE(floodcri)
96	!
97	! Relation between maximum surface of ponds and basin surface, and drainage (mm/j) to the slow_res
98	!
99	REAL(r_std), PARAMETER :: pond_bas = 50.0 !! [DISPENSABLE] - not used
100	REAL(r_std), SAVE :: pondcri = 2000.0 !! Potential height for which all the basin is a pond (mm)
101	!$OMP THREADPRIVATE(pondcri)
102	!
103	REAL(r_std), PARAMETER :: maxevap_lake = 7.5/86400. !! Maximum evaporation rate from lakes (kg/m^2/s)
104	!
105	REAL(r_std),SAVE :: dt_routing !! Routing time step (s)
106	!$OMP THREADPRIVATE(dt_routing)
107	!
108	INTEGER(i_std), SAVE :: diagunit = 87 !! Diagnostic file unit (unitless)
109	!$OMP THREADPRIVATE(diagunit)
110	!
111	! Logicals to control model configuration
112	!
113	LOGICAL, SAVE :: dofloodinfilt = .FALSE. !! Logical to choose if floodplains infiltration is activated or not (true/false)
114	!$OMP THREADPRIVATE(dofloodinfilt)
115	LOGICAL, SAVE :: doswamps = .FALSE. !! Logical to choose if swamps are activated or not (true/false)
116	!$OMP THREADPRIVATE(doswamps)
117	LOGICAL, SAVE :: doponds = .FALSE. !! Logical to choose if ponds are activated or not (true/false)
118	!$OMP THREADPRIVATE(doponds)
119	!
120	! The variables describing the basins and their routing, need to be in the restart file.
121	!
122	INTEGER(i_std), SAVE :: num_largest !! Number of largest river basins which should be treated as independently as rivers
123	!! (not flow into ocean as diffusion coastal flow) (unitless)
124	!$OMP THREADPRIVATE(num_largest)
125	REAL(r_std), SAVE :: time_counter !! Time counter (s)
126	!$OMP THREADPRIVATE(time_counter)
127	REAL(r_std), SAVE, ALLOCATABLE, TARGET, DIMENSION(:,:) :: routing_area_loc !! Surface of basin (m^2)
128	!$OMP THREADPRIVATE(routing_area_loc)
129	REAL(r_std), SAVE, ALLOCATABLE, TARGET, DIMENSION(:,:) :: topo_resid_loc !! Topographic index of the retention time (m)
130	!$OMP THREADPRIVATE(topo_resid_loc)
131	INTEGER(i_std), SAVE, ALLOCATABLE, TARGET, DIMENSION(:,:) :: route_togrid_loc !! Grid into which the basin flows (unitless)
132	!$OMP THREADPRIVATE(route_togrid_loc)
133	INTEGER(i_std), SAVE, ALLOCATABLE, TARGET, DIMENSION(:,:) :: route_tobasin_loc !! Basin in to which the water goes (unitless)
134	!$OMP THREADPRIVATE(route_tobasin_loc)
135	INTEGER(i_std), SAVE, ALLOCATABLE, TARGET, DIMENSION(:,:) :: route_nbintobas_loc !! Number of basin into current one (unitless)
136	!$OMP THREADPRIVATE(route_nbintobas_loc)
137	INTEGER(i_std), SAVE, ALLOCATABLE, TARGET, DIMENSION(:,:) :: global_basinid_loc !! ID of basin (unitless)
138	!$OMP THREADPRIVATE(global_basinid_loc)
139	INTEGER(i_std), SAVE, ALLOCATABLE, TARGET, DIMENSION(:,:) :: hydrodiag_loc !! Variable to diagnose the hydrographs
140	!$OMP THREADPRIVATE(hydrodiag_loc)
141	REAL(r_std), SAVE, ALLOCATABLE, TARGET, DIMENSION(:) :: hydroupbasin_loc !! The area upstream of the gauging station (m^2)
142	!$OMP THREADPRIVATE(hydroupbasin_loc)
143	!
144	! parallelism
145	REAL(r_std), SAVE, ALLOCATABLE, TARGET, DIMENSION(:,:) :: routing_area_glo !! Surface of basin (m^2)
146	!$OMP THREADPRIVATE(routing_area_glo)
147	REAL(r_std), SAVE, ALLOCATABLE, TARGET, DIMENSION(:,:) :: topo_resid_glo !! Topographic index of the retention time (m)
148	!$OMP THREADPRIVATE(topo_resid_glo)
149	INTEGER(i_std), SAVE, ALLOCATABLE, TARGET, DIMENSION(:,:) :: route_togrid_glo !! Grid into which the basin flows (unitless)
150	!$OMP THREADPRIVATE(route_togrid_glo)
151	INTEGER(i_std), SAVE, ALLOCATABLE, TARGET, DIMENSION(:,:) :: route_tobasin_glo !! Basin in to which the water goes (unitless)
152	!$OMP THREADPRIVATE(route_tobasin_glo)
153	INTEGER(i_std), SAVE, ALLOCATABLE, TARGET, DIMENSION(:,:) :: route_nbintobas_glo !! Number of basin into current one (unitless)
154	!$OMP THREADPRIVATE(route_nbintobas_glo)
155	INTEGER(i_std), SAVE, ALLOCATABLE, TARGET, DIMENSION(:,:) :: global_basinid_glo !! ID of basin (unitless)
156	!$OMP THREADPRIVATE(global_basinid_glo)
157	INTEGER(i_std), SAVE, ALLOCATABLE, TARGET, DIMENSION(:,:) :: hydrodiag_glo !! Variable to diagnose the hydrographs
158	!$OMP THREADPRIVATE(hydrodiag_glo)
159	REAL(r_std), SAVE, ALLOCATABLE, TARGET, DIMENSION(:) :: hydroupbasin_glo !! The area upstream of the gauging station (m^2)
160	!$OMP THREADPRIVATE(hydroupbasin_glo)
161	!
162	REAL(r_std), SAVE, POINTER, DIMENSION(:,:) :: routing_area !! Surface of basin (m^2)
163	!$OMP THREADPRIVATE(routing_area)
164	REAL(r_std), SAVE, POINTER, DIMENSION(:,:) :: topo_resid !! Topographic index of the retention time (m)
165	!$OMP THREADPRIVATE(topo_resid)
166	INTEGER(i_std), SAVE, POINTER, DIMENSION(:,:) :: route_togrid !! Grid into which the basin flows (unitless)
167	!$OMP THREADPRIVATE(route_togrid)
168	INTEGER(i_std), SAVE, POINTER, DIMENSION(:,:) :: route_tobasin !! Basin in to which the water goes (unitless)
169	!$OMP THREADPRIVATE(route_tobasin)
170	INTEGER(i_std), SAVE, POINTER, DIMENSION(:,:) :: route_nbintobas !! Number of basin into current one (unitless)
171	!$OMP THREADPRIVATE(route_nbintobas)
172	INTEGER(i_std), SAVE, POINTER, DIMENSION(:,:) :: global_basinid !! ID of basin (unitless)
173	!$OMP THREADPRIVATE(global_basinid)
174	INTEGER(i_std), SAVE, POINTER, DIMENSION(:,:) :: hydrodiag !! Variable to diagnose the hydrographs
175	!$OMP THREADPRIVATE(hydrodiag)
176	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: slowflow_diag !! Diagnostic slow flow hydrographs (kg/dt)
177	!$OMP THREADPRIVATE(slowflow_diag)
178	REAL(r_std), SAVE, POINTER, DIMENSION(:) :: hydroupbasin !! The area upstream of the gauging station (m^2)
179	!$OMP THREADPRIVATE(hydroupbasin)
180	!
181	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: irrigated !! Area equipped for irrigation in each grid box (m^2)
182	!$OMP THREADPRIVATE(irrigated)
183	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: floodplains !! Maximal surface which can be inundated in each grid box (m^2)
184	!$OMP THREADPRIVATE(floodplains)
185	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: swamp !! Maximal surface of swamps in each grid box (m^2)
186	!$OMP THREADPRIVATE(swamp)
187	!
188	! The reservoirs, also to be put into the restart file.
189	!
190	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:,:) :: fast_reservoir !! Water amount in the fast reservoir (kg)
191	!$OMP THREADPRIVATE(fast_reservoir)
192	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:,:) :: slow_reservoir !! Water amount in the slow reservoir (kg)
193	!$OMP THREADPRIVATE(slow_reservoir)
194	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:,:) :: stream_reservoir !! Water amount in the stream reservoir (kg)
195	!$OMP THREADPRIVATE(stream_reservoir)
196	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:,:) :: flood_reservoir !! Water amount in the floodplains reservoir (kg)
197	!$OMP THREADPRIVATE(flood_reservoir)
198	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: lake_reservoir !! Water amount in the lake reservoir (kg)
199	!$OMP THREADPRIVATE(lake_reservoir)
200	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: pond_reservoir !! Water amount in the pond reservoir (kg)
201	!$OMP THREADPRIVATE(pond_reservoir)
202	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:,:) :: flood_frac_bas !! Flooded fraction per basin (unitless;0-1)
203	!$OMP THREADPRIVATE(flood_frac_bas)
204	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: pond_frac !! Pond fraction per grid box (unitless;0-1)
205	!$OMP THREADPRIVATE(pond_frac)
206	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: flood_height !! Floodplain height (mm)
207	!$OMP THREADPRIVATE(flood_height)
208	!
209	! The accumulated fluxes.
210	!
211	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: floodout_mean !! Accumulated flow out of floodplains (kg/m^2/dt)
212	!$OMP THREADPRIVATE(floodout_mean)
213	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: runoff_mean !! Accumulated runoff (kg/m^2/dt)
214	!$OMP THREADPRIVATE(runoff_mean)
215	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: drainage_mean !! Accumulated drainage (kg/m^2/dt)
216	!$OMP THREADPRIVATE(drainage_mean)
217	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: transpot_mean !! Mean potential transpiration from the plants (kg/m^2/dt)
218	!$OMP THREADPRIVATE(transpot_mean)
219	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: precip_mean !! Accumulated precipitation (kg/m^2/dt)
220	!$OMP THREADPRIVATE(precip_mean)
221	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: humrel_mean !! Mean soil moisture stress, mean root extraction potential (unitless)
222	!$OMP THREADPRIVATE(humrel_mean)
223	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: totnobio_mean !! Mean last total fraction of no bio (unitless;0-1)
224	!$OMP THREADPRIVATE(totnobio_mean)
225	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: vegtot_mean !! Mean potentially vegetated fraction (unitless;0-1)
226	!$OMP THREADPRIVATE(vegtot_mean)
227	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: k_litt_mean !! Mean averaged conductivity for saturated infiltration in the 'litter' layer (kg/m^2/dt)
228	!$OMP THREADPRIVATE(k_litt_mean)
229	!
230	! The averaged outflow fluxes.
231	!
232	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: lakeinflow_mean !! Mean lake inflow (kg/m^2/dt)
233	!$OMP THREADPRIVATE(lakeinflow_mean)
234	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: returnflow_mean !! Mean water flow from lakes and swamps which returns to the grid box.
235	!! This water will go back into the hydrol or hydrolc module to allow re-evaporation (kg/m^2/dt)
236	!$OMP THREADPRIVATE(returnflow_mean)
237	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: reinfiltration_mean !! Mean water flow which returns to the grid box (kg/m^2/dt)
238	!$OMP THREADPRIVATE(reinfiltration_mean)
239	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: irrigation_mean !! Mean irrigation flux.
240	!! This is the water taken from the reservoirs and beeing put into the upper layers of the soil (kg/m^2/dt)
241	!$OMP THREADPRIVATE(irrigation_mean)
242	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: riverflow_mean !! Mean Outflow of the major rivers.
243	!! The flux will be located on the continental grid but this should be a coastal point (kg/dt)
244	!$OMP THREADPRIVATE(riverflow_mean)
245	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: coastalflow_mean !! Mean outflow on coastal points by small basins.
246	!! This is the water which flows in a disperse way into the ocean (kg/dt)
247	!$OMP THREADPRIVATE(coastalflow_mean)
248	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: floodtemp !! Temperature to decide if floodplains work (K)
249	!$OMP THREADPRIVATE(floodtemp)
250	INTEGER(i_std), SAVE :: floodtemp_lev !! Temperature level to decide if floodplains work (K)
251	!$OMP THREADPRIVATE(floodtemp_lev)
252	!
253	! Diagnostic variables ... well sort of !
254	!
255	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: irrig_netereq !! Irrigation requirement (water requirements by the crop for its optimal growth (kg/m^2/dt)
256	!$OMP THREADPRIVATE(irrig_netereq)
257	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: hydrographs !! Hydrographs at the outflow of the grid box for major basins (kg/dt)
258	!$OMP THREADPRIVATE(hydrographs)
259	!
260	! Diagnostics for the various reservoirs we use (Kg/m^2)
261	!
262	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: fast_diag !! Diagnostic for the fast reservoir (kg/m^2)
263	!$OMP THREADPRIVATE(fast_diag)
264	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: slow_diag !! Diagnostic for the slow reservoir (kg/m^2)
265	!$OMP THREADPRIVATE(slow_diag)
266	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: stream_diag !! Diagnostic for the stream reservoir (kg/m^2)
267	!$OMP THREADPRIVATE(stream_diag)
268	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: flood_diag !! Diagnostic for the floodplain reservoir (kg/m^2)
269	!$OMP THREADPRIVATE(flood_diag)
270	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: pond_diag !! Diagnostic for the pond reservoir (kg/m^2)
271	!$OMP THREADPRIVATE(pond_diag)
272	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: lake_diag !! Diagnostic for the lake reservoir (kg/m^2)
273	!$OMP THREADPRIVATE(lake_diag)
274
275	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: mask_coast !! Mask with coastal gridcells on local grid(1/0)
276	!$OMP THREADPRIVATE(mask_coast)
277	REAL(r_std), SAVE :: max_lake_reservoir !! Maximum limit of water in lake_reservoir [kg/m2]
278	!$OMP THREADPRIVATE(max_lake_reservoir)
279	INTEGER(i_std), SAVE :: nb_coast_gridcells !! Number of gridcells which can receive coastalflow
280
281
282	CONTAINS
283	!! =============================================================================================================================
284	!! SUBROUTINE: routing_initialize
285	!!
286	!>\BRIEF Initialize the routing module
287	!!
288	!! DESCRIPTION: Initialize the routing module. Read from restart file or read the routing.nc file to initialize the
289	!! routing scheme.
290	!!
291	!! RECENT CHANGE(S)
292	!!
293	!! REFERENCE(S)
294	!!
295	!! FLOWCHART
296	!! \n
297	!_ ==============================================================================================================================
298
299	SUBROUTINE routing_initialize( kjit, nbpt, index, &
300	rest_id, hist_id, hist2_id, lalo, &
301	neighbours, resolution, contfrac, stempdiag, &
302	returnflow, reinfiltration, irrigation, riverflow, &
303	coastalflow, flood_frac, flood_res )
304
305	IMPLICIT NONE
306
307	!! 0.1 Input variables
308	INTEGER(i_std), INTENT(in) :: kjit !! Time step number (unitless)
309	INTEGER(i_std), INTENT(in) :: nbpt !! Domain size (unitless)
310	INTEGER(i_std), INTENT(in) :: index(nbpt) !! Indices of the points on the map (unitless)
311	INTEGER(i_std),INTENT(in) :: rest_id !! Restart file identifier (unitless)
312	INTEGER(i_std),INTENT(in) :: hist_id !! Access to history file (unitless)
313	INTEGER(i_std),INTENT(in) :: hist2_id !! Access to history file 2 (unitless)
314	REAL(r_std), INTENT(in) :: lalo(nbpt,2) !! Vector of latitude and longitudes (beware of the order !)
315
316	INTEGER(i_std), INTENT(in) :: neighbours(nbpt,NbNeighb) !! Vector of neighbours for each grid point
317	!! (1=N, 2=NE, 3=E, 4=SE, 5=S, 6=SW, 7=W, 8=NW) (unitless)
318	REAL(r_std), INTENT(in) :: resolution(nbpt,2) !! The size of each grid box in X and Y (m)
319	REAL(r_std), INTENT(in) :: contfrac(nbpt) !! Fraction of land in each grid box (unitless;0-1)
320	REAL(r_std), INTENT(in) :: stempdiag(nbpt,nbdl) !! Diagnostic soil temperature profile
321
322	!! 0.2 Output variables
323	REAL(r_std), INTENT(out) :: returnflow(nbpt) !! The water flow from lakes and swamps which returns to the grid box.
324	!! This water will go back into the hydrol or hydrolc module to allow re-evaporation (kg/m^2/dt)
325	REAL(r_std), INTENT(out) :: reinfiltration(nbpt) !! Water flow from ponds and floodplains which returns to the grid box (kg/m^2/dt)
326	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)
327	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)
328
329	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)
330	REAL(r_std), INTENT(out) :: flood_frac(nbpt) !! Flooded fraction of the grid box (unitless;0-1)
331	REAL(r_std), INTENT(out) :: flood_res(nbpt) !! Diagnostic of water amount in the floodplains reservoir (kg)
332
333	!! 0.3 Local variables
334	REAL(r_std), DIMENSION(nbp_glo):: mask_coast_glo !! Mask with coastal gridcells on global grid (1/0)
335	LOGICAL :: init_irrig !! Logical to initialize the irrigation (true/false)
336	LOGICAL :: init_flood !! Logical to initialize the floodplains (true/false)
337	LOGICAL :: init_swamp !! Logical to initialize the swamps (true/false)
338	INTEGER :: ig, ib, rtg, rtb !! Index
339	INTEGER :: ier !! Error handeling
340	!_ ================================================================================================================================
341
342	!
343	! do initialisation
344	!
345	nbvmax = 440
346	! Here we will allocate the memory and get the fixed fields from the restart file.
347	! If the info is not found then we will compute the routing map.
348	!
349
350	CALL routing_init (kjit, nbpt, index, returnflow, reinfiltration, irrigation, &
351	riverflow, coastalflow, flood_frac, flood_res, stempdiag, rest_id)
352
353	routing_area => routing_area_loc
354	topo_resid => topo_resid_loc
355	route_togrid => route_togrid_loc
356	route_tobasin => route_tobasin_loc
357	global_basinid => global_basinid_loc
358	hydrodiag => hydrodiag_loc
359
360	! This routine computes the routing map if the route_togrid_glo is undefined. This means that the
361	! map has not been initialized during the restart process..
362	!
363	!! Reads in the map of the basins and flow directions to construct the catchments of each grid box
364	!
365	IF ( COUNT(route_togrid_glo .GE. undef_int) .GT. 0 ) THEN
366	CALL routing_basins_p(nbpt, lalo, neighbours, resolution, contfrac)
367	ENDIF
368
369	!! Create a mask containing all possible coastal gridcells and count total number of coastal gridcells
370	IF (is_root_prc) THEN
371	mask_coast_glo(:)=0
372	DO ib=1,nbasmax
373	DO ig=1,nbp_glo
374	rtg = route_togrid_glo(ig,ib)
375	rtb = route_tobasin_glo(ig,ib)
376	! Coastal gridcells are stored in nbasmax+2
377	IF (rtb == nbasmax+2) THEN
378	mask_coast_glo(rtg) = 1
379	END IF
380	END DO
381	END DO
382	nb_coast_gridcells=SUM(mask_coast_glo)
383	IF (printlev>=3) WRITE(numout,*) 'Number of coastal gridcells = ', nb_coast_gridcells
384	ENDIF
385	CALL bcast(nb_coast_gridcells)
386
387	ALLOCATE(mask_coast(nbpt), stat=ier)
388	IF (ier /= 0) CALL ipslerr_p(3,'routing_inititalize','Pb in allocate for mask_coast','','')
389	CALL scatter(mask_coast_glo, mask_coast)
390	CALL xios_orchidee_send_field("mask_coast",mask_coast)
391
392
393	!
394	! Do we have what we need if we want to do irrigation
395	!! Initialisation of flags for irrigated land, flood plains and swamps
396	!
397	init_irrig = .FALSE.
398	IF ( do_irrigation ) THEN
399	IF (COUNT(irrigated .GE. undef_sechiba-1) > 0) init_irrig = .TRUE.
400	END IF
401
402	init_flood = .FALSE.
403	IF ( do_floodplains ) THEN
404	IF (COUNT(floodplains .GE. undef_sechiba-1) > 0) init_flood = .TRUE.
405	END IF
406
407	init_swamp = .FALSE.
408	IF ( doswamps ) THEN
409	IF (COUNT(swamp .GE. undef_sechiba-1) > 0 ) init_swamp = .TRUE.
410	END IF
411
412	!! If we have irrigated land, flood plains or swamps then we need to interpolate the 0.5 degree
413	!! base data set to the resolution of the model.
414
415	IF ( init_irrig .OR. init_flood .OR. init_swamp ) THEN
416	CALL routing_irrigmap(nbpt, index, lalo, neighbours, resolution, &
417	contfrac, init_irrig, irrigated, init_flood, floodplains, init_swamp, swamp, hist_id, hist2_id)
418	ENDIF
419
420	IF ( do_irrigation ) THEN
421	CALL xios_orchidee_send_field("irrigmap",irrigated)
422
423	WRITE(numout,*) 'Verification : range of irrigated : ', MINVAL(irrigated), MAXVAL(irrigated)
424	IF ( .NOT. almaoutput ) THEN
425	CALL histwrite_p(hist_id, 'irrigmap', 1, irrigated, nbpt, index)
426	ELSE
427	CALL histwrite_p(hist_id, 'IrrigationMap', 1, irrigated, nbpt, index)
428	ENDIF
429	IF ( hist2_id > 0 ) THEN
430	IF ( .NOT. almaoutput ) THEN
431	CALL histwrite_p(hist2_id, 'irrigmap', 1, irrigated, nbpt, index)
432	ELSE
433	CALL histwrite_p(hist2_id, 'IrrigationMap', 1, irrigated, nbpt, index)
434	ENDIF
435	ENDIF
436	ENDIF
437
438	IF ( do_floodplains ) THEN
439	CALL xios_orchidee_send_field("floodmap",floodplains)
440
441	WRITE(numout,*) 'Verification : range of floodplains : ', MINVAL(floodplains), MAXVAL(floodplains)
442	IF ( .NOT. almaoutput ) THEN
443	CALL histwrite_p(hist_id, 'floodmap', 1, floodplains, nbpt, index)
444	ELSE
445	CALL histwrite_p(hist_id, 'FloodplainsMap', 1, floodplains, nbpt, index)
446	ENDIF
447	IF ( hist2_id > 0 ) THEN
448	IF ( .NOT. almaoutput ) THEN
449	CALL histwrite_p(hist2_id, 'floodmap', 1, floodplains, nbpt, index)
450	ELSE
451	CALL histwrite_p(hist2_id, 'FloodplainsMap', 1, floodplains, nbpt, index)
452	ENDIF
453	ENDIF
454	ENDIF
455
456	IF ( doswamps ) THEN
457	CALL xios_orchidee_send_field("swampmap",swamp)
458
459	WRITE(numout,*) 'Verification : range of swamp : ', MINVAL(swamp), MAXVAL(swamp)
460	IF ( .NOT. almaoutput ) THEN
461	CALL histwrite_p(hist_id, 'swampmap', 1, swamp, nbpt, index)
462	ELSE
463	CALL histwrite_p(hist_id, 'SwampMap', 1, swamp, nbpt, index)
464	ENDIF
465	IF ( hist2_id > 0 ) THEN
466	IF ( .NOT. almaoutput ) THEN
467	CALL histwrite_p(hist2_id, 'swampmap', 1, swamp, nbpt, index)
468	ELSE
469	CALL histwrite_p(hist2_id, 'SwampMap', 1, swamp, nbpt, index)
470	ENDIF
471	ENDIF
472	ENDIF
473
474	!! This routine gives a diagnostic of the basins used.
475	CALL routing_diagnostic_p(nbpt, index, lalo, resolution, contfrac, hist_id, hist2_id)
476
477	END SUBROUTINE routing_initialize
478
479	!! ================================================================================================================================
480	!! SUBROUTINE : routing_main
481	!!
482	!>\BRIEF This module routes the water over the continents (runoff and
483	!! drainage produced by the hydrolc or hydrol module) into the oceans.
484	!!
485	!! DESCRIPTION (definitions, functional, design, flags):
486	!! The routing scheme (Polcher, 2003) carries the water from the runoff and drainage simulated by SECHIBA
487	!! to the ocean through reservoirs, with some delay. The routing scheme is based on
488	!! a parametrization of the water flow on a global scale (Miller et al., 1994; Hagemann
489	!! and Dumenil, 1998). Given the global map of the main watersheds (Oki et al., 1999;
490	!! Fekete et al., 1999; Vorosmarty et al., 2000) which delineates the boundaries of subbasins
491	!! and gives the eight possible directions of water flow within the pixel, the surface
492	!! runoff and the deep drainage are routed to the ocean. The time-step of the routing is one day.
493	!! The scheme also diagnoses how much water is retained in the foodplains and thus return to soil
494	!! moisture or is taken out of the rivers for irrigation. \n
495	!!
496	!! RECENT CHANGE(S): None
497	!!
498	!! MAIN OUTPUT VARIABLE(S):
499	!! The result of the routing are 3 fluxes :
500	!! - riverflow : The water which flows out from the major rivers. The flux will be located
501	!! on the continental grid but this should be a coastal point.
502	!! - coastalflow : This is the water which flows in a disperse way into the ocean. Essentially these
503	!! are the outflows from all of the small rivers.
504	!! - returnflow : This is the water which flows into a land-point - typically rivers which end in
505	!! the desert. This water will go back into the hydrol module to allow re-evaporation.
506	!! - irrigation : This is water taken from the reservoir and is being put into the upper
507	!! layers of the soil.
508	!! The two first fluxes are in kg/dt and the last two fluxes are in kg/(m^2dt).\n
509	!!
510	!! REFERENCE(S) :
511	!! - Miller JR, Russell GL, Caliri G (1994)
512	!! Continental-scale river flow in climate models.
513	!! J. Clim., 7:914-928
514	!! - Hagemann S and Dumenil L. (1998)
515	!! A parametrization of the lateral waterflow for the global scale.
516	!! Clim. Dyn., 14:17-31
517	!! - Oki, T., T. Nishimura, and P. Dirmeyer (1999)
518	!! Assessment of annual runoff from land surface models using total runoff integrating pathways (TRIP)
519	!! J. Meteorol. Soc. Jpn., 77, 235-255
520	!! - Fekete BM, Charles V, Grabs W (2000)
521	!! Global, composite runoff fields based on observed river discharge and simulated water balances.
522	!! Technical report, UNH/GRDC, Global Runoff Data Centre, Koblenz
523	!! - Vorosmarty, C., B. Fekete, B. Meybeck, and R. Lammers (2000)
524	!! Global system of rivers: Its role in organizing continental land mass and defining land-to-ocean linkages
525	!! Global Biogeochem. Cycles, 14, 599-621
526	!! - Vivant, A-C. (?? 2002)
527	!! DÃ©veloppement du schÃ©ma de routage et des plaines d'inondation, MSc Thesis, Paris VI University
528	!! - J. Polcher (2003)
529	!! Les processus de surface a l'echelle globale et leurs interactions avec l'atmosphere
530	!! Habilitation a diriger les recherches, Paris VI University, 67pp.
531	!!
532	!! FLOWCHART :
533	!! \latexonly
534	!! \includegraphics[scale=0.75]{routing_main_flowchart.png}
535	!! \endlatexonly
536	!! \n
537	!_ ================================================================================================================================
538
539	SUBROUTINE routing_main(kjit, nbpt, index, &
540	& lalo, neighbours, resolution, contfrac, totfrac_nobio, veget_max, floodout, runoff, &
541	& drainage, transpot, precip_rain, humrel, k_litt, flood_frac, flood_res, &
542	& stempdiag, reinf_slope, returnflow, reinfiltration, irrigation, riverflow, coastalflow, rest_id, hist_id, hist2_id)
543
544	IMPLICIT NONE
545
546	!! 0.1 Input variables
547	INTEGER(i_std), INTENT(in) :: kjit !! Time step number (unitless)
548	INTEGER(i_std), INTENT(in) :: nbpt !! Domain size (unitless)
549	INTEGER(i_std),INTENT(in) :: rest_id !! Restart file identifier (unitless)
550	INTEGER(i_std),INTENT(in) :: hist_id !! Access to history file (unitless)
551	INTEGER(i_std),INTENT(in) :: hist2_id !! Access to history file 2 (unitless)
552	INTEGER(i_std), INTENT(in) :: index(nbpt) !! Indices of the points on the map (unitless)
553	REAL(r_std), INTENT(in) :: lalo(nbpt,2) !! Vector of latitude and longitudes (beware of the order !)
554	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)
555	REAL(r_std), INTENT(in) :: resolution(nbpt,2) !! The size of each grid box in X and Y (m)
556	REAL(r_std), INTENT(in) :: contfrac(nbpt) !! Fraction of land in each grid box (unitless;0-1)
557	REAL(r_std), INTENT(in) :: totfrac_nobio(nbpt) !! Total fraction of no-vegetation (continental ice, lakes ...) (unitless;0-1)
558	REAL(r_std), INTENT(in) :: veget_max(nbpt,nvm) !! Maximal fraction of vegetation (unitless;0-1)
559	REAL(r_std), INTENT(in) :: floodout(nbpt) !! Grid-point flow out of floodplains (kg/m^2/dt)
560	REAL(r_std), INTENT(in) :: runoff(nbpt) !! Grid-point runoff (kg/m^2/dt)
561	REAL(r_std), INTENT(in) :: drainage(nbpt) !! Grid-point drainage (kg/m^2/dt)
562	REAL(r_std), INTENT(in) :: transpot(nbpt,nvm) !! Potential transpiration of the vegetation (kg/m^2/dt)
563	REAL(r_std), INTENT(in) :: precip_rain(nbpt) !! Rainfall (kg/m^2/dt)
564	REAL(r_std), INTENT(in) :: k_litt(nbpt) !! Averaged conductivity for saturated infiltration in the 'litter' layer (kg/m^2/dt)
565	REAL(r_std), INTENT(in) :: humrel(nbpt,nvm) !! Soil moisture stress, root extraction potential (unitless)
566	REAL(r_std), INTENT(in) :: stempdiag(nbpt,nbdl) !! Diagnostic soil temperature profile
567	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)
568
569	!! 0.2 Output variables
570	REAL(r_std), INTENT(out) :: returnflow(nbpt) !! The water flow from lakes and swamps which returns to the grid box.
571	!! This water will go back into the hydrol or hydrolc module to allow re-evaporation (kg/m^2/dt)
572	REAL(r_std), INTENT(out) :: reinfiltration(nbpt) !! Water flow from ponds and floodplains which returns to the grid box (kg/m^2/dt)
573	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)
574	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)
575	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)
576	REAL(r_std), INTENT(out) :: flood_frac(nbpt) !! Flooded fraction of the grid box (unitless;0-1)
577	REAL(r_std), INTENT(out) :: flood_res(nbpt) !! Diagnostic of water amount in the floodplains reservoir (kg)
578
579	!! 0.3 Local variables
580	CHARACTER(LEN=30) :: var_name !! To store variables names for I/O (unitless)
581	REAL(r_std), DIMENSION(1) :: tmp_day !!
582	REAL(r_std), DIMENSION(nbpt) :: return_lakes !! Water from lakes flowing back into soil moisture (kg/m^2/dt)
583
584	INTEGER(i_std) :: ig, jv !! Indices (unitless)
585	REAL(r_std), DIMENSION(nbpt) :: tot_vegfrac_nowoody !! Total fraction occupied by grass (0-1,unitless)
586
587	REAL(r_std), DIMENSION(nbpt) :: fast_diag_old !! Reservoir in the beginning of the time step
588	REAL(r_std), DIMENSION(nbpt) :: slow_diag_old !! Reservoir in the beginning of the time step
589	REAL(r_std), DIMENSION(nbpt) :: stream_diag_old !! Reservoir in the beginning of the time step
590	REAL(r_std), DIMENSION(nbpt) :: lake_diag_old !! Reservoir in the beginning of the time step
591	REAL(r_std), DIMENSION(nbpt) :: pond_diag_old !! Reservoir in the beginning of the time step
592	REAL(r_std), DIMENSION(nbpt) :: flood_diag_old !! Reservoir in the beginning of the time step
593
594	!! For water budget check in the three routing reservoirs (positive if input > output)
595	!! Net fluxes averaged over each grid cell in kg/m^2/dt
596	REAL(r_std), DIMENSION(nbpt) :: netflow_stream_diag !! Input - Output flow to stream reservoir
597	REAL(r_std), DIMENSION(nbpt) :: netflow_fast_diag !! Input - Output flow to fast reservoir
598	REAL(r_std), DIMENSION(nbpt) :: netflow_slow_diag !! Input - Output flow to slow reservoir
599
600
601	!_ ================================================================================================================================
602
603	! Save reservoirs in beginning of time step to calculate the water budget
604	fast_diag_old = fast_diag
605	slow_diag_old = slow_diag
606	stream_diag_old = stream_diag
607	lake_diag_old = lake_diag
608	pond_diag_old = pond_diag
609	flood_diag_old = flood_diag
610
611	!
612	!! Computes the variables averaged between routing time steps and which will be used in subsequent calculations
613	!
614	floodout_mean(:) = floodout_mean(:) + floodout(:)
615	runoff_mean(:) = runoff_mean(:) + runoff(:)
616	drainage_mean(:) = drainage_mean(:) + drainage(:)
617	floodtemp(:) = stempdiag(:,floodtemp_lev)
618	precip_mean(:) = precip_mean(:) + precip_rain(:)
619	!
620	!! Computes the total fraction occupied by the grasses and the crops for each grid cell
621	tot_vegfrac_nowoody(:) = zero
622	DO jv = 1, nvm
623	IF ( (jv /= ibare_sechiba) .AND. .NOT.(is_tree(jv)) ) THEN
624	tot_vegfrac_nowoody(:) = tot_vegfrac_nowoody(:) + veget_max(:,jv)
625	END IF
626	END DO
627
628	DO ig = 1, nbpt
629	IF ( tot_vegfrac_nowoody(ig) .GT. min_sechiba ) THEN
630	DO jv = 1,nvm
631	IF ( (jv /= ibare_sechiba) .AND. .NOT.(is_tree(jv)) ) THEN
632	transpot_mean(ig) = transpot_mean(ig) + transpot(ig,jv) * veget_max(ig,jv)/tot_vegfrac_nowoody(ig)
633	END IF
634	END DO
635	ELSE
636	IF (MAXVAL(veget_max(ig,2:nvm)) .GT. min_sechiba) THEN
637	DO jv = 2, nvm
638	transpot_mean(ig) = transpot_mean(ig) + transpot(ig,jv) * veget_max(ig,jv)/ SUM(veget_max(ig,2:nvm))
639	ENDDO
640	ENDIF
641	ENDIF
642	ENDDO
643
644	!
645	! Averaged variables (i.e. *dt_sechiba/dt_routing). This accounts for the difference between the shorter
646	! timestep dt_sechiba of other parts of the model and the long dt_routing timestep (set to one day at present)
647	!
648	totnobio_mean(:) = totnobio_mean(:) + totfrac_nobio(:)*dt_sechiba/dt_routing
649	k_litt_mean(:) = k_litt_mean(:) + k_litt(:)*dt_sechiba/dt_routing
650	!
651	! Only potentially vegetated surfaces are taken into account. At the start of
652	! the growing seasons we will give more weight to these areas.
653	!
654	DO jv=2,nvm
655	DO ig=1,nbpt
656	humrel_mean(ig) = humrel_mean(ig) + humrel(ig,jv)veget_max(ig,jv)dt_sechiba/dt_routing
657	vegtot_mean(ig) = vegtot_mean(ig) + veget_max(ig,jv)*dt_sechiba/dt_routing
658	ENDDO
659	ENDDO
660	!
661	time_counter = time_counter + dt_sechiba
662	!
663	! If the time has come we do the routing.
664	!
665	IF ( NINT(time_counter) .GE. NINT(dt_routing) ) THEN
666	!
667	! Check the water balance if needed
668	!
669	IF ( check_waterbal ) THEN
670	CALL routing_waterbal(nbpt, .TRUE., floodout_mean, runoff_mean, drainage_mean, returnflow_mean, &
671	& reinfiltration_mean, irrigation_mean, riverflow_mean, coastalflow_mean)
672	ENDIF
673	!
674	!! Computes the transport of water in the various reservoirs
675	!
676	CALL routing_flow(nbpt, dt_routing, lalo, floodout_mean, runoff_mean, drainage_mean, &
677	& vegtot_mean, totnobio_mean, transpot_mean, precip_mean, humrel_mean, k_litt_mean, floodtemp, reinf_slope, &
678	& lakeinflow_mean, returnflow_mean, reinfiltration_mean, irrigation_mean, riverflow_mean, &
679	& coastalflow_mean, hydrographs, slowflow_diag, flood_frac, flood_res, &
680	& netflow_stream_diag, netflow_fast_diag, netflow_slow_diag)
681	!
682	!! Responsible for storing the water in lakes
683	!
684	CALL routing_lake(nbpt, dt_routing, lakeinflow_mean, humrel_mean, return_lakes)
685	!
686	returnflow_mean(:) = returnflow_mean(:) + return_lakes(:)
687	!
688	!! Check the water balance in the routing scheme
689	!
690	IF ( check_waterbal ) THEN
691	CALL routing_waterbal(nbpt, .FALSE., floodout_mean, runoff_mean, drainage_mean, returnflow_mean, &
692	& reinfiltration_mean, irrigation_mean, riverflow_mean, coastalflow_mean)
693	ENDIF
694	!
695	time_counter = zero
696	!
697	floodout_mean(:) = zero
698	runoff_mean(:) = zero
699	drainage_mean(:) = zero
700	transpot_mean(:) = zero
701	precip_mean(:) = zero
702	!
703	humrel_mean(:) = zero
704	totnobio_mean(:) = zero
705	k_litt_mean(:) = zero
706	vegtot_mean(:) = zero
707
708	! Change the units of the routing fluxes from kg/dt_routing into kg/dt_sechiba
709	hydrographs(:) = hydrographs(:)/dt_routing*dt_sechiba
710	slowflow_diag(:) = slowflow_diag(:)/dt_routing*dt_sechiba
711
712	! Change the units of the routing fluxes from kg/m^2/dt_routing into kg/m^2/dt_sechiba
713	returnflow_mean(:) = returnflow_mean(:)/dt_routing*dt_sechiba
714	reinfiltration_mean(:) = reinfiltration_mean(:)/dt_routing*dt_sechiba
715	irrigation_mean(:) = irrigation_mean(:)/dt_routing*dt_sechiba
716	irrig_netereq(:) = irrig_netereq(:)/dt_routing*dt_sechiba
717
718	! Change units as above but at the same time transform the kg/dt_routing to m^3/dt_sechiba
719	riverflow_mean(:) = riverflow_mean(:)/dt_routing*dt_sechiba/mille
720	coastalflow_mean(:) = coastalflow_mean(:)/dt_routing*dt_sechiba/mille
721
722	! Water budget residu of the three routing reservoirs (in kg/m^2/s)
723	! Note that these diagnostics are done using local variables only calculated
724	! during the time steps when the routing is calculated
725	CALL xios_orchidee_send_field("wbr_stream",(stream_diag - stream_diag_old - netflow_stream_diag)/dt_routing)
726	CALL xios_orchidee_send_field("wbr_fast", (fast_diag - fast_diag_old - netflow_fast_diag)/dt_routing)
727	CALL xios_orchidee_send_field("wbr_slow", (slow_diag - slow_diag_old - netflow_slow_diag)/dt_routing)
728	CALL xios_orchidee_send_field("wbr_lake", (lake_diag - lake_diag_old - &
729	lakeinflow_mean + return_lakes)/dt_routing)
730	ENDIF
731
732	!
733	! Return the fraction of routed water for this time step.
734	!
735	returnflow(:) = returnflow_mean(:)
736	reinfiltration(:) = reinfiltration_mean(:)
737	irrigation(:) = irrigation_mean(:)
738	riverflow(:) = riverflow_mean(:)
739	coastalflow(:) = coastalflow_mean(:)
740
741	!
742	! Write diagnostics
743	!
744
745	! Water storage in reservoirs [kg/m^2]
746	CALL xios_orchidee_send_field("fastr",fast_diag)
747	CALL xios_orchidee_send_field("slowr",slow_diag)
748	CALL xios_orchidee_send_field("streamr",stream_diag)
749	CALL xios_orchidee_send_field("laker",lake_diag)
750	CALL xios_orchidee_send_field("pondr",pond_diag)
751	CALL xios_orchidee_send_field("floodr",flood_diag)
752	CALL xios_orchidee_send_field("floodh",flood_height)
753
754	! Difference between the end and the beginning of the routing time step [kg/m^2]
755	CALL xios_orchidee_send_field("delfastr", fast_diag - fast_diag_old)
756	CALL xios_orchidee_send_field("delslowr", slow_diag - slow_diag_old)
757	CALL xios_orchidee_send_field("delstreamr", stream_diag - stream_diag_old)
758	CALL xios_orchidee_send_field("dellaker", lake_diag - lake_diag_old)
759	CALL xios_orchidee_send_field("delpondr", pond_diag - pond_diag_old)
760	CALL xios_orchidee_send_field("delfloodr", flood_diag - flood_diag_old)
761
762	! Water fluxes converted from kg/m^2/dt_sechiba into kg/m^2/s
763	CALL xios_orchidee_send_field("irrigation",irrigation/dt_sechiba)
764	CALL xios_orchidee_send_field("netirrig",irrig_netereq/dt_sechiba)
765	CALL xios_orchidee_send_field("riversret",returnflow/dt_sechiba)
766	CALL xios_orchidee_send_field("reinfiltration",reinfiltration/dt_sechiba)
767
768	! Transform from kg/dt_sechiba into m^3/s
769	CALL xios_orchidee_send_field("hydrographs",hydrographs/mille/dt_sechiba)
770	CALL xios_orchidee_send_field("slowflow",slowflow_diag/mille/dt_sechiba) ! previous id name: Qb
771	CALL xios_orchidee_send_field("coastalflow",coastalflow/dt_sechiba)
772	CALL xios_orchidee_send_field("riverflow",riverflow/dt_sechiba)
773
774	IF ( .NOT. almaoutput ) THEN
775	!
776	CALL histwrite_p(hist_id, 'riversret', kjit, returnflow, nbpt, index)
777	IF (do_floodplains .OR. doponds) THEN
778	CALL histwrite_p(hist_id, 'reinfiltration', kjit, reinfiltration, nbpt, index)
779	ENDIF
780	CALL histwrite_p(hist_id, 'hydrographs', kjit, hydrographs/mille, nbpt, index)
781	!
782	CALL histwrite_p(hist_id, 'fastr', kjit, fast_diag, nbpt, index)
783	CALL histwrite_p(hist_id, 'slowr', kjit, slow_diag, nbpt, index)
784	CALL histwrite_p(hist_id, 'streamr', kjit, stream_diag, nbpt, index)
785	IF ( do_floodplains ) THEN
786	CALL histwrite_p(hist_id, 'floodr', kjit, flood_diag, nbpt, index)
787	CALL histwrite_p(hist_id, 'floodh', kjit, flood_height, nbpt, index)
788	ENDIF
789	CALL histwrite_p(hist_id, 'pondr', kjit, pond_diag, nbpt, index)
790	CALL histwrite_p(hist_id, 'lakevol', kjit, lake_diag, nbpt, index)
791	!
792	IF ( do_irrigation ) THEN
793	CALL histwrite_p(hist_id, 'irrigation', kjit, irrigation, nbpt, index)
794	CALL histwrite_p(hist_id, 'returnflow', kjit, returnflow, nbpt, index)
795	CALL histwrite_p(hist_id, 'netirrig', kjit, irrig_netereq, nbpt, index)
796	ENDIF
797	!
798	ELSE
799	CALL histwrite_p(hist_id, 'SurfStor', kjit, flood_diag+pond_diag+lake_diag, nbpt, index)
800	CALL histwrite_p(hist_id, 'Dis', kjit, hydrographs/mille, nbpt, index)
801	!
802	CALL histwrite_p(hist_id, 'slowr', kjit, slow_diag, nbpt, index)
803	CALL histwrite_p(hist_id, 'fastr', kjit, fast_diag, nbpt, index)
804	CALL histwrite_p(hist_id, 'streamr', kjit, stream_diag, nbpt, index)
805	CALL histwrite_p(hist_id, 'lakevol', kjit, lake_diag, nbpt, index)
806	CALL histwrite_p(hist_id, 'pondr', kjit, pond_diag, nbpt, index)
807	!
808	IF ( do_irrigation ) THEN
809	CALL histwrite_p(hist_id, 'Qirrig', kjit, irrigation, nbpt, index)
810	CALL histwrite_p(hist_id, 'Qirrig_req', kjit, irrig_netereq, nbpt, index)
811	ENDIF
812	!
813	ENDIF
814	IF ( hist2_id > 0 ) THEN
815	IF ( .NOT. almaoutput ) THEN
816	!
817	CALL histwrite_p(hist2_id, 'riversret', kjit, returnflow, nbpt, index)
818	IF (do_floodplains .OR. doponds) THEN
819	CALL histwrite_p(hist2_id, 'reinfiltration', kjit, reinfiltration, nbpt, index)
820	ENDIF
821	CALL histwrite_p(hist2_id, 'hydrographs', kjit, hydrographs/mille, nbpt, index)
822	!
823	CALL histwrite_p(hist2_id, 'fastr', kjit, fast_diag, nbpt, index)
824	CALL histwrite_p(hist2_id, 'slowr', kjit, slow_diag, nbpt, index)
825	IF ( do_floodplains ) THEN
826	CALL histwrite_p(hist2_id, 'floodr', kjit, flood_diag, nbpt, index)
827	CALL histwrite_p(hist2_id, 'floodh', kjit, flood_height, nbpt, index)
828	ENDIF
829	CALL histwrite_p(hist2_id, 'pondr', kjit, pond_diag, nbpt, index)
830	CALL histwrite_p(hist2_id, 'streamr', kjit, stream_diag, nbpt, index)
831	CALL histwrite_p(hist2_id, 'lakevol', kjit, lake_diag, nbpt, index)
832	!
833	IF ( do_irrigation ) THEN
834	CALL histwrite_p(hist2_id, 'irrigation', kjit, irrigation, nbpt, index)
835	CALL histwrite_p(hist2_id, 'returnflow', kjit, returnflow, nbpt, index)
836	CALL histwrite_p(hist2_id, 'netirrig', kjit, irrig_netereq, nbpt, index)
837	ENDIF
838	!
839	ELSE
840	!
841	CALL histwrite_p(hist2_id, 'SurfStor', kjit, flood_diag+pond_diag+lake_diag, nbpt, index)
842	CALL histwrite_p(hist2_id, 'Dis', kjit, hydrographs/mille, nbpt, index)
843	!
844	ENDIF
845	ENDIF
846	!
847	!
848	END SUBROUTINE routing_main
849
850	!! =============================================================================================================================
851	!! SUBROUTINE: routing_finalize
852	!!
853	!>\BRIEF Write to restart file
854	!!
855	!! DESCRIPTION: Write module variables to restart file
856	!!
857	!! RECENT CHANGE(S)
858	!!
859	!! REFERENCE(S)
860	!!
861	!! FLOWCHART
862	!! \n
863	!_ ==============================================================================================================================
864
865	SUBROUTINE routing_finalize( kjit, nbpt, rest_id, flood_frac, flood_res )
866
867	IMPLICIT NONE
868
869	!! 0.1 Input variables
870	INTEGER(i_std), INTENT(in) :: kjit !! Time step number (unitless)
871	INTEGER(i_std), INTENT(in) :: nbpt !! Domain size (unitless)
872	INTEGER(i_std),INTENT(in) :: rest_id !! Restart file identifier (unitless)
873	REAL(r_std), INTENT(in) :: flood_frac(nbpt) !! Flooded fraction of the grid box (unitless;0-1)
874	REAL(r_std), INTENT(in) :: flood_res(nbpt) !! Diagnostic of water amount in the floodplains reservoir (kg)
875
876	!! 0.2 Local variables
877	REAL(r_std), DIMENSION(1) :: tmp_day
878
879	!_ ================================================================================================================================
880
881	!
882	! Write restart variables
883	!
884	tmp_day(1) = time_counter
885	IF (is_root_prc) CALL restput (rest_id, 'routingcounter', 1, 1, 1, kjit, tmp_day)
886
887	CALL restput_p (rest_id, 'routingarea', nbp_glo, nbasmax, 1, kjit, routing_area, 'scatter', nbp_glo, index_g)
888	CALL restput_p (rest_id, 'routetogrid', nbp_glo, nbasmax, 1, kjit, REAL(route_togrid,r_std), 'scatter', &
889	nbp_glo, index_g)
890	CALL restput_p (rest_id, 'routetobasin', nbp_glo, nbasmax, 1, kjit, REAL(route_tobasin,r_std), 'scatter', &
891	nbp_glo, index_g)
892	CALL restput_p (rest_id, 'basinid', nbp_glo, nbasmax, 1, kjit, REAL(global_basinid,r_std), 'scatter', &
893	nbp_glo, index_g)
894	CALL restput_p (rest_id, 'topoindex', nbp_glo, nbasmax, 1, kjit, topo_resid, 'scatter', nbp_glo, index_g)
895	CALL restput_p (rest_id, 'fastres', nbp_glo, nbasmax, 1, kjit, fast_reservoir, 'scatter', nbp_glo, index_g)
896	CALL restput_p (rest_id, 'slowres', nbp_glo, nbasmax, 1, kjit, slow_reservoir, 'scatter', nbp_glo, index_g)
897	CALL restput_p (rest_id, 'streamres', nbp_glo, nbasmax, 1, kjit, stream_reservoir, 'scatter',nbp_glo,index_g)
898	CALL restput_p (rest_id, 'floodres', nbp_glo, nbasmax, 1, kjit, flood_reservoir, 'scatter', nbp_glo, index_g)
899	CALL restput_p (rest_id, 'floodh', nbp_glo, 1, 1, kjit, flood_height, 'scatter', nbp_glo, index_g)
900	CALL restput_p (rest_id, 'flood_frac_bas', nbp_glo, nbasmax, 1, kjit, flood_frac_bas, 'scatter', nbp_glo, index_g)
901	CALL restput_p (rest_id, 'pond_frac', nbp_glo, 1, 1, kjit, pond_frac, 'scatter', nbp_glo, index_g)
902	CALL restput_p (rest_id, 'flood_frac', nbp_glo, 1, 1, kjit, flood_frac, 'scatter', nbp_glo, index_g)
903	CALL restput_p (rest_id, 'flood_res', nbp_glo, 1, 1, kjit, flood_res, 'scatter', nbp_glo, index_g)
904
905	CALL restput_p (rest_id, 'lakeres', nbp_glo, 1, 1, kjit, lake_reservoir, 'scatter', nbp_glo, index_g)
906	CALL restput_p (rest_id, 'pondres', nbp_glo, 1, 1, kjit, pond_reservoir, 'scatter', nbp_glo, index_g)
907
908	CALL restput_p (rest_id, 'lakeinflow', nbp_glo, 1, 1, kjit, lakeinflow_mean, 'scatter', nbp_glo, index_g)
909	CALL restput_p (rest_id, 'returnflow', nbp_glo, 1, 1, kjit, returnflow_mean, 'scatter', nbp_glo, index_g)
910	CALL restput_p (rest_id, 'reinfiltration', nbp_glo, 1, 1, kjit, reinfiltration_mean, 'scatter', nbp_glo, index_g)
911	CALL restput_p (rest_id, 'riverflow', nbp_glo, 1, 1, kjit, riverflow_mean, 'scatter', nbp_glo, index_g)
912	CALL restput_p (rest_id, 'coastalflow', nbp_glo, 1, 1, kjit, coastalflow_mean, 'scatter', nbp_glo, index_g)
913	CALL restput_p (rest_id, 'hydrographs', nbp_glo, 1, 1, kjit, hydrographs, 'scatter', nbp_glo, index_g)
914	CALL restput_p (rest_id, 'slowflow_diag', nbp_glo, 1, 1, kjit, slowflow_diag, 'scatter', nbp_glo, index_g)
915	!
916	! Keep track of the accumulated variables
917	!
918	CALL restput_p (rest_id, 'floodout_route', nbp_glo, 1, 1, kjit, floodout_mean, 'scatter', nbp_glo, index_g)
919	CALL restput_p (rest_id, 'runoff_route', nbp_glo, 1, 1, kjit, runoff_mean, 'scatter', nbp_glo, index_g)
920	CALL restput_p (rest_id, 'drainage_route', nbp_glo, 1, 1, kjit, drainage_mean, 'scatter', nbp_glo, index_g)
921	CALL restput_p (rest_id, 'transpot_route', nbp_glo, 1, 1, kjit, transpot_mean, 'scatter', nbp_glo, index_g)
922	CALL restput_p (rest_id, 'precip_route', nbp_glo, 1, 1, kjit, precip_mean, 'scatter', nbp_glo, index_g)
923	CALL restput_p (rest_id, 'humrel_route', nbp_glo, 1, 1, kjit, humrel_mean, 'scatter', nbp_glo, index_g)
924	CALL restput_p (rest_id, 'totnobio_route', nbp_glo, 1, 1, kjit, totnobio_mean, 'scatter', nbp_glo, index_g)
925	CALL restput_p (rest_id, 'k_litt_route', nbp_glo, 1, 1, kjit, k_litt_mean, 'scatter', nbp_glo, index_g)
926	CALL restput_p (rest_id, 'vegtot_route', nbp_glo, 1, 1, kjit, vegtot_mean, 'scatter', nbp_glo, index_g)
927
928	IF ( do_irrigation ) THEN
929	CALL restput_p (rest_id, 'irrigated', nbp_glo, 1, 1, kjit, irrigated, 'scatter', nbp_glo, index_g)
930	CALL restput_p (rest_id, 'irrigation', nbp_glo, 1, 1, kjit, irrigation_mean, 'scatter', nbp_glo, index_g)
931	ENDIF
932
933	IF ( do_floodplains ) THEN
934	CALL restput_p (rest_id, 'floodplains', nbp_glo, 1, 1, kjit, floodplains, 'scatter', nbp_glo, index_g)
935	ENDIF
936	IF ( doswamps ) THEN
937	CALL restput_p (rest_id, 'swamp', nbp_glo, 1, 1, kjit, swamp, 'scatter', nbp_glo, index_g)
938	ENDIF
939
940	END SUBROUTINE routing_finalize
941
942	!! ================================================================================================================================
943	!! SUBROUTINE : routing_init
944	!!
945	!>\BRIEF This subroutine allocates the memory and get the fixed fields from the restart file.
946	!!
947	!! DESCRIPTION (definitions, functional, design, flags) : None
948	!!
949	!! RECENT CHANGE(S): None
950	!!
951	!! MAIN OUTPUT VARIABLE(S):
952	!!
953	!! REFERENCES : None
954	!!
955	!! FLOWCHART :None
956	!! \n
957	!_ ================================================================================================================================
958
959	SUBROUTINE routing_init(kjit, nbpt, index, returnflow, reinfiltration, irrigation, &
960	& riverflow, coastalflow, flood_frac, flood_res, stempdiag, rest_id)
961	!
962	IMPLICIT NONE
963	!
964	! interface description
965	!
966	!! INPUT VARIABLES
967	INTEGER(i_std), INTENT(in) :: kjit !! Time step number (unitless)
968	INTEGER(i_std), INTENT(in) :: nbpt !! Domain size (unitless)
969	INTEGER(i_std), DIMENSION (nbpt), INTENT(in) :: index !! Indices of the points on the map (unitless)
970	REAL(r_std), DIMENSION(nbpt,nbdl),INTENT(in) :: stempdiag !! Temperature profile in soil
971	INTEGER(i_std), INTENT(in) :: rest_id !! Restart file identifier (unitless)
972	!
973	!! OUTPUT VARIABLES
974	REAL(r_std), DIMENSION (nbpt),INTENT(out) :: returnflow !! The water flow from lakes and swamps which returns into the grid box.
975	!! This water will go back into the hydrol or hydrolc module to allow re-evaporation (kg/m^2/dt)
976	REAL(r_std), DIMENSION (nbpt),INTENT(out) :: reinfiltration !! Water flow from ponds and floodplains which returns to the grid box (kg/m^2/dt)
977	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)
978	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)
979	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)
980	REAL(r_std), DIMENSION (nbpt),INTENT(out) :: flood_frac !! Flooded fraction of the grid box (unitless;0-1)
981	REAL(r_std), DIMENSION (nbpt),INTENT(out) :: flood_res !! Diagnostic of water amount in the floodplains reservoir (kg)
982	!
983	!! LOCAL VARIABLES
984	CHARACTER(LEN=80) :: var_name !! To store variables names for I/O (unitless)
985	REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: tmp_real_g !! A temporary real array for the integers
986	REAL(r_std), DIMENSION(1) :: tmp_day !!
987	REAL(r_std) :: ratio !! Diagnostic ratio to check that dt_routing is a multiple of dt_sechiba (unitless)
988	REAL(r_std) :: totarea !! Total area of basin (m^2)
989	INTEGER(i_std) :: ier, ig, ib, ipn(1) !! Indices (unitless)
990
991	!_ ================================================================================================================================
992	!
993	!
994	! These variables will require the configuration infrastructure
995	!
996	!Config Key = DT_ROUTING
997	!Config If = RIVER_ROUTING
998	!Config Desc = Time step of the routing scheme
999	!Config Def = one_day
1000	!Config Help = This values gives the time step in seconds of the routing scheme.
1001	!Config It should be multiple of the main time step of ORCHIDEE. One day
1002	!Config is a good value.
1003	!Config Units = [seconds]
1004	!
1005	dt_routing = one_day
1006	CALL getin_p('DT_ROUTING', dt_routing)
1007	!
1008	!Config Key = ROUTING_RIVERS
1009	!Config If = RIVER_ROUTING
1010	!Config Desc = Number of rivers
1011	!Config Def = 50
1012	!Config Help = This parameter chooses the number of largest river basins
1013	!Config which should be treated as independently as rivers and not
1014	!Config flow into the oceans as diffusion coastal flow.
1015	!Config Units = [-]
1016	num_largest = 50
1017	CALL getin_p('ROUTING_RIVERS', num_largest)
1018	!
1019	!Config Key = DO_FLOODINFILT
1020	!Config Desc = Should floodplains reinfiltrate into the soil
1021	!Config If = RIVER_ROUTING
1022	!Config Def = n
1023	!Config Help = This parameters allows the user to ask the model
1024	!Config to take into account the flood plains reinfiltration
1025	!Config into the soil moisture. It then can go
1026	!Config back to the slow and fast reservoirs
1027	!Config Units = [FLAG]
1028	!
1029	dofloodinfilt = .FALSE.
1030	CALL getin_p('DO_FLOODINFILT', dofloodinfilt)
1031	!
1032	!Config Key = DO_SWAMPS
1033	!Config Desc = Should we include swamp parameterization
1034	!Config If = RIVER_ROUTING
1035	!Config Def = n
1036	!Config Help = This parameters allows the user to ask the model
1037	!Config to take into account the swamps and return
1038	!Config the water into the bottom of the soil. It then can go
1039	!Config back to the atmopshere. This tried to simulate
1040	!Config internal deltas of rivers.
1041	!Config Units = [FLAG]
1042	!
1043	doswamps = .FALSE.
1044	CALL getin_p('DO_SWAMPS', doswamps)
1045	!
1046	!Config Key = DO_PONDS
1047	!Config Desc = Should we include ponds
1048	!Config If = RIVER_ROUTING
1049	!Config Def = n
1050	!Config Help = This parameters allows the user to ask the model
1051	!Config to take into account the ponds and return
1052	!Config the water into the soil moisture. It then can go
1053	!Config back to the atmopshere. This tried to simulate
1054	!Config little ponds especially in West Africa.
1055	!Config Units = [FLAG]
1056	!
1057	doponds = .FALSE.
1058	CALL getin_p('DO_PONDS', doponds)
1059	!
1060	! Fix the time constants according to hydrol_cwrr flag
1061	!
1062	!
1063	!Config Key = SLOW_TCST
1064	!Config Desc = Time constant for the slow reservoir
1065	!Config If = RIVER_ROUTING
1066	!Config Def = n
1067	!Config Help = This parameters allows the user to fix the
1068	!Config time constant (in days) of the slow reservoir
1069	!Config in order to get better river flows for
1070	!Config particular regions.
1071	!Config Units = [days]
1072	!
1073	!> A value for property of each reservoir (in day/m) is given to compute a time constant (in day)
1074	!> for each reservoir (product of tcst and topo_resid).
1075	!> The value of tcst has been calibrated for the three reservoirs over the Senegal river basin only,
1076	!> during the 1 degree NCEP Corrected by Cru (NCC) resolution simulations (Ngo-Duc et al., 2005, Ngo-Duc et al., 2006) and
1077	!> generalized for all the basins of the world. The "slow reservoir" and the "fast reservoir"
1078	!> have the highest value in order to simulate the groundwater.
1079	!> The "stream reservoir", which represents all the water of the stream, has the lowest value.
1080	!> Those figures are the same for all the basins of the world.
1081	!> The value of slow_tcst is equal to fast_tcst when CWRR is activated.
1082	!> This assumption should be re-discussed.
1083	!
1084	IF ( hydrol_cwrr ) THEN
1085	slow_tcst = slow_tcst_cwrr
1086	ELSE
1087	slow_tcst = slow_tcst_chois
1088	ENDIF
1089	CALL getin_p('SLOW_TCST', slow_tcst)
1090	!
1091	!Config Key = FAST_TCST
1092	!Config Desc = Time constant for the fast reservoir
1093	!Config If = RIVER_ROUTING
1094	!Config Def = fast_tcst_cwrr or fast_tcst_chois depending on flag HYDROL_CWRR
1095	!Config Help = This parameters allows the user to fix the
1096	!Config time constant (in days) of the fast reservoir
1097	!Config in order to get better river flows for
1098	!Config particular regions.
1099	!Config Units = [days]
1100	!
1101	IF ( hydrol_cwrr ) THEN
1102	fast_tcst = fast_tcst_cwrr
1103	ELSE
1104	fast_tcst = fast_tcst_chois
1105	ENDIF
1106	CALL getin_p('FAST_TCST', fast_tcst)
1107	!
1108	!Config Key = STREAM_TCST
1109	!Config Desc = Time constant for the stream reservoir
1110	!Config If = RIVER_ROUTING
1111	!Config Def = stream_tcst_cwrr or stream_tcst_chois depending on flag HYDROL_CWRR
1112	!Config Help = This parameters allows the user to fix the
1113	!Config time constant (in days) of the stream reservoir
1114	!Config in order to get better river flows for
1115	!Config particular regions.
1116	!Config Units = [days]
1117	!
1118	IF ( hydrol_cwrr ) THEN
1119	stream_tcst = stream_tcst_cwrr
1120	ELSE
1121	stream_tcst = stream_tcst_chois
1122	ENDIF
1123	CALL getin_p('STREAM_TCST', stream_tcst)
1124	!
1125	!Config Key = FLOOD_TCST
1126	!Config Desc = Time constant for the flood reservoir
1127	!Config If = RIVER_ROUTING
1128	!Config Def = 4.0
1129	!Config Help = This parameters allows the user to fix the
1130	!Config time constant (in days) of the flood reservoir
1131	!Config in order to get better river flows for
1132	!Config particular regions.
1133	!Config Units = [days]
1134	!
1135	IF ( hydrol_cwrr ) THEN
1136	flood_tcst = flood_tcst_cwrr
1137	ELSE
1138	flood_tcst = flood_tcst_chois
1139	ENDIF
1140	CALL getin_p('FLOOD_TCST', flood_tcst)
1141	!
1142	!Config Key = SWAMP_CST
1143	!Config Desc = Fraction of the river that flows back to swamps
1144	!Config If = RIVER_ROUTING
1145	!Config Def = 0.2
1146	!Config Help = This parameters allows the user to fix the
1147	!Config fraction of the river transport
1148	!Config that flows to swamps
1149	!Config Units = [-]
1150	!
1151	IF ( hydrol_cwrr ) THEN
1152	swamp_cst = swamp_cst_cwrr
1153	ELSE
1154	swamp_cst = swamp_cst_chois
1155	ENDIF
1156	CALL getin_p('SWAMP_CST', swamp_cst)
1157	!
1158	!Config Key = FLOOD_BETA
1159	!Config Desc = Parameter to fix the shape of the floodplain
1160	!Config If = RIVER_ROUTING
1161	!Config Def = 2.0
1162	!Config Help = Parameter to fix the shape of the floodplain
1163	!Config (>1 for convex edges, <1 for concave edges)
1164	!Config Units = [-]
1165	CALL getin_p("FLOOD_BETA", beta)
1166	!
1167	!Config Key = POND_BETAP
1168	!Config Desc = Ratio of the basin surface intercepted by ponds and the maximum surface of ponds
1169	!Config If = RIVER_ROUTING
1170	!Config Def = 0.5
1171	!Config Help =
1172	!Config Units = [-]
1173	CALL getin_p("POND_BETAP", betap)
1174	!
1175	!Config Key = FLOOD_CRI
1176	!Config Desc = Potential height for which all the basin is flooded
1177	!Config If = DO_FLOODPLAINS or DO_PONDS
1178	!Config Def = 2000.
1179	!Config Help =
1180	!Config Units = [mm]
1181	CALL getin_p("FLOOD_CRI", floodcri)
1182	!
1183	!Config Key = POND_CRI
1184	!Config Desc = Potential height for which all the basin is a pond
1185	!Config If = DO_FLOODPLAINS or DO_PONDS
1186	!Config Def = 2000.
1187	!Config Help =
1188	!Config Units = [mm]
1189	CALL getin_p("POND_CRI", pondcri)
1190
1191	!Config Key = MAX_LAKE_RESERVOIR
1192	!Config Desc = Maximum limit of water in lake_reservoir
1193	!Config If = RIVER_ROUTING
1194	!Config Def = 7000
1195	!Config Help =
1196	!Config Units = [kg/m2(routing area)]
1197	max_lake_reservoir = 7000
1198	CALL getin_p("MAX_LAKE_RESERVOIR", max_lake_reservoir)
1199
1200	!
1201	!
1202	! In order to simplify the time cascade check that dt_routing
1203	! is a multiple of dt_sechiba
1204	!
1205	ratio = dt_routing/dt_sechiba
1206	IF ( ABS(NINT(ratio) - ratio) .GT. 10*EPSILON(ratio)) THEN
1207	WRITE(numout,*) 'WARNING -- WARNING -- WARNING -- WARNING'
1208	WRITE(numout,*) "The chosen time step for the routing is not a multiple of the"
1209	WRITE(numout,*) "main time step of the model. We will change dt_routing so that"
1210	WRITE(numout,*) "this condition os fulfilled"
1211	dt_routing = NINT(ratio) * dt_sechiba
1212	WRITE(numout,*) 'THE NEW DT_ROUTING IS : ', dt_routing
1213	ENDIF
1214	!
1215	IF ( dt_routing .LT. dt_sechiba) THEN
1216	WRITE(numout,*) 'WARNING -- WARNING -- WARNING -- WARNING'
1217	WRITE(numout,*) 'The routing timestep can not be smaller than the one'
1218	WRITE(numout,*) 'of the model. We reset its value to the model''s timestep.'
1219	WRITE(numout,*) 'The old DT_ROUTING is : ', dt_routing
1220	dt_routing = dt_sechiba
1221	WRITE(numout,*) 'THE NEW DT_ROUTING IS : ', dt_routing
1222	ENDIF
1223	!
1224	var_name ="routingcounter"
1225	IF (is_root_prc) THEN
1226	CALL ioconf_setatt('UNITS', 's')
1227	CALL ioconf_setatt('LONG_NAME','Time counter for the routing scheme')
1228	CALL restget (rest_id, var_name, 1, 1, 1, kjit, .TRUE., tmp_day)
1229	IF (tmp_day(1) == val_exp) THEN
1230	! The variable was not found in restart file, initialize to zero
1231	time_counter = zero
1232	ELSE
1233	! Take the value from restart file
1234	time_counter = tmp_day(1)
1235	ENDIF
1236	ENDIF
1237	CALL bcast(time_counter)
1238
1239
1240	ALLOCATE (routing_area_loc(nbpt,nbasmax), stat=ier)
1241	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for routing_area_loc','','')
1242
1243	ALLOCATE (routing_area_glo(nbp_glo,nbasmax))
1244	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for routing_area_glo','','')
1245	var_name = 'routingarea'
1246	IF (is_root_prc) THEN
1247	CALL ioconf_setatt('UNITS', 'm^2')
1248	CALL ioconf_setatt('LONG_NAME','Area of basin')
1249	CALL restget (rest_id, var_name, nbp_glo, nbasmax, 1, kjit, .TRUE., routing_area_glo, "gather", nbp_glo, index_g)
1250	ENDIF
1251	CALL scatter(routing_area_glo,routing_area_loc)
1252	routing_area=>routing_area_loc
1253
1254	ALLOCATE (tmp_real_g(nbp_glo,nbasmax), stat=ier)
1255	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for tmp_real_g','','')
1256
1257	ALLOCATE (route_togrid_loc(nbpt,nbasmax), stat=ier)
1258	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for route_togrid_loc','','')
1259	ALLOCATE (route_togrid_glo(nbp_glo,nbasmax), stat=ier) ! used in global in routing_flow
1260	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for route_togrid_glo','','')
1261
1262	IF (is_root_prc) THEN
1263	var_name = 'routetogrid'
1264	CALL ioconf_setatt('UNITS', '-')
1265	CALL ioconf_setatt('LONG_NAME','Grid into which the basin flows')
1266	CALL restget (rest_id, var_name, nbp_glo, nbasmax, 1, kjit, .TRUE., tmp_real_g, "gather", nbp_glo, index_g)
1267	route_togrid_glo(:,:) = undef_int
1268	WHERE ( tmp_real_g .LT. val_exp )
1269	route_togrid_glo = NINT(tmp_real_g)
1270	ENDWHERE
1271	ENDIF
1272	CALL bcast(route_togrid_glo) ! used in global in routing_flow
1273	CALL scatter(route_togrid_glo,route_togrid_loc)
1274	route_togrid=>route_togrid_loc
1275	!
1276	ALLOCATE (route_tobasin_loc(nbpt,nbasmax), stat=ier)
1277	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for route_tobasin_loc','','')
1278
1279	ALLOCATE (route_tobasin_glo(nbp_glo,nbasmax), stat=ier)
1280	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for route_tobasin_glo','','')
1281
1282	IF (is_root_prc) THEN
1283	var_name = 'routetobasin'
1284	CALL ioconf_setatt('UNITS', '-')
1285	CALL ioconf_setatt('LONG_NAME','Basin in to which the water goes')
1286	CALL restget (rest_id, var_name, nbp_glo, nbasmax, 1, kjit, .TRUE., tmp_real_g, "gather", nbp_glo, index_g)
1287	route_tobasin_glo = undef_int
1288	WHERE ( tmp_real_g .LT. val_exp )
1289	route_tobasin_glo = NINT(tmp_real_g)
1290	ENDWHERE
1291	ENDIF
1292	CALL scatter(route_tobasin_glo,route_tobasin_loc)
1293	route_tobasin=>route_tobasin_loc
1294	!
1295	! nbintobasin
1296	!
1297	ALLOCATE (route_nbintobas_loc(nbpt,nbasmax), stat=ier)
1298	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for route_nbintobas_loc','','')
1299	ALLOCATE (route_nbintobas_glo(nbp_glo,nbasmax), stat=ier)
1300	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for route_nbintobas_glo','','')
1301
1302	IF (is_root_prc) THEN
1303	var_name = 'routenbintobas'
1304	CALL ioconf_setatt('UNITS', '-')
1305	CALL ioconf_setatt('LONG_NAME','Number of basin into current one')
1306	CALL restget (rest_id, var_name, nbp_glo, nbasmax, 1, kjit, .TRUE., tmp_real_g, "gather", nbp_glo, index_g)
1307	route_nbintobas_glo = undef_int
1308	WHERE ( tmp_real_g .LT. val_exp )
1309	route_nbintobas_glo = NINT(tmp_real_g)
1310	ENDWHERE
1311	ENDIF
1312	CALL scatter(route_nbintobas_glo,route_nbintobas_loc)
1313	route_nbintobas=>route_nbintobas_loc
1314	!
1315	ALLOCATE (global_basinid_loc(nbpt,nbasmax), stat=ier)
1316	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for global_basinid_loc','','')
1317	ALLOCATE (global_basinid_glo(nbp_glo,nbasmax), stat=ier)
1318	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for global_basinid_glo','','')
1319
1320	IF (is_root_prc) THEN
1321	var_name = 'basinid'
1322	CALL ioconf_setatt('UNITS', '-')
1323	CALL ioconf_setatt('LONG_NAME','ID of basin')
1324	CALL restget (rest_id, var_name, nbp_glo, nbasmax, 1, kjit, .TRUE., tmp_real_g, "gather", nbp_glo, index_g)
1325	global_basinid_glo = undef_int
1326	WHERE ( tmp_real_g .LT. val_exp )
1327	global_basinid_glo = NINT(tmp_real_g)
1328	ENDWHERE
1329	ENDIF
1330	CALL scatter(global_basinid_glo,global_basinid_loc)
1331	global_basinid=>global_basinid_loc
1332	!
1333	ALLOCATE (topo_resid_loc(nbpt,nbasmax), stat=ier)
1334	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for topo_resid_loc','','')
1335	ALLOCATE (topo_resid_glo(nbp_glo,nbasmax), stat=ier)
1336	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for topo_resid_glo','','')
1337
1338	IF (is_root_prc) THEN
1339	var_name = 'topoindex'
1340	CALL ioconf_setatt('UNITS', 'm')
1341	CALL ioconf_setatt('LONG_NAME','Topographic index of the residence time')
1342	CALL restget (rest_id, var_name, nbp_glo, nbasmax, 1, kjit, .TRUE., topo_resid_glo, "gather", nbp_glo, index_g)
1343	ENDIF
1344	CALL scatter(topo_resid_glo,topo_resid_loc)
1345	topo_resid=>topo_resid_loc
1346
1347	ALLOCATE (fast_reservoir(nbpt,nbasmax), stat=ier)
1348	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for fast_reservoir','','')
1349	var_name = 'fastres'
1350	CALL ioconf_setatt_p('UNITS', 'Kg')
1351	CALL ioconf_setatt_p('LONG_NAME','Water in the fast reservoir')
1352	CALL restget_p (rest_id, var_name, nbp_glo, nbasmax, 1, kjit, .TRUE., fast_reservoir, "gather", nbp_glo, index_g)
1353	CALL setvar_p (fast_reservoir, val_exp, 'NO_KEYWORD', zero)
1354
1355	ALLOCATE (slow_reservoir(nbpt,nbasmax), stat=ier)
1356	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for slow_reservoir','','')
1357	var_name = 'slowres'
1358	CALL ioconf_setatt_p('UNITS', 'Kg')
1359	CALL ioconf_setatt_p('LONG_NAME','Water in the slow reservoir')
1360	CALL restget_p (rest_id, var_name, nbp_glo, nbasmax, 1, kjit, .TRUE., slow_reservoir, "gather", nbp_glo, index_g)
1361	CALL setvar_p (slow_reservoir, val_exp, 'NO_KEYWORD', zero)
1362
1363	ALLOCATE (stream_reservoir(nbpt,nbasmax), stat=ier)
1364	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for stream_reservoir','','')
1365	var_name = 'streamres'
1366	CALL ioconf_setatt_p('UNITS', 'Kg')
1367	CALL ioconf_setatt_p('LONG_NAME','Water in the stream reservoir')
1368	CALL restget_p (rest_id, var_name, nbp_glo, nbasmax, 1, kjit, .TRUE., stream_reservoir, "gather", nbp_glo, index_g)
1369	CALL setvar_p (stream_reservoir, val_exp, 'NO_KEYWORD', zero)
1370
1371	ALLOCATE (flood_reservoir(nbpt,nbasmax), stat=ier)
1372	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for flood_reservoir','','')
1373	var_name = 'floodres'
1374	CALL ioconf_setatt_p('UNITS', 'Kg')
1375	CALL ioconf_setatt_p('LONG_NAME','Water in the flood reservoir')
1376	CALL restget_p (rest_id, var_name, nbp_glo, nbasmax, 1, kjit, .TRUE., flood_reservoir, "gather", nbp_glo, index_g)
1377	CALL setvar_p (flood_reservoir, val_exp, 'NO_KEYWORD', zero)
1378
1379	ALLOCATE (flood_frac_bas(nbpt,nbasmax), stat=ier)
1380	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for flood_frac_bas','','')
1381	var_name = 'flood_frac_bas'
1382	CALL ioconf_setatt_p('UNITS', '-')
1383	CALL ioconf_setatt_p('LONG_NAME','Flooded fraction per basin')
1384	CALL restget_p (rest_id, var_name, nbp_glo, nbasmax, 1, kjit, .TRUE., flood_frac_bas, "gather", nbp_glo, index_g)
1385	CALL setvar_p (flood_frac_bas, val_exp, 'NO_KEYWORD', zero)
1386
1387	ALLOCATE (flood_height(nbpt), stat=ier)
1388	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for flood_height','','')
1389	var_name = 'floodh'
1390	CALL ioconf_setatt_p('UNITS', '-')
1391	CALL ioconf_setatt_p('LONG_NAME','')
1392	CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., flood_height, "gather", nbp_glo, index_g)
1393	CALL setvar_p (flood_height, val_exp, 'NO_KEYWORD', zero)
1394
1395	ALLOCATE (pond_frac(nbpt), stat=ier)
1396	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for pond_frac','','')
1397	var_name = 'pond_frac'
1398	CALL ioconf_setatt_p('UNITS', '-')
1399	CALL ioconf_setatt_p('LONG_NAME','Pond fraction per grid box')
1400	CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., pond_frac, "gather", nbp_glo, index_g)
1401	CALL setvar_p (pond_frac, val_exp, 'NO_KEYWORD', zero)
1402
1403	var_name = 'flood_frac'
1404	CALL ioconf_setatt_p('UNITS', '-')
1405	CALL ioconf_setatt_p('LONG_NAME','Flooded fraction per grid box')
1406	CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., flood_frac, "gather", nbp_glo, index_g)
1407	CALL setvar_p (flood_frac, val_exp, 'NO_KEYWORD', zero)
1408
1409	var_name = 'flood_res'
1410	CALL ioconf_setatt_p('UNITS','mm')
1411	CALL ioconf_setatt_p('LONG_NAME','Flooded quantity (estimation)')
1412	CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., flood_res, "gather", nbp_glo, index_g)
1413	CALL setvar_p (flood_res, val_exp, 'NO_KEYWORD', zero)
1414	! flood_res = zero
1415
1416	ALLOCATE (lake_reservoir(nbpt), stat=ier)
1417	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for lake_reservoir','','')
1418	var_name = 'lakeres'
1419	CALL ioconf_setatt_p('UNITS', 'Kg')
1420	CALL ioconf_setatt_p('LONG_NAME','Water in the lake reservoir')
1421	CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., lake_reservoir, "gather", nbp_glo, index_g)
1422	CALL setvar_p (lake_reservoir, val_exp, 'NO_KEYWORD', zero)
1423
1424	ALLOCATE (pond_reservoir(nbpt), stat=ier)
1425	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for pond_reservoir','','')
1426	var_name = 'pondres'
1427	CALL ioconf_setatt_p('UNITS', 'Kg')
1428	CALL ioconf_setatt_p('LONG_NAME','Water in the pond reservoir')
1429	CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., pond_reservoir, "gather", nbp_glo, index_g)
1430	CALL setvar_p (pond_reservoir, val_exp, 'NO_KEYWORD', zero)
1431	!
1432	! Map of irrigated areas
1433	!
1434	IF ( do_irrigation ) THEN
1435	ALLOCATE (irrigated(nbpt), stat=ier)
1436	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for irrigated','','')
1437	var_name = 'irrigated'
1438	CALL ioconf_setatt_p('UNITS', 'm^2')
1439	CALL ioconf_setatt_p('LONG_NAME','Surface of irrigated area')
1440	CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., irrigated, "gather", nbp_glo, index_g)
1441	CALL setvar_p (irrigated, val_exp, 'NO_KEYWORD', undef_sechiba)
1442	ENDIF
1443
1444	IF ( do_floodplains ) THEN
1445	ALLOCATE (floodplains(nbpt), stat=ier)
1446	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for floodplains','','')
1447	var_name = 'floodplains'
1448	CALL ioconf_setatt_p('UNITS', 'm^2')
1449	CALL ioconf_setatt_p('LONG_NAME','Surface which can be flooded')
1450	CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., floodplains, "gather", nbp_glo, index_g)
1451	CALL setvar_p (floodplains, val_exp, 'NO_KEYWORD', undef_sechiba)
1452	ENDIF
1453	IF ( doswamps ) THEN
1454	ALLOCATE (swamp(nbpt), stat=ier)
1455	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for swamp','','')
1456	var_name = 'swamp'
1457	CALL ioconf_setatt_p('UNITS', 'm^2')
1458	CALL ioconf_setatt_p('LONG_NAME','Surface which can become swamp')
1459	CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., swamp, "gather", nbp_glo, index_g)
1460	CALL setvar_p (swamp, val_exp, 'NO_KEYWORD', undef_sechiba)
1461	ENDIF
1462	!
1463	! Put into the restart file the fluxes so that they can be regenerated at restart.
1464	!
1465	ALLOCATE (lakeinflow_mean(nbpt), stat=ier)
1466	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for lakeinflow_mean','','')
1467	var_name = 'lakeinflow'
1468	CALL ioconf_setatt_p('UNITS', 'Kg/dt')
1469	CALL ioconf_setatt_p('LONG_NAME','Lake inflow')
1470	CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., lakeinflow_mean, "gather", nbp_glo, index_g)
1471	CALL setvar_p (lakeinflow_mean, val_exp, 'NO_KEYWORD', zero)
1472
1473	ALLOCATE (returnflow_mean(nbpt), stat=ier)
1474	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for returnflow_mean','','')
1475	var_name = 'returnflow'
1476	CALL ioconf_setatt_p('UNITS', 'Kg/m^2/dt')
1477	CALL ioconf_setatt_p('LONG_NAME','Deep return flux')
1478	CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., returnflow_mean, "gather", nbp_glo, index_g)
1479	CALL setvar_p (returnflow_mean, val_exp, 'NO_KEYWORD', zero)
1480	returnflow(:) = returnflow_mean(:)
1481
1482	ALLOCATE (reinfiltration_mean(nbpt), stat=ier)
1483	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for reinfiltration_mean','','')
1484	var_name = 'reinfiltration'
1485	CALL ioconf_setatt_p('UNITS', 'Kg/m^2/dt')
1486	CALL ioconf_setatt_p('LONG_NAME','Top return flux')
1487	CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., reinfiltration_mean, "gather", nbp_glo, index_g)
1488	CALL setvar_p (reinfiltration_mean, val_exp, 'NO_KEYWORD', zero)
1489	reinfiltration(:) = reinfiltration_mean(:)
1490
1491	ALLOCATE (irrigation_mean(nbpt), stat=ier)
1492	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for irrigation_mean','','')
1493	ALLOCATE (irrig_netereq(nbpt), stat=ier)
1494	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for irrig_netereq','','')
1495	irrig_netereq(:) = zero
1496
1497	IF ( do_irrigation ) THEN
1498	var_name = 'irrigation'
1499	CALL ioconf_setatt_p('UNITS', 'Kg/dt')
1500	CALL ioconf_setatt_p('LONG_NAME','Artificial irrigation flux')
1501	CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., irrigation_mean, "gather", nbp_glo, index_g)
1502	CALL setvar_p (irrigation_mean, val_exp, 'NO_KEYWORD', zero)
1503	ELSE
1504	irrigation_mean(:) = zero
1505	ENDIF
1506	irrigation(:) = irrigation_mean(:)
1507
1508	ALLOCATE (riverflow_mean(nbpt), stat=ier)
1509	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for riverflow_mean','','')
1510	var_name = 'riverflow'
1511	CALL ioconf_setatt_p('UNITS', 'Kg/dt')
1512	CALL ioconf_setatt_p('LONG_NAME','River flux into the sea')
1513	CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., riverflow_mean, "gather", nbp_glo, index_g)
1514	CALL setvar_p (riverflow_mean, val_exp, 'NO_KEYWORD', zero)
1515	riverflow(:) = riverflow_mean(:)
1516
1517	ALLOCATE (coastalflow_mean(nbpt), stat=ier)
1518	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for coastalflow_mean','','')
1519	var_name = 'coastalflow'
1520	CALL ioconf_setatt_p('UNITS', 'Kg/dt')
1521	CALL ioconf_setatt_p('LONG_NAME','Diffuse flux into the sea')
1522	CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., coastalflow_mean, "gather", nbp_glo, index_g)
1523	CALL setvar_p (coastalflow_mean, val_exp, 'NO_KEYWORD', zero)
1524	coastalflow(:) = coastalflow_mean(:)
1525
1526	! Locate it at the 2m level
1527	ipn = MINLOC(ABS(diaglev-2))
1528	floodtemp_lev = ipn(1)
1529	ALLOCATE (floodtemp(nbpt), stat=ier)
1530	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for floodtemp','','')
1531	floodtemp(:) = stempdiag(:,floodtemp_lev)
1532
1533	ALLOCATE(hydrographs(nbpt), stat=ier)
1534	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for hydrographs','','')
1535	var_name = 'hydrographs'
1536	CALL ioconf_setatt_p('UNITS', 'kg/dt_sechiba')
1537	CALL ioconf_setatt_p('LONG_NAME','Hydrograph at outlow of grid')
1538	CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., hydrographs, "gather", nbp_glo, index_g)
1539	CALL setvar_p (hydrographs, val_exp, 'NO_KEYWORD', zero)
1540
1541	ALLOCATE(slowflow_diag(nbpt), stat=ier)
1542	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for slowflow_diag','','')
1543	var_name = 'slowflow_diag'
1544	CALL ioconf_setatt_p('UNITS', 'kg/dt_sechiba')
1545	CALL ioconf_setatt_p('LONG_NAME','Slowflow hydrograph at outlow of grid')
1546	CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE.,slowflow_diag, "gather", nbp_glo, index_g)
1547	CALL setvar_p (slowflow_diag, val_exp, 'NO_KEYWORD', zero)
1548
1549	!
1550	! The diagnostic variables, they are initialized from the above restart variables.
1551	!
1552	ALLOCATE(fast_diag(nbpt), slow_diag(nbpt), stream_diag(nbpt), flood_diag(nbpt), &
1553	& pond_diag(nbpt), lake_diag(nbpt), stat=ier)
1554	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for fast_diag,..','','')
1555
1556	fast_diag(:) = zero
1557	slow_diag(:) = zero
1558	stream_diag(:) = zero
1559	flood_diag(:) = zero
1560	pond_diag(:) = zero
1561	lake_diag(:) = zero
1562
1563	DO ig=1,nbpt
1564	totarea = zero
1565	DO ib=1,nbasmax
1566	totarea = totarea + routing_area(ig,ib)
1567	fast_diag(ig) = fast_diag(ig) + fast_reservoir(ig,ib)
1568	slow_diag(ig) = slow_diag(ig) + slow_reservoir(ig,ib)
1569	stream_diag(ig) = stream_diag(ig) + stream_reservoir(ig,ib)
1570	flood_diag(ig) = flood_diag(ig) + flood_reservoir(ig,ib)
1571	ENDDO
1572	!
1573	fast_diag(ig) = fast_diag(ig)/totarea
1574	slow_diag(ig) = slow_diag(ig)/totarea
1575	stream_diag(ig) = stream_diag(ig)/totarea
1576	flood_diag(ig) = flood_diag(ig)/totarea
1577	!
1578	! This is the volume of the lake scaled to the entire grid.
1579	! It would be better to scale it to the size of the lake
1580	! but this information is not yet available.
1581	!
1582	lake_diag(ig) = lake_reservoir(ig)/totarea
1583	!
1584	ENDDO
1585	!
1586	! Get from the restart the fluxes we accumulated.
1587	!
1588	ALLOCATE (floodout_mean(nbpt), stat=ier)
1589	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for floodout_mean','','')
1590	var_name = 'floodout_route'
1591	CALL ioconf_setatt_p('UNITS', 'Kg')
1592	CALL ioconf_setatt_p('LONG_NAME','Accumulated flow out of floodplains for routing')
1593	CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., floodout_mean, "gather", nbp_glo, index_g)
1594	CALL setvar_p (floodout_mean, val_exp, 'NO_KEYWORD', zero)
1595
1596	ALLOCATE (runoff_mean(nbpt), stat=ier)
1597	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for runoff_mean','','')
1598	var_name = 'runoff_route'
1599	CALL ioconf_setatt_p('UNITS', 'Kg')
1600	CALL ioconf_setatt_p('LONG_NAME','Accumulated runoff for routing')
1601	CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., runoff_mean, "gather", nbp_glo, index_g)
1602	CALL setvar_p (runoff_mean, val_exp, 'NO_KEYWORD', zero)
1603
1604	ALLOCATE(drainage_mean(nbpt), stat=ier)
1605	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for drainage_mean','','')
1606	var_name = 'drainage_route'
1607	CALL ioconf_setatt_p('UNITS', 'Kg')
1608	CALL ioconf_setatt_p('LONG_NAME','Accumulated drainage for routing')
1609	CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., drainage_mean, "gather", nbp_glo, index_g)
1610	CALL setvar_p (drainage_mean, val_exp, 'NO_KEYWORD', zero)
1611
1612	ALLOCATE(transpot_mean(nbpt), stat=ier)
1613	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for transpot_mean','','')
1614	var_name = 'transpot_route'
1615	CALL ioconf_setatt_p('UNITS', 'Kg/m^2')
1616	CALL ioconf_setatt_p('LONG_NAME','Accumulated potential transpiration for routing/irrigation')
1617	CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., transpot_mean, "gather", nbp_glo, index_g)
1618	CALL setvar_p (transpot_mean, val_exp, 'NO_KEYWORD', zero)
1619
1620	ALLOCATE(precip_mean(nbpt), stat=ier)
1621	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for precip_mean','','')
1622	var_name = 'precip_route'
1623	CALL ioconf_setatt_p('UNITS', 'Kg/m^2')
1624	CALL ioconf_setatt_p('LONG_NAME','Accumulated rain precipitation for irrigation')
1625	CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., precip_mean, "gather", nbp_glo, index_g)
1626	CALL setvar_p (precip_mean, val_exp, 'NO_KEYWORD', zero)
1627
1628	ALLOCATE(humrel_mean(nbpt), stat=ier)
1629	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for humrel_mean','','')
1630	var_name = 'humrel_route'
1631	CALL ioconf_setatt_p('UNITS', '-')
1632	CALL ioconf_setatt_p('LONG_NAME','Mean humrel for irrigation')
1633	CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., humrel_mean, "gather", nbp_glo, index_g)
1634	CALL setvar_p (humrel_mean, val_exp, 'NO_KEYWORD', un)
1635
1636	ALLOCATE(k_litt_mean(nbpt), stat=ier)
1637	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for k_litt_mean','','')
1638	var_name = 'k_litt_route'
1639	CALL ioconf_setatt_p('UNITS', '-')
1640	CALL ioconf_setatt_p('LONG_NAME','Mean cond. for litter')
1641	CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., k_litt_mean, "gather", nbp_glo, index_g)
1642	CALL setvar_p (k_litt_mean, val_exp, 'NO_KEYWORD', zero)
1643
1644	ALLOCATE(totnobio_mean(nbpt), stat=ier)
1645	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for totnobio_mean','','')
1646	var_name = 'totnobio_route'
1647	CALL ioconf_setatt_p('UNITS', '-')
1648	CALL ioconf_setatt_p('LONG_NAME','Last Total fraction of no bio for irrigation')
1649	CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., totnobio_mean, "gather", nbp_glo, index_g)
1650	CALL setvar_p (totnobio_mean, val_exp, 'NO_KEYWORD', zero)
1651
1652	ALLOCATE(vegtot_mean(nbpt), stat=ier)
1653	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for vegtot_mean','','')
1654	var_name = 'vegtot_route'
1655	CALL ioconf_setatt_p('UNITS', '-')
1656	CALL ioconf_setatt_p('LONG_NAME','Last Total fraction of vegetation')
1657	CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., vegtot_mean, "gather", nbp_glo, index_g)
1658	CALL setvar_p (vegtot_mean, val_exp, 'NO_KEYWORD', un)
1659	!
1660	!
1661	DEALLOCATE(tmp_real_g)
1662	!
1663	! Allocate diagnostic variables
1664	!
1665	ALLOCATE(hydrodiag_loc(nbpt,nbasmax),hydrodiag_glo(nbp_glo,nbasmax),stat=ier)
1666	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for hydrodiag_glo','','')
1667	hydrodiag=>hydrodiag_loc
1668
1669	ALLOCATE(hydroupbasin_loc(nbpt),hydroupbasin_glo(nbp_glo), stat=ier)
1670	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for hydroupbasin_glo','','')
1671	hydroupbasin=>hydroupbasin_loc
1672
1673	END SUBROUTINE routing_init
1674	!
1675	!! ================================================================================================================================
1676	!! SUBROUTINE : routing_clear
1677	!!
1678	!>\BRIEF : This subroutine deallocates the block memory previously allocated.
1679	!! \n
1680	!_ ================================================================================================================================
1681
1682	SUBROUTINE routing_clear()
1683
1684	IF (ALLOCATED(routing_area_loc)) DEALLOCATE(routing_area_loc)
1685	IF (ALLOCATED(route_togrid_loc)) DEALLOCATE(route_togrid_loc)
1686	IF (ALLOCATED(route_tobasin_loc)) DEALLOCATE(route_tobasin_loc)
1687	IF (ALLOCATED(route_nbintobas_loc)) DEALLOCATE(route_nbintobas_loc)
1688	IF (ALLOCATED(global_basinid_loc)) DEALLOCATE(global_basinid_loc)
1689	IF (ALLOCATED(topo_resid_loc)) DEALLOCATE(topo_resid_loc)
1690	IF (ALLOCATED(routing_area_glo)) DEALLOCATE(routing_area_glo)
1691	IF (ALLOCATED(route_togrid_glo)) DEALLOCATE(route_togrid_glo)
1692	IF (ALLOCATED(route_tobasin_glo)) DEALLOCATE(route_tobasin_glo)
1693	IF (ALLOCATED(route_nbintobas_glo)) DEALLOCATE(route_nbintobas_glo)
1694	IF (ALLOCATED(global_basinid_glo)) DEALLOCATE(global_basinid_glo)
1695	IF (ALLOCATED(topo_resid_glo)) DEALLOCATE(topo_resid_glo)
1696	IF (ALLOCATED(fast_reservoir)) DEALLOCATE(fast_reservoir)
1697	IF (ALLOCATED(slow_reservoir)) DEALLOCATE(slow_reservoir)
1698	IF (ALLOCATED(stream_reservoir)) DEALLOCATE(stream_reservoir)
1699	IF (ALLOCATED(flood_reservoir)) DEALLOCATE(flood_reservoir)
1700	IF (ALLOCATED(flood_frac_bas)) DEALLOCATE(flood_frac_bas)
1701	IF (ALLOCATED(flood_height)) DEALLOCATE(flood_height)
1702	IF (ALLOCATED(pond_frac)) DEALLOCATE(pond_frac)
1703	IF (ALLOCATED(lake_reservoir)) DEALLOCATE(lake_reservoir)
1704	IF (ALLOCATED(pond_reservoir)) DEALLOCATE(pond_reservoir)
1705	IF (ALLOCATED(returnflow_mean)) DEALLOCATE(returnflow_mean)
1706	IF (ALLOCATED(reinfiltration_mean)) DEALLOCATE(reinfiltration_mean)
1707	IF (ALLOCATED(riverflow_mean)) DEALLOCATE(riverflow_mean)
1708	IF (ALLOCATED(coastalflow_mean)) DEALLOCATE(coastalflow_mean)
1709	IF (ALLOCATED(lakeinflow_mean)) DEALLOCATE(lakeinflow_mean)
1710	IF (ALLOCATED(runoff_mean)) DEALLOCATE(runoff_mean)
1711	IF (ALLOCATED(floodout_mean)) DEALLOCATE(floodout_mean)
1712	IF (ALLOCATED(drainage_mean)) DEALLOCATE(drainage_mean)
1713	IF (ALLOCATED(transpot_mean)) DEALLOCATE(transpot_mean)
1714	IF (ALLOCATED(precip_mean)) DEALLOCATE(precip_mean)
1715	IF (ALLOCATED(humrel_mean)) DEALLOCATE(humrel_mean)
1716	IF (ALLOCATED(k_litt_mean)) DEALLOCATE(k_litt_mean)
1717	IF (ALLOCATED(totnobio_mean)) DEALLOCATE(totnobio_mean)
1718	IF (ALLOCATED(vegtot_mean)) DEALLOCATE(vegtot_mean)
1719	IF (ALLOCATED(floodtemp)) DEALLOCATE(floodtemp)
1720	IF (ALLOCATED(hydrodiag_loc)) DEALLOCATE(hydrodiag_loc)
1721	IF (ALLOCATED(hydrodiag_glo)) DEALLOCATE(hydrodiag_glo)
1722	IF (ALLOCATED(hydroupbasin_loc)) DEALLOCATE(hydroupbasin_loc)
1723	IF (ALLOCATED(hydroupbasin_glo)) DEALLOCATE(hydroupbasin_glo)
1724	IF (ALLOCATED(hydrographs)) DEALLOCATE(hydrographs)
1725	IF (ALLOCATED(slowflow_diag)) DEALLOCATE(slowflow_diag)
1726	IF (ALLOCATED(irrigation_mean)) DEALLOCATE(irrigation_mean)
1727	IF (ALLOCATED(irrigated)) DEALLOCATE(irrigated)
1728	IF (ALLOCATED(floodplains)) DEALLOCATE(floodplains)
1729	IF (ALLOCATED(swamp)) DEALLOCATE(swamp)
1730	IF (ALLOCATED(fast_diag)) DEALLOCATE(fast_diag)
1731	IF (ALLOCATED(slow_diag)) DEALLOCATE(slow_diag)
1732	IF (ALLOCATED(stream_diag)) DEALLOCATE(stream_diag)
1733	IF (ALLOCATED(flood_diag)) DEALLOCATE(flood_diag)
1734	IF (ALLOCATED(pond_diag)) DEALLOCATE(pond_diag)
1735	IF (ALLOCATED(lake_diag)) DEALLOCATE(lake_diag)
1736
1737	END SUBROUTINE routing_clear
1738	!
1739
1740	!! ================================================================================================================================
1741	!! SUBROUTINE : routing_flow
1742	!!
1743	!>\BRIEF This subroutine computes the transport of water in the various reservoirs
1744	!! (including ponds and floodplains) and the water withdrawals from the reservoirs for irrigation.
1745	!!
1746	!! DESCRIPTION (definitions, functional, design, flags) :
1747	!! This will first compute the amount of water which flows out of each of the 3 reservoirs using the assumption of an
1748	!! exponential decrease of water in the reservoir (see Hagemann S and Dumenil L. (1998)). Then we compute the fluxes
1749	!! for floodplains and ponds. All this will then be used in order to update each of the basins : taking water out of
1750	!! the up-stream basin and adding it to the down-stream one.
1751	!! As this step happens globaly we have to stop the parallel processing in order to exchange the information. Once
1752	!! all reservoirs are updated we deal with irrigation. The final step is to compute diagnostic fluxes. Among them
1753	!! the hydrographs of the largest rivers we have chosen to monitor.
1754	!!
1755	!! RECENT CHANGE(S): None
1756	!!
1757	!! MAIN OUTPUT VARIABLE(S): lakeinflow, returnflow, reinfiltration, irrigation, riverflow, coastalflow, hydrographs, flood_frac, flood_res
1758	!!
1759	!! REFERENCES :
1760	!! - Ngo-Duc, T., K. Laval, G. Ramillien, J. Polcher, and A. Cazenave (2007)
1761	!! Validation of the land water storage simulated by Organising Carbon and Hydrology in Dynamic Ecosystems (ORCHIDEE) with Gravity Recovery and Climate Experiment (GRACE) data.
1762	!! Water Resour. Res., 43, W04427, doi:10.1029/2006WR004941.
1763	!! * Irrigation:
1764	!! - de Rosnay, P., J. Polcher, K. Laval, and M. Sabre (2003)
1765	!! Integrated parameterization of irrigation in the land surface model ORCHIDEE. Validation over Indian Peninsula.
1766	!! Geophys. Res. Lett., 30(19), 1986, doi:10.1029/2003GL018024.
1767	!! - A.C. Vivant (2003)
1768	!! Les plaines d'inondations et l'irrigation dans ORCHIDEE, impacts de leur prise en compte.
1769	!! , , 51pp.
1770	!! - N. Culson (2004)
1771	!! Impact de l'irrigation sur le cycle de l'eau
1772	!! Master thesis, Paris VI University, 55pp.
1773	!! - X.-T. Nguyen-Vinh (2005)
1774	!! Analyse de l'impact de l'irrigation en Amerique du Nord - plaine du Mississippi - sur la climatologie regionale
1775	!! Master thesis, Paris VI University, 33pp.
1776	!! - M. Guimberteau (2006)
1777	!! Analyse et modifications proposees de la modelisation de l'irrigation dans un modele de surface.
1778	!! Master thesis, Paris VI University, 46pp.
1779	!! - Guimberteau M. (2010)
1780	!! Modelisation de l'hydrologie continentale et influences de l'irrigation sur le cycle de l'eau.
1781	!! Ph.D. thesis, Paris VI University, 195pp.
1782	!! - Guimberteau M., Laval K., Perrier A. and Polcher J. (2011).
1783	!! Global effect of irrigation and its impact on the onset of the Indian summer monsoon.
1784	!! In press, Climate Dynamics, doi: 10.1007/s00382-011-1252-5.
1785	!! * Floodplains:
1786	!! - A.C. Vivant (2002)
1787	!! L'ecoulement lateral de l'eau sur les surfaces continentales. Prise en compte des plaines d'inondations dans ORCHIDEE.
1788	!! Master thesis, Paris VI University, 46pp.
1789	!! - A.C. Vivant (2003)
1790	!! Les plaines d'inondations et l'irrigation dans ORCHIDEE, impacts de leur prise en compte.
1791	!! , , 51pp.
1792	!! - T. d'Orgeval (2006)
1793	!! Impact du changement climatique sur le cycle de l'eau en Afrique de l'Ouest: modelisation et incertitudes.
1794	!! Ph.D. thesis, Paris VI University, 188pp.
1795	!! - T. d'Orgeval, J. Polcher, and P. de Rosnay (2008)
1796	!! Sensitivity of the West African hydrological cycle in ORCHIDEE to infiltration processes.
1797	!! Hydrol. Earth Syst. Sci., 12, 1387-1401
1798	!! - M. Guimberteau, G. Drapeau, J. Ronchail, B. Sultan, J. Polcher, J.-M. Martinez, C. Prigent, J.-L. Guyot, G. Cochonneau,
1799	!! J. C. Espinoza, N. Filizola, P. Fraizy, W. Lavado, E. De Oliveira, R. Pombosa, L. Noriega, and P. Vauchel (2011)
1800	!! Discharge simulation in the sub-basins of the Amazon using ORCHIDEE forced by new datasets.
1801	!! Hydrol. Earth Syst. Sci. Discuss., 8, 11171-11232, doi:10.5194/hessd-8-11171-2011
1802	!!
1803	!! FLOWCHART :None
1804	!! \n
1805	!_ ================================================================================================================================
1806
1807	SUBROUTINE routing_flow(nbpt, dt_routing, lalo, floodout, runoff, drainage, &
1808	& vegtot, totnobio, transpot_mean, precip, humrel, k_litt, floodtemp, reinf_slope, &
1809	& lakeinflow, returnflow, reinfiltration, irrigation, riverflow, &
1810	& coastalflow, hydrographs, slowflow_diag, flood_frac, flood_res, &
1811	netflow_stream_diag, netflow_fast_diag, netflow_slow_diag)
1812	!
1813	IMPLICIT NONE
1814	!
1815	!! INPUT VARIABLES
1816	INTEGER(i_std), INTENT(in) :: nbpt !! Domain size (unitless)
1817	REAL(r_std), INTENT (in) :: dt_routing !! Routing time step (s)
1818	REAL(r_std), INTENT(in) :: lalo(nbpt,2) !! Vector of latitude and longitudes
1819	REAL(r_std), INTENT(in) :: runoff(nbpt) !! Grid-point runoff (kg/m^2/dt)
1820	REAL(r_std), INTENT(in) :: floodout(nbpt) !! Grid-point flow out of floodplains (kg/m^2/dt)
1821	REAL(r_std), INTENT(in) :: drainage(nbpt) !! Grid-point drainage (kg/m^2/dt)
1822	REAL(r_std), INTENT(in) :: vegtot(nbpt) !! Potentially vegetated fraction (unitless;0-1)
1823	REAL(r_std), INTENT(in) :: totnobio(nbpt) !! Other areas which can not have vegetation
1824	REAL(r_std), INTENT(in) :: transpot_mean(nbpt) !! Mean potential transpiration of the vegetation (kg/m^2/dt)
1825	REAL(r_std), INTENT(in) :: precip(nbpt) !! Rainfall (kg/m^2/dt)
1826	REAL(r_std), INTENT(in) :: humrel(nbpt) !! Soil moisture stress, root extraction potential (unitless)
1827	REAL(r_std), INTENT(in) :: k_litt(nbpt) !! Averaged conductivity for saturated infiltration in the 'litter' layer (kg/m^2/dt)
1828	REAL(r_std), INTENT(in) :: floodtemp(nbpt) !! Temperature to decide if floodplains work (K)
1829	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)
1830	REAL(r_std), INTENT(out) :: lakeinflow(nbpt) !! Water inflow to the lakes (kg/dt)
1831	!
1832	!! OUTPUT VARIABLES
1833	REAL(r_std), INTENT(out) :: returnflow(nbpt) !! The water flow from lakes and swamps which returns into the grid box.
1834	!! This water will go back into the hydrol or hydrolc module to allow re-evaporation (kg/m^2/dt_routing)
1835	REAL(r_std), INTENT(out) :: reinfiltration(nbpt) !! Water flow from ponds and floodplains which returns to the grid box (kg/m^2/dt)
1836	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)
1837	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)
1838	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)
1839	REAL(r_std), INTENT(out) :: hydrographs(nbpt) !! Hydrographs at the outflow of the grid box for major basins (kg/dt)
1840	REAL(r_std), INTENT(out) :: slowflow_diag(nbpt) !! Hydrographs of slow_flow = routed slow_flow for major basins (kg/dt)
1841	REAL(r_std), INTENT(out) :: flood_frac(nbpt) !! Flooded fraction of the grid box (unitless;0-1)
1842	REAL(r_std), INTENT(out) :: flood_res(nbpt) !! Diagnostic of water amount in the floodplains reservoir (kg)
1843
1844	REAL(r_std), INTENT(out) :: netflow_stream_diag(nbpt) !! Input - Output flow to stream reservoir
1845	REAL(r_std), INTENT(out) :: netflow_fast_diag(nbpt) !! Input - Output flow to fast reservoir
1846	REAL(r_std), INTENT(out) :: netflow_slow_diag(nbpt) !! Input - Output flow to slow reservoir
1847	!
1848	!! LOCAL VARIABLES
1849	REAL(r_std), DIMENSION(nbpt, nbasmax) :: fast_flow !! Outflow from the fast reservoir (kg/dt)
1850	REAL(r_std), DIMENSION(nbpt, nbasmax) :: slow_flow !! Outflow from the slow reservoir (kg/dt)
1851	REAL(r_std), DIMENSION(nbpt, nbasmax) :: stream_flow !! Outflow from the stream reservoir (kg/dt)
1852	REAL(r_std), DIMENSION(nbpt, nbasmax) :: flood_flow !! Outflow from the floodplain reservoir (kg/dt)
1853	REAL(r_std), DIMENSION(nbpt, nbasmax) :: pond_inflow !! Inflow to the pond reservoir (kg/dt)
1854	REAL(r_std), DIMENSION(nbpt, nbasmax) :: pond_drainage !! Drainage from pond (kg/m^2/dt)
1855	REAL(r_std), DIMENSION(nbpt, nbasmax) :: flood_drainage !! Drainage from floodplains (kg/m^2/dt)
1856	REAL(r_std), DIMENSION(nbpt, nbasmax) :: return_swamp !! Inflow to the swamp (kg/dt)
1857	!
1858	! Irrigation per basin
1859	!
1860	REAL(r_std), DIMENSION(nbpt, nbasmax) :: irrig_needs !! Total irrigation requirement (water requirements by the crop for its optimal growth) (kg)
1861	REAL(r_std), DIMENSION(nbpt, nbasmax) :: irrig_actual !! Possible irrigation according to the water availability in the reservoirs (kg)
1862	REAL(r_std), DIMENSION(nbpt, nbasmax) :: irrig_deficit !! Amount of water missing for irrigation (kg)
1863	REAL(r_std), DIMENSION(nbpt, nbasmax) :: irrig_adduct !! Amount of water carried over from other basins for irrigation (kg)
1864	!
1865	REAL(r_std), DIMENSION(nbpt, 0:nbasmax+3) :: transport !! Water transport between basins (kg/dt)
1866	REAL(r_std), DIMENSION(nbp_glo, 0:nbasmax+3) :: transport_glo !! Water transport between basins (kg/dt)
1867	REAL(r_std), DIMENSION(nbpt, nbasmax) :: floods !! Water flow in to the floodplains (kg/dt)
1868	REAL(r_std), DIMENSION(nbpt, nbasmax) :: potflood !! Potential inflow to the swamps (kg/dt)
1869	REAL(r_std), DIMENSION(nbpt) :: tobeflooded !! Maximal surface which can be inundated in each grid box (m^2)
1870	REAL(r_std), DIMENSION(nbpt) :: totarea !! Total area of basin (m^2)
1871	REAL(r_std), DIMENSION(nbpt) :: totflood !! Total amount of water in the floodplains reservoir (kg)
1872	REAL(r_std), DIMENSION(nbasmax) :: pond_excessflow !!
1873	REAL(r_std) :: flow !! Outflow computation for the reservoirs (kg/dt)
1874	REAL(r_std) :: floodindex !! Fraction of grid box area inundated (unitless;0-1)
1875	REAL(r_std) :: pondex !!
1876	REAL(r_std) :: flood_frac_pot !! Total fraction of the grid box which is flooded at optimum repartition (unitless;0-1)
1877	REAL(r_std) :: stream_tot !! Total water amount in the stream reservoirs (kg)
1878	REAL(r_std) :: adduction !! Importation of water from a stream reservoir of a neighboring grid box (kg)
1879	REAL(r_std), DIMENSION(nbp_glo) :: lake_overflow_g !! Removed water from lake reservoir on global grid (kg/gridcell/dt_routing)
1880	REAL(r_std), DIMENSION(nbpt) :: lake_overflow !! Removed water from lake reservoir on local grid (kg/gridcell/dt_routing)
1881	REAL(r_std), DIMENSION(nbpt) :: lake_overflow_coast !! lake_overflow distributed on coast gridcells, only diag(kg/gridcell/dt_routing)
1882	REAL(r_std) :: total_lake_overflow !! Sum of lake_overflow over full grid (kg)
1883	REAL(r_std), DIMENSION(8,nbasmax) :: streams_around !! Stream reservoirs of the neighboring grid boxes (kg)
1884	INTEGER(i_std), DIMENSION(8) :: igrd !!
1885	INTEGER(i_std), DIMENSION(2) :: ff !!
1886	INTEGER(i_std), DIMENSION(1) :: fi !!
1887	INTEGER(i_std) :: ig, ib, ib2, ig2 !! Indices (unitless)
1888	INTEGER(i_std) :: rtg, rtb, in !! Indices (unitless)
1889	INTEGER(i_std) :: ier !! Error handling
1890	REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: fast_flow_g !! Outflow from the fast reservoir (kg/dt)
1891	REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: slow_flow_g !! Outflow from the slow reservoir (kg/dt)
1892	REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: stream_flow_g !! Outflow from the stream reservoir (kg/dt)
1893	REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: irrig_deficit_glo !! Amount of water missing for irrigation (kg)
1894	REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: stream_reservoir_glo !! Water amount in the stream reservoir (kg)
1895	REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: irrig_adduct_glo !! Amount of water carried over from other basins for irrigation (kg)
1896
1897	REAL(r_std), DIMENSION(nbpt, nbasmax) :: netflow_stream !! Input - Output flow to stream reservoir
1898	REAL(r_std), DIMENSION(nbpt, nbasmax) :: netflow_fast !! Input - Output flow to fast reservoir
1899	REAL(r_std), DIMENSION(nbpt, nbasmax) :: netflow_slow !! Input - Output flow to slow reservoir
1900
1901
1902	!! PARAMETERS
1903	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)
1904	!_ ================================================================================================================================
1905	!
1906	transport(:,:) = zero
1907	transport_glo(:,:) = zero
1908	irrig_netereq(:) = zero
1909	irrig_needs(:,:) = zero
1910	irrig_actual(:,:) = zero
1911	irrig_deficit(:,:) = zero
1912	irrig_adduct(:,:) = zero
1913	totarea(:) = zero
1914	totflood(:) = zero
1915	!
1916	! Compute all the fluxes
1917	!
1918	DO ib=1,nbasmax
1919	DO ig=1,nbpt
1920	!
1921	totarea(ig) = totarea(ig) + routing_area(ig,ib)
1922	totflood(ig) = totflood(ig) + flood_reservoir(ig,ib)
1923	ENDDO
1924	ENDDO
1925	!
1926	!> The outflow fluxes from the three reservoirs are computed.
1927	!> The outflow of volume of water Vi into the reservoir i is assumed to be linearly related to its volume.
1928	!> The water travel simulated by the routing scheme is dependent on the water retention index topo_resid
1929	!> given by a 0.5 degree resolution map for each pixel performed from a simplification of Manning's formula
1930	!> (Dingman, 1994; Ducharne et al., 2003).
1931	!> The resulting product of tcst (in day/m) and topo_resid (in m) represents the time constant (day)
1932	!> which is an e-folding time, the time necessary for the water amount
1933	!> in the stream reservoir to decrease by a factor e. Hence, it gives an order of
1934	!> magnitude of the travel time through this reservoir between
1935	!> the sub-basin considered and its downstream neighbor.
1936
1937	DO ib=1,nbasmax
1938	DO ig=1,nbpt
1939	IF ( route_tobasin(ig,ib) .GT. 0 ) THEN
1940	!
1941	! Each of the fluxes is limited by the water in the reservoir and a small margin
1942	! (min_reservoir) to avoid rounding errors.
1943	!
1944	flow = MIN(fast_reservoir(ig,ib)/((topo_resid(ig,ib)/1000.)fast_tcstone_day/dt_routing),&
1945	& fast_reservoir(ig,ib)-min_sechiba)
1946	fast_flow(ig,ib) = MAX(flow, zero)
1947
1948	flow = MIN(slow_reservoir(ig,ib)/((topo_resid(ig,ib)/1000.)slow_tcstone_day/dt_routing),&
1949	& slow_reservoir(ig,ib)-min_sechiba)
1950	slow_flow(ig,ib) = MAX(flow, zero)
1951
1952	flow = MIN(stream_reservoir(ig,ib)/((topo_resid(ig,ib)/1000.)stream_tcst &
1953	& MAX(un-SQRT(flood_frac_bas(ig,ib)),min_sechiba)*one_day/dt_routing),&
1954	& stream_reservoir(ig,ib)-min_sechiba)
1955	stream_flow(ig,ib) = MAX(flow, zero)
1956	!
1957	ELSE
1958	fast_flow(ig,ib) = zero
1959	slow_flow(ig,ib) = zero
1960	stream_flow(ig,ib) = zero
1961	ENDIF
1962	ENDDO
1963	ENDDO
1964	!-
1965	!- Compute the fluxes out of the floodplains and ponds if they exist.
1966	!-
1967	IF (do_floodplains .OR. doponds) THEN
1968	DO ig=1,nbpt
1969	IF (flood_frac(ig) .GT. min_sechiba) THEN
1970	!
1971	flow = MIN(floodout(ig)totarea(ig)pond_frac(ig)/flood_frac(ig), pond_reservoir(ig)+totflood(ig))
1972	pondex = MAX(flow - pond_reservoir(ig), zero)
1973	pond_reservoir(ig) = pond_reservoir(ig) - (flow - pondex)
1974	!
1975	! If demand was over reservoir size, we will take it out from floodplains
1976	!
1977	pond_excessflow(:) = zero
1978	DO ib=1,nbasmax
1979	pond_excessflow(ib) = MIN(pondex*flood_frac_bas(ig,ib)/(flood_frac(ig)-pond_frac(ig)),&
1980	& flood_reservoir(ig,ib))
1981	pondex = pondex - pond_excessflow(ib)
1982	ENDDO
1983	!
1984	IF ( pondex .GT. min_sechiba) THEN
1985	WRITE(numout,*) "Unable to redistribute the excess pond outflow over the water available in the floodplain."
1986	WRITE(numout,*) "Pondex = ", pondex
1987	WRITE(numout,*) "pond_excessflow(:) = ", pond_excessflow(:)
1988	ENDIF
1989	!
1990	DO ib=1,nbasmax
1991	!
1992	flow = floodout(ig)routing_area(ig,ib)flood_frac_bas(ig,ib)/flood_frac(ig) + pond_excessflow(ib)
1993	!
1994	flood_reservoir(ig,ib) = flood_reservoir(ig,ib) - flow
1995	!
1996	!
1997	IF (flood_reservoir(ig,ib) .LT. min_sechiba) THEN
1998	flood_reservoir(ig,ib) = zero
1999	ENDIF
2000	IF (pond_reservoir(ig) .LT. min_sechiba) THEN
2001	pond_reservoir(ig) = zero
2002	ENDIF
2003	ENDDO
2004	ENDIF
2005	ENDDO
2006	ENDIF
2007
2008	!-
2009	!- Computing the drainage and outflow from floodplains
2010	!> Drainage from floodplains is depending on a averaged conductivity (k_litt)
2011	!> for saturated infiltration in the 'litter' layer. Flood_drainage will be
2012	!> a component of the total reinfiltration that leaves the routing scheme.
2013	!-
2014	IF (do_floodplains) THEN
2015	IF (dofloodinfilt) THEN
2016	DO ib=1,nbasmax
2017	DO ig=1,nbpt
2018	flood_drainage(ig,ib) = MAX(zero, MIN(flood_reservoir(ig,ib), &
2019	& flood_frac(ig)routing_area(ig,ib)k_litt(ig)*dt_routing/one_day))
2020	flood_reservoir(ig,ib) = flood_reservoir(ig,ib) - flood_drainage(ig,ib)
2021	ENDDO
2022	ENDDO
2023	ELSE
2024	DO ib=1,nbasmax
2025	DO ig=1,nbpt
2026	flood_drainage(ig,ib) = zero
2027	ENDDO
2028	ENDDO
2029	ENDIF
2030	!> Outflow from floodplains is computed depending a delay. This delay is characterized by a time constant
2031	!> function of the surface of the floodplains and the product of topo_resid and flood_tcst. flood_tcst
2032	!> has been calibrated through observations in the Niger Inner Delta (D'Orgeval, 2006).
2033	!
2034	DO ib=1,nbasmax
2035	DO ig=1,nbpt
2036	IF ( route_tobasin(ig,ib) .GT. 0 ) THEN
2037	IF (flood_frac_bas(ig,ib) .GT. min_sechiba) THEN
2038	flow = MIN(flood_reservoir(ig,ib) &
2039	& /((topo_resid(ig,ib)/1000.)flood_tcst &
2040	& flood_frac_bas(ig,ib)*one_day/dt_routing),&
2041	& flood_reservoir(ig,ib))
2042	ELSE
2043	flow = zero
2044	ENDIF
2045	flood_flow(ig,ib) = flow
2046	ELSE
2047	flood_flow(ig,ib) = zero
2048	ENDIF
2049	ENDDO
2050	ENDDO
2051	ELSE
2052	DO ib=1,nbasmax
2053	DO ig=1,nbpt
2054	flood_drainage(ig,ib) = zero
2055	flood_flow(ig,ib) = zero
2056	flood_reservoir(ig,ib) = zero
2057	ENDDO
2058	ENDDO
2059	ENDIF
2060
2061	!-
2062	!- Computing drainage and inflow for ponds
2063	!> Drainage from ponds is computed in the same way than for floodplains.
2064	!> Reinfiltrated fraction from the runoff (i.e. the outflow from the fast reservoir)
2065	!> is the inflow of the pond reservoir.
2066	!-
2067	IF (doponds) THEN
2068	! If used, the slope coef is not used in hydrol for water2infilt
2069	DO ib=1,nbasmax
2070	DO ig=1,nbpt
2071	pond_inflow(ig,ib) = fast_flow(ig,ib) * reinf_slope(ig)
2072	pond_drainage(ig,ib) = MIN(pond_reservoir(ig)*routing_area(ig,ib)/totarea(ig), &
2073	& pond_frac(ig)routing_area(ig,ib)k_litt(ig)*dt_routing/one_day)
2074	fast_flow(ig,ib) = fast_flow(ig,ib) - pond_inflow(ig,ib)
2075	ENDDO
2076	ENDDO
2077	ELSE
2078	DO ib=1,nbasmax
2079	DO ig=1,nbpt
2080	pond_inflow(ig,ib) = zero
2081	pond_drainage(ig,ib) = zero
2082	pond_reservoir(ig) = zero
2083	ENDDO
2084	ENDDO
2085	ENDIF
2086
2087	!ym cette methode conserve les erreurs d'arrondie
2088	!ym mais n'est pas la plus efficace
2089
2090	!-
2091	!- Compute the transport from one basin to another
2092	!-
2093
2094	IF (is_root_prc) THEN
2095	ALLOCATE( fast_flow_g(nbp_glo, nbasmax), slow_flow_g(nbp_glo, nbasmax), &
2096	stream_flow_g(nbp_glo, nbasmax), stat=ier)
2097	ELSE
2098	ALLOCATE( fast_flow_g(1,1), slow_flow_g(1,1), &
2099	stream_flow_g(1, 1), stat=ier)
2100	ENDIF
2101	IF (ier /= 0) CALL ipslerr_p(3,'routing_flow','Pb in allocate for fast_flow_g','','')
2102
2103	CALL gather(fast_flow,fast_flow_g)
2104	CALL gather(slow_flow,slow_flow_g)
2105	CALL gather(stream_flow,stream_flow_g)
2106
2107	IF (is_root_prc) THEN
2108	DO ib=1,nbasmax
2109	DO ig=1,nbp_glo
2110	!
2111	rtg = route_togrid_glo(ig,ib)
2112	rtb = route_tobasin_glo(ig,ib)
2113	transport_glo(rtg,rtb) = transport_glo(rtg,rtb) + fast_flow_g(ig,ib) + slow_flow_g(ig,ib) + &
2114	& stream_flow_g(ig,ib)
2115	!
2116	ENDDO
2117	ENDDO
2118	ENDIF
2119
2120	DEALLOCATE( fast_flow_g, slow_flow_g, stream_flow_g )
2121
2122	CALL scatter(transport_glo,transport)
2123
2124	!-
2125	!- Do the floodings - First initialize
2126	!-
2127	return_swamp(:,:)=zero
2128	floods(:,:)=zero
2129	!-
2130	!> Over swamp areas, a fraction of water (return_swamp) is withdrawn from the river depending on the
2131	!> parameter swamp_cst.
2132	!> It will be transferred into soil moisture and thus does not return directly to the river.
2133	!
2134	!- 1. Swamps: Take out water from the river to put it to the swamps
2135	!-
2136	!
2137	IF ( doswamps ) THEN
2138	tobeflooded(:) = swamp(:)
2139	DO ib=1,nbasmax
2140	DO ig=1,nbpt
2141	potflood(ig,ib) = transport(ig,ib)
2142	!
2143	IF ( tobeflooded(ig) > 0. .AND. potflood(ig,ib) > 0. .AND. floodtemp(ig) > tp_00 ) THEN
2144	!
2145	IF (routing_area(ig,ib) > tobeflooded(ig)) THEN
2146	floodindex = tobeflooded(ig) / routing_area(ig,ib)
2147	ELSE
2148	floodindex = 1.0
2149	ENDIF
2150	return_swamp(ig,ib) = swamp_cst * potflood(ig,ib) * floodindex
2151	!
2152	tobeflooded(ig) = tobeflooded(ig) - routing_area(ig,ib)
2153	!
2154	ENDIF
2155	ENDDO
2156	ENDDO
2157	ENDIF
2158	!-
2159	!- 2. Floodplains: Update the reservoir with the flux computed above.
2160	!-
2161	IF ( do_floodplains ) THEN
2162	DO ig=1,nbpt
2163	IF (floodplains(ig) .GT. min_sechiba .AND. floodtemp(ig) .GT. tp_00) THEN
2164	DO ib=1,nbasmax
2165	floods(ig,ib) = transport(ig,ib) - return_swamp(ig,ib)
2166	ENDDO
2167	ENDIF
2168	ENDDO
2169	ENDIF
2170	!
2171	! Update all reservoirs
2172	!> The slow and deep reservoir (slow_reservoir) collect the deep drainage whereas the
2173	!> fast_reservoir collects the computed surface runoff. Both discharge into a third reservoir
2174	!> (stream_reservoir) of the next sub-basin downstream.
2175	!> Water from the floodplains reservoir (flood_reservoir) flows also into the stream_reservoir of the next sub-basin downstream.
2176	!> Water that flows into the pond_reservoir is withdrawn from the fast_reservoir.
2177	!
2178	DO ig=1,nbpt
2179	DO ib=1,nbasmax
2180	!
2181	fast_reservoir(ig,ib) = fast_reservoir(ig,ib) + runoff(ig)*routing_area(ig,ib) - &
2182	& fast_flow(ig,ib) - pond_inflow(ig,ib)
2183	!
2184	slow_reservoir(ig,ib) = slow_reservoir(ig,ib) + drainage(ig)*routing_area(ig,ib) - &
2185	& slow_flow(ig,ib)
2186	!
2187	stream_reservoir(ig,ib) = stream_reservoir(ig,ib) + flood_flow(ig,ib) + transport(ig,ib) - &
2188	& stream_flow(ig,ib) - return_swamp(ig,ib) - floods(ig,ib)
2189	!
2190	flood_reservoir(ig,ib) = flood_reservoir(ig,ib) + floods(ig,ib) - &
2191	& flood_flow(ig,ib)
2192	!
2193	pond_reservoir(ig) = pond_reservoir(ig) + pond_inflow(ig,ib) - pond_drainage(ig,ib)
2194	!
2195	IF ( flood_reservoir(ig,ib) .LT. zero ) THEN
2196	IF ( check_reservoir ) THEN
2197	WRITE(numout,*) "WARNING : negative flood reservoir at :", ig, ib, ". Problem is being corrected."
2198	WRITE(numout,*) "flood_reservoir, floods, flood_flow : ", flood_reservoir(ig,ib), floods(ig,ib), &
2199	& flood_flow(ig,ib)
2200	ENDIF
2201	stream_reservoir(ig,ib) = stream_reservoir(ig,ib) + flood_reservoir(ig,ib)
2202	flood_reservoir(ig,ib) = zero
2203	ENDIF
2204	!
2205	IF ( stream_reservoir(ig,ib) .LT. zero ) THEN
2206	IF ( check_reservoir ) THEN
2207	WRITE(numout,*) "WARNING : negative stream reservoir at :", ig, ib, ". Problem is being corrected."
2208	WRITE(numout,*) "stream_reservoir, flood_flow, transport : ", stream_reservoir(ig,ib), flood_flow(ig,ib), &
2209	& transport(ig,ib)
2210	WRITE(numout,*) "stream_flow, return_swamp, floods :", stream_flow(ig,ib), return_swamp(ig,ib), floods(ig,ib)
2211	ENDIF
2212	fast_reservoir(ig,ib) = fast_reservoir(ig,ib) + stream_reservoir(ig,ib)
2213	stream_reservoir(ig,ib) = zero
2214	ENDIF
2215	!
2216	IF ( fast_reservoir(ig,ib) .LT. zero ) THEN
2217	IF ( check_reservoir ) THEN
2218	WRITE(numout,*) "WARNING : negative fast reservoir at :", ig, ib, ". Problem is being corrected."
2219	WRITE(numout,*) "fast_reservoir, runoff, fast_flow, ponf_inflow : ", fast_reservoir(ig,ib), &
2220	&runoff(ig), fast_flow(ig,ib), pond_inflow(ig,ib)
2221	ENDIF
2222	slow_reservoir(ig,ib) = slow_reservoir(ig,ib) + fast_reservoir(ig,ib)
2223	fast_reservoir(ig,ib) = zero
2224	ENDIF
2225
2226	IF ( slow_reservoir(ig,ib) .LT. - min_sechiba ) THEN
2227	WRITE(numout,*) 'WARNING : There is a negative reservoir at :', ig, ib,lalo(ig,:)
2228	WRITE(numout,*) 'WARNING : slowr, slow_flow, drainage', &
2229	& slow_reservoir(ig,ib), slow_flow(ig,ib), drainage(ig)
2230	WRITE(numout,*) 'WARNING : pondr, pond_inflow, pond_drainage', &
2231	& pond_reservoir(ig), pond_inflow(ig,ib), pond_drainage(ig,ib)
2232	CALL ipslerr_p(2, 'routing_flow', 'WARNING negative slow_reservoir.','','')
2233	ENDIF
2234
2235	ENDDO
2236	ENDDO
2237
2238
2239	totflood(:) = zero
2240	DO ig=1,nbpt
2241	DO ib=1,nbasmax
2242	totflood(ig) = totflood(ig) + flood_reservoir(ig,ib)
2243	ENDDO
2244	ENDDO
2245
2246	!-
2247	!- Computes the fraction of floodplains and ponds according to their volume
2248	!-
2249	IF (do_floodplains .OR. doponds) THEN
2250	flood_frac(:) = zero
2251	flood_height(:) = zero
2252	flood_frac_bas(:,:) = zero
2253	DO ig=1, nbpt
2254	IF (totflood(ig) .GT. min_sechiba) THEN
2255	! We first compute the total fraction of the grid box which is flooded at optimum repartition
2256	flood_frac_pot = (totflood(ig) / (totarea(ig)floodcri/(beta+un)))*(beta/(beta+un))
2257	flood_frac(ig) = MIN(floodplains(ig) / totarea(ig), flood_frac_pot)
2258	! Then we diagnose the fraction for each basin with the size of its flood_reservoir
2259	! (flood_frac_bas may be > 1)
2260	DO ib=1,nbasmax
2261	IF (routing_area(ig,ib) .GT. min_sechiba) THEN
2262	flood_frac_bas(ig,ib) = flood_frac(ig) * &
2263	& (flood_reservoir(ig,ib) / totflood(ig)) / (routing_area(ig,ib) / totarea(ig))
2264	ENDIF
2265	ENDDO
2266	! We diagnose the maximum height of floodplain
2267	flood_height(ig) = (beta/(beta+1))floodcri(flood_frac(ig))*(un/beta) + totflood(ig)/(totarea(ig)flood_frac(ig))
2268	! And finally add the pond surface
2269	pond_frac(ig) = MIN(un-flood_frac(ig), ((betap+1)pond_reservoir(ig) / (pondcritotarea(ig)))**(betap/(betap+1)) )
2270	flood_frac(ig) = flood_frac(ig) + pond_frac(ig)
2271	!
2272	ENDIF
2273	ENDDO
2274	ELSE
2275	flood_frac(:) = zero
2276	flood_height(:) = zero
2277	flood_frac_bas(:,:) = zero
2278	ENDIF
2279
2280	!-
2281	!- Compute the total reinfiltration and returnflow to the grid box
2282	!> A term of returnflow is computed including the water from the swamps that does not return directly to the river
2283	!> but will be put into soil moisture (see hydrol module).
2284	!> A term of reinfiltration is computed including the water that reinfiltrated from the ponds and floodplains areas.
2285	!> It will be put into soil moisture (see hydrol module).
2286	!-
2287	IF (do_floodplains .OR. doswamps .OR. doponds) THEN
2288	returnflow(:) = zero
2289	reinfiltration(:) = zero
2290	!
2291	DO ib=1,nbasmax
2292	DO ig=1,nbpt
2293	returnflow(ig) = returnflow(ig) + return_swamp(ig,ib)
2294	reinfiltration(ig) = reinfiltration(ig) + pond_drainage(ig,ib) + flood_drainage(ig,ib)
2295	ENDDO
2296	ENDDO
2297	!
2298	DO ig=1,nbpt
2299	returnflow(ig) = returnflow(ig)/totarea(ig)
2300	reinfiltration(ig) = reinfiltration(ig)/totarea(ig)
2301	ENDDO
2302	ELSE
2303	returnflow(:) = zero
2304	reinfiltration(:) = zero
2305	ENDIF
2306
2307	!
2308	! Compute the net irrigation requirement from Univ of Kassel
2309	!
2310	! This is a very low priority process and thus only applies if
2311	! there is some water left in the reservoirs after all other things.
2312	!
2313	!> The computation of the irrigation is performed here.
2314	!> * First step
2315	!> In a first time, the water requirements (irrig_netereq) by the crops for their optimal growth are calculated
2316	!> over each irrigated fraction (irrigated(ig)/totarea(ig)). It is the difference
2317	!> between the maximal water loss by the crops (transpot_mean) and the net water amount kept by the soil
2318	!> (precipitation and reinfiltration). Transpot_mean is computed in the routines enerbil and diffuco. It
2319	!> is derived from the effective transpiration parametrization under stress-free conditions, called potential transpiration.
2320	!> Crop_coef was used by a previous parametrization of irrigation in the code. Here, its value is equal to one.
2321	!> The crop coefficient was constant in space and time to represent a mean resistance of the vegetation to the potential evaporation.
2322	!> Now, the term crop_coef*Epot is substituted by transpot_mean (see Guimberteau et al., 2011).
2323	!> * Second step
2324	!> We compute irrigation needs in order to supply Irrig_netereq. Water for irrigation (irrig_actual) is withdrawn
2325	!> from the reservoirs. The amount of water is withdrawn in priority from the stream reservoir.
2326	!> If the irrigation requirement is higher than the water availability of the reservoir, water is withdrawn
2327	!> from the fast reservoir or, in the extreme case, from the slow reservoir.
2328	!> * Third step
2329	!> We compute a deficit in water for irrigation. If it is positive, irrigation (depending on water availibility in the reservoirs)
2330	!> has not supplied the crops requirements.
2331	!
2332	IF ( do_irrigation ) THEN
2333	DO ig=1,nbpt
2334	!
2335	IF ((vegtot(ig) .GT. min_sechiba) .AND. (humrel(ig) .LT. un-min_sechiba) .AND. &
2336	& (runoff(ig) .LT. min_sechiba) ) THEN
2337
2338	irrig_netereq(ig) = (irrigated(ig) / totarea(ig) ) * MAX(zero, transpot_mean(ig) - &
2339	& (precip(ig)+reinfiltration(ig)) )
2340
2341	ENDIF
2342	!
2343	DO ib=1,nbasmax
2344	IF ( routing_area(ig,ib) .GT. 0 ) THEN
2345
2346	irrig_needs(ig,ib) = irrig_netereq(ig) * routing_area(ig,ib)
2347
2348	irrig_actual(ig,ib) = MIN(irrig_needs(ig,ib),&
2349	& stream_reservoir(ig,ib) + fast_reservoir(ig,ib) + slow_reservoir(ig,ib) )
2350
2351	slow_reservoir(ig,ib) = MAX(zero, slow_reservoir(ig,ib) + &
2352	& MIN(zero, fast_reservoir(ig,ib) + MIN(zero, stream_reservoir(ig,ib)-irrig_actual(ig,ib))))
2353
2354	fast_reservoir(ig,ib) = MAX( zero, &
2355	& fast_reservoir(ig,ib) + MIN(zero, stream_reservoir(ig,ib)-irrig_actual(ig,ib)))
2356
2357	stream_reservoir(ig,ib) = MAX(zero, stream_reservoir(ig,ib)-irrig_actual(ig,ib) )
2358
2359	irrig_deficit(ig,ib) = irrig_needs(ig,ib)-irrig_actual(ig,ib)
2360
2361	ENDIF
2362	ENDDO
2363	!
2364	! Check if we cannot find the missing water in another basin of the same grid (stream reservoir only).
2365	! If we find that then we create some adduction from that subbasin to the one where we need it for
2366	! irrigation.
2367	!
2368	!> If crops water requirements have not been supplied (irrig_deficit>0), we check if we cannot find the missing water
2369	!> in another basin of the same grid. If there is water in the stream reservoir of this subbasin, we create some adduction
2370	!> from that subbasin to the one where we need it for irrigation.
2371	!>
2372	DO ib=1,nbasmax
2373
2374	stream_tot = SUM(stream_reservoir(ig,:))
2375
2376	DO WHILE ( irrig_deficit(ig,ib) > min_sechiba .AND. stream_tot > min_sechiba)
2377
2378	fi = MAXLOC(stream_reservoir(ig,:))
2379	ib2 = fi(1)
2380
2381	irrig_adduct(ig,ib) = MIN(irrig_deficit(ig,ib), stream_reservoir(ig,ib2))
2382	stream_reservoir(ig,ib2) = stream_reservoir(ig,ib2)-irrig_adduct(ig,ib)
2383	irrig_deficit(ig,ib) = irrig_deficit(ig,ib)-irrig_adduct(ig,ib)
2384
2385	stream_tot = SUM(stream_reservoir(ig,:))
2386
2387	ENDDO
2388
2389	ENDDO
2390	!
2391	ENDDO
2392	!
2393	! If we are at higher resolution we might need to look at neighboring grid boxes to find the streams
2394	! which can feed irrigation
2395	!
2396	!> At higher resolution (grid box smaller than 100x100km), we can import water from neighboring grid boxes
2397	!> to the one where we need it for irrigation.
2398	!
2399	IF (is_root_prc) THEN
2400	ALLOCATE(irrig_deficit_glo(nbp_glo, nbasmax), stream_reservoir_glo(nbp_glo, nbasmax), &
2401	& irrig_adduct_glo(nbp_glo, nbasmax), stat=ier)
2402	ELSE
2403	ALLOCATE(irrig_deficit_glo(0, 0), stream_reservoir_glo(0, 0), &
2404	& irrig_adduct_glo(0, 0), stat=ier)
2405	ENDIF
2406	IF (ier /= 0) CALL ipslerr_p(3,'routing_flow','Pb in allocate for irrig_deficit_glo, stream_reservoir_glo,...','','')
2407
2408	CALL gather(irrig_deficit, irrig_deficit_glo)
2409	CALL gather(stream_reservoir, stream_reservoir_glo)
2410	CALL gather(irrig_adduct, irrig_adduct_glo)
2411
2412	IF (is_root_prc) THEN
2413	!
2414	DO ig=1,nbp_glo
2415	! Only work if the grid box is smaller than 100x100km. Else the piplines we build
2416	! here would be too long to be reasonable.
2417	IF ( resolution_g(ig,1) < 100000. .AND. resolution_g(ig,2) < 100000. ) THEN
2418	DO ib=1,nbasmax
2419	!
2420	IF ( irrig_deficit_glo(ig,ib) > min_sechiba ) THEN
2421	!
2422	streams_around(:,:) = zero
2423	!
2424	DO in=1,NbNeighb
2425	ig2 = neighbours_g(ig,in)
2426	IF (ig2 .GT. 0 ) THEN
2427	streams_around(in,:) = stream_reservoir_glo(ig2,:)
2428	igrd(in) = ig2
2429	ENDIF
2430	ENDDO
2431	!
2432	IF ( MAXVAL(streams_around) .GT. zero ) THEN
2433	!
2434	ff=MAXLOC(streams_around)
2435	ig2=igrd(ff(1))
2436	ib2=ff(2)
2437	!
2438	IF ( routing_area_glo(ig2,ib2) .GT. 0 .AND. stream_reservoir_glo(ig2,ib2) > zero ) THEN
2439	adduction = MIN(irrig_deficit_glo(ig,ib), stream_reservoir_glo(ig2,ib2))
2440	stream_reservoir_glo(ig2,ib2) = stream_reservoir_glo(ig2,ib2) - adduction
2441	irrig_deficit_glo(ig,ib) = irrig_deficit_glo(ig,ib) - adduction
2442	irrig_adduct_glo(ig,ib) = irrig_adduct_glo(ig,ib) + adduction
2443	ENDIF
2444	!
2445	ENDIF
2446	!
2447	ENDIF
2448	!
2449	ENDDO
2450	ENDIF
2451	ENDDO
2452	!
2453	ENDIF
2454	!
2455
2456	CALL scatter(irrig_deficit_glo, irrig_deficit)
2457	CALL scatter(stream_reservoir_glo, stream_reservoir)
2458	CALL scatter(irrig_adduct_glo, irrig_adduct)
2459
2460	DEALLOCATE(irrig_deficit_glo, stream_reservoir_glo, irrig_adduct_glo)
2461
2462	ENDIF
2463
2464	!! Calculate the net water flow to each routing reservoir (in kg/dt)
2465	!! to further diagnose the corresponding water budget residu
2466	!! in routing_main
2467
2468	netflow_fast_diag(:) = zero
2469	netflow_slow_diag(:) = zero
2470	netflow_stream_diag(:) = zero
2471
2472	DO ib=1,nbasmax
2473	DO ig=1,nbpt
2474	netflow_fast_diag(ig) = netflow_fast_diag(ig) + runoff(ig)*routing_area(ig,ib) &
2475	- fast_flow(ig,ib) - pond_inflow(ig,ib)
2476	netflow_slow_diag(ig) = netflow_slow_diag(ig) + drainage(ig)*routing_area(ig,ib) &
2477	- slow_flow(ig,ib)
2478	netflow_stream_diag(ig) = netflow_stream_diag(ig) + flood_flow(ig,ib) + transport(ig,ib) &
2479	- stream_flow(ig,ib) - return_swamp(ig,ib) - floods(ig,ib)
2480	ENDDO
2481	ENDDO
2482
2483	!! Grid cell averaging
2484	DO ig=1,nbpt
2485	netflow_fast_diag(ig) = netflow_fast_diag(ig)/totarea(ig)
2486	netflow_slow_diag(ig) = netflow_slow_diag(ig)/totarea(ig)
2487	netflow_stream_diag(ig) = netflow_stream_diag(ig)/totarea(ig)
2488	ENDDO
2489
2490	!
2491	!
2492	! Compute the fluxes which leave the routing scheme
2493	!
2494	! Lakeinflow is in Kg/dt
2495	! returnflow is in Kg/m^2/dt
2496	!
2497	hydrographs(:) = zero
2498	slowflow_diag(:) = zero
2499	fast_diag(:) = zero
2500	slow_diag(:) = zero
2501	stream_diag(:) = zero
2502	flood_diag(:) = zero
2503	pond_diag(:) = zero
2504	irrigation(:) = zero
2505	!
2506	!
2507	DO ib=1,nbasmax
2508	!
2509	DO ig=1,nbpt
2510	IF (hydrodiag(ig,ib) > 0 ) THEN
2511	hydrographs(ig) = hydrographs(ig) + fast_flow(ig,ib) + slow_flow(ig,ib) + &
2512	& stream_flow(ig,ib)
2513	slowflow_diag(ig) = slowflow_diag(ig) + slow_flow(ig,ib)
2514	ENDIF
2515	fast_diag(ig) = fast_diag(ig) + fast_reservoir(ig,ib)
2516	slow_diag(ig) = slow_diag(ig) + slow_reservoir(ig,ib)
2517	stream_diag(ig) = stream_diag(ig) + stream_reservoir(ig,ib)
2518	flood_diag(ig) = flood_diag(ig) + flood_reservoir(ig,ib)
2519	irrigation (ig) = irrigation (ig) + irrig_actual(ig,ib) + irrig_adduct(ig,ib)
2520	ENDDO
2521	ENDDO
2522	!
2523	DO ig=1,nbpt
2524	fast_diag(ig) = fast_diag(ig)/totarea(ig)
2525	slow_diag(ig) = slow_diag(ig)/totarea(ig)
2526	stream_diag(ig) = stream_diag(ig)/totarea(ig)
2527	flood_diag(ig) = flood_diag(ig)/totarea(ig)
2528	pond_diag(ig) = pond_reservoir(ig)/totarea(ig)
2529	!
2530	irrigation(ig) = irrigation(ig)/totarea(ig)
2531	!
2532	! The three output types for the routing : endoheric basins,, rivers and
2533	! diffuse coastal flow.
2534	!
2535	lakeinflow(ig) = transport(ig,nbasmax+1)
2536	coastalflow(ig) = transport(ig,nbasmax+2)
2537	riverflow(ig) = transport(ig,nbasmax+3)
2538	!
2539	ENDDO
2540	!
2541	flood_res = flood_diag + pond_diag
2542
2543
2544	!! Remove water from lake reservoir if it exceeds the maximum limit and distribute it
2545	!! uniformly over all possible the coastflow gridcells
2546
2547	! Calculate lake_overflow and remove it from lake_reservoir
2548	DO ig=1,nbpt
2549	lake_overflow(ig) = MAX(0., lake_reservoir(ig) - max_lake_reservoir*totarea(ig))
2550	lake_reservoir(ig) = lake_reservoir(ig) - lake_overflow(ig)
2551	END DO
2552	! Transform lake_overflow from kg/grid-cell/dt_routing into kg/m^2/s
2553	CALL xios_orchidee_send_field("lake_overflow",lake_overflow(:)/totarea(:)/dt_routing)
2554
2555	! Calculate the sum of the lake_overflow and distribute it uniformly over all gridboxes
2556	CALL gather(lake_overflow,lake_overflow_g)
2557	IF (is_root_prc) THEN
2558	total_lake_overflow=SUM(lake_overflow_g)
2559	END IF
2560	CALL bcast(total_lake_overflow)
2561
2562	! Distribute the lake_overflow uniformly over all coastal gridcells
2563	! lake_overflow_coast is only calculated to be used as diagnostics if needed
2564	DO ig=1,nbpt
2565	coastalflow(ig) = coastalflow(ig) + total_lake_overflow/nb_coast_gridcells * mask_coast(ig)
2566	lake_overflow_coast(ig) = total_lake_overflow/nb_coast_gridcells * mask_coast(ig)
2567	END DO
2568	! Transform from kg/grid-cell/dt_routing into m^3/grid-cell/s to match output unit of coastalflow
2569	CALL xios_orchidee_send_field("lake_overflow_coast",lake_overflow_coast/mille/dt_routing)
2570
2571
2572	END SUBROUTINE routing_flow
2573	!
2574	!! ================================================================================================================================
2575	!! SUBROUTINE : routing_lake
2576	!!
2577	!>\BRIEF : This subroutine stores water in lakes so that it does not cycle through the runoff.
2578	!! For the moment it only works for endoheric lakes but I can be extended in the future.
2579	!!
2580	!! DESCRIPTION (definitions, functional, design, flags): The return flow to the soil moisture reservoir
2581	!! is based on a maximum lake evaporation rate (maxevap_lake). \n
2582	!!
2583	!! RECENT CHANGE(S): None
2584	!!
2585	!! MAIN OUTPUT VARIABLE(S):
2586	!!
2587	!! REFERENCES : None
2588	!!
2589	!! FLOWCHART :None
2590	!! \n
2591	!_ ================================================================================================================================
2592
2593	SUBROUTINE routing_lake(nbpt, dt_routing, lakeinflow, humrel, return_lakes)
2594	!
2595	IMPLICIT NONE
2596	!
2597	!! INPUT VARIABLES
2598	INTEGER(i_std), INTENT(in) :: nbpt !! Domain size (unitless)
2599	REAL(r_std), INTENT (in) :: dt_routing !! Routing time step (s)
2600	REAL(r_std), INTENT(out) :: lakeinflow(nbpt) !! Water inflow to the lakes (kg/dt)
2601	REAL(r_std), INTENT(in) :: humrel(nbpt) !! Soil moisture stress, root extraction potential (unitless)
2602	!
2603	!! OUTPUT VARIABLES
2604	REAL(r_std), INTENT(out) :: return_lakes(nbpt) !! Water from lakes flowing back into soil moisture (kg/m^2/dt)
2605	!
2606	!! LOCAL VARIABLES
2607	INTEGER(i_std) :: ig !! Indices (unitless)
2608	REAL(r_std) :: refill !!
2609	REAL(r_std) :: total_area !! Sum of all the surfaces of the basins (m^2)
2610
2611	!_ ================================================================================================================================
2612	!
2613	!
2614	DO ig=1,nbpt
2615	!
2616	total_area = SUM(routing_area(ig,:))
2617	!
2618	lake_reservoir(ig) = lake_reservoir(ig) + lakeinflow(ig)
2619
2620	IF ( doswamps ) THEN
2621	! Calculate a return flow that will be extracted from the lake reservoir and reinserted in the soil in hydrol
2622	! Uptake in Kg/dt
2623	refill = MAX(zero, maxevap_lake * (un - humrel(ig)) * dt_routing * total_area)
2624	return_lakes(ig) = MIN(refill, lake_reservoir(ig))
2625	lake_reservoir(ig) = lake_reservoir(ig) - return_lakes(ig)
2626	! Return in Kg/m^2/dt
2627	return_lakes(ig) = return_lakes(ig)/total_area
2628	ELSE
2629	return_lakes(ig) = zero
2630	ENDIF
2631
2632	! This is the volume of the lake scaled to the entire grid.
2633	! It would be better to scale it to the size of the lake
2634	! but this information is not yet available.
2635	lake_diag(ig) = lake_reservoir(ig)/total_area
2636
2637	lakeinflow(ig) = lakeinflow(ig)/total_area
2638
2639	ENDDO
2640	!
2641	END SUBROUTINE routing_lake
2642	!
2643
2644	!! ================================================================================================================================
2645	!! SUBROUTINE : routing_diagnostic_p
2646	!!
2647	!>\BRIEF This parallelized subroutine gives a diagnostic of the basins used
2648	!!
2649	!! DESCRIPTION (definitions, functional, design, flags) : None
2650	!!
2651	!! RECENT CHANGE(S): None
2652	!!
2653	!! MAIN OUTPUT VARIABLE(S):
2654	!!
2655	!! REFERENCES : None
2656	!!
2657	!! FLOWCHART : None
2658	!! \n
2659	!_ ================================================================================================================================
2660
2661	SUBROUTINE routing_diagnostic_p(nbpt, index, lalo, resolution, contfrac, hist_id, hist2_id)
2662	!
2663	IMPLICIT NONE
2664
2665	!! INPUT VARIABLES
2666	INTEGER(i_std), INTENT(in) :: nbpt !! Domain size (unitless)
2667	INTEGER(i_std), INTENT(in) :: index(nbpt) !! Indices of the points on the map (unitless)
2668	REAL(r_std), INTENT(in) :: lalo(nbpt,2) !! Vector of latitude and longitudes (beware of the order !)
2669	REAL(r_std), INTENT(in) :: resolution(nbpt,2) !! The size of each grid box in X and Y (m)
2670	REAL(r_std), INTENT(in) :: contfrac(nbpt) !! Fraction of land in each grid box (unitless;0-1)
2671	INTEGER(i_std),INTENT (in) :: hist_id !! Access to history file (unitless)
2672	INTEGER(i_std),INTENT (in) :: hist2_id !! Access to history file 2 (unitless)
2673	!
2674	!! LOCAL VARIABLES
2675	REAL(r_std), DIMENSION(nbpt) :: nbrivers !! Number of rivers in the grid (unitless)
2676	REAL(r_std), DIMENSION(nbpt) :: basinmap !! Map of basins (unitless)
2677	REAL(r_std), DIMENSION(nbp_glo) :: nbrivers_g !! Number of rivers in the grid (unitless)
2678	REAL(r_std), DIMENSION(nbp_glo) :: basinmap_g !! Map of basins (unitless)
2679
2680	!_ ================================================================================================================================
2681	routing_area => routing_area_glo
2682	topo_resid => topo_resid_glo
2683	route_togrid => route_togrid_glo
2684	route_tobasin => route_tobasin_glo
2685	route_nbintobas => route_nbintobas_glo
2686	global_basinid => global_basinid_glo
2687	hydrodiag=>hydrodiag_glo
2688	hydroupbasin=>hydroupbasin_glo
2689
2690	IF (is_root_prc) CALL routing_diagnostic(nbp_glo, index_g, lalo_g, resolution_g, contfrac_g, nbrivers_g,basinmap_g)
2691
2692	routing_area => routing_area_loc
2693	topo_resid => topo_resid_loc
2694	route_togrid => route_togrid_loc
2695	route_tobasin => route_tobasin_loc
2696	route_nbintobas => route_nbintobas_loc
2697	global_basinid => global_basinid_loc
2698	hydrodiag=>hydrodiag_loc
2699	hydroupbasin=>hydroupbasin_loc
2700
2701	CALL scatter(nbrivers_g,nbrivers)
2702	CALL scatter(basinmap_g,basinmap)
2703	CALL scatter(hydrodiag_glo,hydrodiag_loc)
2704	CALL scatter(hydroupbasin_glo,hydroupbasin_loc)
2705
2706	CALL xios_orchidee_send_field("basinmap",basinmap)
2707	CALL xios_orchidee_send_field("nbrivers",nbrivers)
2708
2709	IF ( .NOT. almaoutput ) THEN
2710	CALL histwrite_p(hist_id, 'basinmap', 1, basinmap, nbpt, index)
2711	CALL histwrite_p(hist_id, 'nbrivers', 1, nbrivers, nbpt, index)
2712	ELSE
2713	ENDIF
2714	IF ( hist2_id > 0 ) THEN
2715	IF ( .NOT. almaoutput ) THEN
2716	CALL histwrite_p(hist2_id, 'basinmap', 1, basinmap, nbpt, index)
2717	CALL histwrite_p(hist2_id, 'nbrivers', 1, nbrivers, nbpt, index)
2718	ELSE
2719	ENDIF
2720	ENDIF
2721
2722
2723	END SUBROUTINE routing_diagnostic_p
2724
2725	!! ================================================================================================================================
2726	!! SUBROUTINE : routing_diagnostic
2727	!!
2728	!>\BRIEF This non-parallelized subroutine gives a diagnostic of the basins used. This produces some information
2729	!! on the rivers which are being diagnosed.
2730	!!
2731	!! DESCRIPTION (definitions, functional, design, flags) : As not all rivers can be monitored in the model, we will only
2732	!! archive num_largest rivers. In this routine we will diagnose the num_largest largest rivers and print to the standard
2733	!! 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
2734	!! routine routing_names. As this standard output is not sufficient, we will also write it to a netCDF file with the routine
2735	!! routing_diagncfile. It is important to keep for diagnostic the fraction of the largest basins in each grid box and keep information
2736	!! how they are linked one to the other.
2737	!!
2738	!! RECENT CHANGE(S): None
2739	!!
2740	!! MAIN OUTPUT VARIABLE(S): No output variables.
2741	!!
2742	!! REFERENCES : None
2743	!!
2744	!! FLOWCHART :None
2745	!! \n
2746	!_ ================================================================================================================================
2747
2748	SUBROUTINE routing_diagnostic(nbpt, l_index, lalo, resolution, contfrac, nbrivers, basinmap)
2749	!
2750	IMPLICIT NONE
2751	!
2752	!! INPUT VARIABLES
2753	INTEGER(i_std), INTENT(in) :: nbpt !! Domain size (unitless)
2754	INTEGER(i_std), INTENT(in) :: l_index(nbpt) !! Indices of the points on the map (unitless)
2755	REAL(r_std), INTENT(in) :: lalo(nbpt,2) !! Vector of latitude and longitudes (beware of the order !)
2756	REAL(r_std), INTENT(in) :: resolution(nbpt,2) !! The size of each grid box in X and Y (m)
2757	REAL(r_std), INTENT(in) :: contfrac(nbpt) !! Fraction of land in each grid box (unitless;0-1)
2758	!
2759	!! OUTPUT VARIABLES
2760	REAL(r_std), DIMENSION(nbpt), INTENT(out) :: nbrivers !! Number of rivers in the grid (unitless)
2761	REAL(r_std), DIMENSION(nbpt), INTENT(out) :: basinmap !! Map of basins (unitless)
2762	!
2763	!! LOCAL VARIABLES
2764	INTEGER(i_std), DIMENSION(nbpt,nbasmax) :: outids !! IDs of river to which this basin contributes (unitless)
2765	INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:) :: pts !! List the points belonging to the basin (unitless)
2766	INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:) :: ptbas !! List the basin number for this point (unitless)
2767	INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:) :: outpt !! Outflow point for each basin (unitless)
2768	INTEGER(i_std), ALLOCATABLE, DIMENSION(:) :: nb_pts !! Number of points in the basin (unitless)
2769	REAL(r_std), ALLOCATABLE, DIMENSION(:) :: totarea !! Total area of basin (m^2)
2770	REAL(r_std), ALLOCATABLE, DIMENSION(:) :: tmparea !!
2771	INTEGER(i_std), ALLOCATABLE, DIMENSION(:) :: topids !! The IDs of the first num_largest basins (unitless)
2772	CHARACTER(LEN=25), ALLOCATABLE, DIMENSION(:) :: basin_names !! Names of the rivers (unitless)
2773	CHARACTER(LEN=25) :: name_str !!
2774	!
2775	LOGICAL :: river_file !! Choose to write a description of the rivers (true/false)
2776	CHARACTER(LEN=80) :: river_file_name !! Filename in which we write the description of the rivers (unitless)
2777	!
2778	CHARACTER(LEN=25), ALLOCATABLE, DIMENSION(:) :: sorted_names !!
2779	INTEGER(i_std), ALLOCATABLE, DIMENSION(:) :: streams_nb !! Number of streams in basin (unitless)
2780	INTEGER(i_std), ALLOCATABLE, DIMENSION(:) :: streams_avehops !! Average number of hops in streams (unitless)
2781	INTEGER(i_std), ALLOCATABLE, DIMENSION(:) :: streams_minhops !! Minimum number of hops in streams (unitless)
2782	INTEGER(i_std), ALLOCATABLE, DIMENSION(:) :: streams_maxhops !! Minimum number of hops in streams (unitless)
2783	REAL(r_std), ALLOCATABLE, DIMENSION(:) :: streams_resid !! Average residence time
2784	!
2785	REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: lbasin_area !!
2786	REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: lbasin_uparea !!
2787	INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:) :: lrivercode !!
2788	!
2789	INTEGER(i_std) :: ig, ib, og, ob, ign, ibn, ff(1), ic, icc, nb_small, idbas, slen, ii !! Indices (unitless)
2790	INTEGER(i_std) :: ier !! Error handling
2791	CHARACTER(LEN=1) :: nn !!
2792	INTEGER(i_std) :: name_found !!
2793	!
2794	REAL(r_std) :: averesid !!
2795	REAL(r_std), DIMENSION(nbasmax) :: tmpbas !!
2796	REAL(r_std), DIMENSION(nbpt,nbasmax) :: areaupbasin !!
2797	INTEGER(i_std), ALLOCATABLE, DIMENSION(:) :: sortedrivs !!
2798	!
2799	! Variables for the river coding
2800	!
2801	INTEGER(i_std) :: longest_river !!
2802	INTEGER(i_std) :: nbmax !!
2803	INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:) :: allstreams !!
2804	REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: upstreamchange !!
2805	INTEGER(i_std), ALLOCATABLE, DIMENSION(:) :: tstreams, tslen, tpts, tptbas, tcode !!
2806	REAL(r_std), ALLOCATABLE, DIMENSION(:) :: tuparea !!
2807	REAL(r_std), ALLOCATABLE, DIMENSION(:) :: tupstreamchange !!
2808	!
2809	LOGICAL :: err_nbpt_grid_basin !! (true/false)
2810	LOGICAL :: err_basin_number !! (true/false)
2811
2812	!_ ================================================================================================================================
2813	!
2814	!
2815	ALLOCATE(pts(num_largest, nbpt), stat=ier)
2816	IF (ier /= 0) CALL ipslerr_p(3,'routing_diagnostic','Pb in allocate for pts','','')
2817
2818	ALLOCATE(ptbas(num_largest, nbpt), stat=ier)
2819	IF (ier /= 0) CALL ipslerr_p(3,'routing_diagnostic','Pb in allocate for ptbas','','')
2820
2821	ALLOCATE(outpt(num_largest, 2), stat=ier)
2822	IF (ier /= 0) CALL ipslerr_p(3,'routing_diagnostic','Pb in allocate for outpt','','')
2823
2824	ALLOCATE(nb_pts(num_largest), stat=ier)
2825	IF (ier /= 0) CALL ipslerr_p(3,'routing_diagnostic','Pb in allocate for nb_pts','','')
2826
2827	ALLOCATE(totarea(num_largest), tmparea(num_largest), stat=ier)
2828	IF (ier /= 0) CALL ipslerr_p(3,'routing_diagnostic','Pb in allocate for totarea','','')
2829
2830	ALLOCATE(topids(num_largest), stat=ier)
2831	IF (ier /= 0) CALL ipslerr_p(3,'routing_diagnostic','Pb in allocate for topids','','')
2832
2833	ALLOCATE(sortedrivs(num_largest), stat=ier)
2834	IF (ier /= 0) CALL ipslerr_p(3,'routing_diagnostic','Pb in allocate for sortedrivs','','')
2835
2836	ALLOCATE(sorted_names(num_largest), stat=ier)
2837	IF (ier /= 0) CALL ipslerr_p(3,'routing_diagnostic','Pb in allocate for sorted_names','','')
2838
2839	ALLOCATE(streams_nb(num_largest), streams_avehops(num_largest), streams_minhops(num_largest), stat=ier)
2840	IF (ier /= 0) CALL ipslerr_p(3,'routing_diagnostic','Pb in allocate for streams_nb','','')
2841
2842	ALLOCATE(streams_maxhops(num_largest), stat=ier)
2843	IF (ier /= 0) CALL ipslerr_p(3,'routing_diagnostic','Pb in allocate for streams_maxhops','','')
2844
2845	ALLOCATE(streams_resid(num_largest), stat=ier)
2846	IF (ier /= 0) CALL ipslerr_p(3,'routing_diagnostic','Pb in allocate for streams_resid','','')
2847
2848	ALLOCATE(lbasin_area(num_largest,nbpt), lbasin_uparea(num_largest,nbpt), lrivercode(num_largest,nbpt), stat=ier)
2849	IF (ier /= 0) CALL ipslerr_p(3,'routing_diagnostic','Pb in allocate for lbasin_area','','')
2850
2851	IF ( .NOT. is_root_prc) THEN
2852	WRITE(numout,*) "routing_diagnostic is not suitable for running in parallel"
2853	WRITE(numout,*) "We are here on a non root processor. is_root_prc = ", is_root_prc
2854	WRITE(numout,*) "STOP from routing_diagnostic"
2855	CALL ipslerr_p(3,'routing_diagnostic','This routine is not suitable for running in parallel','','')
2856	ENDIF
2857
2858
2859	!Config Key = RIVER_DESC
2860	!Config Desc = Writes out a description of the rivers
2861	!Config If = RIVER_ROUTING
2862	!Config Def = n
2863	!Config Help = This flag allows to write out a file containing the list of
2864	!Config rivers which are beeing simulated. It provides location of outflow
2865	!Config drainage area, name and ID.
2866	!Config Units = [FLAG]
2867	!
2868	river_file=.FALSE.
2869	CALL getin('RIVER_DESC', river_file)
2870	!
2871	!Config Key = RIVER_DESC_FILE
2872	!Config Desc = Filename in which we write the description of the rivers. If suffix is ".nc" a netCDF file is created
2873	!Config If = RIVER_DESC
2874	!Config Def = river_desc.nc
2875	!Config Help = File name where we will write the information. If the suffix is ".nc" a netCDF file is generated. Else
2876	!Config a simple text file will contain some information. The netCDF file is valuable for post-processing the
2877	! data as it will contain the fraction of the large basins in each grid box.
2878	!Config Units = [FILE]
2879	!
2880	river_file_name="river_desc.nc"
2881	CALL getin('RIVER_DESC_FILE', river_file_name)
2882	!
2883	!
2884	! First we get the list of all river outflow points
2885	! We work under the assumption that we only have num_largest basins finishing with
2886	! nbasmax+3. This is checked in routing_truncate.
2887	!
2888	nb_small = 1
2889	outpt(:,:) = -1
2890	ic = 0
2891	DO ig=1,nbpt
2892	DO ib=1,nbasmax
2893	ign = route_togrid(ig, ib)
2894	ibn = route_tobasin(ig, ib)
2895	IF ( ibn .EQ. nbasmax+3) THEN
2896	ic = ic + 1
2897	outpt(ic,1) = ig
2898	outpt(ic,2) = ib
2899	!
2900	! Get the largest id of the basins we call a river. This is
2901	! to extract the names of all rivers.
2902	!
2903	IF ( global_basinid(ig,ib) > nb_small ) THEN
2904	nb_small = global_basinid(ig,ib)
2905	ENDIF
2906	ENDIF
2907	ENDDO
2908	ENDDO
2909
2910	nb_small = MIN(nb_small, 349)
2911
2912	ALLOCATE(basin_names(nb_small), stat=ier)
2913	IF (ier /= 0) CALL ipslerr_p(3,'routing_diagnostic','Pb in allocate for basins_names','','')
2914
2915	CALL routing_names(nb_small, basin_names)
2916	!
2917	! Go through all points and basins to see if they outflow as a river and store the
2918	! information needed in the various arrays.
2919	!
2920	nb_pts(:) = 0
2921	totarea(:) = zero
2922	hydrodiag(:,:) = 0
2923	areaupbasin(:,:) = zero
2924	outids(:,:) = -1
2925	ob = -1
2926	og = -1
2927	lbasin_area(:,:) = zero
2928	lbasin_uparea(:,:) = zero
2929	longest_river = 0
2930	!
2931	err_nbpt_grid_basin = .FALSE.
2932	loopgridbasin : DO ig=1,nbpt
2933	!
2934	DO ib=1,nbasmax
2935	IF ( routing_area(ig,ib) .GT. zero ) THEN
2936	ic = 0
2937	ign = ig
2938	ibn = ib
2939	! Locate outflow point
2940	DO WHILE (ibn .GT. 0 .AND. ibn .LE. nbasmax .AND. ic .LT. nbasmax*nbpt)
2941	ic = ic + 1
2942	og = ign
2943	ob = ibn
2944	ign = route_togrid(og, ob)
2945	ibn = route_tobasin(og, ob)
2946	areaupbasin(og, ob) = areaupbasin(og, ob) + routing_area(ig,ib)
2947	ENDDO
2948	!
2949	longest_river = MAX(longest_river, ic)
2950	!
2951	! Now that we have an outflow check if it is one of the num_largest rivers.
2952	! In this case we keeps the location so we diagnose it.
2953	!
2954	IF ( ibn .EQ. nbasmax + 3) THEN
2955	DO icc = 1,num_largest
2956	IF ( outpt(icc,1) .EQ. og .AND. outpt(icc,2) .EQ. ob ) THEN
2957	!
2958	! We only keep this point for our map if it is large enough.
2959	!
2960	nb_pts(icc) = nb_pts(icc) + 1
2961	!
2962	!
2963	IF ( nb_pts(icc) > nbpt ) THEN
2964	err_nbpt_grid_basin = .TRUE.
2965	EXIT loopgridbasin
2966	ENDIF
2967	!
2968	pts(icc, nb_pts(icc)) = ig
2969	ptbas(icc, nb_pts(icc)) = ib
2970	totarea(icc) = totarea(icc) + routing_area(ig,ib)
2971	!
2972	lbasin_area(icc,nb_pts(icc)) = routing_area(ig,ib)
2973	!
2974	! ID of the river is taken from the last point before the outflow.
2975	topids(icc) = global_basinid(og,ob)
2976	outids(ig,ib) = global_basinid(og,ob)
2977	!
2978	! On this gridbox and basin we will diagnose the hydrograph
2979	!
2980	hydrodiag(ig, ib) = 1
2981	!
2982	ENDIF
2983	ENDDO
2984	ENDIF
2985	ENDIF
2986	!
2987	ENDDO
2988	!
2989	ENDDO loopgridbasin
2990	!
2991	IF ( err_nbpt_grid_basin ) THEN
2992	WRITE(numout, *) "routing_diagnostic : The number of grid points in basin ", icc
2993	WRITE(numout, *) "routing_diagnostic : is larger than anticiped. "
2994	CALL ipslerr_p(3, 'routing_diagnostic', 'We are heading for a out of bounds in arrays pts, ptsbas and lbasin_area.',&
2995	& 'Increase the last dimension of these arrays.','')
2996	ENDIF
2997	!
2998	! Now we decide which points we will keep from the largest basins
2999	!
3000	! Temporary fix
3001	route_nbintobas(:,:) = 0
3002	!
3003	basinmap(:) = zero
3004	DO ig=1,nbpt
3005	!
3006	! Look for the dominant basin in this grid. This information only affects some
3007	! diagnostics : hydrographs and saved area upstream.
3008	!
3009	icc = 0
3010	idbas = -1
3011	!
3012	DO ib=1,nbasmax
3013	IF ( outids(ig,ib) > 0 ) THEN
3014	IF ( COUNT(outids(ig,:) == outids(ig,ib)) > icc ) THEN
3015	icc = COUNT(outids(ig,:) == outids(ig,ib))
3016	idbas = outids(ig,ib)
3017	ENDIF
3018	ENDIF
3019	ENDDO
3020	!
3021	! If we have found a point from the large basins and decided which one
3022	! takes over this grid then we note it on the map.
3023	! Clean-up a little the hydrodiag array
3024	!
3025	IF ( idbas > 0 ) THEN
3026	basinmap(ig) = REAL(idbas, r_std)
3027	ENDIF
3028	!
3029	! Now place the hydrograph diagnostic on the point closest to the
3030	! ocean.
3031	!
3032	tmpbas(:) = zero
3033	DO ib=1,nbasmax
3034	IF ( outids(ig,ib) .EQ. idbas) THEN
3035	tmpbas(ib) = areaupbasin(ig,ib)
3036	ENDIF
3037	ENDDO
3038	hydrodiag(ig,:) = 0
3039	ff=MAXLOC(tmpbas)
3040	hydrodiag(ig,ff(1)) = 1
3041	hydroupbasin(ig) = areaupbasin(ig,ff(1))
3042	!
3043	ENDDO
3044	!
3045	!
3046	!
3047	tmparea(:) = totarea(:)
3048	DO icc = 1, num_largest
3049	ff = MAXLOC(tmparea)
3050	sortedrivs(icc) = ff(1)
3051	tmparea(ff(1)) = 0.0
3052	ENDDO
3053	!
3054	! Diagnose the complexity of the basins obtained and determine their code in the Pfafstetter system
3055	!
3056	nbmax=MAXVAL(nb_pts)
3057	ALLOCATE(allstreams(nbmax, longest_river), upstreamchange(nbmax, longest_river), stat=ier)
3058	IF (ier /= 0) CALL ipslerr_p(3,'routing_diagnostic','Pb in allocate for allstreams','','')
3059
3060	ALLOCATE(tstreams(longest_river), tupstreamchange(longest_river), stat=ier)
3061	IF (ier /= 0) CALL ipslerr_p(3,'routing_diagnostic','Pb in allocate for tstreams','','')
3062
3063	ALLOCATE(tslen(nbmax), tpts(nbmax), tptbas(nbmax), tuparea(nbmax), stat=ier)
3064	IF (ier /= 0) CALL ipslerr_p(3,'routing_diagnostic','Pb in allocate for tslen','','')
3065
3066	ALLOCATE(tcode(nbmax), stat=ier)
3067	IF (ier /= 0) CALL ipslerr_p(3,'routing_diagnostic','Pb in allocate for tcode','','')
3068
3069	DO icc = 1, num_largest
3070	!
3071	! Work through the largest basins
3072	!
3073	idbas = sortedrivs(icc)
3074	!
3075	streams_nb(idbas) = 0
3076	streams_avehops(idbas) = 0
3077	streams_minhops(idbas) = undef_int
3078	streams_maxhops(idbas) = 0
3079	streams_resid(idbas) = zero
3080	tslen(:) = 0
3081	!
3082	allstreams(:,:) = 0
3083	upstreamchange(:,:) = zero
3084	!
3085	DO ii=1,nb_pts(idbas)
3086	!
3087	ig = pts(idbas, ii)
3088	ib = ptbas(idbas, ii)
3089	!
3090	lbasin_uparea(idbas,ii) = areaupbasin(ig,ib)
3091	!
3092	slen = 0
3093	ign = ig
3094	ibn = ib
3095	og = ig
3096	ob = ib
3097	!
3098	averesid = zero
3099	tupstreamchange(:) = zero
3100	! go to outflow point to count the number of hops
3101	DO WHILE (ibn .GT. 0 .AND. ibn .LE. nbasmax)
3102	! Store data
3103	slen = slen + 1
3104	tstreams(slen) = ign
3105	tupstreamchange(slen) = areaupbasin(ign,ibn)-areaupbasin(og,ob)
3106	! Move to next point
3107	og = ign
3108	ob = ibn
3109	ign = route_togrid(og, ob)
3110	ibn = route_tobasin(og, ob)
3111	averesid = averesid + topo_resid(og, ob)**2
3112	ENDDO
3113	!
3114	allstreams(ii,1:slen) = tstreams(slen:1:-1)
3115	upstreamchange(ii,1:slen) = tupstreamchange(slen:1:-1)
3116	tslen(ii) = slen
3117	!
3118	! Save diagnostics
3119	!
3120	streams_nb(idbas) = streams_nb(idbas) + 1
3121	streams_avehops(idbas) = streams_avehops(idbas) + slen
3122	streams_resid(idbas) = streams_resid(idbas) + SQRT(averesid)
3123	IF ( slen < streams_minhops(idbas) ) THEN
3124	streams_minhops(idbas) = slen
3125	ENDIF
3126	IF ( slen > streams_maxhops(idbas) ) THEN
3127	streams_maxhops(idbas) = slen
3128	ENDIF
3129	!
3130	ENDDO
3131	! build the average
3132	IF ( streams_nb(idbas) > 0 ) THEN
3133	streams_avehops(idbas) = streams_avehops(idbas)/streams_nb(idbas)
3134	streams_resid(idbas) = streams_resid(idbas)/REAL(streams_nb(idbas), r_std)
3135	ELSE
3136	! River without streams ... very rare but happens
3137	streams_avehops(idbas) = zero
3138	streams_resid(idbas) = zero
3139	streams_maxhops(idbas) = zero
3140	streams_minhops(idbas) = zero
3141	ENDIF
3142	!
3143	!
3144	ii=nb_pts(idbas)
3145	tpts(:) = 0
3146	tpts(1:ii) = pts(idbas,1:ii)
3147	tptbas(:) = 0
3148	tptbas(1:ii) = ptbas(idbas,1:ii)
3149	tuparea(:) = 0
3150	tuparea(1:ii) = lbasin_uparea(idbas,1:ii)
3151	!
3152	CALL routing_diagcode(ii, tpts, tptbas, tuparea, tslen, MAXVAL(tslen), allstreams, upstreamchange, tcode)
3153	!
3154	lrivercode(idbas,:) = 0
3155	lrivercode(idbas,1:ii) = tcode(1:ii)
3156	!
3157	ENDDO
3158	!
3159	! Create the sorted list of names
3160	!
3161	err_basin_number = .FALSE.
3162	DO icc = 1, num_largest
3163	!
3164	ib=sortedrivs(icc)
3165	!
3166	IF ( topids(ib) .GT. nb_small ) THEN
3167	IF (topids(ib) <= 99 ) THEN
3168	WRITE(sorted_names(icc), '("Nb_",I2.2)') topids(ib)
3169	ELSE IF (topids(ib) <= 999 ) THEN
3170	WRITE(sorted_names(icc), '("Nb_",I3.3)') topids(ib)
3171	ELSE IF (topids(ib) <= 9999 ) THEN
3172	WRITE(sorted_names(icc), '("Nb_",I4.4)') topids(ib)
3173	ELSE IF (topids(ib) <= 99999 ) THEN
3174	WRITE(sorted_names(icc), '("Nb_",I5.5)') topids(ib)
3175	ELSE IF (topids(ib) <= 999999 ) THEN
3176	WRITE(sorted_names(icc), '("Nb_",I6.6)') topids(ib)
3177	ELSE
3178	err_basin_number = .TRUE.
3179	EXIT
3180	ENDIF
3181
3182	ELSE
3183	IF (topids(ib) <= -1 ) THEN
3184	WRITE(sorted_names(icc), '("Ne_",I2.2)') -1*topids(ib)
3185	ELSE
3186	IF (printlev >=6) WRITE(numout,*) ">>> nb_small, ib, topids :", nb_small, ib, topids(ib)
3187	sorted_names(icc) = basin_names(topids(ib))
3188	ENDIF
3189	ENDIF
3190	!
3191	ENDDO
3192	!
3193	IF ( err_basin_number ) THEN
3194	CALL ipslerr_p(3, 'routing_diagnostic', 'We found a basin number larger than 999999.',&
3195	& 'This is impossible. Please verify your configuration.','')
3196	ENDIF
3197	!
3198	! Check for doubles and rename if needed
3199	!
3200	DO icc = 1, num_largest
3201	name_found=0
3202	DO ic=1, num_largest
3203	IF ( TRIM(sorted_names(icc)) == TRIM(sorted_names(ic)) ) THEN
3204	name_found = name_found + 1
3205	ENDIF
3206	ENDDO
3207	!
3208	IF ( name_found > 1 ) THEN
3209	DO ic=num_largest,1,-1
3210	IF ( TRIM(sorted_names(icc)) == TRIM(sorted_names(ic)) ) THEN
3211	IF ( name_found > 1 ) THEN
3212	WRITE(nn,'(I1)') name_found
3213	sorted_names(ic) = TRIM(sorted_names(ic))//nn
3214	name_found = name_found - 1
3215	ENDIF
3216	ENDIF
3217	ENDDO
3218	ENDIF
3219	!
3220	ENDDO
3221	!
3222	! Print to stdout on ROOT_PROC the diagnostics for the largest basins we have found.
3223	!
3224	DO icc = 1, num_largest
3225	!
3226	IF ( nb_pts(sortedrivs(icc)) .GT. 2 ) THEN
3227	name_str = sorted_names(icc)
3228	WRITE(numout,'("Basin ID ", I5," ", A15, " Area [km^2] : ", F13.4, " Nb points : ", I4)')&
3229	& topids(sortedrivs(icc)), name_str(1:15), totarea(sortedrivs(icc))/1.e6, nb_pts(sortedrivs(icc))
3230	ENDIF
3231	!
3232	ENDDO
3233	!
3234	! Save some of the basin information into files.
3235	!
3236	IF ( river_file ) THEN
3237
3238	IF ( INDEX(river_file_name,".nc") > 1 ) THEN
3239
3240	CALL routing_diagncfile(river_file_name, nbpt, lalo, nb_pts, topids, sorted_names, sortedrivs, &
3241	& pts, lbasin_area, lbasin_uparea, lrivercode, outpt, streams_nb, streams_avehops, &
3242	& streams_minhops, streams_maxhops, streams_resid)
3243
3244	ELSE
3245
3246	OPEN(diagunit, FILE=river_file_name)
3247	WRITE(diagunit,'(A)') "Basin ID, Area [km^2], Nb points, Lon and Lat of outflow"
3248	WRITE(diagunit,'(A)') "Nb streams, total number of hops, min, ave and max number of hops per stream"
3249	!
3250	DO icc = 1, num_largest
3251	!
3252	IF ( nb_pts(sortedrivs(icc)) .GT. 2 ) THEN
3253	!
3254	name_str = sorted_names(icc)
3255	!
3256	WRITE(diagunit,'(I5,A25,F14.5,I5,2F9.2)') topids(sortedrivs(icc)), name_str(1:15), totarea(sortedrivs(icc))/1.e6, &
3257	& nb_pts(sortedrivs(icc)), lalo(outpt(sortedrivs(icc),1),2), lalo(outpt(sortedrivs(icc),1),1)
3258	WRITE(diagunit,'(5I9,F16.4)') streams_nb(sortedrivs(icc)), &
3259	& streams_avehops(sortedrivs(icc))*streams_nb(sortedrivs(icc)), &
3260	& streams_minhops(sortedrivs(icc)), &
3261	& streams_avehops(sortedrivs(icc)), &
3262	& streams_maxhops(sortedrivs(icc)), streams_resid(sortedrivs(icc))
3263	!
3264	ENDIF
3265	!
3266	ENDDO
3267	!
3268	CLOSE(diagunit)
3269	!
3270	ENDIF
3271	!
3272	ENDIF
3273	!
3274	!
3275	nbrivers(:) = zero
3276	DO ig=1,nbpt
3277	nbrivers(ig) = COUNT(route_tobasin(ig,1:nbasmax) == nbasmax+3)
3278	ENDDO
3279	DO ig=1,nbpt
3280	IF ( nbrivers(ig) > 1 ) THEN
3281	WRITE(numout,*) 'Grid box ', ig, ' has ', NINT(nbrivers(ig)), ' outflow points.'
3282	WRITE(numout,*) 'The rivers which flow into the ocean at this point are :'
3283	DO icc=1,nbasmax
3284	IF ( route_tobasin(ig,icc) == nbasmax+3) THEN
3285	IF ( global_basinid(ig,icc) <= nb_small ) THEN
3286	WRITE(numout,*) 'ID = ',global_basinid(ig,icc), ' Name = ', basin_names(global_basinid(ig,icc))
3287	ELSE
3288	WRITE(numout,*) 'ID = ',global_basinid(ig,icc), ' Problem ===== ID is larger than possible'
3289	ENDIF
3290	ENDIF
3291	ENDDO
3292	ENDIF
3293	ENDDO
3294	!
3295	WRITE(numout,*) 'Maximum topographic index :', MAXVAL(topo_resid)
3296	ic = COUNT(topo_resid .GT. 0.)
3297	WRITE(numout,*) 'Mean topographic index :', SUM(topo_resid, MASK=topo_resid .GT. zero)/ic
3298	WRITE(numout,*) 'Minimum topographic index :', MINVAL(topo_resid, MASK=topo_resid .GT. zero)
3299	!
3300	DEALLOCATE(pts)
3301	DEALLOCATE(outpt)
3302	DEALLOCATE(nb_pts)
3303	DEALLOCATE(totarea, tmparea)
3304	DEALLOCATE(streams_nb, streams_avehops, streams_minhops, streams_maxhops)
3305	!
3306	DEALLOCATE(lbasin_area, lbasin_uparea, lrivercode)
3307	!
3308	DEALLOCATE(allstreams)
3309	DEALLOCATE(tstreams)
3310	DEALLOCATE(tslen, tpts, tptbas, tuparea)
3311	DEALLOCATE(tcode)
3312	!
3313	WRITE(numout,*) 'Maximum topographic index :', MAXVAL(topo_resid)
3314	ic = COUNT(topo_resid .GT. 0.)
3315	WRITE(numout,*) 'Mean topographic index :', SUM(topo_resid, MASK=topo_resid .GT. 0.)/ic
3316	WRITE(numout,*) 'Minimum topographic index :', MINVAL(topo_resid, MASK=topo_resid .GT. 0.)
3317	!
3318	!
3319	END SUBROUTINE routing_diagnostic
3320	!
3321	!! ================================================================================================================================
3322	!! SUBROUTINE : routing_diagcode
3323	!!
3324	!>\BRIEF This subroutine determines the code in the Pfafstetter system for all points
3325	!! within the given catchment.
3326	!!
3327	!! DESCRIPTION (definitions, functional, design, flags) : None
3328	!!
3329	!! RECENT CHANGE(S): None
3330	!!
3331	!! MAIN OUTPUT VARIABLE(S): streamcode
3332	!!
3333	!! REFERENCES : None
3334	!!
3335	!! FLOWCHART :None
3336	!! \n
3337	!_ ================================================================================================================================
3338
3339	SUBROUTINE routing_diagcode(ip, tpts, tpbas, tuparea, tslen, ls, allstreams, upstreamchange, streamcode)
3340	!
3341	IMPLICIT NONE
3342	!
3343	!! INPUT VARIABLES
3344	INTEGER(i_std), INTENT(in) :: ip !!
3345	INTEGER(i_std), INTENT(in) :: ls !!
3346	INTEGER(i_std), DIMENSION(ip), INTENT(in) :: tpts !!
3347	INTEGER(i_std), DIMENSION(ip), INTENT(in) :: tpbas !!
3348	REAL(r_std), DIMENSION(ip), INTENT(in) :: tuparea !!
3349	INTEGER(i_std), DIMENSION(ip), INTENT(in) :: tslen !!
3350	INTEGER(i_std), DIMENSION(ip,ls), INTENT(in) :: allstreams !!
3351	REAL(r_std), DIMENSION(ip,ls), INTENT(in) :: upstreamchange !!
3352	!
3353	!! OUTPUT VARIABLES
3354	INTEGER(i_std), DIMENSION(ip), INTENT(out) :: streamcode !!
3355	!
3356	!! LOCAL VARIABLES
3357	INTEGER(i_std) :: ilev, cntsubbas, ib, ic, i, it, ilevmax, imaxlen, nbzero !!
3358	INTEGER(i_std) :: tstreamcode(ip)!!
3359	INTEGER(i_std) :: indsubbas(ip) !!
3360	INTEGER(i_std) :: iw(ip) !!
3361	INTEGER(i_std) :: tdiff(ip) !!
3362	INTEGER(i_std) :: tmpjunc(4) !!
3363	INTEGER(i_std) :: junction(4) !!
3364	INTEGER(i_std) :: ff(1) !!
3365	INTEGER(i_std) :: ll !!
3366	REAL(r_std) :: chguparea(ip) !!
3367	REAL(r_std) :: largest !!
3368
3369	!_ ================================================================================================================================
3370	!
3371	streamcode(:) = 0
3372	!
3373	! If we accept 4 grid boxes per coded basin then per level we need at least
3374	! 4*9=36 boxes.
3375	!
3376	ilevmax = 0
3377	it = ip
3378	DO WHILE (it >= 36)
3379	ilevmax = ilevmax+1
3380	it = it/9
3381	ENDDO
3382	!
3383	DO ilev=1,ilevmax
3384	!
3385	! Count number of sub-basins we already have
3386	!
3387	cntsubbas=0
3388	tstreamcode(:) = streamcode(:)
3389	DO WHILE ( COUNT(tstreamcode(:) >= 0) > 0 )
3390	cntsubbas=cntsubbas+1
3391	indsubbas(cntsubbas) = MAXVAL(tstreamcode(:))
3392	WHERE ( tstreamcode(:) == indsubbas(cntsubbas) ) tstreamcode = -1
3393	ENDDO
3394	!
3395	! Go through all these basins in order to find the next Pfafstetter numbers
3396	!
3397	DO ib=1,cntsubbas
3398	!
3399	! Get all the streams which have the current Pfadstetter number
3400	!
3401	it=0
3402	DO ic=1,ip
3403	IF ( streamcode(ic) == indsubbas(ib) ) THEN
3404	it =it+1
3405	iw(it)=ic
3406	ENDIF
3407	ENDDO
3408	!
3409	! Which is the longest stream in this basin ?
3410	!
3411	ff=MAXLOC(tslen(iw(1:it)))
3412	imaxlen=iw(ff(1))
3413	chguparea(:) = zero
3414	chguparea(1:tslen(imaxlen)) = upstreamchange(imaxlen, 1:tslen(imaxlen))
3415	!
3416	IF ( COUNT(chguparea(1:tslen(imaxlen)) > 0) < 4 ) THEN
3417	!
3418	! If this subbasin is too small we just set all points to zero
3419	!
3420	DO i=1,it
3421	streamcode(iw(i)) = streamcode(iw(i))*10
3422	ENDDO
3423	ELSE
3424	!
3425	! Else do the Pfafstetter numbering
3426	!
3427	!
3428	! Where do we have the 4 largest change in upstream area on this stream.
3429	! This must be the confluence of 2 rivers and thus a junction point.
3430	!
3431	largest=piR_EarthR_Earth
3432	DO i=1,4
3433	ff = MAXLOC(chguparea(1:tslen(imaxlen)), MASK = chguparea(1:tslen(imaxlen)) < largest)
3434	tmpjunc(i) = ff(1)
3435	largest=chguparea(tmpjunc(i))
3436	ENDDO
3437	! sort junctions to go from the outflow up-stream
3438	ff(1)=0
3439	DO i=1,4
3440	junction(i) = MINVAL(tmpjunc, MASK=tmpjunc > ff(1))
3441	ff(1) = junction(i)
3442	ENDDO
3443	!
3444	! Find all streams which are identical up to that junction and increase their code accordingly
3445	!
3446	DO i=1,it
3447	ll=MIN(tslen(imaxlen),tslen(iw(i)))
3448	tdiff(1:ll) = allstreams(imaxlen,1:ll)-allstreams(iw(i),1:ll)
3449	nbzero = COUNT(tdiff(1:ll) == 0)
3450	IF (nbzero < junction(1) ) THEN
3451	! Before first of the 4 largest basins
3452	streamcode(iw(i)) = streamcode(iw(i))*10+1
3453	ELSE IF (nbzero == junction(1) ) THEN
3454	! Stream part of the first largest basin
3455	streamcode(iw(i)) = streamcode(iw(i))*10+2
3456	ELSE IF (nbzero < junction(2) ) THEN
3457	! Between first and second stream
3458	streamcode(iw(i)) = streamcode(iw(i))*10+3
3459	ELSE IF (nbzero == junction(2) ) THEN
3460	! Stream part of the second basin
3461	streamcode(iw(i)) = streamcode(iw(i))*10+4
3462	ELSE IF (nbzero < junction(3) ) THEN
3463	! In between stream 2 and 3
3464	streamcode(iw(i)) = streamcode(iw(i))*10+5
3465	ELSE IF (nbzero == junction(3) ) THEN
3466	! Part of 3rd basin
3467	streamcode(iw(i)) = streamcode(iw(i))*10+6
3468	ELSE IF (nbzero < junction(4) ) THEN
3469	! In between 3 and 4th basins
3470	streamcode(iw(i)) = streamcode(iw(i))*10+7
3471	ELSE IF (nbzero == junction(4) ) THEN
3472	! Final of the 4 largest basins
3473	streamcode(iw(i)) = streamcode(iw(i))*10+8
3474	ELSE
3475	! The rest of the points and also the basin of the longest stream
3476	streamcode(iw(i)) = streamcode(iw(i))*10+9
3477	ENDIF
3478	ENDDO
3479	ENDIF
3480	ENDDO
3481	!
3482	ENDDO
3483	!
3484	!
3485	END SUBROUTINE routing_diagcode
3486	!
3487	!! ================================================================================================================================
3488	!! SUBROUTINE : routing_diagncfile
3489	!!
3490	!>\BRIEF This subroutine creates a netCDF file containing all the informations
3491	!! on the largest rivers which can be used for a refined analysis.
3492	!!
3493	!! DESCRIPTION (definitions, functional, design, flags) : None
3494	!!
3495	!! RECENT CHANGE(S): None
3496	!!
3497	!! MAIN OUTPUT VARIABLE(S): None
3498	!!
3499	!! REFERENCES : None
3500	!!
3501	!! FLOWCHART : None
3502	!! \n
3503	!_ ================================================================================================================================
3504
3505	SUBROUTINE routing_diagncfile(river_file_name, nbpt, lalo, nb_pts, topids, sorted_names, sortedrivs, &
3506	& lbasin_index, lbasin_area, lbasin_uparea, lrivercode, outpt, streams_nb, streams_avehops, &
3507	& streams_minhops, streams_maxhops, streams_resid)
3508	!
3509	USE netcdf
3510	!
3511	IMPLICIT NONE
3512	!
3513	!
3514	!! INPUT VARIABLES
3515	REAL(r_std), INTENT(in) :: lalo(nbpt,2) !! Vector of latitude and longitudes (beware of the order !)
3516
3517	!! LOCAL VARIABLES
3518	CHARACTER(LEN=80) :: river_file_name !! Filename in which we write the description of the rivers (1)
3519	INTEGER(i_std) :: nbpt !! Domain size (unitless)
3520	INTEGER(i_std), DIMENSION(num_largest) :: nb_pts !! Number of points in the basin (unitless)
3521	INTEGER(i_std), DIMENSION(num_largest) :: topids !! The IDs of the first num_largest basins (unitless)
3522	CHARACTER(LEN=25), DIMENSION(num_largest) :: sorted_names !! Names of the basins to be put into the file (unitless)
3523	INTEGER(i_std), DIMENSION(num_largest) :: sortedrivs !!
3524	INTEGER(i_std), DIMENSION(num_largest,nbpt) :: lbasin_index !!
3525	REAL(r_std), DIMENSION(num_largest,nbpt) :: lbasin_area !!
3526	REAL(r_std), DIMENSION(num_largest,nbpt) :: lbasin_uparea !!
3527	INTEGER(i_std), DIMENSION(num_largest,nbpt) :: lrivercode !!
3528	!
3529	INTEGER(i_std), DIMENSION(num_largest,2) :: outpt !! Outflow point for each basin (unitless)
3530	INTEGER(i_std), DIMENSION(num_largest) :: streams_nb !! Number of streams in basin (unitless)
3531	INTEGER(i_std), DIMENSION(num_largest) :: streams_avehops !! Average number of hops in streams (unitless)
3532	INTEGER(i_std), DIMENSION(num_largest) :: streams_minhops !! Minimum number of hops in streams (unitless)
3533	INTEGER(i_std), DIMENSION(num_largest) :: streams_maxhops !! Minimum number of hops in streams (unitless)
3534	REAL(r_std), DIMENSION(num_largest) :: streams_resid !! Average residence time
3535	!
3536	INTEGER(i_std) :: icc, fid, iret, ierr_tot, ib, ij, ik, i, j, lcc !! Indices (unitless)
3537	INTEGER(i_std) :: nlonid, nlatid, varid, varid2, varid3
3538	INTEGER(i_std) :: dims(2) !!
3539	REAL(r_std) :: lon_min, lon_max, lat_min, lat_max
3540	CHARACTER(LEN=80) :: lon_name, lat_name, var_name, long_name, nc_name, att_str
3541	CHARACTER(LEN=15) :: gridtype !!
3542	!
3543	REAL(r_std) :: basinfrac(iim_g,jjm_g) !!
3544	REAL(r_std) :: basinuparea(iim_g,jjm_g) !!
3545	INTEGER(i_std) :: basincode(iim_g,jjm_g) !!
3546	!
3547	LOGICAL :: check=.FALSE. !! (true/false)
3548	!
3549	!! PARAMETERS
3550	INTEGER(i_std),PARAMETER :: kind_r_diag=NF90_REAL8 !!
3551	INTEGER(i_std),PARAMETER :: kind_i_diag=NF90_INT !!
3552
3553	!_ ================================================================================================================================
3554	!
3555	!
3556	! 1.0 Create the NETCDF file and store the coordinates.
3557	!
3558	! This variable should be defined and computed in the module grid.f90.
3559	! Jan
3560	gridtype="regular"
3561	!
3562	iret = NF90_CREATE(TRIM(river_file_name), NF90_CLOBBER, fid)
3563	IF (iret /= NF90_NOERR) THEN
3564	CALL ipslerr_p (3,'routing_diagncfile', 'Could not create file :', &
3565	& TRIM(river_file_name), '(Problem with disk place or filename ?)')
3566	ENDIF
3567	!
3568	! 1.1 Define dimensions
3569	!
3570	IF ( INDEX(gridtype, "regular") == 1 ) THEN
3571	!
3572	! 1.1.1 regular grid
3573	!
3574	iret = NF90_DEF_DIM(fid, 'lon', iim_g, dims(1))
3575	IF (iret /= NF90_NOERR) THEN
3576	CALL ipslerr_p (3,'routing_diagncfile', 'Dimension "x" can not be defined for the file : ', &
3577	& TRIM(river_file_name),'(Solution ?)')
3578	ENDIF
3579	iret = NF90_DEF_DIM(fid, 'lat', jjm_g, dims(2))
3580	IF (iret /= NF90_NOERR) THEN
3581	CALL ipslerr_p (3,'routing_diagncfile', 'Dimension "y" can not be defined for the file : ', &
3582	& TRIM(river_file_name),'(Solution ?)')
3583	ENDIF
3584	ELSE
3585	!
3586	! 1.1.2 irregular grid
3587	!
3588	iret = NF90_DEF_DIM(fid, 'x', iim_g, dims(1))
3589	IF (iret /= NF90_NOERR) THEN
3590	CALL ipslerr_p (3,'routing_diagncfile', 'Dimension "x" can not be defined for the file : ', &
3591	& TRIM(river_file_name),'(Solution ?)')
3592	ENDIF
3593
3594	iret = NF90_DEF_DIM(fid, 'y', jjm_g, dims(2))
3595	IF (iret /= NF90_NOERR) THEN
3596	CALL ipslerr_p (3,'routing_diagncfile', 'Dimension "y" can not be defined for the file : ', &
3597	& TRIM(river_file_name),'(Solution ?)')
3598	ENDIF
3599	ENDIF
3600	!
3601	!
3602	! 1.2 Define variables and attributes
3603	!
3604	IF ( INDEX(gridtype, "regular") == 1 ) THEN
3605	!
3606	! 1.2.1 regular grid
3607	!
3608	lon_name = 'lon'
3609	!
3610	iret = NF90_DEF_VAR(fid, lon_name, kind_r_diag, dims(1), nlonid)
3611	IF (iret /= NF90_NOERR) THEN
3612	CALL ipslerr_p (3,'routing_diagncfile', 'Variable '//lon_name//' can not be defined for the file : ', &
3613	& TRIM(river_file_name),'(Solution ?)')
3614	ENDIF
3615	!
3616	lat_name = 'lat'
3617	iret = NF90_DEF_VAR(fid, lat_name, kind_r_diag, dims(2), nlatid)
3618	IF (iret /= NF90_NOERR) THEN
3619	CALL ipslerr_p (3,'routing_diagncfile', 'Variable '//lat_name//' can not be defined for the file : ', &
3620	& TRIM(river_file_name),'(Solution ?)')
3621	ENDIF
3622	!
3623	ELSE
3624	!
3625	! 1.2.2 irregular grid
3626	!
3627	lon_name = 'nav_lon'
3628	!
3629	iret = NF90_DEF_VAR(fid, lon_name, kind_r_diag, dims, nlonid)
3630	IF (iret /= NF90_NOERR) THEN
3631	CALL ipslerr_p (3,'routing_diagncfile', 'Variable '//lon_name//' can not be defined for the file : ', &
3632	& TRIM(river_file_name),'(Solution ?)')
3633	ENDIF
3634	!
3635	lat_name = 'nav_lat'
3636	iret = NF90_DEF_VAR(fid, lat_name, kind_r_diag, dims, nlatid)
3637	IF (iret /= NF90_NOERR) THEN
3638	CALL ipslerr_p (3,'routing_diagncfile', 'Variable '//lat_name//' can not be defined for the file : ', &
3639	& TRIM(river_file_name),'(Solution ?)')
3640	ENDIF
3641	!
3642	ENDIF
3643	!
3644	! 1.3 Add attributes to the coordinate variables
3645	!
3646	iret = NF90_PUT_ATT(fid, nlonid, 'units', "degrees_east")
3647	IF (iret /= NF90_NOERR) THEN
3648	CALL ipslerr_p (3,'routing_diagncfile', 'Could not add attribut to variable '//lon_name//' for the file :', &
3649	& TRIM(river_file_name),'(Solution ?)')
3650	ENDIF
3651	!
3652	lon_min = -180.
3653	lon_max = 180.
3654	!
3655	iret = NF90_PUT_ATT(fid, nlonid, 'valid_min', lon_min)
3656	IF (iret /= NF90_NOERR) THEN
3657	CALL ipslerr_p (3,'routing_diagncfile', 'Could not add attribut to variable '//lon_name//' for the file :', &
3658	& TRIM(river_file_name),'(Solution ?)')
3659	ENDIF
3660	iret = NF90_PUT_ATT(fid, nlonid, 'valid_max', lon_max)
3661	IF (iret /= NF90_NOERR) THEN
3662	CALL ipslerr_p (3,'routing_diagncfile', 'Could not add attribut to variable '//lon_name//' for the file :', &
3663	& TRIM(river_file_name),'(Solution ?)')
3664	ENDIF
3665	!
3666	iret = NF90_PUT_ATT(fid, nlonid, 'long_name', "Longitude")
3667	IF (iret /= NF90_NOERR) THEN
3668	CALL ipslerr_p (3,'routing_diagncfile', 'Could not add attribut to variable '//lon_name//' for the file :', &
3669	& TRIM(river_file_name),'(Solution ?)')
3670	ENDIF
3671	iret = NF90_PUT_ATT(fid, nlatid, 'units', "degrees_north")
3672	IF (iret /= NF90_NOERR) THEN
3673	CALL ipslerr_p (3,'routing_diagncfile', 'Could not add attribut to variable '//lat_name//' for the file :', &
3674	& TRIM(river_file_name),'(Solution ?)')
3675	ENDIF
3676	!
3677	lat_max = 90.
3678	lat_min = -90.
3679	!
3680	iret = NF90_PUT_ATT(fid, nlatid, 'valid_min', lat_min)
3681	IF (iret /= NF90_NOERR) THEN
3682	CALL ipslerr_p (3,'routing_diagncfile', 'Could not add attribut to variable '//lat_name//' for the file :', &
3683	& TRIM(river_file_name),'(Solution ?)')
3684	ENDIF
3685	iret = NF90_PUT_ATT(fid, nlatid, 'valid_max', lat_max)
3686	IF (iret /= NF90_NOERR) THEN
3687	CALL ipslerr_p (3,'routing_diagncfile', 'Could not add attribut to variable '//lat_name//' for the file :', &
3688	& TRIM(river_file_name),'(Solution ?)')
3689	ENDIF
3690	iret = NF90_PUT_ATT(fid, nlatid, 'long_name', "Latitude")
3691	IF (iret /= NF90_NOERR) THEN
3692	CALL ipslerr_p (3,'routing_diagncfile', 'Could not add attribut to variable '//lat_name//' for the file :', &
3693	& TRIM(river_file_name),'(Solution ?)')
3694	ENDIF
3695	!
3696	iret = NF90_ENDDEF(fid)
3697	IF (iret /= NF90_NOERR) THEN
3698	CALL ipslerr_p (3,'routing_diagncfile', 'Could not end definitions in the file : ', &
3699	& TRIM(river_file_name),'(Solution ?)')
3700	ENDIF
3701	!
3702	! 1.4 Write coordinates
3703	!
3704	IF ( INDEX(gridtype, "regular") == 1 ) THEN
3705	!
3706	! 1.4.1 regular grid
3707	!
3708	iret = NF90_PUT_VAR(fid, nlonid, lon_g(1:iim_g,1))
3709	IF (iret /= NF90_NOERR) THEN
3710	CALL ipslerr_p (3,'routing_diagncfile', 'Could not put variable nav_lon in the file : ', &
3711	& TRIM(river_file_name),'(Solution ?)')
3712	ENDIF
3713	!
3714	iret = NF90_PUT_VAR(fid, nlatid, lat_g(1,1:jjm_g))
3715	IF (iret /= NF90_NOERR) THEN
3716	CALL ipslerr_p (3,'routing_diagncfile', 'Could not put variable nav_lat in the file : ', &
3717	& TRIM(river_file_name),'(Solution ?)')
3718	ENDIF
3719	ELSE
3720	!
3721	! 1.4.2 irregular grid
3722	!
3723	iret = NF90_PUT_VAR(fid, nlonid, lon_g)
3724	IF (iret /= NF90_NOERR) THEN
3725	CALL ipslerr_p (3,'routing_diagncfile', 'Could not put variable nav_lon in the file : ', &
3726	& TRIM(river_file_name),'(Solution ?)')
3727	ENDIF
3728	!
3729	iret = NF90_PUT_VAR(fid, nlatid, lat_g)
3730	IF (iret /= NF90_NOERR) THEN
3731	CALL ipslerr_p (3,'routing_diagncfile', 'Could not put variable nav_lat in the file : ', &
3732	& TRIM(river_file_name),'(Solution ?)')
3733	ENDIF
3734	ENDIF
3735	!
3736	! 2.0 Go through all basins and wirte the information into the netCDF file.
3737	!
3738	DO icc = 1, num_largest
3739	!
3740	! 2.1 Compute the fields to be saved in the file
3741	!
3742	ib=sortedrivs(icc)
3743	!
3744	!
3745	IF ( nb_pts(ib) > 2 ) THEN
3746	!
3747	basinfrac(:,:) = zero
3748	basinuparea(:,:) = zero
3749	basincode(:,:) = zero
3750	!
3751	DO ij=1, nb_pts(ib)
3752
3753	ik=lbasin_index(ib,ij)
3754
3755	j = ((index_g(ik)-1)/iim_g) + 1
3756	i = (index_g(ik)-(j-1)*iim_g)
3757
3758	basinfrac(i,j) = basinfrac(i,j) + lbasin_area(ib,ij)/(resolution_g(ik,1)*resolution_g(ik,2))
3759	basinuparea(i,j) = MAX(basinuparea(i,j), lbasin_uparea(ib,ij))
3760	basincode(i,j) = lrivercode(ib,ij)
3761
3762	ENDDO
3763	!
3764	DO i=1,iim_g
3765	DO j=1,jjm_g
3766	IF ( basinfrac(i,j) <= EPSILON(zero) ) THEN
3767	basinfrac(i,j) = undef_sechiba
3768	basinuparea(i,j) = undef_sechiba
3769	basincode(i,j) = undef_int
3770	ELSE
3771	basinfrac(i,j) = MIN(basinfrac(i,j), un)
3772	ENDIF
3773	ENDDO
3774	ENDDO
3775	!
3776	!
3777	! 2.2 Define the variables in the netCDF file
3778	!
3779	iret = NF90_REDEF(fid)
3780	IF (iret /= NF90_NOERR) THEN
3781	CALL ipslerr_p (3,'routing_diagncfile', &
3782	& 'Could not restart definitions in the file : ', &
3783	& TRIM(river_file_name),'(Solution ?)')
3784	ENDIF
3785	!
3786	! Create a name more suitable for a variable in a netCDF file
3787	!
3788	nc_name = TRIM(sorted_names(icc))
3789	! Take out all character which could cause problems
3790	lcc=LEN_TRIM(nc_name)
3791	DO ij=1,lcc
3792	IF ( nc_name(ij:ij) == " " ) nc_name(ij:ij) = "_"
3793	IF ( nc_name(ij:ij) == "(" ) nc_name(ij:ij) = "_"
3794	IF ( nc_name(ij:ij) == ")" ) nc_name(ij:ij) = "_"
3795	ENDDO
3796	! reduce redundant "__"
3797	DO ij=1,lcc
3798	IF ( nc_name(ij:ij+1) == "__" ) nc_name(ij+1:)=nc_name(ij+2:lcc)
3799	ENDDO
3800	lcc=LEN_TRIM(nc_name)
3801	IF ( nc_name(lcc:lcc) == "_" ) nc_name(lcc:lcc) = " "
3802	!
3803	!
3804	! 2.3 Fraction variable
3805	!
3806	IF (check) WRITE(numout,*) "Define Fraction variable and add attributes"
3807	!
3808	var_name = TRIM(nc_name)//"_frac"
3809	!
3810	iret = NF90_DEF_VAR(fid, TRIM(var_name), kind_r_diag, dims, varid)
3811	IF (iret /= NF90_NOERR) THEN
3812	CALL ipslerr_p (3,'routing_diagncfile', 'Variable '//TRIM(var_name)//' can not be defined for the file : ', &
3813	& TRIM(river_file_name),'(Solution ?)')
3814	ENDIF
3815	!
3816	ierr_tot = 0
3817	! Units
3818	iret = NF90_PUT_ATT(fid, varid, 'units', "-")
3819	IF (iret /= NF90_NOERR) THEN
3820	WRITE(numout,*) 'Units', iret
3821	WRITE(numout,*) TRIM(NF90_STRERROR(iret))
3822	ierr_tot = ierr_tot + 1
3823	ENDIF
3824	! Long name
3825	long_name = "Fraction of basin "//TRIM(sorted_names(icc))//" per grid box"
3826	iret = NF90_PUT_ATT(fid, varid, 'long_name', long_name)
3827	IF (iret /= NF90_NOERR) THEN
3828	WRITE(numout,*) 'Long_Name', long_name, iret
3829	WRITE(numout,*) TRIM(NF90_STRERROR(iret))
3830	ierr_tot = ierr_tot + 1
3831	ENDIF
3832	! Missing value
3833	iret = NF90_PUT_ATT(fid, varid, 'missing_value', undef_sechiba)
3834	IF (iret /= NF90_NOERR) THEN
3835	WRITE(numout,*) 'Missing value', undef_sechiba, iret
3836	WRITE(numout,*) TRIM(NF90_STRERROR(iret))
3837	ierr_tot = ierr_tot + 1
3838	ENDIF
3839	!
3840	ib=sortedrivs(icc)
3841	IF ( check ) WRITE(numout,*) "Doing basin ", icc," corrsdponding to index = ", ib, "num_largest : ", num_largest
3842	!
3843	! Nb of grid points in basin
3844	att_str='Nb_of_grid_points_in_basin'
3845	iret = NF90_PUT_ATT(fid, varid, att_str, nb_pts(ib))
3846	IF (iret /= NF90_NOERR) THEN
3847	WRITE(numout,*) 'Nb of grid points in basin', nb_pts(ib), iret
3848	WRITE(numout,*) TRIM(NF90_STRERROR(iret))
3849	ierr_tot = ierr_tot + 1
3850	ENDIF
3851	!
3852	! Longitude of outflow point
3853	att_str='Longitude_of_outflow_point'
3854	iret = NF90_PUT_ATT(fid, varid, att_str, lalo(outpt(ib,1),2))
3855	IF (iret /= NF90_NOERR) THEN
3856	WRITE(numout,*) 'Longitude of outflow point', lalo(outpt(ib,1),2), iret
3857	WRITE(numout,*) TRIM(NF90_STRERROR(iret))
3858	ierr_tot = ierr_tot + 1
3859	ENDIF
3860	!
3861	! Latitide of outflow point
3862	att_str='Latitude_of_outflow_point'
3863	iret = NF90_PUT_ATT(fid, varid, att_str, lalo(outpt(ib,1),1))
3864	IF (iret /= NF90_NOERR) THEN
3865	WRITE(numout,*) 'Latitude of outflow point', lalo(outpt(ib,1),1), iret
3866	WRITE(numout,*) TRIM(NF90_STRERROR(iret))
3867	ierr_tot = ierr_tot + 1
3868	ENDIF
3869	!
3870	! Number of streams
3871	att_str= 'Number_of_streams'
3872	iret = NF90_PUT_ATT(fid, varid, att_str, streams_nb(ib))
3873	IF (iret /= NF90_NOERR) THEN
3874	WRITE(numout,*) 'Number of streams', streams_nb(ib), iret
3875	WRITE(numout,*) TRIM(NF90_STRERROR(iret))
3876	ierr_tot = ierr_tot + 1
3877	ENDIF
3878	!
3879	! Total number of hops to go to the oceans
3880	att_str='Total_number_of_hops_to_ocean'
3881	iret = NF90_PUT_ATT(fid, varid, att_str, streams_avehops(ib)*streams_nb(ib))
3882	IF (iret /= NF90_NOERR) THEN
3883	WRITE(numout,) 'Total number of hops to go to the oceans ', streams_avehops(ib)streams_nb(ib), iret
3884	ierr_tot = ierr_tot + 1
3885	ENDIF
3886	!
3887	! Minimum number of hops to go to the ocean for any stream
3888	att_str='Minimum_number_of_hops_to_ocean_for_any_stream'
3889	iret = NF90_PUT_ATT(fid, varid, att_str, streams_minhops(ib))
3890	IF (iret /= NF90_NOERR) THEN
3891	WRITE(numout,*) 'Minimum number of hops to go tp the ocean for any stream', streams_minhops(ib), iret
3892	ierr_tot = ierr_tot + 1
3893	ENDIF
3894	!
3895	! Average number of hops to go to the ocean for any stream
3896	att_str='Average_number_of_hops_to_ocean_for_any_stream'
3897	iret = NF90_PUT_ATT(fid, varid, att_str, streams_avehops(ib))
3898	IF (iret /= NF90_NOERR) THEN
3899	WRITE(numout,*) 'Average number of hops to go tp the ocean for any stream', streams_avehops(ib), iret
3900	ierr_tot = ierr_tot + 1
3901	ENDIF
3902	!
3903	! Maximum number of hops to go to the ocean for any stream
3904	att_str='Maximum_number_of_hops_to_ocean_for_any_stream'
3905	iret = NF90_PUT_ATT(fid, varid, att_str, streams_maxhops(ib))
3906	IF (iret /= NF90_NOERR) THEN
3907	WRITE(numout,*) 'Maximum number of hops to go tp the ocean for any stream', streams_maxhops(ib), iret
3908	ierr_tot = ierr_tot + 1
3909	ENDIF
3910	!
3911	! Average residence time in the basin
3912	att_str='Average_residence_time_in_basin'
3913	iret = NF90_PUT_ATT(fid, varid, att_str, streams_resid(ib))
3914	IF (iret /= NF90_NOERR) THEN
3915	WRITE(numout,*) 'Average residence time in the basin', streams_resid(ib), iret
3916	ierr_tot = ierr_tot + 1
3917	ENDIF
3918	!
3919	IF (ierr_tot > 0 ) THEN
3920	CALL ipslerr_p (3,'routing_diagncfile', 'Could not add some attributes to variable '//var_name//' for the file :', &
3921	& TRIM(river_file_name),'(Solution ?)')
3922	ENDIF
3923	!
3924	! 2.4 Upstream area variable variable
3925	!
3926	IF (check) WRITE(numout,*) "Define Upstream variable and add attributes"
3927	!
3928	! Create a name more suitable for a variable in a netCDF file
3929	!
3930	var_name = TRIM(nc_name)//"_upstream"
3931	DO ij=1,LEN_TRIM(var_name)
3932	IF ( var_name(ij:ij) == " " ) var_name(ij:ij) = "_"
3933	ENDDO
3934	!
3935	iret = NF90_DEF_VAR(fid, TRIM(var_name), kind_r_diag, dims, varid2)
3936	IF (iret /= NF90_NOERR) THEN
3937	CALL ipslerr_p (3,'routing_diagncfile', 'Variable '//TRIM(var_name)//' can not be defined for the file : ', &
3938	& TRIM(river_file_name),'(Solution ?)')
3939	ENDIF
3940	!
3941	ierr_tot = 0
3942	! Units
3943	iret = NF90_PUT_ATT(fid, varid2, 'units', "m^2")
3944	IF (iret /= NF90_NOERR) ierr_tot = ierr_tot + 1
3945	! Long name
3946	long_name = "Upstream area of basin "//TRIM(sorted_names(icc))//" in the grid box"
3947	iret = NF90_PUT_ATT(fid, varid2, 'long_name', long_name)
3948	IF (iret /= NF90_NOERR) ierr_tot = ierr_tot + 1
3949	! Missing value
3950	iret = NF90_PUT_ATT(fid, varid2, 'missing_value', undef_sechiba)
3951	IF (iret /= NF90_NOERR) ierr_tot = ierr_tot + 1
3952	!
3953	IF (ierr_tot > 0 ) THEN
3954	CALL ipslerr_p (3,'routing_diagncfile', 'Could not add some attributes to variable '//var_name//' for the file :', &
3955	& TRIM(river_file_name),'(Solution ?)')
3956	ENDIF
3957	!
3958	! 2.5 Pfafstetter codes for basins
3959	!
3960	IF (check) WRITE(numout,*) "Define Pfafstetter codes variable and add attributes"
3961	!
3962	var_name = TRIM(nc_name)//"_coding"
3963	DO ij=1,LEN_TRIM(var_name)
3964	IF ( var_name(ij:ij) == " " ) var_name(ij:ij) = "_"
3965	ENDDO
3966	!
3967	iret = NF90_DEF_VAR(fid, TRIM(var_name), kind_i_diag, dims, varid3)
3968	IF (iret /= NF90_NOERR) THEN
3969	CALL ipslerr_p (3,'routing_diagncfile', 'Variable '//TRIM(var_name)//' can not be defined for the file : ', &
3970	& TRIM(river_file_name),'(Solution ?)')
3971	ENDIF
3972	!
3973	ierr_tot = 0
3974	! Units
3975	iret = NF90_PUT_ATT(fid, varid3, 'units', "-")
3976	IF (iret /= NF90_NOERR) ierr_tot = ierr_tot + 1
3977	! Long name
3978	long_name = "Pfafstetter codes of grid boxes in basin "//TRIM(sorted_names(icc))
3979	iret = NF90_PUT_ATT(fid, varid3, 'long_name', long_name)
3980	IF (iret /= NF90_NOERR) ierr_tot = ierr_tot + 1
3981	! Missing value
3982	iret = NF90_PUT_ATT(fid, varid3, 'missing_value', undef_int)
3983	IF (iret /= NF90_NOERR) ierr_tot = ierr_tot + 1
3984	!
3985	IF (ierr_tot > 0 ) THEN
3986	CALL ipslerr_p (3,'routing_diagncfile', 'Could not add some attributes to variable '//var_name//' for the file :', &
3987	& TRIM(river_file_name),'(Solution ?)')
3988	ENDIF
3989	!
3990	! 2.6 ENDDEF of netCDF file
3991	!
3992	IF (check) WRITE(numout,*) "END define"
3993	!
3994	iret = NF90_ENDDEF(fid)
3995	IF (iret /= NF90_NOERR) THEN
3996	CALL ipslerr_p (3,'routing_diagncfile', &
3997	& 'Could not end definitions in the file : ', &
3998	& TRIM(river_file_name),'(Solution ?)')
3999	ENDIF
4000	!
4001	! 2.7 Write the data to the file
4002	!
4003	IF (check) WRITE(numout,*) "Put basinfrac"
4004	iret = NF90_PUT_VAR(fid, varid, basinfrac)
4005	IF (iret /= NF90_NOERR) THEN
4006	CALL ipslerr_p (3,'routing_diagncfile', 'Could not put variable basinfrac in the file : ', &
4007	& TRIM(river_file_name),'(Solution ?)')
4008	ENDIF
4009
4010	IF (check) WRITE(numout,*) "Put basinuparea"
4011	iret = NF90_PUT_VAR(fid, varid2, basinuparea)
4012	IF (iret /= NF90_NOERR) THEN
4013	CALL ipslerr_p (3,'routing_diagncfile', 'Could not put variable basinuparea in the file : ', &
4014	& TRIM(river_file_name),'(Solution ?)')
4015	ENDIF
4016
4017	IF (check) WRITE(numout,*) "Put basincode"
4018	iret = NF90_PUT_VAR(fid, varid3, basincode)
4019	IF (iret /= NF90_NOERR) THEN
4020	CALL ipslerr_p (3,'routing_diagfile', 'Could not put variable basincode in the file : ', &
4021	& TRIM(river_file_name),'(Solution ?)')
4022	ENDIF
4023	!
4024	ENDIF
4025	!
4026	ENDDO
4027	!
4028	IF (check) WRITE(numout,*) "Close file"
4029	!
4030	! Close netCDF file and do some memory management.
4031	!
4032	iret = NF90_CLOSE(fid)
4033	IF (iret /= NF90_NOERR) THEN
4034	CALL ipslerr_p (3,'routing_diagncfile', &
4035	& 'Could not end definitions in the file : ', &
4036	& TRIM(river_file_name),'(Solution ?)')
4037	ENDIF
4038	!
4039	!
4040	END SUBROUTINE routing_diagncfile
4041	!
4042	!! ================================================================================================================================
4043	!! SUBROUTINE : routing_basins_p
4044	!!
4045	!>\BRIEF This parallelized subroutine computes the routing map if needed.
4046	!!
4047	!! DESCRIPTION (definitions, functional, design, flags) : None
4048	!!
4049	!! RECENT CHANGE(S): None
4050	!!
4051	!! MAIN OUTPUT VARIABLE(S):
4052	!!
4053	!! REFERENCES : None
4054	!!
4055	!! FLOWCHART : None
4056	!! \n
4057	!_ ================================================================================================================================
4058
4059	SUBROUTINE routing_basins_p(nbpt, lalo, neighbours, resolution, contfrac)
4060	!
4061	IMPLICIT NONE
4062	!
4063	!! INPUT VARIABLES
4064	INTEGER(i_std), INTENT(in) :: nbpt !! Domain size (unitless)
4065	REAL(r_std), INTENT(in) :: lalo(nbpt,2) !! Vector of latitude and longitudes (beware of the order !)
4066	INTEGER(i_std), INTENT(in) :: neighbours(nbpt,NbNeighb) !! Vector of neighbours for each grid point (1=North and then clockwise) (unitless)
4067	REAL(r_std), INTENT(in) :: resolution(nbpt,2) !! The size of each grid box in X and Y (m)
4068	REAL(r_std), INTENT(in) :: contfrac(nbpt) !! Fraction of land in each grid box (unitless;0-1)
4069
4070	!_ ================================================================================================================================
4071
4072	! INTEGER(i_std) :: neighbours_tmp(nbpt,8)
4073	! INTEGER(i_std) :: i,j
4074
4075	! DO i=1,nbp_loc
4076	! DO j=1,NbNeighb
4077	! IF (neighbours(i,j)==-1) THEN
4078	! neighbours_tmp(i,j)=neighbours(i,j)
4079	! ELSE
4080	! neighbours_tmp(i,j)=neighbours(i,j)+nbp_para_begin(mpi_rank)-1
4081	! ENDIF
4082	! ENDDO
4083	! ENDDO
4084
4085	routing_area => routing_area_glo
4086	topo_resid => topo_resid_glo
4087	route_togrid => route_togrid_glo
4088	route_tobasin => route_tobasin_glo
4089	route_nbintobas => route_nbintobas_glo
4090	global_basinid => global_basinid_glo
4091
4092	IF (is_root_prc) CALL routing_basins(nbp_glo,lalo_g, neighbours_g, resolution_g, contfrac_g)
4093
4094	routing_area => routing_area_loc
4095	topo_resid => topo_resid_loc
4096	route_togrid => route_togrid_loc
4097	route_tobasin => route_tobasin_loc
4098	route_nbintobas => route_nbintobas_loc
4099	global_basinid => global_basinid_loc
4100
4101	CALL scatter(routing_area_glo,routing_area_loc)
4102	CALL scatter(topo_resid_glo,topo_resid_loc)
4103	CALL scatter(route_togrid_glo,route_togrid_loc)
4104	CALL scatter(route_tobasin_glo,route_tobasin_loc)
4105	CALL scatter(route_nbintobas_glo,route_nbintobas_loc)
4106	CALL scatter(global_basinid_glo,global_basinid_loc)
4107
4108	END SUBROUTINE routing_basins_p
4109	!
4110
4111	!! ================================================================================================================================
4112	!! SUBROUTINE : routing_basins
4113	!!
4114	!>\BRIEF This non-parallelized subroutine reads in the map of basins and flow direction to construct
4115	!! the catchments of each grid box.
4116	!!
4117	!! DESCRIPTION (definitions, functional, design, flags) :
4118	!! The work is done in a number of steps which are performed locally on the
4119	!! GCM grid:
4120	!! 1) First we find the grid-points of the high resolution routing grid which are
4121	!! within the coarser grid of the GCM.
4122	!! 2) When we have these grid points we decompose them into basins in the routine
4123	!! routing_findbasins. A number of simplifications are done if needed.
4124	!! 3) In the routine routing_globalize we put the basin information of this grid
4125	!! into the global fields.
4126	!! Then we work on the global grid to perform the following tasks :
4127	!! 1) We link up the basins of the various grid points and check the global consistency.
4128	!! 2) The area of each outflow point is computed.
4129	!! 3) The final step is to reduce the number of basins in order to fit into the truncation.\n
4130	!!
4131	!! RECENT CHANGE(S): None
4132	!!
4133	!! MAIN OUTPUT VARIABLE(S): None, as the routine puts information into the global variables of the module.
4134	!!
4135	!! REFERENCES : None
4136	!!
4137	!! FLOWCHART : None
4138	!! \n
4139	!_ ================================================================================================================================
4140
4141	SUBROUTINE routing_basins(nbpt, lalo, neighbours, resolution, contfrac)
4142	!
4143	IMPLICIT NONE
4144	!
4145	!! INPUT VARIABLES
4146	INTEGER(i_std), INTENT(in) :: nbpt !! Domain size (unitless)
4147	REAL(r_std), INTENT(in) :: lalo(nbpt,2) !! Vector of latitude and longitudes (beware of the order !)
4148	INTEGER(i_std), INTENT(in) :: neighbours(nbpt,NbNeighb)!! Vector of neighbours for each grid point
4149	!! (1=North and then cloxkwise)
4150	REAL(r_std), INTENT(in) :: resolution(nbpt,2) !! The size of each grid box in X and Y (m)
4151	REAL(r_std), INTENT(in) :: contfrac(nbpt) !! Fraction of land in each grid box (unitless;0-1)
4152	!
4153	!! LOCAL VARIABLES
4154	CHARACTER(LEN=80) :: filename !! Name of the netcdf file (unitless)
4155	INTEGER(i_std) :: iml, jml, lml, tml, fid, ib, ip, jp, fopt !! Indices (unitless)
4156	REAL(r_std) :: lev(1), date, dt, coslat
4157	INTEGER(i_std) :: itau(1) !!
4158	REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: trip !! The trip field (unitless)
4159	REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: basins !! The basin field (unitless)
4160	REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: topoindex !! Topographic index of the residence time (m)
4161	REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: hierarchy !!
4162	REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: lat_rel !!
4163	REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: lon_rel !!
4164	!
4165	INTEGER(i_std) :: nbi, nbj !! Number of point in x and y within the grid (unitless)
4166	REAL(r_std) :: min_topoind !! The current minimum of topographic index (m)
4167	REAL(r_std) :: max_basins !!
4168	REAL(r_std) :: invented_basins !!
4169	!
4170	REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: area_bx !! Area of each small box in the grid box (m^2)
4171	REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: hierarchy_bx !! Level in the basin of the point
4172	REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: lon_bx !!
4173	REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: lat_bx !!
4174	REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: topoind_bx !! Topographic index of the residence time for each of the smaller boxes (m)
4175	INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:) :: trip_bx !! The trip field for each of the smaller boxes (unitless)
4176	INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:) :: basin_bx !!
4177	INTEGER(i_std), ALLOCATABLE, DIMENSION(:) :: coast_pts !! The coastal flow points (unitless)
4178	!
4179	INTEGER(i_std), ALLOCATABLE, DIMENSION(:) :: basin_count !!
4180	INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:) :: basin_id !!
4181	REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: basin_area !!
4182	REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: basin_hierarchy !!
4183	REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: basin_topoind !! Topographic index of the residence time for a basin (m)
4184	REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: fetch_basin !!
4185	INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:) :: basin_flowdir !! Water flow directions in the basin (unitless)
4186	INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:) :: outflow_grid !! Type of outflow on the grid box (unitless)
4187	INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:) :: outflow_basin !!
4188	INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:) :: inflow_number !!
4189	INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:,:) :: inflow_basin !!
4190	INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:,:) :: inflow_grid !!
4191	INTEGER(i_std), ALLOCATABLE, DIMENSION(:) :: nbcoastal !!
4192	INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:) :: coastal_basin !!
4193	!
4194	! Interpolation help variables
4195	!
4196	INTEGER(i_std) :: nix, njx !!
4197	CHARACTER(LEN=30) :: callsign !!
4198	REAL(r_std), ALLOCATABLE, DIMENSION(:,:,:) :: resol_lu !! Resolution
4199	INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:) :: mask !! Mask to exclude some points (unitless)
4200	REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: sub_area !! Area on the fine grid (m^2)
4201	INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:,:) :: sub_index !! Indices of the points we need on the fine grid (unitless)
4202	INTEGER(i_std), ALLOCATABLE, DIMENSION(:) :: sub_pts !! Number of high resolution points on this grid (unitless)
4203	INTEGER :: ALLOC_ERR !!
4204	LOGICAL :: ok_interpol = .FALSE. !! Flag for interpolation (true/false)
4205	!
4206	INTEGER(i_std) :: nb_basin !! Number of sub-basins (unitless)
4207	INTEGER(i_std) :: nwbas !!
4208	INTEGER(i_std), ALLOCATABLE, DIMENSION(:) :: basin_inbxid !!
4209	INTEGER(i_std), ALLOCATABLE, DIMENSION(:) :: basin_sz !!
4210	INTEGER(i_std), ALLOCATABLE, DIMENSION(:) :: basin_bxout !!
4211	INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:,:) :: basin_pts !!
4212	CHARACTER(LEN=7) :: fmt !!
4213	LOGICAL :: debug = .FALSE. !! (true/false)
4214	!
4215	INTEGER(i_std), DIMENSION(2) :: diagbox = (/ 1, 2 /) !!
4216
4217	!_ ================================================================================================================================
4218	!
4219	!
4220	IF ( .NOT. is_root_prc) THEN
4221	WRITE(numout,*) "is_root_prc = ", is_root_prc
4222	CALL ipslerr_p (3,'routing_basins', &
4223	& 'routing_basins is not suitable for running in parallel', &
4224	& 'We are here on a non root processor. ','(STOP from routing_basins)')
4225	ENDIF
4226	!
4227	! Test on diagbox and nbpt
4228	!
4229	IF (debug) THEN
4230	IF (ANY(diagbox .GT. nbpt)) THEN
4231	WRITE(numout,*) "Debug diganostics : nbpt, diagbox", nbpt, diagbox
4232	call ipslerr_p(3,'routing_basin', &
4233	& 'Problem with diagbox in debug mode.', &
4234	& 'diagbox values can''t be greater than land points number.', &
4235	& '(decrease diagbox wrong value)')
4236	ENDIF
4237	ENDIF
4238	!
4239	!
4240	! Needs to be a configurable variable
4241	!
4242	!
4243	!Config Key = ROUTING_FILE
4244	!Config Desc = Name of file which contains the routing information
4245	!Config If = RIVER_ROUTING
4246	!Config Def = routing.nc
4247	!Config Help = The file provided here should alow the routing module to
4248	!Config read the high resolution grid of basins and the flow direction
4249	!Config from one mesh to the other.
4250	!Config Units = [FILE]
4251	!
4252	filename = 'routing.nc'
4253	CALL getin('ROUTING_FILE',filename)
4254	!
4255	CALL flininfo(filename,iml, jml, lml, tml, fid)
4256	CALL flinclo(fid)
4257	!
4258	! soils_param.nc file is 1Â° soit texture file.
4259	!
4260	ALLOCATE(lat_rel(iml,jml), STAT=ALLOC_ERR)
4261	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for lat_rel','','')
4262
4263	ALLOCATE(lon_rel(iml,jml), STAT=ALLOC_ERR)
4264	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for lon_rel','','')
4265
4266	ALLOCATE (trip(iml,jml), STAT=ALLOC_ERR)
4267	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for trip','','')
4268
4269	ALLOCATE (basins(iml,jml), STAT=ALLOC_ERR)
4270	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for basins','','')
4271
4272	ALLOCATE (topoindex(iml,jml), STAT=ALLOC_ERR)
4273	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for topoindex','','')
4274
4275	ALLOCATE (hierarchy(iml,jml), STAT=ALLOC_ERR)
4276	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for hierarchy','','')
4277
4278	!
4279	CALL flinopen(filename, .FALSE., iml, jml, lml, lon_rel, lat_rel, lev, tml, itau, date, dt, fid)
4280	!!
4281	!! From the basin description data we will read the following variables :
4282	!!
4283	!! Trip : Provides the flow direction following the convention :
4284	!! trip = 1 : flow = N
4285	!! trip = 2 : flow = NE
4286	!! trip = 3 : flow = E
4287	!! trip = 4 : flow = SE
4288	!! trip = 5 : flow = S
4289	!! trip = 6 : flow = SW
4290	!! trip = 7 : flow = W
4291	!! trip = 8 : flow = NW
4292	!! trip = 97 : return flow into the ground
4293	!! trip = 98 : coastal flow (diffuse flow into the oceans)
4294	!! trip = 99 : river flow into the oceans
4295	!!
4296	!! Basins : Provides a uniqe ID for each basin. These IDs are also used to get
4297	!! the name of the basin from the table in routine routing_names.
4298	!!
4299	!! Topoind : is the topographic index for the retention time of the water in the
4300	!! grid box. It has been computed with the following formula : 1000 x sqrt(d^3/Dz)
4301	!! where d is the distance of the river from the current grid box to the next one
4302	!! as indicated by the variable trip.
4303	!! Dz the hight difference between between the two grid boxes.
4304	!! All these variables are in meters.
4305	!! Furthermore we have to limit the height difference to 5m in order to avoid any unpleasant
4306	!! surprises. If dz < 5m then dz=5.
4307	!!
4308	!
4309	CALL flinget(fid, 'trip', iml, jml, lml, tml, 1, 1, trip)
4310	!
4311	CALL flinget(fid, 'basins', iml, jml, lml, tml, 1, 1, basins)
4312	!
4313	CALL flinget(fid, 'topoind', iml, jml, lml, tml, 1, 1, topoindex)
4314	!
4315	CALL flinclo(fid)
4316	!
4317	min_topoind = MINVAL(topoindex, MASK=topoindex .LT. undef_sechiba-un)
4318	!
4319	DO ip=1,iml
4320	DO jp=1,jml
4321	IF ( trip(ip,jp) < 1.e10 .AND. topoindex(ip,jp) > 1.e10) THEN
4322	WRITE(numout,*) 'trip exists but not topoind :'
4323	WRITE(numout,*) 'ip, jp :', ip, jp
4324	WRITE(numout,*) 'trip, topoind : ', trip(ip,jp), topoindex(ip,jp)
4325	CALL ipslerr_p(3,'routing_basins','trip exists but not topoind','','')
4326	ENDIF
4327	ENDDO
4328	ENDDO
4329
4330	ALLOCATE(resol_lu(iml,jml,2), STAT=ALLOC_ERR)
4331	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for resol_lu','','')
4332
4333	ALLOCATE(mask(iml,jml), STAT=ALLOC_ERR)
4334	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for mask','','')
4335	!
4336	! Consider all points a priori
4337	!
4338	mask(:,:) = 0
4339	!
4340	DO ip=1,iml
4341	DO jp=1,jml
4342	!
4343	! Determine the land mask of the basin map read from the file ROUTING_FILE
4344	!
4345	IF ( trip(ip,jp) < 1.e10 ) THEN
4346	mask(ip,jp) = 1
4347	ENDIF
4348	!
4349	! Resolution in longitude
4350	!
4351	coslat = MAX( COS( lat_rel(ip,jp) * pi/180. ), mincos )
4352	IF ( ip .EQ. 1 ) THEN
4353	resol_lu(ip,jp,1) = ABS( lon_rel(ip+1,jp) - lon_rel(ip,jp) ) * pi/180. * R_Earth * coslat
4354	ELSEIF ( ip .EQ. iml ) THEN
4355	resol_lu(ip,jp,1) = ABS( lon_rel(ip,jp) - lon_rel(ip-1,jp) ) * pi/180. * R_Earth * coslat
4356	ELSE
4357	resol_lu(ip,jp,1) = ABS( lon_rel(ip+1,jp) - lon_rel(ip-1,jp) )/2. * pi/180. * R_Earth * coslat
4358	ENDIF
4359	!
4360	! Resolution in latitude
4361	!
4362	IF ( jp .EQ. 1 ) THEN
4363	resol_lu(ip,jp,2) = ABS( lat_rel(ip,jp) - lat_rel(ip,jp+1) ) * pi/180. * R_Earth
4364	ELSEIF ( jp .EQ. jml ) THEN
4365	resol_lu(ip,jp,2) = ABS( lat_rel(ip,jp-1) - lat_rel(ip,jp) ) * pi/180. * R_Earth
4366	ELSE
4367	resol_lu(ip,jp,2) = ABS( lat_rel(ip,jp-1) - lat_rel(ip,jp+1) )/2. * pi/180. * R_Earth
4368	ENDIF
4369	!
4370	ENDDO
4371	ENDDO
4372	!
4373	! The maximum number of points of the source map (basin description here) which can fit into
4374	! any grid point of the ORCHIDEE grid is stimated here.
4375	! Some margin is taken.
4376	!
4377	callsign = "routing_basins"
4378	ok_interpol = .FALSE.
4379	!
4380	nix=INT(MAXVAL(resolution_g(:,1))/MAXVAL(resol_lu(:,:,1)))+2
4381	njx=INT(MAXVAL(resolution_g(:,2))/MAXVAL(resol_lu(:,:,2)))+2
4382	nbvmax = nixnjx2
4383	!
4384	! We are on the root processor here as this routine is not in parallel. So no need to broadcast.
4385	!
4386	WRITE(numout,*) "Projection arrays for ",callsign," : "
4387	WRITE(numout,*) "Routing : nbvmax = ", nbvmax
4388
4389
4390	ALLOCATE (sub_area(nbpt,nbvmax), STAT=ALLOC_ERR)
4391	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for sub_area','','')
4392	sub_area(:,:)=zero
4393
4394	ALLOCATE (sub_index(nbpt,nbvmax,2), STAT=ALLOC_ERR)
4395	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for sub_index','','')
4396	sub_index(:,:,:)=0
4397
4398	ALLOCATE (sub_pts(nbpt), STAT=ALLOC_ERR)
4399	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for sub_pts','','')
4400	sub_pts(:)=0
4401	!
4402	! routine aggregate will for each point of the ORCHIDEE grid determine which points
4403	! of the source grid (basin definitions here) fit in there and which fraction of
4404	! of the ORCHIDEE grid it represents.
4405	!
4406	CALL aggregate(nbpt, lalo, neighbours, resolution, contfrac, &
4407	& iml, jml, lon_rel, lat_rel, mask, callsign, &
4408	& nbvmax, sub_index, sub_area, ok_interpol)
4409	!
4410	WHERE (sub_area < 0) sub_area=zero
4411	!
4412	! Some verifications
4413	!
4414	DO ib=1,nbpt
4415	sub_pts(ib) = COUNT(sub_area(ib,:) > zero)
4416	DO fopt=1,sub_pts(ib)
4417	IF (sub_area(ib, fopt) == 0 ) THEN
4418	WRITE(numout,*) "Zero Area - Sub_area > 0 : ", ib, fopt
4419	WRITE(numout,*) "Zero Area - lon : ",lalo(ib,2)
4420	WRITE(numout,*) "Zero Area - lon_rel : ", lon_rel(sub_index(ib, fopt, 1),sub_index(ib, fopt, 2))
4421	WRITE(numout,*) "Zero Area - lat : ",lalo(ib,1)
4422	WRITE(numout,*) "Zero Area - lat_rel : ", lat_rel(sub_index(ib, fopt, 1),sub_index(ib, fopt, 2))
4423	ENDIF
4424	ENDDO
4425	ENDDO
4426	!
4427	! Do some memory management.
4428	!
4429	nwbas = MAX(MAXVAL(sub_pts), NbNeighb+1)
4430	!
4431	ALLOCATE (area_bx(nbvmax,nbvmax), stat=ALLOC_ERR)
4432	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for area_bx','','')
4433	ALLOCATE (hierarchy_bx(nbvmax,nbvmax), stat=ALLOC_ERR)
4434	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for hierarchy_bx','','')
4435	ALLOCATE (lon_bx(nbvmax,nbvmax), stat=ALLOC_ERR)
4436	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for lon_bx','','')
4437	ALLOCATE (lat_bx(nbvmax,nbvmax), stat=ALLOC_ERR)
4438	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for lat_bx','','')
4439	ALLOCATE (topoind_bx(nbvmax,nbvmax), stat=ALLOC_ERR)
4440	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for topoind_bx','','')
4441	ALLOCATE (trip_bx(nbvmax,nbvmax), stat=ALLOC_ERR)
4442	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for trip_bx','','')
4443	ALLOCATE (basin_bx(nbvmax,nbvmax), stat=ALLOC_ERR)
4444	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for basin_bx','','')
4445	ALLOCATE (coast_pts(nbvmax), stat=ALLOC_ERR)
4446	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for coast_pts','','')
4447	ALLOCATE (basin_inbxid(nbvmax), stat=ALLOC_ERR)
4448	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for basin_inbxid','','')
4449	ALLOCATE (basin_sz(nbvmax), stat=ALLOC_ERR)
4450	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for basin_sz','','')
4451	ALLOCATE (basin_pts(nbvmax,nbvmax,2), stat=ALLOC_ERR)
4452	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for basin_pts','','')
4453	ALLOCATE (basin_bxout(nbvmax), stat=ALLOC_ERR)
4454	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for basin_bxout','','')
4455	ALLOCATE (basin_count(nbpt), stat=ALLOC_ERR)
4456	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for basin_count','','')
4457	ALLOCATE (basin_area(nbpt,nwbas), basin_hierarchy(nbpt,nwbas), basin_topoind(nbpt,nwbas), stat=ALLOC_ERR)
4458	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for basin_area','','')
4459	ALLOCATE (fetch_basin(nbpt,nwbas), stat=ALLOC_ERR)
4460	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for fetch_basin','','')
4461	ALLOCATE (basin_id(nbpt,nwbas), basin_flowdir(nbpt,nwbas), stat=ALLOC_ERR)
4462	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for basin_id','','')
4463	ALLOCATE (outflow_grid(nbpt,nwbas),outflow_basin(nbpt,nwbas), stat=ALLOC_ERR)
4464	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for outflow_grid','','')
4465	ALLOCATE (inflow_number(nbpt,nwbas), stat=ALLOC_ERR)
4466	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for inflow_number','','')
4467	ALLOCATE (inflow_basin(nbpt,nwbas,nbvmax), inflow_grid(nbpt,nwbas,nbvmax), stat=ALLOC_ERR)
4468	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for inflow_basin','','')
4469	ALLOCATE (nbcoastal(nbpt), coastal_basin(nbpt,nwbas), stat=ALLOC_ERR)
4470	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for nbcoastal','','')
4471
4472	! Order all sub points in each grid_box and find the sub basins
4473	!
4474	! before we start we set the maps to empty
4475	!
4476	basin_id(:,:) = undef_int
4477	basin_count(:) = 0
4478	hierarchy(:,:) = undef_sechiba
4479	max_basins = MAXVAL(basins, MASK=basins .LT. 1.e10)
4480	invented_basins = max_basins
4481	nbcoastal(:) = 0
4482	!
4483	!! Finds,in each grid box, the distance to the outflow point ... this defines the order in which
4484	!! the water will go through the sub-basins and grid boxes.
4485	!
4486	CALL routing_hierarchy(iml, jml, trip, topoindex, hierarchy)
4487	!
4488	!
4489	DO ib =1, nbpt
4490	!
4491	!
4492	! extract the information for this grid box
4493	!
4494	!! Extracts from the global high resolution fields the data for the current grid box.
4495	!
4496	CALL routing_getgrid(nbpt, iml, jml, ib, sub_pts, sub_index, sub_area, max_basins, min_topoind, &
4497	& lon_rel, lat_rel, lalo, resolution, contfrac, trip, basins, topoindex, hierarchy, &
4498	& nbi, nbj, area_bx, trip_bx, basin_bx, topoind_bx, hierarchy_bx, lon_bx, lat_bx)
4499	!
4500	!! Finds the basins: returns the list of all points which are within the same basin of the grid box.
4501	!
4502	CALL routing_findbasins(nbi, nbj, trip_bx, basin_bx, hierarchy_bx, topoind_bx,&
4503	& nb_basin, basin_inbxid, basin_sz, basin_bxout, basin_pts, coast_pts)
4504	!
4505	! Deal with the case where nb_basin=0 for this grid box. In this case all goes into coastal flow.
4506	!
4507	IF ( debug .AND. (COUNT(diagbox .EQ. ib) .GT. 0) ) THEN
4508	WRITE(numout,*) '===================== IB = :', ib
4509	WRITE(numout,*) "sub_pts(ib) :", sub_pts(ib), "sub_area(ib,:) :",sub_area(ib,1:2)
4510	WRITE(numout,*) 'LON LAT of GCM :', lalo(ib,2), lalo(ib,1)
4511	WRITE(numout,*) 'Neighbor options :', neighbours(ib,1:NbNeighb)
4512	WRITE(numout,*) 'Resolution :', resolution(ib,1:2)
4513	WRITE(fmt,"('(',I3,'I6)')") nbi
4514	WRITE(numout,*) '-------------> trip ', trip_bx(1,1)
4515	DO jp=1,nbj
4516	WRITE(numout,fmt) trip_bx(1:nbi,jp)
4517	ENDDO
4518	WRITE(numout,*) '-------------> basin ',basin_bx(1,1)
4519	DO jp=1,nbj
4520	WRITE(numout,fmt) basin_bx(1:nbi,jp)
4521	ENDDO
4522	WRITE(numout,*) '-------------> hierarchy ',hierarchy_bx(1,1)
4523	DO jp=1,nbj
4524	WRITE(numout,fmt) INT(hierarchy_bx(1:nbi,jp)/1000.)
4525	ENDDO
4526	WRITE(numout,*) '-------------> topoindex ',topoind_bx(1,1)
4527	DO jp=1,nbj
4528	WRITE(numout,fmt) INT(topoind_bx(1:nbi,jp)/1000.)
4529	ENDDO
4530	!
4531	WRITE(numout,*) '------------> The basins we retain'
4532	DO jp=1,nb_basin
4533	WRITE(numout,*) 'index, size, bxout, coast :', basin_inbxid(jp), basin_sz(jp),&
4534	& basin_bxout(jp), coast_pts(jp)
4535	ENDDO
4536	!
4537	ENDIF
4538	!
4539	!! Puts the basins found for the current grid box in the context of the global map.
4540	!
4541	CALL routing_globalize(nbpt, ib, neighbours, area_bx, trip_bx, hierarchy_bx, topoind_bx, min_topoind,&
4542	& nb_basin, basin_inbxid, basin_sz, basin_pts, basin_bxout, coast_pts, nwbas, basin_count,&
4543	& basin_area, basin_hierarchy, basin_topoind, basin_id, basin_flowdir, outflow_grid,&
4544	& nbcoastal, coastal_basin)
4545	!
4546	!
4547	IF ( debug .AND. (COUNT(diagbox .EQ. ib) .GT. 0) ) THEN
4548	WRITE(numout,*) 'GLOBAL information after routing_globalize for grid ', ib
4549	DO jp=1,basin_count(ib)
4550	WRITE(numout,*) 'Basin ID : ', basin_id(ib, jp)
4551	WRITE(numout,*) 'Basin flowdir :', basin_flowdir(ib, jp)
4552	WRITE(numout,*) 'Basin hierarchy :', basin_hierarchy(ib, jp)
4553	WRITE(numout,*) 'Basin topoindex :', basin_topoind(ib, jp)
4554	WRITE(numout,*) 'Basin outflow grid :', outflow_grid(ib,jp)
4555	ENDDO
4556	ENDIF
4557	!
4558	ENDDO
4559	!
4560	!! Makes the connections between the bains and ensures global coherence.
4561	!
4562	CALL routing_linkup(nbpt, contfrac, neighbours, nwbas, basin_count, basin_area, basin_id, basin_flowdir, &
4563	& basin_hierarchy, outflow_grid, outflow_basin, inflow_number, inflow_grid, inflow_basin, &
4564	& nbcoastal, coastal_basin, invented_basins)
4565	!
4566	!
4567	WRITE(numout,*) 'The maximum number of basins in any grid :', MAXVAL(basin_count)
4568	!
4569	IF ( debug ) THEN
4570	DO ib=1,SIZE(diagbox)
4571	IF ( diagbox(ib) .GT. 0 ) THEN
4572	WRITE(numout,*) 'After routing_linkup information for grid ', diagbox(ib)
4573	DO jp=1,basin_count(diagbox(ib))
4574	WRITE(numout,*) 'Basin ID : ', basin_id(diagbox(ib), jp)
4575	WRITE(numout,*) 'Basin outflow_grid :', outflow_grid(diagbox(ib), jp)
4576	WRITE(numout,*) 'Basin outflow_basin:', outflow_basin(diagbox(ib), jp)
4577	WRITE(numout,*) 'Basin hierarchy :', basin_hierarchy(diagbox(ib), jp)
4578	ENDDO
4579	ENDIF
4580	ENDDO
4581	ENDIF
4582	!
4583	!! Computes the fetch of each basin, upstream area in known.
4584	!
4585	CALL routing_fetch(nbpt, resolution, contfrac, nwbas, basin_count, basin_area, basin_id, outflow_grid, &
4586	& outflow_basin, fetch_basin)
4587	!
4588	!
4589	WRITE(numout,*) "Start reducing the number of basins per grid to meet the required truncation."
4590	!
4591	!! Reduces the number of basins per grid to the value chosen by the user.
4592	!
4593	CALL routing_truncate(nbpt, resolution, contfrac, nwbas, basin_count, basin_area, basin_topoind,&
4594	& fetch_basin, basin_id, basin_flowdir, outflow_grid, outflow_basin, inflow_number,&
4595	& inflow_grid, inflow_basin)
4596	!
4597	DEALLOCATE (lat_rel)
4598	DEALLOCATE (lon_rel)
4599	!
4600	DEALLOCATE (trip)
4601	DEALLOCATE (basins)
4602	DEALLOCATE (topoindex)
4603	DEALLOCATE (hierarchy)
4604	!
4605	DEALLOCATE (sub_area)
4606	DEALLOCATE (sub_index)
4607	DEALLOCATE (sub_pts)
4608	!
4609	DEALLOCATE (mask)
4610	DEALLOCATE (resol_lu)
4611	!
4612	DEALLOCATE (basin_count)
4613	DEALLOCATE (basin_area, basin_hierarchy, basin_topoind, fetch_basin)
4614	DEALLOCATE (basin_id, basin_flowdir)
4615	DEALLOCATE (outflow_grid,outflow_basin)
4616	DEALLOCATE (inflow_number)
4617	DEALLOCATE (inflow_basin, inflow_grid)
4618	DEALLOCATE (nbcoastal, coastal_basin)
4619
4620	END SUBROUTINE routing_basins
4621
4622
4623	!! ================================================================================================================================
4624	!! SUBROUTINE : routing_getgrid
4625	!!
4626	!>\BRIEF This subroutine extracts from the global high resolution fields
4627	!! the data for the current grid box we are dealing with.
4628	!!
4629	!! DESCRIPTION (definitions, functional, design, flags) :
4630	!! Convention for trip on the input :
4631	!! The trip field follows the following convention for the flow of the water :
4632	!! trip = 1 : flow = N
4633	!! trip = 2 : flow = NE
4634	!! trip = 3 : flow = E
4635	!! trip = 4 : flow = SE
4636	!! trip = 5 : flow = S
4637	!! trip = 6 : flow = SW
4638	!! trip = 7 : flow = W
4639	!! trip = 8 : flow = NW
4640	!! trip = 97 : return flow into the ground
4641	!! trip = 98 : coastal flow (diffuse flow into the oceans) These values are created here
4642	!! trip = 99 : river flow into the oceans
4643	!!
4644	!! On output, the grid boxes of the basin map which flow out of the GCM grid are identified
4645	!! by numbers larger than 100 :
4646	!! trip = 101 : flow = N out of the coarse grid
4647	!! trip = 102 : flow = NE out of the coarse grid
4648	!! trip = 103 : flow = E out of the coarse grid
4649	!! trip = 104 : flow = SE out of the coarse grid
4650	!! trip = 105 : flow = S out of the coarse grid
4651	!! trip = 106 : flow = SW out of the coarse grid
4652	!! trip = 107 : flow = W out of the coarse grid
4653	!! trip = 108 : flow = NW out of the coarse grid
4654	!! Inside the grid the convention remains the same as above (ie between 1 and 99).:\n
4655	!!
4656	!! RECENT CHANGE(S): None
4657	!!
4658	!! MAIN OUTPUT VARIABLE(S):
4659	!!
4660	!! REFERENCES : None
4661	!!
4662	!! FLOWCHART : None
4663	!! \n
4664	!_ ================================================================================================================================
4665
4666	SUBROUTINE routing_getgrid(nbpt, iml, jml, ib, sub_pts, sub_index, sub_area, max_basins, min_topoind, &
4667	& lon_rel, lat_rel, lalo, resolution, contfrac, trip, basins, topoindex, hierarchy, &
4668	& nbi, nbj, area_bx, trip_bx, basin_bx, topoind_bx, hierarchy_bx, lon_bx, lat_bx)
4669	!
4670	IMPLICIT NONE
4671	!
4672	!! INPUT VARIABLES
4673	INTEGER(i_std), INTENT(in) :: nbpt !! Domain size (unitless)
4674	INTEGER(i_std), INTENT(in) :: iml !! X resolution of the high resolution grid
4675	INTEGER(i_std), INTENT(in) :: jml !! Y resolution of the high resolution grid
4676	INTEGER(i_std), INTENT(in) :: ib !! Current basin (unitless)
4677	INTEGER(i_std), INTENT(in) :: sub_pts(nbpt) !! Number of high resolution points on this grid (unitless)
4678	INTEGER(i_std), INTENT(in) :: sub_index(nbpt,nbvmax,2) !! Indices of the points we need on the fine grid (unitless)
4679	REAL(r_std), INTENT(inout) :: max_basins !! The current maximum of basins
4680	REAL(r_std), INTENT(in) :: min_topoind !! The current minimum of topographic index (m)
4681	REAL(r_std), INTENT(in) :: sub_area(nbpt,nbvmax) !! Area on the fine grid (m^2)
4682	REAL(r_std), INTENT(in) :: lon_rel(iml,jml) !!
4683	REAL(r_std), INTENT(in) :: lat_rel(iml,jml) !! coordinates of the fine grid
4684	REAL(r_std), INTENT(in) :: lalo(nbpt,2) !! Vector of latitude and longitudes (beware of the order !)
4685	REAL(r_std), INTENT(in) :: resolution(nbpt,2) !! The size of each grid box in X and Y (m)
4686	REAL(r_std), INTENT(in) :: contfrac(nbpt) !! Fraction of land in each grid box (unitless;0-1)
4687	REAL(r_std), INTENT(inout) :: trip(iml,jml) !! The trip field (unitless)
4688	REAL(r_std), INTENT(inout) :: basins(iml,jml) !! data on the fine grid
4689	REAL(r_std), INTENT(inout) :: topoindex(iml,jml) !! Topographic index of the residence time (m)
4690	REAL(r_std), INTENT(inout) :: hierarchy(iml, jml) !! data on the fine grid
4691	!
4692	!! OUTPUT VARIABLES
4693	INTEGER(i_std), INTENT(out) :: nbi, nbj !! Number of point in x and y within the grid (unitless)
4694	REAL(r_std), INTENT(out) :: area_bx(nbvmax,nbvmax) !! Area of each small box in the grid box (m^2)
4695	REAL(r_std), INTENT(out) :: hierarchy_bx(nbvmax,nbvmax) !! Level in the basin of the point
4696	REAL(r_std), INTENT(out) :: lon_bx(nbvmax,nbvmax) !!
4697	REAL(r_std), INTENT(out) :: lat_bx(nbvmax,nbvmax) !!
4698	REAL(r_std), INTENT(out) :: topoind_bx(nbvmax,nbvmax) !! Topographic index of the residence time for each of the smaller boxes (m)
4699	INTEGER(i_std), INTENT(out) :: trip_bx(nbvmax,nbvmax) !! The trip field for each of the smaller boxes (unitless)
4700	INTEGER(i_std), INTENT(out) :: basin_bx(nbvmax,nbvmax) !!
4701	!
4702	!! LOCAL VARIABLES
4703	INTEGER(i_std) :: ip, jp, ll(1), iloc, jloc !! Indices (unitless)
4704	REAL(r_std) :: lonstr(nbvmax*nbvmax) !!
4705	REAL(r_std) :: latstr(nbvmax*nbvmax) !!
4706
4707	!_ ================================================================================================================================
4708
4709	!
4710	! Set everything to undef to locate easily empty points
4711	!
4712	trip_bx(:,:) = undef_int
4713	basin_bx(:,:) = undef_int
4714	topoind_bx(:,:) = undef_sechiba
4715	area_bx(:,:) = undef_sechiba
4716	hierarchy_bx(:,:) = undef_sechiba
4717	!
4718	IF ( sub_pts(ib) > 0 ) THEN
4719	!
4720	DO ip=1,sub_pts(ib)
4721	lonstr(ip) = lon_rel(sub_index(ib, ip, 1), sub_index(ib, ip, 2))
4722	latstr(ip) = lat_rel(sub_index(ib, ip, 1), sub_index(ib, ip, 2))
4723	ENDDO
4724	!
4725	! Get the size of the area and order the coordinates to go from North to South and West to East
4726	!
4727	CALL routing_sortcoord(sub_pts(ib), lonstr, 'WE', nbi)
4728	CALL routing_sortcoord(sub_pts(ib), latstr, 'NS', nbj)
4729	!
4730	! Transfer the data in such a way that (1,1) is the North Western corner and
4731	! (nbi, nbj) the South Eastern.
4732	!
4733	DO ip=1,sub_pts(ib)
4734	ll = MINLOC(ABS(lonstr(1:nbi) - lon_rel(sub_index(ib, ip, 1), sub_index(ib, ip, 2))))
4735	iloc = ll(1)
4736	ll = MINLOC(ABS(latstr(1:nbj) - lat_rel(sub_index(ib, ip, 1), sub_index(ib, ip, 2))))
4737	jloc = ll(1)
4738	trip_bx(iloc, jloc) = NINT(trip(sub_index(ib, ip, 1), sub_index(ib, ip, 2)))
4739	basin_bx(iloc, jloc) = NINT(basins(sub_index(ib, ip, 1), sub_index(ib, ip, 2)))
4740	area_bx(iloc, jloc) = sub_area(ib, ip)
4741	topoind_bx(iloc, jloc) = topoindex(sub_index(ib, ip, 1), sub_index(ib, ip, 2))
4742	hierarchy_bx(iloc, jloc) = hierarchy(sub_index(ib, ip, 1), sub_index(ib, ip, 2))
4743	lon_bx(iloc, jloc) = lon_rel(sub_index(ib, ip, 1), sub_index(ib, ip, 2))
4744	lat_bx(iloc, jloc) = lat_rel(sub_index(ib, ip, 1), sub_index(ib, ip, 2))
4745	ENDDO
4746	ELSE
4747	!
4748	! This is the case where the model invented a continental point
4749	!
4750	nbi = 1
4751	nbj = 1
4752	iloc = 1
4753	jloc = 1
4754	trip_bx(iloc, jloc) = 98
4755	basin_bx(iloc, jloc) = NINT(max_basins + 1)
4756	max_basins = max_basins + 1
4757	area_bx(iloc, jloc) = resolution(ib,1)resolution(ib,2)contfrac(ib)
4758	topoind_bx(iloc, jloc) = min_topoind
4759	hierarchy_bx(iloc, jloc) = min_topoind
4760	lon_bx(iloc, jloc) = lalo(ib,2)
4761	lat_bx(iloc, jloc) = lalo(ib,1)
4762	!
4763	ENDIF
4764	!
4765	! Tag in trip all the outflow conditions. The table is thus :
4766	! trip = 100+n : Outflow into another grid box
4767	! trip = 99 : River outflow into the ocean
4768	! trip = 98 : This will be coastal flow (not organized as a basin)
4769	! trip = 97 : return flow into the soil (local)
4770	!
4771	DO jp=1,nbj
4772	IF ( trip_bx(1,jp) .EQ. 8 .OR. trip_bx(1,jp) .EQ. 7 .OR. trip_bx(1,jp) .EQ. 6) THEN
4773	trip_bx(1,jp) = trip_bx(1,jp) + 100
4774	ENDIF
4775	IF ( trip_bx(nbi,jp) .EQ. 2 .OR. trip_bx(nbi,jp) .EQ. 3 .OR. trip_bx(nbi,jp) .EQ. 4) THEN
4776	trip_bx(nbi,jp) = trip_bx(nbi,jp) + 100
4777	ENDIF
4778	ENDDO
4779	DO ip=1,nbi
4780	IF ( trip_bx(ip,1) .EQ. 8 .OR. trip_bx(ip,1) .EQ. 1 .OR. trip_bx(ip,1) .EQ. 2) THEN
4781	trip_bx(ip,1) = trip_bx(ip,1) + 100
4782	ENDIF
4783	IF ( trip_bx(ip,nbj) .EQ. 6 .OR. trip_bx(ip,nbj) .EQ. 5 .OR. trip_bx(ip,nbj) .EQ. 4) THEN
4784	trip_bx(ip,nbj) = trip_bx(ip,nbj) + 100
4785	ENDIF
4786	ENDDO
4787	!
4788	!
4789	! We simplify the outflow. We only need the direction normal to the
4790	! box boundary and the 4 corners.
4791	!
4792	! Northern border
4793	IF ( trip_bx(1,1) .EQ. 102 ) trip_bx(1,1) = 101
4794	IF ( trip_bx(nbi,1) .EQ. 108 ) trip_bx(nbi,1) = 101
4795	DO ip=2,nbi-1
4796	IF ( trip_bx(ip,1) .EQ. 108 .OR. trip_bx(ip,1) .EQ. 102 ) trip_bx(ip,1) = 101
4797	ENDDO
4798	! Southern border
4799	IF ( trip_bx(1,nbj) .EQ. 104 ) trip_bx(1,nbj) = 105
4800	IF ( trip_bx(nbi,nbj) .EQ. 106 ) trip_bx(nbi,nbj) = 105
4801	DO ip=2,nbi-1
4802	IF ( trip_bx(ip,nbj) .EQ. 104 .OR. trip_bx(ip,nbj) .EQ. 106 ) trip_bx(ip,nbj) = 105
4803	ENDDO
4804	! Eastern border
4805	IF ( trip_bx(nbi,1) .EQ. 104) trip_bx(nbi,1) = 103
4806	IF ( trip_bx(nbi,nbj) .EQ. 102) trip_bx(nbi,nbj) = 103
4807	DO jp=2,nbj-1
4808	IF ( trip_bx(nbi,jp) .EQ. 104 .OR. trip_bx(nbi,jp) .EQ. 102 ) trip_bx(nbi,jp) = 103
4809	ENDDO
4810	! Western border
4811	IF ( trip_bx(1,1) .EQ. 106) trip_bx(1,1) = 107
4812	IF ( trip_bx(1,nbj) .EQ. 108) trip_bx(1,nbj) = 107
4813	DO jp=2,nbj-1
4814	IF ( trip_bx(1,jp) .EQ. 106 .OR. trip_bx(1,jp) .EQ. 108 ) trip_bx(1,jp) = 107
4815	ENDDO
4816	!
4817	!
4818	END SUBROUTINE routing_getgrid
4819	!
4820	!! ================================================================================================================================
4821	!! SUBROUTINE : routing_sortcoord
4822	!!
4823	!>\BRIEF This subroutines orders the coordinates to go from North to South and West to East.
4824	!!
4825	!! DESCRIPTION (definitions, functional, design, flags) : None
4826	!!
4827	!! RECENT CHANGE(S): None
4828	!!
4829	!! MAIN OUTPUT VARIABLE(S):
4830	!!
4831	!! REFERENCES : None
4832	!!
4833	!! FLOWCHART : None
4834	!! \n
4835	!_ ================================================================================================================================
4836
4837	SUBROUTINE routing_sortcoord(nb_in, coords, direction, nb_out)
4838	!
4839	IMPLICIT NONE
4840	!
4841	!! INPUT VARIABLES
4842	INTEGER(i_std), INTENT(in) :: nb_in !!
4843	REAL(r_std), INTENT(inout) :: coords(nb_in) !!
4844	!
4845	!! OUTPUT VARIABLES
4846	INTEGER(i_std), INTENT(out) :: nb_out !!
4847	!
4848	!! LOCAL VARIABLES
4849	CHARACTER(LEN=2) :: direction !!
4850	INTEGER(i_std) :: ipos !!
4851	REAL(r_std) :: coords_tmp(nb_in) !!
4852	INTEGER(i_std), DIMENSION(1) :: ll !!
4853	INTEGER(i_std) :: ind(nb_in) !!
4854
4855	!_ ================================================================================================================================
4856	!
4857	ipos = 1
4858	nb_out = nb_in
4859	!
4860	! Compress the coordinates array
4861	!
4862	DO WHILE ( ipos < nb_in )
4863	IF ( coords(ipos+1) /= undef_sechiba) THEN
4864	IF ( COUNT(coords(ipos:nb_out) == coords(ipos)) > 1 ) THEN
4865	coords(ipos:nb_out-1) = coords(ipos+1:nb_out)
4866	coords(nb_out:nb_in) = undef_sechiba
4867	nb_out = nb_out - 1
4868	ELSE
4869	ipos = ipos + 1
4870	ENDIF
4871	ELSE
4872	EXIT
4873	ENDIF
4874	ENDDO
4875	!
4876	! Sort it now
4877	!
4878	! First we get ready and adjust for the periodicity in longitude
4879	!
4880	coords_tmp(:) = undef_sechiba
4881	IF ( INDEX(direction, 'WE') == 1 .OR. INDEX(direction, 'EW') == 1) THEN
4882	IF ( MAXVAL(ABS(coords(1:nb_out))) .GT. 160 ) THEN
4883	coords_tmp(1:nb_out) = MOD(coords(1:nb_out) + 360.0, 360.0)
4884	ELSE
4885	coords_tmp(1:nb_out) = coords(1:nb_out)
4886	ENDIF
4887	ELSE IF ( INDEX(direction, 'NS') == 1 .OR. INDEX(direction, 'SN') == 1) THEN
4888	coords_tmp(1:nb_out) = coords(1:nb_out)
4889	ELSE
4890	WRITE(numout,*) 'The chosen direction (', direction,') is not recognized'
4891	CALL ipslerr_p(3,'routing_sortcoord','The chosen direction is not recognized','First section','')
4892	ENDIF
4893	!
4894	! Get it sorted out now
4895	!
4896	ipos = 1
4897	!
4898	IF ( INDEX(direction, 'WE') == 1 .OR. INDEX(direction, 'SN') == 1) THEN
4899	DO WHILE (COUNT(ABS(coords_tmp(:)-undef_sechiba) > EPSILON(undef_sechiba)*10.) >= 1)
4900	ll = MINLOC(coords_tmp(:), coords_tmp /= undef_sechiba)
4901	ind(ipos) = ll(1)
4902	coords_tmp(ll(1)) = undef_sechiba
4903	ipos = ipos + 1
4904	ENDDO
4905	ELSE IF ( INDEX(direction, 'EW') == 1 .OR. INDEX(direction, 'NS') == 1) THEN
4906	DO WHILE (COUNT(ABS(coords_tmp(:)-undef_sechiba) > EPSILON(undef_sechiba)*10.) >= 1)
4907	ll = MAXLOC(coords_tmp(:), coords_tmp /= undef_sechiba)
4908	ind(ipos) = ll(1)
4909	coords_tmp(ll(1)) = undef_sechiba
4910	ipos = ipos + 1
4911	ENDDO
4912	ELSE
4913	WRITE(numout,*) 'The chosen direction (', direction,') is not recognized (second)'
4914	CALL ipslerr_p(3,'routing_sortcoord','The chosen direction is not recognized','Second section','')
4915	ENDIF
4916	!
4917	coords(1:nb_out) = coords(ind(1:nb_out))
4918	IF (nb_out < nb_in) THEN
4919	coords(nb_out+1:nb_in) = zero
4920	ENDIF
4921	!
4922	END SUBROUTINE routing_sortcoord
4923	!
4924
4925	!! ================================================================================================================================
4926	!! SUBROUTINE : routing_findbasins
4927	!!
4928	!>\BRIEF This subroutine finds the basins and does some clean up.
4929	!! The aim is to return the list off all points which are within the
4930	!! same basin of the grid box.
4931	!!
4932	!! DESCRIPTION (definitions, functional, design, flags) :
4933	!! We will also collect all points which directly flow into the ocean in one basin
4934	!! Make sure that we do not have a basin with two outflows and other exceptions.
4935	!! At this stage no effort is made to come down to the truncation of the model.
4936	!!
4937	!! Convention for trip \n
4938	!! ------------------- \n
4939	!! Inside of the box : \n
4940	!! trip = 1 : flow = N \n
4941	!! trip = 2 : flow = NE \n
4942	!! trip = 3 : flow = E \n
4943	!! trip = 4 : flow = SE \n
4944	!! trip = 5 : flow = S \n
4945	!! trip = 6 : flow = SW \n
4946	!! trip = 7 : flow = W \n
4947	!! trip = 8 : flow = NW \n
4948	!! trip = 97 : return flow into the ground \n
4949	!! trip = 98 : coastal flow (diffuse flow into the oceans) These values are created here \n
4950	!! trip = 99 : river flow into the oceans \n
4951	!!
4952	!! Out flow from the grid : \n
4953	!! trip = 101 : flow = N out of the coarse grid \n
4954	!! trip = 102 : flow = NE out of the coarse grid \n
4955	!! trip = 103 : flow = E out of the coarse grid \n
4956	!! trip = 104 : flow = SE out of the coarse grid \n
4957	!! trip = 105 : flow = S out of the coarse grid \n
4958	!! trip = 106 : flow = SW out of the coarse grid \n
4959	!! trip = 107 : flow = W out of the coarse grid \n
4960	!! trip = 108 : flow = NW out of the coarse grid! \n
4961	!! RECENT CHANGE(S): None
4962	!!
4963	!! MAIN OUTPUT VARIABLE(S):
4964	!!
4965	!! REFERENCES : None
4966	!!
4967	!! FLOWCHART : None
4968	!! \n
4969	!_ ================================================================================================================================
4970
4971	SUBROUTINE routing_findbasins(nbi, nbj, trip, basin, hierarchy, topoind, nb_basin, basin_inbxid, basin_sz,&
4972	& basin_bxout, basin_pts, coast_pts)
4973	!
4974	IMPLICIT NONE
4975	!
4976	!! INPUT VARIABLES
4977	INTEGER(i_std), INTENT(in) :: nbi !! Number of point in x within the grid (unitless)
4978	INTEGER(i_std), INTENT(in) :: nbj !! Number of point in y within the grid (unitless)
4979	REAL(r_std), INTENT(in) :: hierarchy(:,:) !!
4980	REAL(r_std), INTENT(in) :: topoind(:,:) !! Topographic index of the residence time (m)
4981	!
4982	! Modified
4983	INTEGER(i_std), INTENT(inout) :: trip(:,:) !! The trip field (unitless)
4984	INTEGER(i_std), INTENT(inout) :: basin(:,:) !!
4985	!
4986	!! OUTPUT VARIABLES
4987	INTEGER(i_std), INTENT(out) :: nb_basin !! Number of sub-basins (unitless)
4988	INTEGER(i_std), INTENT(out) :: basin_inbxid(nbvmax) !!
4989	INTEGER(i_std), INTENT(out) :: basin_sz(nbvmax) !!
4990	INTEGER(i_std), INTENT(out) :: basin_bxout(nbvmax) !!
4991	INTEGER(i_std), INTENT(out) :: basin_pts(nbvmax, nbvmax, 2) !!
4992	INTEGER(i_std), INTENT(out) :: coast_pts(nbvmax) !! The coastal flow points (unitless)
4993	!
4994	!! LOCAL VARIABLES
4995	INTEGER(i_std) :: ibas, ilf, nbb, nb_in !!
4996	INTEGER(i_std) :: bname(nbvmax) !!
4997	INTEGER(i_std) :: sz(nbvmax) !!
4998	INTEGER(i_std) :: pts(nbvmax,nbvmax,2) !!
4999	INTEGER(i_std) :: nbout(nbvmax) !!
5000	INTEGER(i_std) :: new_nb !!
5001	INTEGER(i_std) :: new_bname(nbvmax) !!
5002	INTEGER(i_std) :: new_sz(nbvmax) !!
5003	INTEGER(i_std) :: new_pts(nbvmax,nbvmax,2) !!
5004	INTEGER(i_std) :: itrans !!
5005	INTEGER(i_std) :: trans(nbvmax) !!
5006	INTEGER(i_std) :: outdir(nbvmax) !!
5007	INTEGER(i_std) :: tmpsz(nbvmax) !!
5008	INTEGER(i_std) :: ip, jp, jpp(1), ipb !!
5009	INTEGER(i_std) :: sortind(nbvmax) !!
5010	CHARACTER(LEN=7) :: fmt !!
5011
5012	!_ ================================================================================================================================
5013	!
5014	nbb = 0
5015	ibas = -1
5016	bname(:) = undef_int
5017	sz(:) = 0
5018	nbout(:) = 0
5019	new_pts(:,:,:) = 0
5020	!
5021	! 1.0 Find all basins within this grid box
5022	! Sort the variables per basin so that we can more easily
5023	! access data from the same basin (The variables are :
5024	! bname, sz, pts, nbout)
5025	!
5026	DO ip=1,nbi
5027	DO jp=1,nbj
5028	IF ( basin(ip,jp) .LT. undef_int) THEN
5029	IF ( COUNT(basin(ip,jp) .EQ. bname(:)) .EQ. 0 ) THEN
5030	nbb = nbb + 1
5031	IF ( nbb .GT. nbvmax ) CALL ipslerr_p(3,'routing_findbasins','nbvmax too small','first section','')
5032	bname(nbb) = basin(ip,jp)
5033	sz(nbb) = 0
5034	ENDIF
5035	!
5036	DO ilf=1,nbb
5037	IF ( basin(ip,jp) .EQ. bname(ilf) ) THEN
5038	ibas = ilf
5039	ENDIF
5040	ENDDO
5041	!
5042	sz(ibas) = sz(ibas) + 1
5043	IF ( sz(ibas) .GT. nbvmax ) CALL ipslerr_p(3,'routing_findbasins','nbvmax too small','second section','')
5044	pts(ibas, sz(ibas), 1) = ip
5045	pts(ibas, sz(ibas), 2) = jp
5046	! We deal only with outflow and leave flow back into the grid box for later.
5047	IF ( trip(ip,jp) .GE. 97 ) THEN
5048	nbout(ibas) = nbout(ibas) + 1
5049	ENDIF
5050	!
5051	ENDIF
5052	!
5053	ENDDO
5054	ENDDO
5055	!
5056	! 2.0 All basins which have size 1 and flow to the ocean are put together.
5057	!
5058	itrans = 0
5059	coast_pts(:) = undef_int
5060	! Get all the points we can collect
5061	DO ip=1,nbb
5062	IF ( sz(ip) .EQ. 1 .AND. trip(pts(ip,1,1),pts(ip,1,2)) .EQ. 99) THEN
5063	itrans = itrans + 1
5064	trans(itrans) = ip
5065	trip(pts(ip,1,1),pts(ip,1,2)) = 98
5066	ENDIF
5067	ENDDO
5068	! put everything in the first basin
5069	IF ( itrans .GT. 1) THEN
5070	ipb = trans(1)
5071	coast_pts(sz(ipb)) = bname(ipb)
5072	bname(ipb) = -1
5073	DO ip=2,itrans
5074	sz(ipb) = sz(ipb) + 1
5075	coast_pts(sz(ipb)) = bname(trans(ip))
5076	sz(trans(ip)) = 0
5077	pts(ipb, sz(ipb), 1) = pts(trans(ip), 1, 1)
5078	pts(ipb, sz(ipb), 2) = pts(trans(ip), 1, 2)
5079	ENDDO
5080	ENDIF
5081	!
5082	! 3.0 Make sure that we have only one outflow point in each basin
5083	!
5084	! nbb is the number of basins on this grid box.
5085	new_nb = 0
5086	DO ip=1,nbb
5087	! We only do this for grid-points which have more than one outflow
5088	IF ( sz(ip) .GT. 1 .AND. nbout(ip) .GT. 1) THEN
5089	!
5090	! Pick up all points needed and store them in trans
5091	!
5092	itrans = 0
5093	DO jp=1,sz(ip)
5094	IF ( trip(pts(ip,jp,1),pts(ip,jp,2)) .GE. 97) THEN
5095	itrans = itrans + 1
5096	trans(itrans) = trip(pts(ip,jp,1),pts(ip,jp,2))
5097	ENDIF
5098	ENDDO
5099	!
5100	! First issue : We have more than one point of the basin which flows into
5101	! the ocean. In this case we put everything into coastal flow. It will go into
5102	! a separate basin in the routing_globalize routine.
5103	!
5104	IF ( (COUNT(trans(1:itrans) .EQ. 99) + COUNT(trans(1:itrans) .EQ. 98)) .GT. 1) THEN
5105	DO jp=1,sz(ip)
5106	IF ( trip(pts(ip,jp,1),pts(ip,jp,2)) .EQ. 99 ) THEN
5107	trip(pts(ip,jp,1),pts(ip,jp,2)) = 98
5108	trans(itrans) = trip(pts(ip,jp,1),pts(ip,jp,2))
5109	ENDIF
5110	ENDDO
5111	ENDIF
5112	!
5113	! Second issue : We have redundant outflows at the boundaries. That is two small grid
5114	! boxes flowing into the same GCM grid box.
5115	!
5116	IF ( COUNT(trans(1:itrans) .GT. 100) .GE. 1) THEN
5117	CALL routing_simplify(nbi, nbj, trip, basin, hierarchy, bname(ip))
5118	itrans = 0
5119	DO jp=1,sz(ip)
5120	IF ( trip(pts(ip,jp,1),pts(ip,jp,2)) .GE. 9) THEN
5121	itrans = itrans + 1
5122	trans(itrans) = trip(pts(ip,jp,1),pts(ip,jp,2))
5123	ENDIF
5124	ENDDO
5125	ENDIF
5126	!
5127	! Third issue : we have more than one outflow from the boxes. This could be
5128	! - flow into 2 or more neighboring GCM grids
5129	! - flow into a neighboring GCM grids and into the ocean or be a return flow (=97. =98, =99)
5130	! - flow into a neighboring GCM grids or ocean and back into the same GCM grid box
5131	! The only solution is to cut the basin up in as many parts.
5132	!
5133	IF ( COUNT(trans(1:itrans) .GE. 97) .GT. 1) THEN
5134	!
5135	nb_in = new_nb
5136	CALL routing_cutbasin(nbi, nbj, nbb, trip, basin, bname(ip), new_nb, new_bname, new_sz, new_pts)
5137	!
5138	! If we have split the basin then we need to cancel the old one
5139	!
5140	IF ( nb_in .NE. new_nb) THEN
5141	sz(ip) = 0
5142	ENDIF
5143	!
5144	ENDIF
5145	!
5146	ENDIF
5147	ENDDO
5148	!
5149	! Add the new basins to the end of the list
5150	!
5151	If ( nbb+new_nb .LE. nbvmax) THEN
5152	DO ip=1,new_nb
5153	bname(nbb+ip) = new_bname(ip)
5154	sz(nbb+ip) = new_sz(ip)
5155	pts(nbb+ip,:,:) = new_pts(ip,:,:)
5156	ENDDO
5157	nbb = nbb+new_nb
5158	ELSE
5159	WRITE(numout,*) 'Increase nbvmax. It is too small to contain all the basins (routing_findbasins)'
5160	CALL ipslerr_p(3,'routing_findbasins','Increase nbvmax.','It is too small to contain all the basins','')
5161	ENDIF
5162	!
5163	! Keep the output direction
5164	!
5165	DO ip=1,nbb
5166	IF ( sz(ip) .GT. 0 ) THEN
5167	trans(:) = 0
5168	DO jp=1,sz(ip)
5169	trans(jp) = trip(pts(ip,jp,1),pts(ip,jp,2))
5170	ENDDO
5171	outdir(ip) = MAXVAL(trans(1:sz(ip)))
5172	IF ( outdir(ip) .GE. 97 ) THEN
5173	outdir(ip) = outdir(ip) - 100
5174	ELSE
5175	WRITE(numout,*) 'Why are we here and can not find a trip larger than 96'
5176	WRITE(numout,*) 'Does this mean that the basin does not have any outflow ', ip, bname(ip)
5177	WRITE(fmt,"('(',I3,'I9)')") nbi
5178	WRITE(numout,*) '-----------------------> trip'
5179	DO jp=1,nbj
5180	WRITE(numout,fmt) trip(1:nbi,jp)
5181	ENDDO
5182	WRITE(numout,*) '-----------------------> basin'
5183	DO jp=1,nbj
5184	WRITE(numout,fmt) basin(1:nbi,jp)
5185	ENDDO
5186	CALL ipslerr_p(3,'routing_findbasins','Probleme finding trip','','')
5187	ENDIF
5188	ENDIF
5189	ENDDO
5190	!
5191	!
5192	! Sort the output by size of the various basins.
5193	!
5194	nb_basin = COUNT(sz(1:nbb) .GT. 0)
5195	tmpsz(:) = -1
5196	tmpsz(1:nbb) = sz(1:nbb)
5197	DO ip=1,nbb
5198	jpp = MAXLOC(tmpsz(:))
5199	IF ( sz(jpp(1)) .GT. 0) THEN
5200	sortind(ip) = jpp(1)
5201	tmpsz(jpp(1)) = -1
5202	ENDIF
5203	ENDDO
5204	basin_inbxid(1:nb_basin) = bname(sortind(1:nb_basin))
5205	basin_sz(1:nb_basin) = sz(sortind(1:nb_basin))
5206	basin_pts(1:nb_basin,:,:) = pts(sortind(1:nb_basin),:,:)
5207	basin_bxout(1:nb_basin) = outdir(sortind(1:nb_basin))
5208	!
5209	! We can only check if we have at least as many outflows as basins
5210	!
5211	ip = COUNT(trip(1:nbi,1:nbj) .GE. 97 .AND. trip(1:nbi,1:nbj) .LT. undef_int)
5212	!! ip = ip + COUNT(trip(1:nbi,1:nbj) .EQ. 97)
5213	!! IF ( COUNT(trip(1:nbi,1:nbj) .EQ. 98) .GT. 0) ip = ip + 1
5214	IF ( ip .LT. nb_basin ) THEN
5215	WRITE(numout,*) 'We have less outflow points than basins :', ip
5216	WRITE(fmt,"('(',I3,'I9)')") nbi
5217	WRITE(numout,*) '-----------------------> trip'
5218	DO jp=1,nbj
5219	WRITE(numout,fmt) trip(1:nbi,jp)
5220	ENDDO
5221	WRITE(numout,*) '-----------------------> basin'
5222	DO jp=1,nbj
5223	WRITE(numout,fmt) basin(1:nbi,jp)
5224	ENDDO
5225	WRITE(numout,*) 'nb_basin :', nb_basin
5226	WRITE(numout,*) 'Basin sized :', basin_sz(1:nb_basin)
5227	CALL ipslerr_p(3,'routing_findbasins','Probleme less outflow points than basins','','')
5228	ENDIF
5229
5230	END SUBROUTINE routing_findbasins
5231	!
5232	!! ================================================================================================================================
5233	!! SUBROUTINE : routing_simplify
5234	!!
5235	!>\BRIEF This subroutine symplifies the routing out of each basin by taking
5236	!! out redundancies at the borders of the GCM box.
5237	!! The aim is to have only one outflow point per basin and grid box.
5238	!! But here we will not change the direction of the outflow.
5239	!!
5240	!! DESCRIPTION (definitions, functional, design, flags) : None
5241	!!
5242	!! RECENT CHANGE(S): None
5243	!!
5244	!! MAIN OUTPUT VARIABLE(S):
5245	!!
5246	!! REFERENCES : None
5247	!!
5248	!! FLOWCHART : None
5249	!! \n
5250	!_ ================================================================================================================================
5251
5252	SUBROUTINE routing_simplify(nbi, nbj, trip, basin, hierarchy, basin_inbxid)
5253	!
5254	IMPLICIT NONE
5255	!
5256	!! LOCAL VARIABLES
5257	INTEGER(i_std) :: nbi !! Number of point in x within the grid (unitless)
5258	INTEGER(i_std) :: nbj !! Number of point in y within the grid (unitless)
5259	INTEGER(i_std) :: trip(:,:) !! The trip field (unitless)
5260	INTEGER(i_std) :: basin(:,:) !!
5261	REAL(r_std) :: hierarchy(:,:) !!
5262	INTEGER(i_std) :: basin_inbxid !!
5263	!
5264	INTEGER(i_std) :: ip, jp, nbout, basin_sz, iborder !!
5265	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)
5266	INTEGER(i_std), DIMENSION(nbvmax,nbvmax,2) :: trip_flow !!
5267	INTEGER(i_std), DIMENSION(nbvmax,2) :: outflow !!
5268	INTEGER(i_std), DIMENSION(nbvmax) :: outsz !!
5269	CHARACTER(LEN=7) :: fmt !!
5270	!
5271	INTEGER(i_std), DIMENSION(8,2) :: inc !!
5272	INTEGER(i_std) :: itodo, ill(1), icc, ismall, ibas, iip, jjp, ib, id !! Indices (unitless)
5273	INTEGER(i_std), DIMENSION(nbvmax) :: todopt !!
5274	!!$, todosz
5275	REAL(r_std), DIMENSION(nbvmax) :: todohi !!
5276	LOGICAL :: not_found, debug = .FALSE. !! (true/false)
5277
5278	!_ ================================================================================================================================
5279	!
5280	!
5281	! The routing code (i=1, j=2)
5282	!
5283	inc(1,1) = 0
5284	inc(1,2) = -1
5285	inc(2,1) = 1
5286	inc(2,2) = -1
5287	inc(3,1) = 1
5288	inc(3,2) = 0
5289	inc(4,1) = 1
5290	inc(4,2) = 1
5291	inc(5,1) = 0
5292	inc(5,2) = 1
5293	inc(6,1) = -1
5294	inc(6,2) = 1
5295	inc(7,1) = -1
5296	inc(7,2) = 0
5297	inc(8,1) = -1
5298	inc(8,2) = -1
5299	!
5300	!
5301	! Symplify the outflow conditions first. We are only interested in the
5302	! outflows which go to different GCM grid boxes.
5303	!
5304	IF ( debug ) THEN
5305	WRITE(numout,*) '+++++++++++++++++++ BEFORE ANYTHING ++++++++++++++++++++'
5306	WRITE(fmt,"('(',I3,'I6)')") nbi
5307	DO jp=1,nbj
5308	WRITE(numout,fmt) trip_tmp(1:nbi,jp)
5309	ENDDO
5310	ENDIF
5311	!
5312	! transfer the trips into an array which only contains the basin we are interested in
5313	!
5314	trip_tmp(:,:) = -1
5315	basin_sz = 0
5316	DO ip=1,nbi
5317	DO jp=1,nbj
5318	IF ( basin(ip,jp) .EQ. basin_inbxid) THEN
5319	trip_tmp(ip,jp) = trip(ip,jp)
5320	basin_sz = basin_sz + 1
5321	ENDIF
5322	ENDDO
5323	ENDDO
5324	!
5325	! Determine for each point where it flows to
5326	!
5327	CALL routing_findrout(nbi, nbj, trip_tmp, basin_sz, basin_inbxid, nbout, outflow, trip_flow, outsz)
5328	!
5329	!
5330	!
5331	!
5332	! Over the width of a GCM grid box we can have many outflows but we are interested
5333	! in only one for each basin. Thus we wish to collect them all to form only one outflow
5334	! to the neighboring grid box.
5335	!
5336	DO iborder = 101,107,2
5337	!
5338	! If we have more than one of these outflows then we need to merge the sub-basins
5339	!
5340	icc = COUNT(trip_tmp .EQ. iborder)-1
5341	DO WHILE ( icc .GT. 0)
5342	! Pick out all the points we will have to do
5343	itodo = 0
5344	DO ip=1,nbout
5345	IF (trip_tmp(outflow(ip,1),outflow(ip,2)) .EQ. iborder) THEN
5346	itodo = itodo + 1
5347	todopt(itodo) = ip
5348	!!$ todosz(itodo) = outsz(ip)
5349	! We take the hierarchy of the outflow point as we will try to
5350	! minimize if for the outflow of the entire basin.
5351	todohi(itodo) = hierarchy(outflow(ip,1),outflow(ip,2))
5352	ENDIF
5353	ENDDO
5354	!
5355	! We change the direction of the smallest basin.
5356	!
5357	ill=MAXLOC(todohi(1:itodo))
5358	ismall = todopt(ill(1))
5359	!
5360	DO ip=1,nbi
5361	DO jp=1,nbj
5362	IF ( trip_flow(ip,jp,1) .EQ. outflow(ismall,1) .AND.&
5363	& trip_flow(ip,jp,2) .EQ. outflow(ismall,2) ) THEN
5364	! Now that we have found a point of the smallest sub-basin we
5365	! look around for another sub-basin
5366	ib = 1
5367	not_found = .TRUE.
5368	DO WHILE ( not_found .AND. ib .LE. itodo )
5369	IF ( ib .NE. ill(1) ) THEN
5370	ibas = todopt(ib)
5371	DO id=1,8
5372	iip = ip + inc(id,1)
5373	jjp = jp + inc(id,2)
5374	! Can we look at this points or is there any need to ?
5375	IF ( iip .GE. 1 .AND. iip .LE. nbi .AND. &
5376	& jjp .GE. 1 .AND. jjp .LE. nbj .AND. not_found) THEN
5377	! Is this point the one we look for ?
5378	IF ( trip_flow(iip,jjp,1) .EQ. outflow(ibas,1) .AND. &
5379	& trip_flow(iip,jjp,2) .EQ. outflow(ibas,2)) THEN
5380	trip_flow(ip,jp,1) = outflow(ibas,1)
5381	trip_flow(ip,jp,2) = outflow(ibas,2)
5382	trip_tmp(ip,jp) = id
5383	! This last line ensures that we do not come back to this point
5384	! and that in the end the outer while will stop
5385	not_found = .FALSE.
5386	ENDIF
5387	ENDIF
5388	ENDDO
5389	ENDIF
5390	ib = ib + 1
5391	ENDDO
5392	ENDIF
5393	ENDDO
5394	ENDDO
5395	!
5396	icc = icc - 1
5397	ENDDO
5398	!
5399	!
5400	ENDDO
5401	!
5402	IF ( debug ) THEN
5403	WRITE(numout,*) '+++++++++++++++++++ AFTER +++++++++++++++++++++++++++++'
5404	WRITE(fmt,"('(',I3,'I6)')") nbi
5405	DO jp=1,nbj
5406	WRITE(numout,fmt) trip_tmp(1:nbi,jp)
5407	ENDDO
5408	ENDIF
5409	!
5410	! Put trip_tmp back into trip
5411	!
5412	DO ip=1,nbi
5413	DO jp=1,nbj
5414	IF ( trip_tmp(ip,jp) .GT. 0) THEN
5415	trip(ip,jp) = trip_tmp(ip,jp)
5416	ENDIF
5417	ENDDO
5418	ENDDO
5419	!
5420	END SUBROUTINE routing_simplify
5421	!
5422	!! ================================================================================================================================
5423	!! SUBROUTINE : routing_cutbasin
5424	!!
5425	!>\BRIEF This subroutine cuts the original basin which has more than one outflow
5426	!! into as many subbasins as outflow directions.
5427	!!
5428	!! DESCRIPTION (definitions, functional, design, flags) : None
5429	!!
5430	!! RECENT CHANGE(S): None
5431	!!
5432	!! MAIN OUTPUT VARIABLE(S):
5433	!!
5434	!! REFERENCES : None
5435	!!
5436	!! FLOWCHART : None
5437	!! \n
5438	!_ ================================================================================================================================
5439
5440	SUBROUTINE routing_cutbasin (nbi, nbj, nbbasins, trip, basin, basin_inbxid, nb, bname, sz, pts)
5441	!
5442	IMPLICIT NONE
5443	!
5444	!! INPUT VARIABLES
5445	INTEGER(i_std), INTENT(in) :: nbi, nbj !! Number of point in x and y within the grid (unitless)
5446	INTEGER(i_std), INTENT(in) :: nbbasins !!
5447	INTEGER(i_std), INTENT(in) :: basin_inbxid !!
5448	!
5449	! Modified
5450	INTEGER(i_std), INTENT(inout) :: trip(:,:) !! The trip field (unitless)
5451	INTEGER(i_std), INTENT(inout) :: basin(:,:) !!
5452	!
5453	!! OUTPUT VARIABLES
5454	INTEGER(i_std), INTENT(out) :: nb !!
5455	INTEGER(i_std), INTENT(out) :: bname(nbvmax) !!
5456	INTEGER(i_std), INTENT(out) :: sz(nbvmax) !!
5457	INTEGER(i_std), INTENT(out) :: pts(nbvmax,nbvmax,2) !!
5458	!
5459	!! LOCAL VARIABLES
5460	INTEGER(i_std) :: ip, jp, iip, jjp, ib, ibb, id, nbout !! Indices (unitless)
5461	INTEGER(i_std) :: basin_sz !!
5462	INTEGER(i_std) :: nb_in !!
5463	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)
5464	INTEGER(i_std), DIMENSION(nbvmax,nbvmax,2) :: trip_flow !!
5465	INTEGER(i_std), DIMENSION(nbvmax,2) :: outflow !!
5466	INTEGER(i_std), DIMENSION(nbvmax) :: outsz !!
5467	CHARACTER(LEN=7) :: fmt !!
5468	LOGICAL :: not_found !! (true/false)
5469	LOGICAL :: debug=.FALSE. !! (true/false)
5470	!
5471	INTEGER(i_std), DIMENSION(8,2) :: inc !!
5472
5473	!_ ================================================================================================================================
5474	!
5475	!
5476	! The routing code (i=1, j=2)
5477	!
5478	inc(1,1) = 0
5479	inc(1,2) = -1
5480	inc(2,1) = 1
5481	inc(2,2) = -1
5482	inc(3,1) = 1
5483	inc(3,2) = 0
5484	inc(4,1) = 1
5485	inc(4,2) = 1
5486	inc(5,1) = 0
5487	inc(5,2) = 1
5488	inc(6,1) = -1
5489	inc(6,2) = 1
5490	inc(7,1) = -1
5491	inc(7,2) = 0
5492	inc(8,1) = -1
5493	inc(8,2) = -1
5494	!
5495	! Set up a temporary trip field which only contains the values
5496	! for the basin on which we currently work.
5497	!
5498	trip_tmp(:,:) = -1
5499	basin_sz = 0
5500	DO ip=1,nbi
5501	DO jp=1,nbj
5502	IF ( basin(ip,jp) .EQ. basin_inbxid) THEN
5503	trip_tmp(ip,jp) = trip(ip,jp)
5504	basin_sz = basin_sz + 1
5505	ENDIF
5506	ENDDO
5507	ENDDO
5508	!
5509	CALL routing_findrout(nbi, nbj, trip_tmp, basin_sz, basin_inbxid, nbout, outflow, trip_flow, outsz)
5510	!
5511	! IF ( debug ) THEN
5512	! DO ib = nb_in+1,nb
5513	! DO ip=1,sz(ib)
5514	! trip_tmp(pts(ib, ip, 1),pts(ib, ip, 2)) = ib*(-1)-900
5515	! ENDDO
5516	! ENDDO
5517	! WRITE(fmt,"('(',I3,'I6)')") nbi
5518	! WRITE(numout,*) 'BEFORE ------------> New basins '
5519	! WRITE(numout,*) nb, ' sz :', sz(1:nb)
5520	! DO jp=1,nbj
5521	! WRITE(numout,fmt) trip_tmp(1:nbi,jp)
5522	! ENDDO
5523	! ENDIF
5524	!
5525	! Take out the small sub-basins. That is those which have only one grid box
5526	! This is only done if we need to save space in the number of basins. Else we
5527	! can take it easy and keep diverging sub-basins for the moment.
5528	!
5529	IF ( nbbasins .GE. nbasmax ) THEN
5530	DO ib=1,nbout
5531	! If the sub-basin is of size one and its larger neighbor is flowing into another
5532	! direction then we put them together.
5533	IF ( outsz(ib) .EQ. 1 .AND. trip(outflow(ib,1), outflow(ib,2)) .GT. 99 ) THEN
5534	!
5535	not_found = .TRUE.
5536	DO id=1,8
5537	ip = outflow(ib,1)
5538	jp = outflow(ib,2)
5539	iip = ip + inc(id,1)
5540	jjp = jp + inc(id,2)
5541	! Can we look at this points ?
5542	IF ( iip .GE. 1 .AND. iip .LE. nbi .AND. &
5543	& jjp .GE. 1 .AND. jjp .LE. nbj .AND. not_found) THEN
5544	! Did we find a direct neighbor which is an outflow point ?
5545	IF ( trip_tmp(iip,jjp) .GT. 100 ) THEN
5546	! IF so direct the flow towards it and update the tables.
5547	not_found = .FALSE.
5548	trip(ip,jp) = id
5549	trip_tmp(ip,jp) = id
5550	outsz(ib) = 0
5551	! update the table of this basin
5552	DO ibb=1,nbout
5553	IF ( iip .EQ. outflow(ibb,1) .AND. jjp .EQ. outflow(ibb,2) ) THEN
5554	outsz(ibb) = outsz(ibb)+1
5555	trip_flow(ip,jp,1) = outflow(ibb,1)
5556	trip_flow(ip,jp,2) = outflow(ibb,2)
5557	ENDIF
5558	ENDDO
5559	ENDIF
5560	ENDIF
5561	ENDDO
5562	ENDIF
5563	ENDDO
5564	ENDIF
5565	!
5566	!
5567	! Cut the basin if we have more than 1 left.
5568	!
5569	!
5570	IF ( COUNT(outsz(1:nbout) .GT. 0) .GT. 1 ) THEN
5571	!
5572	nb_in = nb
5573	!
5574	DO ib = 1,nbout
5575	IF ( outsz(ib) .GT. 0) THEN
5576	nb = nb+1
5577	IF ( nb .GT. nbvmax) THEN
5578	WRITE(numout,*) 'nbvmax too small, increase it (routing_cutbasin)'
5579	ENDIF
5580	bname(nb) = basin_inbxid
5581	sz(nb) = 0
5582	DO ip=1,nbi
5583	DO jp=1,nbj
5584	IF ( (trip_flow(ip,jp,1) + trip_flow(ip,jp,1)) .GT. 0 .AND. &
5585	& trip_flow(ip,jp,1) .EQ. outflow(ib,1) .AND. &
5586	& trip_flow(ip,jp,2) .EQ. outflow(ib,2) ) THEN
5587	sz(nb) = sz(nb) + 1
5588	pts(nb, sz(nb), 1) = ip
5589	pts(nb, sz(nb), 2) = jp
5590	ENDIF
5591	ENDDO
5592	ENDDO
5593	ENDIF
5594	ENDDO
5595	! A short verification
5596	IF ( SUM(sz(nb_in+1:nb)) .NE. basin_sz) THEN
5597	WRITE(numout,*) 'Lost some points while spliting the basin'
5598	WRITE(numout,*) 'nbout :', nbout
5599	DO ib = nb_in+1,nb
5600	WRITE(numout,*) 'ib, SZ :', ib, sz(ib)
5601	ENDDO
5602	WRITE(fmt,"('(',I3,'I6)')") nbi
5603	WRITE(numout,*) '-------------> trip '
5604	DO jp=1,nbj
5605	WRITE(numout,fmt) trip_tmp(1:nbi,jp)
5606	ENDDO
5607	CALL ipslerr_p(3,'routing_cutbasin','Lost some points while spliting the basin','','')
5608	ENDIF
5609
5610	IF ( debug ) THEN
5611	DO ib = nb_in+1,nb
5612	DO ip=1,sz(ib)
5613	trip_tmp(pts(ib, ip, 1),pts(ib, ip, 2)) = ib*(-1)-900
5614	ENDDO
5615	ENDDO
5616	WRITE(fmt,"('(',I3,'I6)')") nbi
5617	WRITE(numout,*) 'AFTER-------------> New basins '
5618	WRITE(numout,*) nb, ' sz :', sz(1:nb)
5619	DO jp=1,nbj
5620	WRITE(numout,fmt) trip_tmp(1:nbi,jp)
5621	ENDDO
5622	IF ( MAXVAl(trip_tmp(1:nbi,1:nbj)) .GT. 0) THEN
5623	CALL ipslerr_p(3,'routing_cutbasin','Error in debug checking','','')
5624	ENDIF
5625	ENDIF
5626	ENDIF
5627	!
5628	END SUBROUTINE routing_cutbasin
5629	!
5630	!! ================================================================================================================================
5631	!! SUBROUTINE : routing_hierarchy
5632	!!
5633	!>\BRIEF This subroutine finds, for each point, the distance to the outflow
5634	!! point along the flowlines of the basin.
5635	!!
5636	!! DESCRIPTION (definitions, functional, design, flags) : None
5637	!!
5638	!! RECENT CHANGE(S): None
5639	!!
5640	!! MAIN OUTPUT VARIABLE(S):
5641	!!
5642	!! REFERENCES : None
5643	!!
5644	!! FLOWCHART : None
5645	!! \n
5646	!_ ================================================================================================================================
5647
5648	SUBROUTINE routing_hierarchy(iml, jml, trip, topoindex, hierarchy)
5649	!
5650	IMPLICIT NONE
5651	!
5652	!! LOCAL VARIABLES
5653	INTEGER(i_std) :: iml !! X resolution of the high resolution grid
5654	INTEGER(i_std) :: jml !! Y resolution of the high resolution grid
5655	REAL(r_std), DIMENSION(iml,jml) :: trip !! The trip field (unitless)
5656	REAL(r_std), DIMENSION(iml,jml) :: hierarchy !!
5657	REAL(r_std), DIMENSION(iml,jml) :: topoindex !! Topographic index of the residence time (m)
5658	!
5659	INTEGER(i_std), DIMENSION(8,2) :: inc !!
5660	INTEGER(i_std) :: ip, jp, ib, ntripi, ntripj, cnt, trp !!
5661	REAL(r_std) :: topohier !! The new value of topographically weighted hierarchy (m)
5662	REAL(r_std) :: topohier_old !! The old value of topographically weighted hierarchy (m)
5663	CHARACTER(LEN=7) :: fmt !!
5664
5665	!_ ================================================================================================================================
5666	!
5667	! The routing code (i=1, j=2)
5668	!
5669	inc(1,1) = 0
5670	inc(1,2) = -1
5671	inc(2,1) = 1
5672	inc(2,2) = -1
5673	inc(3,1) = 1
5674	inc(3,2) = 0
5675	inc(4,1) = 1
5676	inc(4,2) = 1
5677	inc(5,1) = 0
5678	inc(5,2) = 1
5679	inc(6,1) = -1
5680	inc(6,2) = 1
5681	inc(7,1) = -1
5682	inc(7,2) = 0
5683	inc(8,1) = -1
5684	inc(8,2) = -1
5685	!
5686	DO ip=1,iml
5687	DO jp=1,jml
5688	IF ( trip(ip,jp) .LT. undef_sechiba ) THEN
5689	ntripi = ip
5690	ntripj = jp
5691	trp = NINT(trip(ip,jp))
5692	cnt = 1
5693	! Warn for extreme numbers
5694	IF ( topoindex(ip,jp) .GT. 1.e10 ) THEN
5695	WRITE(numout,*) 'We have a very large topographic index for point ', ip, jp
5696	WRITE(numout,*) 'This can not be right :', topoindex(ip,jp)
5697	CALL ipslerr_p(3,'routing_hierarchy','Too large topographic index','','')
5698	ELSE
5699	topohier = topoindex(ip,jp)
5700	ENDIF
5701	!
5702	DO WHILE ( trp .GT. 0 .AND. trp .LT. 9 .AND. cnt .LT. iml*jml)
5703	cnt = cnt + 1
5704	ntripi = ntripi + inc(trp,1)
5705	IF ( ntripi .LT. 1) ntripi = iml
5706	IF ( ntripi .GT. iml) ntripi = 1
5707	ntripj = ntripj + inc(trp,2)
5708	topohier_old = topohier
5709	topohier = topohier + topoindex(ntripi, ntripj)
5710	IF ( topohier_old .GT. topohier) THEN
5711	WRITE(numout,*) 'Big Problem, how comes we climb up a hill ?'
5712	WRITE(numout,*) 'The old value of topographicaly weighted hierarchy was : ', topohier_old
5713	WRITE(numout,*) 'The new one is :', topohier
5714	CALL ipslerr_p(3,'routing_hierarchy','Big Problem, how comes we climb up a hill ?','','')
5715	ENDIF
5716	trp = NINT(trip(ntripi, ntripj))
5717	ENDDO
5718
5719	IF ( cnt .EQ. iml*jml) THEN
5720	WRITE(numout,*) 'We could not route point (routing_findrout) :', ip, jp
5721	WRITE(numout,*) '-------------> trip '
5722	WRITE(fmt,"('(',I3,'I6)')") iml
5723	DO ib=1,jml
5724	WRITE(numout,fmt) trip(1:iml,ib)
5725	ENDDO
5726	CALL ipslerr_p(3,'routing_hierarchy','We could not route point','','')
5727	ENDIF
5728
5729	hierarchy(ip,jp) = topohier
5730
5731	ENDIF
5732	ENDDO
5733	ENDDO
5734	!
5735	!
5736	END SUBROUTINE routing_hierarchy
5737	!
5738	!! ================================================================================================================================
5739	!! SUBROUTINE : routing_findrout
5740	!!
5741	!>\BRIEF This subroutine simply computes the route to each outflow point
5742	!! and returns the outflow point for each point in the basin.
5743	!!
5744	!! DESCRIPTION (definitions, functional, design, flags) : None
5745	!!
5746	!! RECENT CHANGE(S): None
5747	!!
5748	!! MAIN OUTPUT VARIABLE(S):
5749	!!
5750	!! REFERENCES : None
5751	!!
5752	!! FLOWCHART : None
5753	!! \n
5754	!_ ================================================================================================================================
5755
5756	SUBROUTINE routing_findrout(nbi, nbj, trip, basin_sz, basinid, nbout, outflow, trip_flow, outsz)
5757	!
5758	IMPLICIT NONE
5759	!
5760	!! INPUT VARIABLES
5761	INTEGER(i_std) :: nbi !! Number of point in x within the grid (unitless)
5762	INTEGER(i_std) :: nbj !! Number of point in y within the grid (unitless)
5763	INTEGER(i_std), DIMENSION(nbvmax,nbvmax) :: trip !! The trip field (unitless)
5764	INTEGER(i_std) :: basin_sz !!
5765	INTEGER(i_std) :: basinid !!
5766	!
5767	!! OUTPUT VARIABLES
5768	INTEGER(i_std), DIMENSION(nbvmax,2), INTENT(out) :: outflow !!
5769	INTEGER(i_std), DIMENSION(nbvmax,nbvmax,2), INTENT(out) :: trip_flow !!
5770	INTEGER(i_std), INTENT(out) :: nbout !!
5771	INTEGER(i_std), DIMENSION(nbvmax), INTENT(out) :: outsz !!
5772	!
5773	!! LOCAL VARIABLES
5774	INTEGER(i_std), DIMENSION(8,2) :: inc !!
5775	INTEGER(i_std) :: ip, jp, ib, cnt, trp, totsz !! Indices (unitless)
5776	CHARACTER(LEN=7) :: fmt !!
5777
5778	!_ ================================================================================================================================
5779	!
5780	!
5781	! The routing code (i=1, j=2)
5782	!
5783	inc(1,1) = 0
5784	inc(1,2) = -1
5785	inc(2,1) = 1
5786	inc(2,2) = -1
5787	inc(3,1) = 1
5788	inc(3,2) = 0
5789	inc(4,1) = 1
5790	inc(4,2) = 1
5791	inc(5,1) = 0
5792	inc(5,2) = 1
5793	inc(6,1) = -1
5794	inc(6,2) = 1
5795	inc(7,1) = -1
5796	inc(7,2) = 0
5797	inc(8,1) = -1
5798	inc(8,2) = -1
5799	!
5800	!
5801	! Get the outflows and determine for each point to which outflow point it belong
5802	!
5803	nbout = 0
5804	trip_flow(:,:,:) = 0
5805	DO ip=1,nbi
5806	DO jp=1,nbj
5807	IF ( trip(ip,jp) .GT. 9) THEN
5808	nbout = nbout + 1
5809	outflow(nbout,1) = ip
5810	outflow(nbout,2) = jp
5811	ENDIF
5812	IF ( trip(ip,jp) .GT. 0) THEN
5813	trip_flow(ip,jp,1) = ip
5814	trip_flow(ip,jp,2) = jp
5815	ENDIF
5816	ENDDO
5817	ENDDO
5818	!
5819	! Follow the flow of the water
5820	!
5821	DO ip=1,nbi
5822	DO jp=1,nbj
5823	IF ( (trip_flow(ip,jp,1) + trip_flow(ip,jp,2)) .GT. 0) THEN
5824	trp = trip(trip_flow(ip,jp,1), trip_flow(ip,jp,2))
5825	cnt = 0
5826	DO WHILE ( trp .GT. 0 .AND. trp .LT. 9 .AND. cnt .LT. nbi*nbj)
5827	cnt = cnt + 1
5828	trip_flow(ip,jp,1) = trip_flow(ip,jp,1) + inc(trp,1)
5829	trip_flow(ip,jp,2) = trip_flow(ip,jp,2) + inc(trp,2)
5830	trp = trip(trip_flow(ip,jp,1), trip_flow(ip,jp,2))
5831	ENDDO
5832	IF ( cnt .EQ. nbi*nbj) THEN
5833	WRITE(numout,*) 'We could not route point (routing_findrout) :', ip, jp
5834	WRITE(numout,*) '-------------> trip '
5835	WRITE(fmt,"('(',I3,'I6)')") nbi
5836	DO ib=1,nbj
5837	WRITE(numout,fmt) trip(1:nbi,ib)
5838	ENDDO
5839	CALL ipslerr_p(3,'routing_findrout','We could not route point','','')
5840	ENDIF
5841	ENDIF
5842	ENDDO
5843	ENDDO
5844	!
5845	! What is the size of the region behind each outflow point ?
5846	!
5847	totsz = 0
5848	DO ip=1,nbout
5849	outsz(ip) = COUNT(trip_flow(:,:,1) .EQ. outflow(ip,1) .AND. trip_flow(:,:,2) .EQ. outflow(ip,2))
5850	totsz = totsz + outsz(ip)
5851	ENDDO
5852	IF ( basin_sz .NE. totsz) THEN
5853	WRITE(numout,*) 'Water got lost while I tried to follow it '
5854	WRITE(numout,*) basin_sz, totsz
5855	WRITE(numout,*) 'Basin id :', basinid
5856	DO ip=1,nbout
5857	WRITE(numout,*) 'ip :', ip, ' outsz :', outsz(ip), ' outflow :', outflow(ip,1), outflow(ip,2)
5858	ENDDO
5859	WRITE(numout,*) '-------------> trip '
5860	WRITE(fmt,"('(',I3,'I6)')") nbi
5861	DO jp=1,nbj
5862	WRITE(numout,fmt) trip(1:nbi,jp)
5863	ENDDO
5864	CALL ipslerr_p(3,'routing_findrout','Water got lost while I tried to follow it','','')
5865	ENDIF
5866	!
5867	END SUBROUTINE routing_findrout
5868	!
5869	!! ================================================================================================================================
5870	!! SUBROUTINE : routing_globalize
5871	!!
5872	!>\BRIEF This subroutine puts the basins found for grid box in the global map.
5873	!! Connection can only be made later when all information is together.
5874	!!
5875	!! DESCRIPTION (definitions, functional, design, flags) : None
5876	!!
5877	!! RECENT CHANGE(S): None
5878	!!
5879	!! MAIN OUTPUT VARIABLE(S):
5880	!! One of the outputs is basin_flowdir. Its convention is 1-8 for the directions from North to North
5881	!! West going through South. The negative values will be -3 for return flow, -2 for coastal flow
5882	!!
5883	!! REFERENCES : None
5884	!!
5885	!! FLOWCHART : None
5886	!! \n
5887	!_ ================================================================================================================================
5888
5889	SUBROUTINE routing_globalize(nbpt, ib, neighbours, area_bx, trip_bx, hierarchy_bx, topoind_bx, min_topoind,&
5890	& nb_basin, basin_inbxid, basin_sz, basin_pts, basin_bxout, coast_pts, nwbas, basin_count,&
5891	& basin_area, basin_hierarchy, basin_topoind, basin_id, basin_flowdir, outflow_grid,&
5892	& nbcoastal, coastal_basin)
5893	!
5894	IMPLICIT NONE
5895	!
5896	!! INPUT VARIABLES
5897	INTEGER(i_std), INTENT (in) :: nbpt !! Domain size (unitless)
5898	INTEGER(i_std), INTENT (in) :: ib !! Current basin (unitless)
5899	INTEGER(i_std), INTENT(in) :: neighbours(nbpt,NbNeighb)!! Vector of neighbours for each grid point
5900	!! (1=North and then clockwise)
5901	!! LOCAL VARIABLES
5902	REAL(r_std), DIMENSION(nbvmax,nbvmax) :: area_bx !! Area of each small box in the grid box (m^2)
5903	INTEGER(i_std), DIMENSION(nbvmax,nbvmax) :: trip_bx !! The trip field for each of the smaller boxes (unitless)
5904	REAL(r_std), DIMENSION(nbvmax,nbvmax) :: hierarchy_bx !! Level in the basin of the point
5905	REAL(r_std), DIMENSION(nbvmax,nbvmax) :: topoind_bx !! Topographic index of the residence time for each of the smaller boxes (m)
5906	REAL(r_std) :: min_topoind !! The current minimum of topographic index (m)
5907	INTEGER(i_std) :: nb_basin !! Number of sub-basins (unitless)
5908	INTEGER(i_std), DIMENSION(nbvmax) :: basin_inbxid, basin_sz !! ID of basin, number of points in the basin
5909	INTEGER(i_std), DIMENSION(nbvmax,nbvmax,2) :: basin_pts !! Points in each basin
5910	INTEGER(i_std), DIMENSION(nbvmax) :: basin_bxout !! outflow direction
5911	INTEGER(i_std) :: coast_pts(nbvmax) !! The coastal flow points (unitless)
5912	! global maps
5913	INTEGER(i_std) :: nwbas !!
5914	INTEGER(i_std), DIMENSION(nbpt) :: basin_count !!
5915	INTEGER(i_std), DIMENSION(nbpt,nwbas) :: basin_id !!
5916	INTEGER(i_std), DIMENSION(nbpt,nwbas) :: basin_flowdir !! Water flow directions in the basin (unitless)
5917	REAL(r_std), DIMENSION(nbpt,nwbas) :: basin_area !!
5918	REAL(r_std), DIMENSION(nbpt,nwbas) :: basin_hierarchy !!
5919	REAL(r_std), DIMENSION(nbpt,nwbas) :: basin_topoind !! Topographic index of the residence time for a basin (m)
5920	INTEGER(i_std), DIMENSION(nbpt,nwbas) :: outflow_grid !! Type of outflow on the grid box (unitless)
5921	INTEGER(i_std), DIMENSION(nbpt) :: nbcoastal !!
5922	INTEGER(i_std), DIMENSION(nbpt,nwbas) :: coastal_basin !!
5923	!
5924	INTEGER(i_std) :: ij, iz !! Indices (unitless)
5925	CHARACTER(LEN=4) :: hierar_method = 'OUTP' !!
5926
5927	!_ ================================================================================================================================
5928	!
5929	!
5930	DO ij=1, nb_basin
5931	!
5932	! Count the basins and keep their ID
5933	!
5934	basin_count(ib) = basin_count(ib)+1
5935	if (basin_count(ib) > nwbas) then
5936	WRITE(numout,*) 'ib=',ib
5937	call ipslerr_p(3,'routing_globalize', &
5938	& 'Problem with basin_count : ', &
5939	& 'It is greater than number of allocated basin nwbas.', &
5940	& '(stop to count basins)')
5941	endif
5942	basin_id(ib,basin_count(ib)) = basin_inbxid(ij)
5943	!
5944	! Transfer the list of basins which flow into the ocean as coastal flow.
5945	!
5946	IF ( basin_id(ib,basin_count(ib)) .LT. 0) THEN
5947	nbcoastal(ib) = basin_sz(ij)
5948	coastal_basin(ib,1:nbcoastal(ib)) = coast_pts(1:nbcoastal(ib))
5949	ENDIF
5950	!
5951	!
5952	! Compute the area of the basin
5953	!
5954	basin_area(ib,ij) = zero
5955	basin_hierarchy(ib,ij) = zero
5956	!
5957	SELECT CASE (hierar_method)
5958	!
5959	CASE("MINI")
5960	basin_hierarchy(ib,ij) = undef_sechiba
5961	!
5962	END SELECT
5963	basin_topoind(ib,ij) = zero
5964	!
5965	DO iz=1,basin_sz(ij)
5966	!
5967	basin_area(ib,ij) = basin_area(ib,ij) + area_bx(basin_pts(ij,iz,1),basin_pts(ij,iz,2))
5968	basin_topoind(ib,ij) = basin_topoind(ib,ij) + topoind_bx(basin_pts(ij,iz,1),basin_pts(ij,iz,2))
5969	!
5970	! There are a number of ways to determine the hierarchy of the entire basin.
5971	! We allow for three here :
5972	! - Take the mean value
5973	! - Take the minimum value within the basin
5974	! - Take the value at the outflow point
5975	! Probably taking the value of the outflow point is the best solution.
5976	!
5977	SELECT CASE (hierar_method)
5978	!
5979	CASE("MEAN")
5980	! Mean hierarchy of the basin
5981	basin_hierarchy(ib,ij) = basin_hierarchy(ib,ij) + &
5982	& hierarchy_bx(basin_pts(ij,iz,1),basin_pts(ij,iz,2))
5983	CASE("MINI")
5984	! The smallest value of the basin
5985	IF ( hierarchy_bx(basin_pts(ij,iz,1),basin_pts(ij,iz,2)) .LT. basin_hierarchy(ib,ij)) THEN
5986	basin_hierarchy(ib,ij) = hierarchy_bx(basin_pts(ij,iz,1),basin_pts(ij,iz,2))
5987	ENDIF
5988	CASE("OUTP")
5989	! Value at the outflow point
5990	IF ( trip_bx(basin_pts(ij,iz,1),basin_pts(ij,iz,2)) .GT. 100 ) THEN
5991	basin_hierarchy(ib,ij) = hierarchy_bx(basin_pts(ij,iz,1),basin_pts(ij,iz,2))
5992	ENDIF
5993	CASE DEFAULT
5994	WRITE(numout,*) 'Unknown method for computing the hierarchy of the basin'
5995	CALL ipslerr_p(3,'routing_globalize','Unknown method for computing the hierarchy of the basin','','')
5996	END SELECT
5997	!
5998	ENDDO
5999	!
6000	basin_topoind(ib,ij) = basin_topoind(ib,ij)/REAL(basin_sz(ij),r_std)
6001	!
6002	SELECT CASE (hierar_method)
6003	!
6004	CASE("MEAN")
6005	basin_hierarchy(ib,ij) = basin_hierarchy(ib,ij)/REAL(basin_sz(ij),r_std)
6006	!
6007	END SELECT
6008	!
6009	! To make sure that it has the lowest number if this is an outflow point we reset basin_hierarchy
6010	!
6011	IF (basin_bxout(ij) .LT. 0) THEN
6012	basin_hierarchy(ib,ij) = min_topoind
6013	basin_topoind(ib,ij) = min_topoind
6014	ENDIF
6015	!
6016	!
6017	! Keep the outflow boxes and basin
6018	!
6019	basin_flowdir(ib,ij) = basin_bxout(ij)
6020	IF (basin_bxout(ij) .GT. 0) THEN
6021	outflow_grid(ib,ij) = neighbours(ib,basin_bxout(ij))
6022	ELSE
6023	outflow_grid(ib,ij) = basin_bxout(ij)
6024	ENDIF
6025	!
6026	!
6027	ENDDO
6028	!
6029
6030	!
6031	END SUBROUTINE routing_globalize
6032	!
6033	!! ================================================================================================================================
6034	!! SUBROUTINE : routing_linkup
6035	!!
6036	!>\BRIEF This subroutine makes the connections between the basins and ensure global coherence.
6037	!!
6038	!! DESCRIPTION (definitions, functional, design, flags) :
6039	!! The convention for outflow_grid is :
6040	!! outflow_grid = -1 : River flow
6041	!! outflow_grid = -2 : Coastal flow
6042	!! outflow_grid = -3 : Return flow\n
6043	!!
6044	!! RECENT CHANGE(S): None
6045	!!
6046	!! MAIN OUTPUT VARIABLE(S):
6047	!!
6048	!! REFERENCES : None
6049	!!
6050	!! FLOWCHART : None
6051	!! \n
6052	!_ ================================================================================================================================
6053
6054	SUBROUTINE routing_linkup(nbpt, contfrac, neighbours, nwbas, basin_count, basin_area, basin_id, basin_flowdir, &
6055	& basin_hierarchy, outflow_grid, outflow_basin, inflow_number, inflow_grid, inflow_basin, nbcoastal,&
6056	& coastal_basin, invented_basins)
6057	!
6058	IMPLICIT NONE
6059	!
6060	!! INPUT VARIABLES
6061	INTEGER(i_std), INTENT (in) :: nbpt !! Domain size (unitless)
6062	REAL(r_std), DIMENSION(nbpt) :: contfrac
6063	INTEGER(i_std), DIMENSION(nbpt,NbNeighb), INTENT (in) :: neighbours !!
6064	REAL(r_std), INTENT(in) :: invented_basins !!
6065	!
6066	INTEGER(i_std) :: nwbas !!
6067	INTEGER(i_std), DIMENSION(nbpt) :: basin_count !!
6068	INTEGER(i_std), DIMENSION(nbpt,nwbas) :: basin_id !!
6069	INTEGER(i_std), DIMENSION(nbpt,nwbas) :: basin_flowdir !! Water flow directions in the basin (unitless)
6070	REAL(r_std), DIMENSION(nbpt,nwbas) :: basin_area !!
6071	REAL(r_std), DIMENSION(nbpt,nwbas) :: basin_hierarchy !!
6072	INTEGER(i_std), DIMENSION(nbpt,nwbas) :: outflow_grid !! Type of outflow on the grid box (unitless)
6073	INTEGER(i_std), DIMENSION(nbpt,nwbas) :: outflow_basin !!
6074	INTEGER(i_std), DIMENSION(nbpt,nwbas) :: inflow_number !!
6075	INTEGER(i_std), DIMENSION(nbpt,nwbas,nbvmax) :: inflow_basin !!
6076	INTEGER(i_std), DIMENSION(nbpt,nwbas,nbvmax) :: inflow_grid !!
6077	INTEGER(i_std), DIMENSION(nbpt) :: nbcoastal !!
6078	INTEGER(i_std), DIMENSION(nbpt,nwbas) :: coastal_basin !!
6079	!
6080	!! LOCAL VARIABLES
6081	INTEGER(i_std) :: sp, sb, sbl, inp, bid, outdm1, outdp1 !! Indices (unitless)
6082	INTEGER(i_std) :: dp1, dm1, dm1i, dp1i, bp1, bm1 !! Indices (unitless)
6083	INTEGER(i_std) :: dop, bop !!
6084	INTEGER(i_std) :: fbas(nwbas), nbfbas !!
6085	REAL(r_std) :: fbas_hierarchy(nwbas) !!
6086	REAL(r_std) :: angle
6087	INTEGER(i_std) :: ff(1) !!
6088	!
6089	! ERRORS
6090	LOGICAL :: error1, error2, error3, error4, error5 !! (true/false)
6091	!
6092	!! PARAMETERS
6093	LOGICAL, PARAMETER :: check = .TRUE. !! (true/false)
6094
6095	!_ ================================================================================================================================
6096	error1=.FALSE.
6097	error2=.FALSE.
6098	error3=.FALSE.
6099	error4=.FALSE.
6100	error5=.FALSE.
6101
6102	outflow_basin(:,:) = undef_int
6103	inflow_number(:,:) = 0
6104	!
6105	DO sp=1,nbpt
6106	DO sb=1,basin_count(sp)
6107	!
6108	inp = outflow_grid(sp,sb)
6109	bid = basin_id(sp,sb)
6110	!
6111	! We only work on this point if it does not flow into the ocean
6112	! At this point any of the outflows is designated by a negative values in
6113	! outflow_grid
6114	!
6115	IF ( inp .GT. 0 ) THEN
6116	!
6117	! Now find the basin in the onflow point (inp)
6118	!
6119	nbfbas = 0
6120	!
6121	!
6122	DO sbl=1,basin_count(inp)
6123	!
6124	! Either it is a standard basin or one aggregated from ocean flow points.
6125	! If we flow into a another grid box we have to make sure that its hierarchy in the
6126	! basin is lower.
6127	!
6128	!
6129	IF ( basin_id(inp,sbl) .GT. 0 ) THEN
6130	IF ( basin_id(inp,sbl) .EQ. bid .OR. basin_id(inp,sbl) .GT. invented_basins) THEN
6131	nbfbas =nbfbas + 1
6132	fbas(nbfbas) = sbl
6133	fbas_hierarchy(nbfbas) = basin_hierarchy(inp,sbl)
6134	ENDIF
6135	ELSE
6136	IF ( COUNT(coastal_basin(inp,1:nbcoastal(inp)) .EQ. bid) .GT. 0 ) THEN
6137	nbfbas =nbfbas + 1
6138	fbas(nbfbas) = sbl
6139	fbas_hierarchy(nbfbas) = basin_hierarchy(inp,sbl)
6140	ENDIF
6141	ENDIF
6142	!
6143	ENDDO
6144	!
6145	! If we have more than one basin we will take the one which is lowest
6146	! in the hierarchy.
6147	!
6148	IF (nbfbas .GE. 1) THEN
6149	ff = MINLOC(fbas_hierarchy(1:nbfbas))
6150	sbl = fbas(ff(1))
6151	!
6152	bop = undef_int
6153	IF ( basin_hierarchy(inp,sbl) .LE. basin_hierarchy(sp,sb) ) THEN
6154	IF ( basin_hierarchy(inp,sbl) .LT. basin_hierarchy(sp,sb) ) THEN
6155	bop = sbl
6156	ELSE
6157	! The same hierarchy is allowed if both grids flow in about
6158	! the same direction :
6159	IF ( ( MOD(basin_flowdir(inp,sbl)+1-1, 8)+1 .EQ. basin_flowdir(sp,sb)).OR. &
6160	& ( basin_flowdir(inp,sbl) .EQ. basin_flowdir(sp,sb)).OR. &
6161	& ( MOD(basin_flowdir(inp,sbl)+7-1, 8)+1 .EQ. basin_flowdir(sp,sb)) ) THEN
6162	bop = sbl
6163	ENDIF
6164	ENDIF
6165	ENDIF
6166	!
6167	! If the basin is suitable (bop < undef_int) then take it
6168	!
6169	IF ( bop .LT. undef_int ) THEN
6170	outflow_basin(sp,sb) = bop
6171	inflow_number(inp,bop) = inflow_number(inp,bop) + 1
6172	IF ( inflow_number(inp,bop) .LE. nbvmax ) THEN
6173	inflow_grid(inp, bop, inflow_number(inp,bop)) = sp
6174	inflow_basin(inp, bop, inflow_number(inp,bop)) = sb
6175	ELSE
6176	error1=.TRUE.
6177	EXIT
6178	ENDIF
6179	ENDIF
6180	ENDIF
6181	!
6182	!
6183	ENDIF
6184	!
6185	!
6186	!
6187	! Did we find it ?
6188	!
6189	! In case the outflow point was ocean or we did not find the correct basin we start to look
6190	! around. We find two options for the outflow direction (dp1 & dm1) and the corresponding
6191	! basin index (bp1 & bm1).
6192	!
6193	!
6194	IF ( outflow_basin(sp,sb) .EQ. undef_int &
6195	& .AND. basin_flowdir(sp,sb) .GT. 0) THEN
6196	!
6197	dp1i = MOD(basin_flowdir(sp,sb)+1-1, NbNeighb)+1
6198	dp1 = neighbours(sp,dp1i)
6199	dm1i = MOD(basin_flowdir(sp,sb)+7-1, NbNeighb)+1
6200	IF ( dm1i .LT. 1 ) dm1i = 8
6201	dm1 = neighbours(sp,dm1i)
6202	!
6203	!
6204	bp1 = -1
6205	IF ( dp1 .GT. 0 ) THEN
6206	DO sbl=1,basin_count(dp1)
6207	IF (basin_id(dp1,sbl) .EQ. bid .AND.&
6208	& basin_hierarchy(sp,sb) .GE. basin_hierarchy(dp1,sbl) .AND. &
6209	& bp1 .LT. 0) THEN
6210	IF ( basin_hierarchy(sp,sb) .GT. basin_hierarchy(dp1,sbl) ) THEN
6211	bp1 = sbl
6212	ELSE
6213	! The same hierarchy is allowed if both grids flow in about
6214	! the same direction :
6215	angle=MODULO(basin_flowdir(dp1,sbl)-basin_flowdir(sp,sb)+8,8)
6216	IF ( angle >= 4 ) angle = angle-8
6217	!
6218	IF ( ABS(angle) <= 1 ) THEN
6219	bp1 = sbl
6220	ENDIF
6221	ENDIF
6222	ENDIF
6223	ENDDO
6224	ENDIF
6225	!
6226	bm1 = -1
6227	IF ( dm1 .GT. 0 ) THEN
6228	DO sbl=1,basin_count(dm1)
6229	IF (basin_id(dm1,sbl) .EQ. bid .AND.&
6230	& basin_hierarchy(sp,sb) .GE. basin_hierarchy(dm1,sbl) .AND. &
6231	& bm1 .LT. 0) THEN
6232	IF ( basin_hierarchy(sp,sb) .GT. basin_hierarchy(dm1,sbl) ) THEN
6233	bm1 = sbl
6234	ELSE
6235	! The same hierarchy is allowed if both grids flow in about
6236	! the same direction :
6237	angle=MODULO(basin_flowdir(dm1,sbl)-basin_flowdir(sp,sb)+8,8)
6238	IF ( angle >= 4 ) angle = angle-8
6239	!
6240	IF ( ABS(angle) <= 1 ) THEN
6241	bm1 = sbl
6242	ENDIF
6243	ENDIF
6244	ENDIF
6245	ENDDO
6246	ENDIF
6247	!
6248	!
6249	! First deal with the case on land.
6250	!
6251	! For that we need to check if the water will be able to flow out of the grid dp1 or dm1
6252	! and not return to our current grid. If it is the current grid
6253	! then we can not do anything with that neighbour. Thus we set the
6254	! value of outdm1 and outdp1 back to -1
6255	!
6256	outdp1 = undef_int
6257	IF ( dp1 .GT. 0 .AND. bp1 .GT. 0 ) THEN
6258	! if the outflow is into the ocean then we put something less than undef_int in outdp1!
6259	IF (basin_flowdir(dp1,bp1) .GT. 0) THEN
6260	outdp1 = neighbours(dp1,basin_flowdir(dp1,bp1))
6261	IF ( outdp1 .EQ. sp ) outdp1 = undef_int
6262	ELSE
6263	outdp1 = nbpt + 1
6264	ENDIF
6265	ENDIF
6266	outdm1 = undef_int
6267	IF ( dm1 .GT. 0 .AND. bm1 .GT. 0 ) THEN
6268	IF (basin_flowdir(dm1,bm1) .GT. 0) THEN
6269	outdm1 = neighbours(dm1,basin_flowdir(dm1,bm1))
6270	IF ( outdm1 .EQ. sp ) outdm1 = undef_int
6271	ELSE
6272	outdm1 = nbpt + 1
6273	ENDIF
6274	ENDIF
6275	!
6276	! Now that we know our options we need go through them.
6277	!
6278	dop = undef_int
6279	bop = undef_int
6280	IF ( outdp1 .LT. undef_int .AND. outdm1 .LT. undef_int) THEN
6281	!
6282	! In this case we let the current basin flow into the smaller one
6283	!
6284	IF ( basin_area(dp1,bp1) .LT. basin_area(dm1,bm1) ) THEN
6285	dop = dp1
6286	bop = bp1
6287	ELSE
6288	dop = dm1
6289	bop = bm1
6290	ENDIF
6291	!
6292	!
6293	ELSE IF ( outdp1 .LT. undef_int ) THEN
6294	! If only the first one is possible
6295	dop = dp1
6296	bop = bp1
6297	ELSE IF ( outdm1 .LT. undef_int ) THEN
6298	! If only the second one is possible
6299	dop = dm1
6300	bop = bm1
6301	ELSE
6302	!
6303	! Now we are at the point where none of the neighboring points is suitable
6304	! or we have a coastal point.
6305	!
6306	! If there is an option to put the water into the ocean go for it.
6307	!
6308	IF ( outflow_grid(sp,sb) .LT. 0 .OR. dm1 .LT. 0 .OR. dp1 .LT. 0 ) THEN
6309	dop = -1
6310	ELSE
6311	!
6312	! If we are on a land point with only land neighbors but no one suitable to let the
6313	! water flow into we have to look for a solution in the current grid box.
6314	!
6315	!
6316	IF ( bp1 .LT. 0 .AND. bm1 .LT. 0 ) THEN
6317	!
6318	! Do we have more than one basin with the same ID ?
6319	!
6320	IF ( COUNT(basin_id(sp,1:basin_count(sp)) .EQ. bid) .GE. 2) THEN
6321	!
6322	! Now we can try the option of flowing into the basin of the same grid box.
6323	!
6324	DO sbl=1,basin_count(sp)
6325	IF (sbl .NE. sb .AND. basin_id(sp,sbl) .EQ. bid) THEN
6326	! In case this basin has a lower hierarchy or flows into a totaly
6327	! different direction we go for it.
6328	IF ( (basin_hierarchy(sp,sb) .GE. basin_hierarchy(sp,sbl)) .OR. &
6329	& (basin_flowdir(sp,sbl) .LT. dm1i .AND.&
6330	& basin_flowdir(sp,sbl) .GT. dp1i) ) THEN
6331	dop = sp
6332	bop = sbl
6333	IF (check) THEN
6334	IF (basin_hierarchy(sp,sb) .LT. basin_hierarchy(sp,sbl)) THEN
6335	WRITE(numout,*) '>>>>>>> POINT CORRECTED against hierarchy :',&
6336	& sp, sb, 'into', sbl
6337	ENDIF
6338	ENDIF
6339	ENDIF
6340	!
6341	ENDIF
6342	ENDDO
6343	!
6344	ENDIF
6345	ENDIF
6346	ENDIF
6347	!
6348	IF ( dop .EQ. undef_int .AND. bop .EQ. undef_int ) THEN
6349	IF (check) THEN
6350	WRITE(numout,*) 'Why are we here with point ', sp, sb
6351	WRITE(numout,*) 'Coordinates : (lon,lat) = ', lalo_g(sp,2), lalo_g(sp,1)
6352	WRITE(numout,*) 'neighbours :', neighbours_g(sp,:)
6353	WRITE(numout,*) 'Contfrac : = ', contfrac(sp)
6354	WRITE(numout,*) 'Local Basin ID :', basin_id(sp,1:basin_count(sp))
6355	WRITE(numout,*) 'Local hierarchies :', basin_hierarchy(sp,1:basin_count(sp))
6356	WRITE(numout,*) 'Local basin_flowdir :', basin_flowdir(sp,1:basin_count(sp))
6357	WRITE(numout,*) 'Local outflowgrid :', outflow_grid(sp,1:basin_count(sp))
6358	WRITE(numout,*) 'outflow_grid :', inp
6359	WRITE(numout,*) 'Coodinates outflow : (lon,lat) = ', lalo_g(inp,2), lalo_g(inp,1)
6360	WRITE(numout,*) 'Contfrac : = ', contfrac(inp)
6361	WRITE(numout,*) 'Outflow Basin ID :', basin_id(inp,1:basin_count(inp))
6362	WRITE(numout,*) 'Outflow hierarchies :', basin_hierarchy(inp,1:basin_count(inp))
6363	WRITE(numout,*) 'Outflow basin_flowdir :', basin_flowdir(inp,1:basin_count(inp))
6364	WRITE(numout,*) 'Explored options +1 :', dp1, bp1, outdp1
6365	WRITE(numout,*) 'Explored +1 Basin ID :', basin_id(dp1,1:basin_count(dp1))
6366	WRITE(numout,*) 'Explored +1 hierarchies :', basin_hierarchy(dp1,1:basin_count(dp1))
6367	WRITE(numout,*) 'Explored +1 basin_flowdir :', basin_flowdir(dp1,1:basin_count(dp1))
6368	WRITE(numout,*) 'Explored options -1 :', dm1, bm1, outdm1
6369	WRITE(numout,*) 'Explored -1 Basin ID :', basin_id(dm1,1:basin_count(dm1))
6370	WRITE(numout,*) 'Explored -1 hierarchies :', basin_hierarchy(dm1,1:basin_count(dm1))
6371	WRITE(numout,*) 'Explored -1 basin_flowdir :', basin_flowdir(dm1,1:basin_count(dm1))
6372	WRITE(numout,) '***************************'
6373	CALL FLUSH(numout)
6374	ENDIF
6375	IF ( contfrac(sp) > 0.01 ) THEN
6376	error2=.TRUE.
6377	EXIT
6378	ENDIF
6379	ENDIF
6380	!
6381	ENDIF
6382	!
6383	! Now that we know where we want the water to flow to we write the
6384	! the information in the right fields.
6385	!
6386	IF ( dop .GT. 0 .AND. dop .NE. undef_int ) THEN
6387	outflow_grid(sp,sb) = dop
6388	outflow_basin(sp,sb) = bop
6389	inflow_number(dop,bop) = inflow_number(dop,bop) + 1
6390	IF ( inflow_number(dop,bop) .LE. nbvmax ) THEN
6391	inflow_grid(dop, bop, inflow_number(dop,bop)) = sp
6392	inflow_basin(dop, bop, inflow_number(dop,bop)) = sb
6393	ELSE
6394	error3=.TRUE.
6395	EXIT
6396	ENDIF
6397	!
6398	ELSE
6399	outflow_grid(sp,sb) = -2
6400	outflow_basin(sp,sb) = undef_int
6401	ENDIF
6402	!
6403	ENDIF
6404	!
6405	!
6406	! If we still have not found anything then we have to check that there is not a basin
6407	! within the same grid box which has a lower hierarchy.
6408	!
6409	!
6410	IF ( outflow_grid(sp,sb) .GT. 0 .AND. outflow_basin(sp,sb) .EQ. undef_int &
6411	& .AND. basin_flowdir(sp,sb) .GT. 0) THEN
6412	!
6413
6414	IF (check) &
6415	WRITE(numout,*) 'There is no reason to here, this part of the code should be dead :', sp,sb
6416	!
6417	DO sbl=1,basin_count(sp)
6418	!
6419	! Three conditions are needed to let the water flow into another basin of the
6420	! same grid :
6421	! - another basin than the current one
6422	! - same ID
6423	! - of lower hierarchy.
6424	!
6425	IF ( (sbl .NE. sb) .AND. (basin_id(sp,sbl) .EQ. bid)&
6426	& .AND. (basin_hierarchy(sp,sb) .GT. basin_hierarchy(sp,sbl)) ) THEN
6427	outflow_basin(sp,sb) = sbl
6428	inflow_number(sp,sbl) = inflow_number(sp,sbl) + 1
6429	IF ( inflow_number(sp,sbl) .LE. nbvmax ) THEN
6430	IF ( sp .EQ. 42 .AND. sbl .EQ. 1) THEN
6431	IF (check) &
6432	WRITE(numout,*) 'ADD INFLOW (3):', sp, sb
6433	ENDIF
6434	inflow_grid(sp, sbl, inflow_number(sp,sbl)) = sp
6435	inflow_basin(sp, sbl, inflow_number(sp,sbl)) = sb
6436	ELSE
6437	error4=.TRUE.
6438	EXIT
6439	ENDIF
6440	ENDIF
6441	ENDDO
6442	ENDIF
6443	!
6444	! Ok that is it, we give up :-)
6445	!
6446	IF ( outflow_grid(sp,sb) .GT. 0 .AND. outflow_basin(sp,sb) .EQ. undef_int &
6447	& .AND. basin_flowdir(sp,sb) .GT. 0) THEN
6448	!
6449	error5=.TRUE.
6450	EXIT
6451	ENDIF
6452	ENDDO
6453	!
6454	ENDDO
6455	IF (error1) THEN
6456	WRITE(numout,*) " routing_linkup : bop .LT. undef_int",bop
6457	CALL ipslerr_p(3,'routing_linkup', &
6458	"bop .LT. undef_int",'Increase nbvmax','stop routing_linkup')
6459	ENDIF
6460	IF (error2) THEN
6461	CALL ipslerr_p(3,'routing_linkup', &
6462	& 'In the routine which make connections between the basins and ensure global coherence,', &
6463	& 'there is a problem with outflow linkup without any valid direction. Try with check=.TRUE.', &
6464	& '(Perhaps there is a problem with the grid.)')
6465	ENDIF
6466	IF (error3) THEN
6467	WRITE(numout,*) " routing_linkup : dop .GT. 0 .AND. dop .NE. undef_int",dop
6468	CALL ipslerr_p(3,'routing_linkup', &
6469	"dop .GT. 0 .AND. dop .NE. undef_int",'Increase nbvmax. Try with check=.TRUE.','stop routing_linkup')
6470	ENDIF
6471	IF (error4) THEN
6472	WRITE(numout,*) " routing_linkup : (sbl .NE. sb) .AND. (basin_id(sp,sbl) .EQ. bid) ", &
6473	& " .AND. (basin_hierarchy(sp,sb) .GT. basin_hierarchy(sp,sbl))",sbl,sb,basin_id(sp,sbl),bid, &
6474	& basin_hierarchy(sp,sb),basin_hierarchy(sp,sbl)
6475	CALL ipslerr_p(3,'routing_linkup', &
6476	"(sbl .NE. sb) .AND. (basin_id(sp,sbl) .EQ. bid) .AND. (basin_hierarchy(sp,sb) .GT. basin_hierarchy(sp,sbl))" &
6477	,'Increase nbvmax. Try with check=.TRUE.','stop routing_linkup')
6478	ENDIF
6479	IF (error5) THEN
6480	WRITE(numout,*) 'We could not find the basin into which we need to flow'
6481	WRITE(numout,*) 'Grid point ', sp, ' and basin ', sb
6482	WRITE(numout,*) 'Explored neighbours :', dm1, dp1
6483	WRITE(numout,*) 'Outflow direction :', basin_flowdir(sp,sb)
6484	WRITE(numout,*) 'Outlfow grid :', outflow_grid(sp,sb)
6485	WRITE(numout,*) 'Outlfow basin :',outflow_basin(sp,sb)
6486	WRITE(numout,*) 'basin ID:',basin_id(sp,sb)
6487	WRITE(numout,*) 'Hierarchy :', basin_hierarchy(sp,sb)
6488	CALL ipslerr_p(3,'routing_linkup', &
6489	"We could not find the basin into which we need to flow",'Try with check=.TRUE.','stop routing_linkup')
6490	ENDIF
6491	!
6492	! Check for each outflow basin that it exists
6493	!
6494	DO sp=1,nbpt
6495	DO sb=1,basin_count(sp)
6496	!
6497	inp = outflow_grid(sp,sb)
6498	sbl = outflow_basin(sp,sb)
6499	IF ( inp .GE. 0 ) THEN
6500	IF ( basin_count(inp) .LT. sbl ) THEN
6501	WRITE(numout,*) 'point :', sp, ' basin :', sb
6502	WRITE(numout,*) 'Flows into point :', inp, ' basin :', sbl
6503	WRITE(numout,*) 'But it flows into now here as basin count = ', basin_count(inp)
6504	CALL ipslerr_p(3,'routing_linkup','Problem with outflow','','')
6505	ENDIF
6506	ENDIF
6507	ENDDO
6508	ENDDO
6509	!
6510	END SUBROUTINE routing_linkup
6511	!
6512	!! ================================================================================================================================
6513	!! SUBROUTINE : routing_fetch
6514	!!
6515	!>\BRIEF This subroutine computes the fetch of each basin. This means that for each basin we
6516	!! will know how much area is upstream. It will help decide how to procede with the
6517	!! the truncation later and allow to set correctly in outflow_grid the distinction
6518	!! between coastal and river flow.
6519	!!
6520	!! DESCRIPTION (definitions, functional, design, flags) : None
6521	!!
6522	!! RECENT CHANGE(S): None
6523	!!
6524	!! MAIN OUTPUT VARIABLE(S):
6525	!!
6526	!! REFERENCES : None
6527	!!
6528	!! FLOWCHART : None
6529	!! \n
6530	!_ ================================================================================================================================
6531
6532	SUBROUTINE routing_fetch(nbpt, resolution, contfrac, nwbas, basin_count, basin_area, basin_id,&
6533	& outflow_grid, outflow_basin, fetch_basin)
6534	!
6535	IMPLICIT NONE
6536	!
6537	!! INPUT VARIABLES
6538	INTEGER(i_std), INTENT(in) :: nbpt !! Domain size (unitless)
6539	!
6540	REAL(r_std), DIMENSION(nbpt,2), INTENT(in) :: resolution !! The size of each grid box in X and Y (m)
6541	REAL(r_std), DIMENSION(nbpt), INTENT(in) :: contfrac !! Fraction of land in each grid box (unitless;0-1)
6542	!
6543	INTEGER(i_std) :: nwbas !!
6544	INTEGER(i_std), DIMENSION(nbpt), INTENT(in) :: basin_count !!
6545	REAL(r_std), DIMENSION(nbpt,nwbas), INTENT(inout) :: basin_area !!
6546	INTEGER(i_std), DIMENSION(nbpt,nwbas), INTENT(in) :: basin_id !!
6547	INTEGER(i_std), DIMENSION(nbpt,nwbas), INTENT(inout) :: outflow_grid !! Type of outflow on the grid box (unitless)
6548	INTEGER(i_std), DIMENSION(nbpt,nwbas), INTENT(in) :: outflow_basin !!
6549	!
6550	!! OUTPUT VARIABLES
6551	REAL(r_std), DIMENSION(nbpt,nwbas), INTENT(out) :: fetch_basin !!
6552	!
6553	!! LOCAL VARIABLES
6554	INTEGER(i_std) :: ib, ij, ff(1), it, itt, igrif, ibasf, nboutflow !! Indices (unitless)
6555	REAL(r_std) :: contarea !!
6556	REAL(r_std) :: totbasins !!
6557	REAL(r_std), DIMENSION(nbpt*nbvmax) :: tmp_area !!
6558	INTEGER(i_std), DIMENSION(nbpt*nbvmax,2) :: tmpindex !!
6559
6560	!_ ================================================================================================================================
6561	!
6562	!
6563	! Normalize the area of all basins
6564	!
6565	DO ib=1,nbpt
6566	!
6567	totbasins = SUM(basin_area(ib,1:basin_count(ib)))
6568	contarea = resolution(ib,1)resolution(ib,2)contfrac(ib)
6569	!
6570	DO ij=1,basin_count(ib)
6571	basin_area(ib,ij) = basin_area(ib,ij)/totbasins*contarea
6572	ENDDO
6573	!
6574	ENDDO
6575	WRITE(numout,*) 'Normalization done'
6576	!
6577	! Compute the area upstream of each basin
6578	!
6579	fetch_basin(:,:) = zero
6580	!
6581	!
6582	DO ib=1,nbpt
6583	!
6584	DO ij=1,basin_count(ib)
6585	!
6586	fetch_basin(ib, ij) = fetch_basin(ib, ij) + basin_area(ib,ij)
6587	!
6588	igrif = outflow_grid(ib,ij)
6589	ibasf = outflow_basin(ib,ij)
6590	!
6591	itt = 0
6592	DO WHILE (igrif .GT. 0)
6593	fetch_basin(igrif,ibasf) = fetch_basin(igrif,ibasf) + basin_area(ib, ij)
6594	it = outflow_grid(igrif, ibasf)
6595	ibasf = outflow_basin(igrif, ibasf)
6596	igrif = it
6597	itt = itt + 1
6598	IF ( itt .GT. 500) THEN
6599	WRITE(numout,&
6600	"('Grid ',I5, ' and basin ',I5, 'did not converge after iteration ',I5)") ib, ij, itt
6601	WRITE(numout,*) 'Basin ID :', basin_id(igrif,ibasf)
6602	WRITE(numout,&
6603	"('We are stuck with the flow into grid ',I5,' and basin ',I5)") igrif, ibasf
6604	WRITE(numout,*) "Coordinates : ", lalo_g(igrif,2), lalo_g(igrif,1)
6605	IF ( itt .GT. 510) THEN
6606	CALL ipslerr_p(3,'routing_fetch','Problem...','','')
6607	ENDIF
6608	ENDIF
6609	ENDDO
6610	!
6611	ENDDO
6612	!
6613	ENDDO
6614	!
6615	WRITE(numout,*) 'The smallest FETCH :', MINVAL(fetch_basin)
6616	WRITE(numout,*) 'The largest FETCH :', MAXVAL(fetch_basin)
6617	!
6618	! Now we set for the 'num_largest' largest basins the outflow condition as stream flow
6619	! (i.e. outflow_grid = -1) and all other outflow basins are set to coastal flow
6620	! (i.e. outflow_grid = -2). The return flow is not touched.
6621	!
6622	nboutflow = 0
6623	!
6624	DO ib=1,nbpt
6625	!
6626	DO ij=1,basin_count(ib)
6627	!
6628	! We do not need any more the river flow flag as we are going to reset it.
6629	!
6630	IF ( outflow_grid(ib,ij) .EQ. -1) THEN
6631	outflow_grid(ib,ij) = -2
6632	ENDIF
6633	!
6634	IF ( outflow_grid(ib,ij) .EQ. -2) THEN
6635	!
6636	nboutflow = nboutflow + 1
6637	tmp_area(nboutflow) = fetch_basin(ib,ij)
6638	tmpindex(nboutflow,1) = ib
6639	tmpindex(nboutflow,2) = ij
6640	!
6641	ENDIF
6642	!
6643	ENDDO
6644	ENDDO
6645	!
6646	DO ib=1, num_largest
6647	ff = MAXLOC(tmp_area(1:nboutflow))
6648	outflow_grid(tmpindex(ff(1),1), tmpindex(ff(1),2)) = -1
6649	tmp_area(ff(1)) = zero
6650	ENDDO
6651	!
6652	END SUBROUTINE routing_fetch
6653	!
6654	!! ================================================================================================================================
6655	!! SUBROUTINE : routing_truncate
6656	!!
6657	!>\BRIEF This subroutine reduces the number of basins per grid to the value chosen by the user.
6658	!! It also computes the final field which will be used to route the water at the
6659	!! requested truncation.
6660	!!
6661	!! DESCRIPTION (definitions, functional, design, flags) :
6662	!! Truncate if needed and find the path closest to the high resolution data.
6663	!!
6664	!! The algorithm :
6665	!!
6666	!! We only go through this procedure only as many times as there are basins to take out at most.
6667	!! This is important as it allows the simplifications to spread from one grid to the other.
6668	!! The for each step of the iteration and at each grid point we check the following options for
6669	!! simplifying the pathways of water :
6670	!! 1) If the basin of a grid flows into another basin of the same grid. Kill the one which only
6671	!! served as a transition
6672	!! 2) If in one grid box we have a number of basins which flow into the ocean as coastal flow.
6673	!! We kill the smallest one and put into the largest basin. There is no need to manage many
6674	!! basins going into the ocean as coastal flows.
6675	!! 3) If we have streams run in parallel from one gird box to the others (that is these are
6676	!! different basins) we will put the smaller one in the larger one. This may hapen at any
6677	!! level of the flow but in theory it should propagate downstream.
6678	!! 4) If we have two basins with the same ID but flow into different grid boxes we sacrifice
6679	!! the smallest one and route it through the largest.
6680	!!
6681	!! Obviously if any of the options find something then we skip the rest and take out the basin.:\n
6682	!!
6683	!! RECENT CHANGE(S): None
6684	!!
6685	!! MAIN OUTPUT VARIABLE(S):
6686	!!
6687	!! REFERENCES : None
6688	!!
6689	!! FLOWCHART : None
6690	!! \n
6691	!_ ================================================================================================================================
6692
6693	SUBROUTINE routing_truncate(nbpt, resolution, contfrac, nwbas, basin_count, basin_area, basin_topoind,&
6694	& fetch_basin, basin_id, basin_flowdir, outflow_grid, outflow_basin, inflow_number,&
6695	& inflow_grid, inflow_basin)
6696	!
6697	IMPLICIT NONE
6698	!
6699	!! PARAMETERS
6700	INTEGER(i_std), PARAMETER :: pickmax = 200 !!
6701
6702	!! INPUT VARIABLES
6703	INTEGER(i_std) :: nbpt !! Domain size (unitless)
6704	!
6705	REAL(r_std), DIMENSION(nbpt,2) :: resolution !! The size of each grid box in X and Y (m)
6706	REAL(r_std), DIMENSION(nbpt), INTENT(in) :: contfrac !! Fraction of land in each grid box (unitless;0-1)
6707	!
6708	INTEGER(i_std) :: nwbas !!
6709	INTEGER(i_std), DIMENSION(nbpt) :: basin_count !!
6710	INTEGER(i_std), DIMENSION(nbpt,nwbas) :: basin_id !!
6711	INTEGER(i_std), DIMENSION(nbpt,nwbas) :: basin_flowdir !! Water flow directions in the basin (unitless)
6712	REAL(r_std), DIMENSION(nbpt,nwbas) :: basin_area !!
6713	REAL(r_std), DIMENSION(nbpt,nwbas) :: basin_topoind !! Topographic index of the residence time for a basin (m)
6714	REAL(r_std), DIMENSION(nbpt,nwbas) :: fetch_basin !!
6715	INTEGER(i_std), DIMENSION(nbpt,nwbas) :: outflow_grid !! Type of outflow on the grid box (unitless)
6716	INTEGER(i_std), DIMENSION(nbpt,nwbas) :: outflow_basin !!
6717	INTEGER(i_std), DIMENSION(nbpt,nwbas) :: inflow_number !!
6718	INTEGER(i_std), DIMENSION(nbpt,nwbas,nwbas) :: inflow_basin !!
6719	INTEGER(i_std), DIMENSION(nbpt,nwbas,nwbas) :: inflow_grid !!
6720	!
6721	!! LOCAL VARIABLES
6722	INTEGER(i_std) :: ib, ij, ibf, ijf, igrif, ibasf, cnt, pold, bold, ff(2) !! Indices (unitless)
6723	INTEGER(i_std) :: ii, kbas, sbas, ik, iter, ibt, obj !! Indices (unitless)
6724	REAL(r_std), DIMENSION(nbpt,nbasmax) :: floflo !!
6725	REAL(r_std), DIMENSION(nbpt) :: gridarea !!
6726	REAL(r_std), DIMENSION(nbpt) :: gridbasinarea !!
6727	REAL(r_std) :: ratio !!
6728	INTEGER(i_std), DIMENSION(pickmax,2) :: largest_basins !!
6729	INTEGER(i_std), DIMENSION(pickmax) :: tmp_ids !!
6730	INTEGER(i_std) :: multbas !!
6731	INTEGER(i_std) :: iml(1) !! X resolution of the high resolution grid
6732	INTEGER(i_std), DIMENSION(pickmax) :: multbas_sz !!
6733	REAL(r_std), DIMENSION(pickmax) :: tmp_area !!
6734	INTEGER(i_std), DIMENSION(pickmax,pickmax) :: multbas_list !!
6735	!
6736	INTEGER(i_std) :: nbtruncate !!
6737	INTEGER(i_std), SAVE, ALLOCATABLE, DIMENSION(:) :: indextrunc !!
6738	!$OMP THREADPRIVATE(indextrunc)
6739
6740	!_ ================================================================================================================================
6741	!
6742	!
6743	IF ( .NOT. ALLOCATED(indextrunc)) THEN
6744	ALLOCATE(indextrunc(nbpt))
6745	ENDIF
6746	!
6747	! We have to go through the grid as least as often as we have to reduce the number of basins
6748	! For good measure we add 3 more passages.
6749	!
6750	!
6751	DO iter = 1, MAXVAL(basin_count) - nbasmax +3
6752	!
6753	! Get the points over which we wish to truncate
6754	!
6755	nbtruncate = 0
6756	DO ib = 1, nbpt
6757	IF ( basin_count(ib) .GT. nbasmax ) THEN
6758	nbtruncate = nbtruncate + 1
6759	indextrunc(nbtruncate) = ib
6760	ENDIF
6761	ENDDO
6762	!
6763	! Go through the basins which need to be truncated.
6764	!
6765	DO ibt=1,nbtruncate
6766	!
6767	ib = indextrunc(ibt)
6768	!
6769	! Check if we have basin which flows into a basin in the same grid
6770	! kbas = basin we will have to kill
6771	! sbas = basin which takes over kbas
6772	!
6773	kbas = 0
6774	sbas = 0
6775	!
6776	! 1) Can we find a basin which flows into a basin of the same grid ?
6777	!
6778	DO ij=1,basin_count(ib)
6779	DO ii=1,basin_count(ib)
6780	IF ( outflow_grid(ib,ii) .EQ. ib .AND. outflow_basin(ib, ii) .EQ. ij .AND. kbas*sbas .NE. 0) THEN
6781	kbas = ii
6782	sbas = ij
6783	ENDIF
6784	ENDDO
6785	ENDDO
6786	!
6787	! 2) Merge two basins which flow into the ocean as coastal or return flow
6788	! (outflow_grid = -2 or -3). Well obviously only if we have more than 1 and
6789	! have not found anything yet!
6790	!
6791	IF ( (COUNT(outflow_grid(ib,1:basin_count(ib)) .EQ. -2) .GT. 1 .OR.&
6792	& COUNT(outflow_grid(ib,1:basin_count(ib)) .EQ. -3) .GT. 1) .AND.&
6793	& kbas*sbas .EQ. 0) THEN
6794	!
6795	multbas = 0
6796	multbas_sz(:) = 0
6797	!
6798	IF ( COUNT(outflow_grid(ib,1:basin_count(ib)) .EQ. -2) .GT. 1 ) THEN
6799	obj = -2
6800	ELSE
6801	obj = -3
6802	ENDIF
6803	!
6804	! First we get the list of all basins which go out as coastal or return flow (obj)
6805	!
6806	DO ij=1,basin_count(ib)
6807	IF ( outflow_grid(ib,ij) .EQ. obj ) THEN
6808	multbas = multbas + 1
6809	multbas_sz(multbas) = ij
6810	tmp_area(multbas) = fetch_basin(ib,ij)
6811	ENDIF
6812	ENDDO
6813	!
6814	! Now the take the smallest to be transfered to the largest
6815	!
6816	iml = MAXLOC(tmp_area(1:multbas), MASK = tmp_area(1:multbas) .GT. zero)
6817	sbas = multbas_sz(iml(1))
6818	iml = MINLOC(tmp_area(1:multbas), MASK = tmp_area(1:multbas) .GT. zero)
6819	kbas = multbas_sz(iml(1))
6820	!
6821	ENDIF
6822	!
6823	! 3) If we have basins flowing into the same grid but different basins then we put them
6824	! together. Obviously we first work with the grid which has most streams running into it
6825	! and putting the smallest in the largests catchments.
6826	!
6827	IF ( kbas*sbas .EQ. 0) THEN
6828	!
6829	tmp_ids(1:basin_count(ib)) = outflow_grid(ib,1:basin_count(ib))
6830	multbas = 0
6831	multbas_sz(:) = 0
6832	!
6833	! First obtain the list of basins which flow into the same basin
6834	!
6835	DO ij=1,basin_count(ib)
6836	IF ( outflow_grid(ib,ij) .GT. 0 .AND.&
6837	& COUNT(tmp_ids(1:basin_count(ib)) .EQ. outflow_grid(ib,ij)) .GT. 1) THEN
6838	multbas = multbas + 1
6839	DO ii=1,basin_count(ib)
6840	IF ( tmp_ids(ii) .EQ. outflow_grid(ib,ij)) THEN
6841	multbas_sz(multbas) = multbas_sz(multbas) + 1
6842	multbas_list(multbas,multbas_sz(multbas)) = ii
6843	tmp_ids(ii) = -99
6844	ENDIF
6845	ENDDO
6846	ELSE
6847	tmp_ids(ij) = -99
6848	ENDIF
6849	ENDDO
6850	!
6851	! Did we come up with any basins to deal with this way ?
6852	!
6853	IF ( multbas .GT. 0 ) THEN
6854	!
6855	iml = MAXLOC(multbas_sz(1:multbas))
6856	ik = iml(1)
6857	!
6858	! Take the smallest and largest of these basins !
6859	!
6860	DO ii=1,multbas_sz(ik)
6861	tmp_area(ii) = fetch_basin(ib, multbas_list(ik,ii))
6862	ENDDO
6863	!
6864	iml = MAXLOC(tmp_area(1:multbas_sz(ik)), MASK = tmp_area(1:multbas_sz(ik)) .GT. zero)
6865	sbas = multbas_list(ik,iml(1))
6866	iml = MINLOC(tmp_area(1:multbas_sz(ik)), MASK = tmp_area(1:multbas_sz(ik)) .GT. zero)
6867	kbas = multbas_list(ik,iml(1))
6868	!
6869	ENDIF
6870	!
6871	ENDIF
6872	!
6873	! 4) If we have twice the same basin we put them together even if they flow into different
6874	! directions. If one of them goes to the ocean it takes the advantage.
6875	!
6876	IF ( kbas*sbas .EQ. 0) THEN
6877	!
6878	tmp_ids(1:basin_count(ib)) = basin_id(ib,1:basin_count(ib))
6879	multbas = 0
6880	multbas_sz(:) = 0
6881	!
6882	! First obtain the list of basins which have sub-basins in this grid box.
6883	! (these are identified by their IDs)
6884	!
6885	DO ij=1,basin_count(ib)
6886	IF ( COUNT(tmp_ids(1:basin_count(ib)) .EQ. basin_id(ib,ij)) .GT. 1) THEN
6887	multbas = multbas + 1
6888	DO ii=1,basin_count(ib)
6889	IF ( tmp_ids(ii) .EQ. basin_id(ib,ij)) THEN
6890	multbas_sz(multbas) = multbas_sz(multbas) + 1
6891	multbas_list(multbas,multbas_sz(multbas)) = ii
6892	tmp_ids(ii) = -99
6893	ENDIF
6894	ENDDO
6895	ELSE
6896	tmp_ids(ij) = -99
6897	ENDIF
6898	ENDDO
6899	!
6900	! We are going to work on the basin with the largest number of sub-basins.
6901	! (IF we have a basin which has subbasins !)
6902	!
6903	IF ( multbas .GT. 0 ) THEN
6904	!
6905	iml = MAXLOC(multbas_sz(1:multbas))
6906	ik = iml(1)
6907	!
6908	! If one of the basins goes to the ocean then it is going to have the priority
6909	!
6910	tmp_area(:) = zero
6911	IF ( COUNT(outflow_grid(ib,multbas_list(ik,1:multbas_sz(ik))) .LT. 0) .GT. 0) THEN
6912	DO ii=1,multbas_sz(ik)
6913	IF ( outflow_grid(ib,multbas_list(ik,ii)) .LT. 0 .AND. sbas .EQ. 0 ) THEN
6914	sbas = multbas_list(ik,ii)
6915	ELSE
6916	tmp_area(ii) = fetch_basin(ib, multbas_list(ik,ii))
6917	ENDIF
6918	ENDDO
6919	! take the smallest of the subbasins
6920	iml = MINLOC(tmp_area(1:multbas_sz(ik)), MASK = tmp_area(1:multbas_sz(ik)) .GT. zero)
6921	kbas = multbas_list(ik,iml(1))
6922	ELSE
6923	!
6924	! Else we take simply the largest and smallest
6925	!
6926	DO ii=1,multbas_sz(ik)
6927	tmp_area(ii) = fetch_basin(ib, multbas_list(ik,ii))
6928	ENDDO
6929	iml = MAXLOC(tmp_area(1:multbas_sz(ik)), MASK = tmp_area(1:multbas_sz(ik)) .GT. zero)
6930	sbas = multbas_list(ik,iml(1))
6931	iml = MINLOC(tmp_area(1:multbas_sz(ik)), MASK = tmp_area(1:multbas_sz(ik)) .GT. zero)
6932	kbas = multbas_list(ik,iml(1))
6933	!
6934	ENDIF
6935	!
6936	!
6937	ENDIF
6938	ENDIF
6939	!
6940	!
6941	!
6942	! Then we call routing_killbas to clean up the basins in this grid
6943	!
6944	IF ( kbas .GT. 0 .AND. sbas .GT. 0 ) THEN
6945	CALL routing_killbas(nbpt, ib, kbas, sbas, nwbas, basin_count, basin_area, basin_topoind,&
6946	& fetch_basin, basin_id, basin_flowdir, outflow_grid, outflow_basin, inflow_number,&
6947	& inflow_grid, inflow_basin)
6948	ENDIF
6949	!
6950	ENDDO
6951	!
6952	!
6953	ENDDO
6954	!
6955	! If there are any grids left with too many basins we need to take out the big hammer !
6956	! We will only do it if this represents less than 5% of all points.
6957	!
6958	IF ( COUNT(basin_count .GT. nbasmax) .GT. 0 ) THEN
6959	!
6960	!
6961	IF ( COUNT(basin_count .GT. nbasmax)/nbpt*100 .GT. 5 ) THEN
6962	WRITE(numout,) 'We have ', COUNT(basin_count .GT. nbasmax)/nbpt100, '% of all points which do not yet'
6963	WRITE(numout,*) 'have the right trunctaction. That is too much to apply a brutal method'
6964	DO ib = 1, nbpt
6965	IF ( basin_count(ib) .GT. nbasmax ) THEN
6966	!
6967	WRITE(numout,*) 'We did not find a basin which could be supressed. We will'
6968	WRITE(numout,*) 'not be able to reduce the truncation in grid ', ib
6969	DO ij=1,basin_count(ib)
6970	WRITE(numout,*) 'grid, basin nb and id :', ib, ij, basin_id(ib,ij)
6971	WRITE(numout,*) 'Outflow grid and basin ->', outflow_grid(ib,ij), outflow_basin(ib, ij)
6972	ENDDO
6973	ENDIF
6974	ENDDO
6975	CALL ipslerr_p(3,'routing_truncate','No basin found which could be supressed.','','')
6976	ELSE
6977	!
6978	!
6979	DO ib = 1,nbpt
6980	DO WHILE ( basin_count(ib) .GT. nbasmax )
6981	!
6982	WRITE(numout,*) 'HAMMER, ib, basin_count :', ib, basin_count(ib)
6983	!
6984	! Here we simply put the smallest basins into the largest ones. It is really a brute force
6985	! method but it will only be applied if everything has failed.
6986	!
6987	DO ii = 1,basin_count(ib)
6988	tmp_area(ii) = fetch_basin(ib, ii)
6989	ENDDO
6990	!
6991	iml = MAXLOC(tmp_area(1:basin_count(ib)), MASK = tmp_area(1:basin_count(ib)) .GT. 0.)
6992	sbas =iml(1)
6993	iml = MINLOC(tmp_area(1:basin_count(ib)), MASK = tmp_area(1:basin_count(ib)) .GT. 0.)
6994	kbas = iml(1)
6995	!
6996	IF ( kbas .GT. 0 .AND. sbas .GT. 0 ) THEN
6997	CALL routing_killbas(nbpt, ib, kbas, sbas, nwbas, basin_count, basin_area, basin_topoind,&
6998	& fetch_basin, basin_id, basin_flowdir, outflow_grid, outflow_basin, inflow_number,&
6999	& inflow_grid, inflow_basin)
7000	ENDIF
7001	ENDDO
7002	ENDDO
7003	!
7004	ENDIF
7005	!
7006	!
7007	ENDIF
7008	!
7009	! Now that we have reached the right truncation (resolution) we will start
7010	! to produce the variables we will use to route the water.
7011	!
7012	DO ib=1,nbpt
7013	!
7014	! For non existing basins the route_tobasin variable is put to zero. This will allow us
7015	! to pick up the number of basin afterwards.
7016	!
7017	route_togrid(ib,:) = ib
7018	route_tobasin(ib,:) = 0
7019	routing_area(ib,:) = zero
7020	!
7021	ENDDO
7022	!
7023	! Transfer the info into the definitive variables
7024	!
7025	DO ib=1,nbpt
7026	DO ij=1,basin_count(ib)
7027	routing_area(ib,ij) = basin_area(ib,ij)
7028	topo_resid(ib,ij) = basin_topoind(ib,ij)
7029	global_basinid(ib,ij) = basin_id(ib,ij)
7030	route_togrid(ib,ij) = outflow_grid(ib,ij)
7031	route_tobasin(ib,ij) = outflow_basin(ib,ij)
7032	ENDDO
7033	ENDDO
7034	!
7035	!
7036	! Set the new convention for the outflow conditions
7037	! Now it is based in the outflow basin and the outflow grid will
7038	! be the same as the current.
7039	! returnflow to the grid : nbasmax + 1
7040	! coastal flow : nbasmax + 2
7041	! river outflow : nbasmax + 3
7042	!
7043	! Here we put everything here in coastal flow. It is later where we will
7044	! put the largest basins into river outflow.
7045	!
7046	DO ib=1,nbpt
7047	DO ij=1,basin_count(ib)
7048	! River flows
7049	IF ( route_togrid(ib,ij) .EQ. -1 ) THEN
7050	route_tobasin(ib,ij) = nbasmax + 2
7051	route_togrid(ib,ij) = ib
7052	! Coastal flows
7053	ELSE IF ( route_togrid(ib,ij) .EQ. -2 ) THEN
7054	route_tobasin(ib,ij) = nbasmax + 2
7055	route_togrid(ib,ij) = ib
7056	! Return flow
7057	ELSE IF ( route_togrid(ib,ij) .EQ. -3 ) THEN
7058	route_tobasin(ib,ij) = nbasmax + 1
7059	route_togrid(ib,ij) = ib
7060	ENDIF
7061	ENDDO
7062	ENDDO
7063	!
7064	! A second check on the data. Just make sure that each basin flows somewhere.
7065	!
7066	DO ib=1,nbpt
7067	DO ij=1,basin_count(ib)
7068	ibf = route_togrid(ib,ij)
7069	ijf = route_tobasin(ib,ij)
7070	IF ( ijf .GT. basin_count(ibf) .AND. ijf .LE. nbasmax) THEN
7071	WRITE(numout,*) 'Second check'
7072	WRITE(numout,*) 'point :', ib, ' basin :', ij
7073	WRITE(numout,*) 'Flows into point :', ibf, ' basin :', ijf
7074	WRITE(numout,*) 'But it flows into now here as basin count = ', basin_count(ibf)
7075	CALL ipslerr_p(3,'routing_truncate','Problem with routing..','','')
7076	ENDIF
7077	ENDDO
7078	ENDDO
7079	!
7080	! Verify areas of the continents
7081	!
7082	floflo(:,:) = zero
7083	gridarea(:) = contfrac(:)resolution(:,1)resolution(:,2)
7084	DO ib=1,nbpt
7085	gridbasinarea(ib) = SUM(routing_area(ib,:))
7086	ENDDO
7087	!
7088	DO ib=1,nbpt
7089	DO ij=1,basin_count(ib)
7090	cnt = 0
7091	igrif = ib
7092	ibasf = ij
7093	DO WHILE (ibasf .LE. nbasmax .AND. cnt .LT. nbasmax*nbpt)
7094	cnt = cnt + 1
7095	pold = igrif
7096	bold = ibasf
7097	igrif = route_togrid(pold, bold)
7098	ibasf = route_tobasin(pold, bold)
7099	IF ( ibasf .GT. basin_count(igrif) .AND. ibasf .LE. nbasmax) THEN
7100	WRITE(numout,*) 'We should not be here as the basin flows into the pampa'
7101	WRITE(numout,*) 'Last correct point :', pold, bold
7102	WRITE(numout,*) 'It pointed to in the new variables :', route_togrid(pold, bold),route_tobasin(pold, bold)
7103	WRITE(numout,*) 'The old variables gave :', outflow_grid(pold, bold), outflow_basin(pold, bold)
7104	WRITE(numout,*) 'Where we ended up :', igrif,ibasf
7105	CALL ipslerr_p(3,'routing_truncate','Problem with routing..','','')
7106	ENDIF
7107	ENDDO
7108	!
7109	IF ( ibasf .GT. nbasmax ) THEN
7110	floflo(igrif,bold) = floflo(igrif,bold) + routing_area(ib,ij)
7111	ELSE
7112	WRITE(numout,*) 'The flow did not end up in the ocean or in the grid cell.'
7113	WRITE(numout,*) 'For grid ', ib, ' and basin ', ij
7114	WRITE(numout,*) 'The last grid was ', igrif, ' and basin ', ibasf
7115	CALL ipslerr_p(3,'routing_truncate','Problem with routing..','','')
7116	ENDIF
7117	ENDDO
7118	ENDDO
7119	!
7120	DO ib=1,nbpt
7121	IF ( gridbasinarea(ib) > zero ) THEN
7122	ratio = gridarea(ib)/gridbasinarea(ib)
7123	routing_area(ib,:) = routing_area(ib,:)*ratio
7124	ELSE
7125	WRITE(numout,*) 'gridbasinarea(ib) <= zero. We should stop here :', ib
7126	ENDIF
7127	ENDDO
7128	!
7129	WRITE(numout,*) 'Sum of area of all outflow areas :',SUM(routing_area)
7130	WRITE(numout,*) 'Surface of all continents :', SUM(gridarea)
7131	!
7132	! Redo the the distinction between river outflow and coastal flow. We can not
7133	! take into account the return flow points.
7134	!
7135	ibf = 0
7136	DO ib=1, pickmax
7137	ff = MAXLOC(floflo)
7138	! tdo - To take into account rivers that do not flow to the oceans
7139	IF ( route_tobasin(ff(1), ff(2)) .GT. nbasmax ) THEN
7140	! IF ( route_tobasin(ff(1), ff(2)) .EQ. nbasmax + 2) THEN
7141	ibf = ibf + 1
7142	largest_basins(ibf,:) = ff(:)
7143	ENDIF
7144	floflo(ff(1), ff(2)) = zero
7145	ENDDO
7146	!
7147	! Put the largest basins into river flows.
7148	!
7149	IF ( ibf .LT. num_largest) THEN
7150	WRITE(numout,*) 'Not enough basins to choose the ', num_largest, 'largest'
7151	CALL ipslerr_p(3,'routing_truncate','Not enough basins','','')
7152	ENDIF
7153	!
7154	!
7155	!
7156	DO ib=1, num_largest
7157	route_tobasin(largest_basins(ib,1),largest_basins(ib,2)) = nbasmax + 3
7158	ENDDO
7159	!
7160	WRITE(numout,*) 'NUMBER OF RIVERS :', COUNT(route_tobasin .GE. nbasmax + 3)
7161	!
7162	END SUBROUTINE routing_truncate
7163	!
7164	!! ================================================================================================================================
7165	!! SUBROUTINE : routing_killbas
7166	!!
7167	!>\BRIEF The aim of this subroutine is to kill a basin (that is put into another larger one).
7168	!! When we do this we need to be careful and change all associated variables.
7169	!!
7170	!! DESCRIPTION (definitions, functional, design, flags) : None
7171	!!
7172	!! RECENT CHANGE(S): None
7173	!!
7174	!! MAIN OUTPUT VARIABLE(S):
7175	!!
7176	!! REFERENCES : None
7177	!!
7178	!! FLOWCHART : None
7179	!! \n
7180	!_ ================================================================================================================================
7181
7182	SUBROUTINE routing_killbas(nbpt, ib, tokill, totakeover, nwbas, basin_count, basin_area, basin_topoind,&
7183	& fetch_basin, basin_id, basin_flowdir, outflow_grid, outflow_basin, inflow_number,&
7184	& inflow_grid, inflow_basin)
7185	!
7186	!
7187	IMPLICIT NONE
7188	!
7189	INTEGER(i_std) :: tokill !!
7190	INTEGER(i_std) :: totakeover !!
7191	INTEGER(i_std) :: nbpt !! Domain size (unitless)
7192	INTEGER(i_std) :: ib !! Current basin (unitless)
7193	!
7194	INTEGER(i_std) :: nwbas !!
7195	INTEGER(i_std), DIMENSION(nbpt) :: basin_count !!
7196	INTEGER(i_std), DIMENSION(nbpt,nwbas) :: basin_id !!
7197	INTEGER(i_std), DIMENSION(nbpt,nwbas) :: basin_flowdir !! Water flow directions in the basin (unitless)
7198	REAL(r_std), DIMENSION(nbpt,nwbas) :: basin_area !!
7199	REAL(r_std), DIMENSION(nbpt,nwbas) :: basin_topoind !! Topographic index of the residence time for a basin (m)
7200	REAL(r_std), DIMENSION(nbpt,nwbas) :: fetch_basin !!
7201	INTEGER(i_std), DIMENSION(nbpt,nwbas) :: outflow_grid !! Type of outflow on the grid box (unitless)
7202	INTEGER(i_std), DIMENSION(nbpt,nwbas) :: outflow_basin !!
7203	INTEGER(i_std), DIMENSION(nbpt,nwbas) :: inflow_number !!
7204	INTEGER(i_std), DIMENSION(nbpt,nwbas,nwbas) :: inflow_basin !!
7205	INTEGER(i_std), DIMENSION(nbpt,nwbas,nwbas) :: inflow_grid !!
7206	!
7207	!! LOCAL VARIABLES
7208	INTEGER(i_std) :: inf, ibs, ing, inb, ibasf, igrif, it !! Indices (unitless)
7209	LOGICAL :: doshift !! (true/false)
7210
7211	!_ ================================================================================================================================
7212	!
7213	! Update the information needed in the basin "totakeover"
7214	! For the moment only area
7215	!
7216	WRITE(numout,*) 'KILL BASIN :', ib, tokill, totakeover, basin_id(ib,tokill), basin_id(ib,totakeover)
7217	!
7218	!
7219	basin_area(ib, totakeover) = basin_area(ib, totakeover) + basin_area(ib, tokill)
7220	basin_topoind(ib, totakeover) = (basin_topoind(ib, totakeover) + basin_topoind(ib, tokill))/2.0
7221	!
7222	! Add the fetch of the basin will kill to the one which gets the water
7223	!
7224	fetch_basin(ib, totakeover) = fetch_basin(ib, totakeover) + fetch_basin(ib, tokill)
7225	igrif = outflow_grid(ib,totakeover)
7226	ibasf = outflow_basin(ib,totakeover)
7227	!
7228	inf = 0
7229	DO WHILE (igrif .GT. 0)
7230	fetch_basin(igrif,ibasf) = fetch_basin(igrif,ibasf) + fetch_basin(ib, tokill)
7231	it = outflow_grid(igrif, ibasf)
7232	ibasf = outflow_basin(igrif, ibasf)
7233	igrif = it
7234	inf = inf + 1
7235	ENDDO
7236	!
7237	! Take out the basin we have just rerouted from the fetch of the basins in which it used to flow.
7238	!
7239	igrif = outflow_grid(ib,tokill)
7240	ibasf = outflow_basin(ib,tokill)
7241	!
7242	DO WHILE (igrif .GT. 0)
7243	fetch_basin(igrif,ibasf) = fetch_basin(igrif,ibasf) - fetch_basin(ib, tokill)
7244	it = outflow_grid(igrif, ibasf)
7245	ibasf = outflow_basin(igrif, ibasf)
7246	igrif = it
7247	ENDDO
7248	!
7249	! Redirect the flows which went into the basin to be killed before we change everything
7250	!
7251	DO inf = 1, inflow_number(ib, tokill)
7252	outflow_basin(inflow_grid(ib, tokill, inf), inflow_basin(ib, tokill, inf)) = totakeover
7253	inflow_number(ib, totakeover) = inflow_number(ib, totakeover) + 1
7254	inflow_grid(ib, totakeover, inflow_number(ib, totakeover)) = inflow_grid(ib, tokill, inf)
7255	inflow_basin(ib, totakeover, inflow_number(ib, totakeover)) = inflow_basin(ib, tokill, inf)
7256	ENDDO
7257	!
7258	! Take out the basin to be killed from the list of inflow basins of the downstream basin
7259	! (In case the basin does not flow into an ocean or lake)
7260	!
7261	IF ( outflow_grid(ib,tokill) .GT. 0) THEN
7262	!
7263	ing = outflow_grid(ib, tokill)
7264	inb = outflow_basin(ib, tokill)
7265	doshift = .FALSE.
7266	!
7267	DO inf = 1, inflow_number(ing, inb)
7268	IF ( doshift ) THEN
7269	inflow_grid(ing, inb, inf-1) = inflow_grid(ing, inb, inf)
7270	inflow_basin(ing, inb, inf-1) = inflow_basin(ing, inb, inf)
7271	ENDIF
7272	IF ( inflow_grid(ing, inb, inf) .EQ. ib .AND. inflow_basin(ing, inb, inf) .EQ. tokill) THEN
7273	doshift = .TRUE.
7274	ENDIF
7275	ENDDO
7276	!
7277	! This is only to allow for the last check
7278	!
7279	inf = inflow_number(ing, inb)
7280	IF ( inflow_grid(ing, inb, inf) .EQ. ib .AND. inflow_basin(ing, inb, inf) .EQ. tokill) THEN
7281	doshift = .TRUE.
7282	ENDIF
7283	!
7284	IF ( .NOT. doshift ) THEN
7285	WRITE(numout,*) 'Strange we did not find the basin to kill in the downstream basin'
7286	CALL ipslerr_p(3,'routing_killbas','Basin not found','','')
7287	ENDIF
7288	inflow_number(ing, inb) = inflow_number(ing, inb) - 1
7289
7290	ENDIF
7291	!
7292	! Now remove from the arrays the information of basin "tokill"
7293	!
7294	basin_id(ib, tokill:basin_count(ib)-1) = basin_id(ib, tokill+1:basin_count(ib))
7295	basin_flowdir(ib, tokill:basin_count(ib)-1) = basin_flowdir(ib, tokill+1:basin_count(ib))
7296	basin_area(ib, tokill:basin_count(ib)-1) = basin_area(ib, tokill+1:basin_count(ib))
7297	basin_area(ib, basin_count(ib):nwbas) = zero
7298	basin_topoind(ib, tokill:basin_count(ib)-1) = basin_topoind(ib, tokill+1:basin_count(ib))
7299	basin_topoind(ib, basin_count(ib):nwbas) = zero
7300	fetch_basin(ib, tokill:basin_count(ib)-1) = fetch_basin(ib, tokill+1:basin_count(ib))
7301	fetch_basin(ib, basin_count(ib):nwbas) = zero
7302	!
7303	! Before we remove the information from the outflow fields we have to correct the corresponding inflow fields
7304	! of the grids into which the flow goes
7305	!
7306	DO ibs = tokill+1,basin_count(ib)
7307	ing = outflow_grid(ib, ibs)
7308	inb = outflow_basin(ib, ibs)
7309	IF ( ing .GT. 0 ) THEN
7310	DO inf = 1, inflow_number(ing, inb)
7311	IF ( inflow_grid(ing,inb,inf) .EQ. ib .AND. inflow_basin(ing,inb,inf) .EQ. ibs) THEN
7312	inflow_basin(ing,inb,inf) = ibs - 1
7313	ENDIF
7314	ENDDO
7315	ENDIF
7316	ENDDO
7317	outflow_grid(ib, tokill:basin_count(ib)-1) = outflow_grid(ib, tokill+1:basin_count(ib))
7318	outflow_basin(ib, tokill:basin_count(ib)-1) = outflow_basin(ib, tokill+1:basin_count(ib))
7319	!
7320	! Basins which moved down also need to redirect their incoming flows.
7321	!
7322	DO ibs=tokill+1, basin_count(ib)
7323	DO inf = 1, inflow_number(ib, ibs)
7324	outflow_basin(inflow_grid(ib, ibs, inf), inflow_basin(ib, ibs, inf)) = ibs-1
7325	ENDDO
7326	ENDDO
7327	!
7328	! Shift the inflow basins
7329	!
7330	DO it = tokill+1,basin_count(ib)
7331	inflow_grid(ib, it-1, 1:inflow_number(ib,it)) = inflow_grid(ib, it, 1:inflow_number(ib,it))
7332	inflow_basin(ib, it-1, 1:inflow_number(ib,it)) = inflow_basin(ib, it, 1:inflow_number(ib,it))
7333	inflow_number(ib,it-1) = inflow_number(ib,it)
7334	ENDDO
7335	!
7336	basin_count(ib) = basin_count(ib) - 1
7337	!
7338	END SUBROUTINE routing_killbas
7339	!
7340	!! ================================================================================================================================
7341	!! SUBROUTINE : routing_names
7342	!!
7343	!>\BRIEF This subroutine lists the name of the largest basins which are explicitly listed in the basin
7344	!! description file used by ORCHIDEE.
7345	!!
7346	!! DESCRIPTION (definitions, functional, design, flags) : None
7347	!!
7348	!! RECENT CHANGE(S): None
7349	!!
7350	!! MAIN OUTPUT VARIABLE(S):
7351	!!
7352	!! REFERENCES : None
7353	!!
7354	!! FLOWCHART : None
7355	!! \n
7356	!_ ================================================================================================================================
7357
7358	SUBROUTINE routing_names(numlar, basin_names)
7359	!
7360	IMPLICIT NONE
7361	!
7362	! Arguments
7363	!
7364	INTEGER(i_std), INTENT(in) :: numlar !!
7365	CHARACTER(LEN=*), INTENT(inout) :: basin_names(numlar) !! Name of the basins (unitless)
7366	!! PARAMETERS
7367	INTEGER(i_std), PARAMETER :: listleng=349 !!
7368	!
7369	!! LOCAL VARIABLES
7370	INTEGER(i_std) :: lenstr, i !!
7371	CHARACTER(LEN=60), DIMENSION(listleng) :: list_names !!
7372	CHARACTER(LEN=60) :: tmp_str !!
7373
7374	!_ ================================================================================================================================
7375	!
7376
7377	lenstr = LEN(basin_names(1))
7378	!
7379	list_names(1) = "Amazon"
7380	list_names(2) = "Nile"
7381	list_names(3) = "Zaire"
7382	list_names(4) = "Mississippi"
7383	list_names(5) = "Amur"
7384	list_names(6) = "Parana"
7385	list_names(7) = "Yenisei"
7386	list_names(8) = "Ob"
7387	list_names(9) = "Lena"
7388	list_names(10) = "Niger"
7389	list_names(11) = "Zambezi"
7390	list_names(12) = "Erg Iguidi (Sahara)"
7391	list_names(13) = "Chang Jiang (Yangtze)"
7392	list_names(14) = "Mackenzie"
7393	list_names(15) = "Ganges"
7394	list_names(16) = "Chari"
7395	list_names(17) = "Volga"
7396	list_names(18) = "St. Lawrence"
7397	list_names(19) = "Indus"
7398	list_names(20) = "Syr-Darya"
7399	list_names(21) = "Nelson"
7400	list_names(22) = "Orinoco"
7401	list_names(23) = "Murray"
7402	list_names(24) = "Great Artesian Basin"
7403	list_names(25) = "Shatt el Arab"
7404	list_names(26) = "Orange"
7405	list_names(27) = "Huang He"
7406	list_names(28) = "Yukon"
7407	list_names(29) = "Senegal"
7408	list_names(30) = "Chott Jerid"
7409	list_names(31) = "Jubba"
7410	list_names(32) = "Colorado (Ari)"
7411	list_names(33) = "Rio Grande (US)"
7412	list_names(34) = "Danube"
7413	list_names(35) = "Mekong"
7414	list_names(36) = "Tocantins"
7415	list_names(37) = "Wadi al Farigh"
7416	list_names(38) = "Tarim"
7417	list_names(39) = "Columbia"
7418	list_names(40) = "Komadugu Yobe (Tchad)"
7419	list_names(41) = "Kolyma"
7420	list_names(42) = "Sao Francisco"
7421	list_names(43) = "Amu-Darya"
7422	list_names(44) = "GHAASBasin51"
7423	list_names(45) = "Dnepr"
7424	list_names(46) = "GHAASBasin61"
7425	list_names(47) = "Don"
7426	list_names(48) = "Colorado (Arg)"
7427	list_names(49) = "Limpopo"
7428	list_names(50) = "GHAASBasin50"
7429	list_names(51) = "Zhujiang"
7430	list_names(52) = "Irrawaddy"
7431	list_names(53) = "Volta"
7432	list_names(54) = "GHAASBasin54"
7433	list_names(55) = "Farah"
7434	list_names(56) = "Khatanga"
7435	list_names(57) = "Dvina"
7436	list_names(58) = "Urugay"
7437	list_names(59) = "Qarqan"
7438	list_names(60) = "GHAASBasin75"
7439	list_names(61) = "Parnaiba"
7440	list_names(62) = "GHAASBasin73"
7441	list_names(63) = "Indigirka"
7442	list_names(64) = "Churchill (Hud)"
7443	list_names(65) = "Godavari"
7444	list_names(66) = "Pur - Taz"
7445	list_names(67) = "Pechora"
7446	list_names(68) = "Baker"
7447	list_names(69) = "Ural"
7448	list_names(70) = "Neva"
7449	list_names(71) = "Liao"
7450	list_names(72) = "Salween"
7451	list_names(73) = "GHAASBasin73"
7452	list_names(74) = "Jordan"
7453	list_names(75) = "GHAASBasin78"
7454	list_names(76) = "Magdalena"
7455	list_names(77) = "Krishna"
7456	list_names(78) = "Salado"
7457	list_names(79) = "Fraser"
7458	list_names(80) = "Hai Ho"
7459	list_names(81) = "Huai"
7460	list_names(82) = "Yana"
7461	list_names(83) = "GHAASBasin95"
7462	list_names(84) = "GHAASBasin105"
7463	list_names(85) = "Kura"
7464	list_names(86) = "Olenek"
7465	list_names(87) = "Ogooue"
7466	list_names(88) = "Taymyr"
7467	list_names(89) = "Negro Arg"
7468	list_names(90) = "Chubut"
7469	list_names(91) = "GHAASBasin91"
7470	list_names(92) = "GHAASBasin122"
7471	list_names(93) = "GHAASBasin120"
7472	list_names(94) = "Sacramento"
7473	list_names(95) = "Fitzroy West"
7474	list_names(96) = "Grande de Santiago"
7475	list_names(97) = "Rufiji"
7476	list_names(98) = "Wisla"
7477	list_names(99) = "GHAASBasin47"
7478	list_names(100) = "GHAASBasin127"
7479	list_names(101) = "Hong"
7480	list_names(102) = "GHAASBasin97"
7481	list_names(103) = "Swan-Avon"
7482	list_names(104) = "Rhine"
7483	list_names(105) = "Cuanza"
7484	list_names(106) = "GHAASBasin106"
7485	list_names(107) = "GHAASBasin142"
7486	list_names(108) = "Roviuna"
7487	list_names(109) = "Essequibo"
7488	list_names(110) = "Elbe"
7489	list_names(111) = "Koksoak"
7490	list_names(112) = "Chao Phraya"
7491	list_names(113) = "Brahmani"
7492	list_names(114) = "GHAASBasin165"
7493	list_names(115) = "Pyasina"
7494	list_names(116) = "Fitzroy East"
7495	list_names(117) = "GHAASBasin173"
7496	list_names(118) = "Albany"
7497	list_names(119) = "Sanaga"
7498	list_names(120) = "GHAASBasin120"
7499	list_names(121) = "GHAASBasin178"
7500	list_names(122) = "GHAASBasin148"
7501	list_names(123) = "Brazos (Tex)"
7502	list_names(124) = "GHAASBasin124"
7503	list_names(125) = "Alabama"
7504	list_names(126) = "GHAASBasin174"
7505	list_names(127) = "GHAASBasin179"
7506	list_names(128) = "Balsas"
7507	list_names(129) = "GHAASBasin172"
7508	list_names(130) = "Burdekin"
7509	list_names(131) = "Colorado (Texas)"
7510	list_names(132) = "GHAASBasin150"
7511	list_names(133) = "Odra"
7512	list_names(134) = "Loire"
7513	list_names(135) = "GHAASBasin98"
7514	list_names(136) = "Galana"
7515	list_names(137) = "Kuskowin"
7516	list_names(138) = "Moose"
7517	list_names(139) = "Narmada"
7518	list_names(140) = "GHAASBasin140"
7519	list_names(141) = "GHAASBasin141"
7520	list_names(142) = "Flinders"
7521	list_names(143) = "Kizil Irmak"
7522	list_names(144) = "GHAASBasin144"
7523	list_names(145) = "Save"
7524	list_names(146) = "Roper"
7525	list_names(147) = "Churchill (Atlantic)"
7526	list_names(148) = "GHAASBasin148"
7527	list_names(149) = "Victoria"
7528	list_names(150) = "Back"
7529	list_names(151) = "Bandama"
7530	list_names(152) = "Severn (Can)"
7531	list_names(153) = "Po"
7532	list_names(154) = "GHAASBasin154"
7533	list_names(155) = "GHAASBasin155"
7534	list_names(156) = "GHAASBasin156"
7535	list_names(157) = "Rhone"
7536	list_names(158) = "Tana (Ken)"
7537	list_names(159) = "La Grande"
7538	list_names(160) = "GHAASBasin160"
7539	list_names(161) = "Cunene"
7540	list_names(162) = "Douro"
7541	list_names(163) = "GHAASBasin163"
7542	list_names(164) = "Nemanus"
7543	list_names(165) = "GHAASBasin165"
7544	list_names(166) = "Anabar"
7545	list_names(167) = "Hayes"
7546	list_names(168) = "Mearim"
7547	list_names(169) = "GHAASBasin169"
7548	list_names(170) = "Panuco"
7549	list_names(171) = "GHAASBasin171"
7550	list_names(172) = "Doce"
7551	list_names(173) = "Gasgoyne"
7552	list_names(174) = "GHAASBasin174"
7553	list_names(175) = "GHAASBasin175"
7554	list_names(176) = "Ashburton"
7555	list_names(177) = "GHAASBasin177"
7556	list_names(178) = "Peel"
7557	list_names(179) = "Daugava"
7558	list_names(180) = "GHAASBasin180"
7559	list_names(181) = "Ebro"
7560	list_names(182) = "Comoe"
7561	list_names(183) = "Jacui"
7562	list_names(184) = "GHAASBasin184"
7563	list_names(185) = "Kapuas"
7564	list_names(186) = "GHAASBasin186"
7565	list_names(187) = "Penzhina"
7566	list_names(188) = "Cauweri"
7567	list_names(189) = "GHAASBasin189"
7568	list_names(190) = "Mamberamo"
7569	list_names(191) = "Sepik"
7570	list_names(192) = "GHAASBasin192"
7571	list_names(193) = "Sassandra"
7572	list_names(194) = "GHAASBasin194"
7573	list_names(195) = "GHAASBasin195"
7574	list_names(196) = "Nottaway"
7575	list_names(197) = "Barito"
7576	list_names(198) = "GHAASBasin198"
7577	list_names(199) = "Seine"
7578	list_names(200) = "Tejo"
7579	list_names(201) = "GHAASBasin201"
7580	list_names(202) = "Gambia"
7581	list_names(203) = "Susquehanna"
7582	list_names(204) = "Dnestr"
7583	list_names(205) = "Murchinson"
7584	list_names(206) = "Deseado"
7585	list_names(207) = "Mitchell"
7586	list_names(208) = "Mahakam"
7587	list_names(209) = "GHAASBasin209"
7588	list_names(210) = "Pangani"
7589	list_names(211) = "GHAASBasin211"
7590	list_names(212) = "GHAASBasin212"
7591	list_names(213) = "GHAASBasin213"
7592	list_names(214) = "GHAASBasin214"
7593	list_names(215) = "GHAASBasin215"
7594	list_names(216) = "Bug"
7595	list_names(217) = "GHAASBasin217"
7596	list_names(218) = "Usumacinta"
7597	list_names(219) = "Jequitinhonha"
7598	list_names(220) = "GHAASBasin220"
7599	list_names(221) = "Corantijn"
7600	list_names(222) = "Fuchun Jiang"
7601	list_names(223) = "Copper"
7602	list_names(224) = "Tapti"
7603	list_names(225) = "Menjiang"
7604	list_names(226) = "Karun"
7605	list_names(227) = "Mezen"
7606	list_names(228) = "Guadiana"
7607	list_names(229) = "Maroni"
7608	list_names(230) = "GHAASBasin230"
7609	list_names(231) = "Uda"
7610	list_names(232) = "GHAASBasin232"
7611	list_names(233) = "Kuban"
7612	list_names(234) = "Colville"
7613	list_names(235) = "Thaane"
7614	list_names(236) = "Alazeya"
7615	list_names(237) = "Paraiba do Sul"
7616	list_names(238) = "GHAASBasin238"
7617	list_names(239) = "Fortesque"
7618	list_names(240) = "GHAASBasin240"
7619	list_names(241) = "GHAASBasin241"
7620	list_names(242) = "Winisk"
7621	list_names(243) = "GHAASBasin243"
7622	list_names(244) = "GHAASBasin244"
7623	list_names(245) = "Ikopa"
7624	list_names(246) = "Gilbert"
7625	list_names(247) = "Kouilou"
7626	list_names(248) = "Fly"
7627	list_names(249) = "GHAASBasin249"
7628	list_names(250) = "GHAASBasin250"
7629	list_names(251) = "GHAASBasin251"
7630	list_names(252) = "Mangoky"
7631	list_names(253) = "Damodar"
7632	list_names(254) = "Onega"
7633	list_names(255) = "Moulouya"
7634	list_names(256) = "GHAASBasin256"
7635	list_names(257) = "Ord"
7636	list_names(258) = "GHAASBasin258"
7637	list_names(259) = "GHAASBasin259"
7638	list_names(260) = "GHAASBasin260"
7639	list_names(261) = "GHAASBasin261"
7640	list_names(262) = "Narva"
7641	list_names(263) = "GHAASBasin263"
7642	list_names(264) = "Seal"
7643	list_names(265) = "Cheliff"
7644	list_names(266) = "Garonne"
7645	list_names(267) = "Rupert"
7646	list_names(268) = "GHAASBasin268"
7647	list_names(269) = "Brahmani"
7648	list_names(270) = "Sakarya"
7649	list_names(271) = "Gourits"
7650	list_names(272) = "Sittang"
7651	list_names(273) = "Rajang"
7652	list_names(274) = "Evros"
7653	list_names(275) = "Appalachicola"
7654	list_names(276) = "Attawapiskat"
7655	list_names(277) = "Lurio"
7656	list_names(278) = "Daly"
7657	list_names(279) = "Penner"
7658	list_names(280) = "GHAASBasin280"
7659	list_names(281) = "GHAASBasin281"
7660	list_names(282) = "Guadalquivir"
7661	list_names(283) = "Nadym"
7662	list_names(284) = "GHAASBasin284"
7663	list_names(285) = "Saint John"
7664	list_names(286) = "GHAASBasin286"
7665	list_names(287) = "Cross"
7666	list_names(288) = "Omoloy"
7667	list_names(289) = "Oueme"
7668	list_names(290) = "GHAASBasin290"
7669	list_names(291) = "Gota"
7670	list_names(292) = "Nueces"
7671	list_names(293) = "Stikine"
7672	list_names(294) = "Yalu"
7673	list_names(295) = "Arnaud"
7674	list_names(296) = "GHAASBasin296"
7675	list_names(297) = "Jequitinhonha"
7676	list_names(298) = "Kamchatka"
7677	list_names(299) = "GHAASBasin299"
7678	list_names(300) = "Grijalva"
7679	list_names(301) = "GHAASBasin301"
7680	list_names(302) = "Kemijoki"
7681	list_names(303) = "Olifants"
7682	list_names(304) = "GHAASBasin304"
7683	list_names(305) = "Tsiribihina"
7684	list_names(306) = "Coppermine"
7685	list_names(307) = "GHAASBasin307"
7686	list_names(308) = "GHAASBasin308"
7687	list_names(309) = "Kovda"
7688	list_names(310) = "Trinity"
7689	list_names(311) = "Glama"
7690	list_names(312) = "GHAASBasin312"
7691	list_names(313) = "Luan"
7692	list_names(314) = "Leichhardt"
7693	list_names(315) = "GHAASBasin315"
7694	list_names(316) = "Gurupi"
7695	list_names(317) = "GR Baleine"
7696	list_names(318) = "Aux Feuilles"
7697	list_names(319) = "GHAASBasin319"
7698	list_names(320) = "Weser"
7699	list_names(321) = "GHAASBasin321"
7700	list_names(322) = "GHAASBasin322"
7701	list_names(323) = "Yesil"
7702	list_names(324) = "Incomati"
7703	list_names(325) = "GHAASBasin325"
7704	list_names(326) = "GHAASBasin326"
7705	list_names(327) = "Pungoe"
7706	list_names(328) = "GHAASBasin328"
7707	list_names(329) = "Meuse"
7708	list_names(330) = "Eastmain"
7709	list_names(331) = "Araguari"
7710	list_names(332) = "Hudson"
7711	list_names(333) = "GHAASBasin333"
7712	list_names(334) = "GHAASBasin334"
7713	list_names(335) = "GHAASBasin335"
7714	list_names(336) = "GHAASBasin336"
7715	list_names(337) = "Kobuk"
7716	list_names(338) = "Altamaha"
7717	list_names(339) = "GHAASBasin339"
7718	list_names(340) = "Mand"
7719	list_names(341) = "Santee"
7720	list_names(342) = "GHAASBasin342"
7721	list_names(343) = "GHAASBasin343"
7722	list_names(344) = "GHAASBasin344"
7723	list_names(345) = "Hari"
7724	list_names(346) = "GHAASBasin346"
7725	list_names(347) = "Wami"
7726	list_names(348) = "GHAASBasin348"
7727	list_names(349) = "GHAASBasin349"
7728	!
7729	basin_names(:) = ' '
7730	!
7731	DO i=1,numlar
7732	tmp_str = list_names(i)
7733	basin_names(i) = tmp_str(1:MIN(lenstr,LEN_TRIM(tmp_str)))
7734	ENDDO
7735	!
7736	END SUBROUTINE routing_names
7737	!
7738	!! ================================================================================================================================
7739	!! SUBROUTINE : routing_irrigmap
7740	!!
7741	!>\BRIEF This subroutine interpolates the 0.5x0.5 degree based map of irrigated areas to the resolution of the model.
7742	!!
7743	!! DESCRIPTION (definitions, functional, design, flags) : None
7744	!!
7745	!! RECENT CHANGE(S): None
7746	!!
7747	!! MAIN OUTPUT VARIABLE(S):
7748	!!
7749	!! REFERENCES : None
7750	!!
7751	!! FLOWCHART : None
7752	!! \n
7753	!_ ================================================================================================================================
7754
7755	SUBROUTINE routing_irrigmap (nbpt, index, lalo, neighbours, resolution, contfrac, &
7756	& init_irrig, irrigated, init_flood, floodplains, init_swamp, swamp, hist_id, hist2_id)
7757	!
7758	IMPLICIT NONE
7759	!
7760	!! PARAMETERS
7761	INTEGER(i_std), PARAMETER :: ilake = 1 !! Number of type of lakes area (unitless)
7762	INTEGER(i_std), PARAMETER :: idam = 2 !! Number of type of dams area (unitless)
7763	INTEGER(i_std), PARAMETER :: iflood = 3 !! Number of type of floodplains area (unitless)
7764	INTEGER(i_std), PARAMETER :: iswamp = 4 !! Number of type of swamps area (unitless)
7765	INTEGER(i_std), PARAMETER :: isal = 5 !! Number of type of salines area (unitless)
7766	INTEGER(i_std), PARAMETER :: ipond = 6 !! Number of type of ponds area (unitless)
7767	INTEGER(i_std), PARAMETER :: ntype = 6 !! Number of types of flooded surfaces (unitless)
7768
7769	!! INPUT VARIABLES
7770	INTEGER(i_std), INTENT(in) :: nbpt !! Domain size (unitless)
7771	INTEGER(i_std), INTENT(in) :: index(nbpt) !! Index on the global map.
7772	REAL(r_std), INTENT(in) :: lalo(nbpt,2) !! Vector of latitude and longitudes (beware of the order !)
7773	INTEGER(i_std), INTENT(in) :: neighbours(nbpt,NbNeighb)!! Vector of neighbours for each grid point
7774	REAL(r_std), INTENT(in) :: resolution(nbpt,2) !! The size of each grid box in X and Y (m)
7775	REAL(r_std), INTENT(in) :: contfrac(nbpt) !! Fraction of land in each grid box (unitless;0-1)
7776	INTEGER(i_std), INTENT(in) :: hist_id !! Access to history file (unitless)
7777	INTEGER(i_std), INTENT(in) :: hist2_id !! Access to history file 2 (unitless)
7778	LOGICAL, INTENT(in) :: init_irrig !! Logical to initialize the irrigation (true/false)
7779	LOGICAL, INTENT(in) :: init_flood !! Logical to initialize the floodplains (true/false)
7780	LOGICAL, INTENT(in) :: init_swamp !! Logical to initialize the swamps (true/false)
7781	!
7782	!! OUTPUT VARIABLES
7783	REAL(r_std), INTENT(out) :: irrigated(:) !! Irrigated surface in each grid box (m^2)
7784	REAL(r_std), INTENT(out) :: floodplains(:) !! Surface which can be inundated in each grid box (m^2)
7785	REAL(r_std), INTENT(out) :: swamp(:) !! Surface which can be swamp in each grid box (m^2)
7786	!
7787	!! LOCAL VARIABLES
7788	! Interpolation variables
7789	!
7790	INTEGER(i_std) :: nbpmax, nix, njx, fopt !!
7791	CHARACTER(LEN=30) :: callsign !!
7792	REAL(r_std), ALLOCATABLE, DIMENSION(:,:,:) :: resol_lu !! Resolution read on the map
7793	INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:) :: mask !! Mask to exclude some points (unitless)
7794	REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: irrsub_area !! Area on the fine grid (m^2)
7795	INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:,:) :: irrsub_index !! Indices of the points we need on the fine grid (unitless)
7796	INTEGER :: ALLOC_ERR !!
7797	LOGICAL :: ok_interpol = .FALSE. !! Flag for interpolation (true/false)
7798	!
7799	CHARACTER(LEN=80) :: filename !! Name of the netcdf file (unitless)
7800	INTEGER(i_std) :: iml, jml, lml, tml, fid, ib, ip, jp, itype !! Indices (unitless)
7801	REAL(r_std) :: lev(1), date, dt, coslat !!
7802	INTEGER(i_std) :: itau(1) !!
7803	REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: latrel !! Latitude
7804	REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: lonrel !! Longitude
7805	REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: irrigated_frac !! Irrigated fraction of the grid box (unitless;0-1)
7806	REAL(r_std), ALLOCATABLE, DIMENSION(:,:,:) :: flood_fracmax !! Maximal flooded fraction of the grid box (unitless;0-1)
7807	REAL(r_std) :: area_irrig !! Irrigated surface in the grid box (m^2)
7808	REAL(r_std) :: area_flood(ntype) !! Flooded surface in the grid box (m^2)
7809	!!$ REAL(r_std) :: irrigmap(nbpt)
7810	!!$ REAL(r_std) :: floodmap(nbpt)
7811	!!$ REAL(r_std) :: swampmap(nbpt)
7812
7813	!_ ================================================================================================================================
7814
7815	!
7816	!Config Key = IRRIGATION_FILE
7817	!Config Desc = Name of file which contains the map of irrigated areas
7818	!Config Def = floodplains.nc
7819	!Config If = DO_IRRIGATION OR DO_FLOODPLAINS
7820	!Config Help = The name of the file to be opened to read the field
7821	!Config with the area in m^2 of the area irrigated within each
7822	!Config 0.5 0.5 deg grid box. The map currently used is the one
7823	!Config developed by the Center for Environmental Systems Research
7824	!Config in Kassel (1995).
7825	!Config Units = [FILE]
7826	!
7827	filename = 'floodplains.nc'
7828	CALL getin_p('IRRIGATION_FILE',filename)
7829	!
7830	IF (is_root_prc) THEN
7831	CALL flininfo(filename,iml, jml, lml, tml, fid)
7832	CALL flinclo(fid)
7833	ELSE
7834	iml = 0
7835	jml = 0
7836	lml = 0
7837	tml = 0
7838	ENDIF
7839	!
7840	CALL bcast(iml)
7841	CALL bcast(jml)
7842	CALL bcast(lml)
7843	CALL bcast(tml)
7844	!
7845	!
7846	!
7847	ALLOCATE (latrel(iml,jml), STAT=ALLOC_ERR)
7848	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_irrigmap','Pb in allocate for latrel','','')
7849
7850	ALLOCATE (lonrel(iml,jml), STAT=ALLOC_ERR)
7851	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_irrigmap','Pb in allocate for lonrel','','')
7852
7853	ALLOCATE (irrigated_frac(iml,jml), STAT=ALLOC_ERR)
7854	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_irrigmap','Pb in allocate for irrigated_frac','','')
7855
7856	ALLOCATE (flood_fracmax(iml,jml,ntype), STAT=ALLOC_ERR)
7857	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_irrigmap','Pb in allocate for flood_fracmax','','')
7858
7859	IF (is_root_prc) CALL flinopen(filename, .FALSE., iml, jml, lml, lonrel, latrel, lev, tml, itau, date, dt, fid)
7860
7861	CALL bcast(lonrel)
7862	CALL bcast(latrel)
7863	!
7864	IF (is_root_prc) CALL flinget(fid, 'irrig', iml, jml, lml, tml, 1, 1, irrigated_frac)
7865	CALL bcast(irrigated_frac)
7866	IF (is_root_prc) CALL flinget(fid, 'lake', iml, jml, lml, tml, 1, 1, flood_fracmax(:,:,ilake))
7867	IF (is_root_prc) CALL flinget(fid, 'dam', iml, jml, lml, tml, 1, 1, flood_fracmax(:,:,idam))
7868	IF (is_root_prc) CALL flinget(fid, 'flood', iml, jml, lml, tml, 1, 1, flood_fracmax(:,:,iflood))
7869	IF (is_root_prc) CALL flinget(fid, 'swamp', iml, jml, lml, tml, 1, 1, flood_fracmax(:,:,iswamp))
7870	IF (is_root_prc) CALL flinget(fid, 'saline', iml, jml, lml, tml, 1, 1, flood_fracmax(:,:,isal))
7871	CALL bcast(flood_fracmax)
7872	!
7873	IF (is_root_prc) CALL flinclo(fid)
7874	!
7875	! Set to zero all fraction which are less than 0.5%
7876	!
7877	DO ip=1,iml
7878	DO jp=1,jml
7879	!
7880	IF ( irrigated_frac(ip,jp) .LT. undef_sechiba-un) THEN
7881	irrigated_frac(ip,jp) = irrigated_frac(ip,jp)/100.
7882	IF ( irrigated_frac(ip,jp) < 0.005 ) irrigated_frac(ip,jp) = zero
7883	ENDIF
7884	!
7885	DO itype=1,ntype
7886	IF ( flood_fracmax(ip,jp,itype) .LT. undef_sechiba-1.) THEN
7887	flood_fracmax(ip,jp,itype) = flood_fracmax(ip,jp,itype)/100
7888	IF ( flood_fracmax(ip,jp,itype) < 0.005 ) flood_fracmax(ip,jp,itype) = zero
7889	ENDIF
7890	ENDDO
7891	!
7892	ENDDO
7893	ENDDO
7894	!
7895	WRITE(numout,*) 'lonrel : ', MAXVAL(lonrel), MINVAL(lonrel)
7896	WRITE(numout,*) 'latrel : ', MAXVAL(latrel), MINVAL(latrel)
7897	WRITE(numout,*) 'irrigated_frac : ', MINVAL(irrigated_frac, MASK=irrigated_frac .GT. 0), &
7898	& MAXVAL(irrigated_frac, MASK=irrigated_frac .LT. undef_sechiba)
7899	WRITE(numout,*) 'flood_fracmax : ', MINVAL(flood_fracmax, MASK=flood_fracmax .GT. 0), &
7900	& MAXVAL(flood_fracmax, MASK=flood_fracmax .LT. undef_sechiba)
7901	!
7902	! Consider all points a priori
7903	!
7904	ALLOCATE(resol_lu(iml,jml,2), STAT=ALLOC_ERR)
7905	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_irrigmap','Pb in allocate for resol_lu','','')
7906
7907	ALLOCATE(mask(iml,jml), STAT=ALLOC_ERR)
7908	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_irrigmap','Pb in allocate for mask','','')
7909	mask(:,:) = 0
7910
7911	DO ip=1,iml
7912	DO jp=1,jml
7913	!
7914	! Exclude the points where we are close to the missing value.
7915	!
7916	!MG This condition cannot be applied in floodplains/swamps configuration because
7917	! the same mask would be used for the interpolation of irrigation, floodplains and swamps maps.
7918	! IF ( irrigated_frac(ip,jp) < undef_sechiba ) THEN
7919	mask(ip,jp) = 1
7920	! ENDIF
7921	!
7922	! Resolution in longitude
7923	!
7924	coslat = MAX( COS( latrel(ip,jp) * pi/180. ), mincos )
7925	IF ( ip .EQ. 1 ) THEN
7926	resol_lu(ip,jp,1) = ABS( lonrel(ip+1,jp) - lonrel(ip,jp) ) * pi/180. * R_Earth * coslat
7927	ELSEIF ( ip .EQ. iml ) THEN
7928	resol_lu(ip,jp,1) = ABS( lonrel(ip,jp) - lonrel(ip-1,jp) ) * pi/180. * R_Earth * coslat
7929	ELSE
7930	resol_lu(ip,jp,1) = ABS( lonrel(ip+1,jp) - lonrel(ip-1,jp) )/2. * pi/180. * R_Earth * coslat
7931	ENDIF
7932	!
7933	! Resolution in latitude
7934	!
7935	IF ( jp .EQ. 1 ) THEN
7936	resol_lu(ip,jp,2) = ABS( latrel(ip,jp) - latrel(ip,jp+1) ) * pi/180. * R_Earth
7937	ELSEIF ( jp .EQ. jml ) THEN
7938	resol_lu(ip,jp,2) = ABS( latrel(ip,jp-1) - latrel(ip,jp) ) * pi/180. * R_Earth
7939	ELSE
7940	resol_lu(ip,jp,2) = ABS( latrel(ip,jp-1) - latrel(ip,jp+1) )/2. * pi/180. * R_Earth
7941	ENDIF
7942	!
7943	ENDDO
7944	ENDDO
7945	!
7946	! The number of maximum vegetation map points in the GCM grid is estimated.
7947	! Some lmargin is taken.
7948	!
7949	callsign = 'Irrigation map'
7950	ok_interpol = .FALSE.
7951	IF (is_root_prc) THEN
7952	nix=INT(MAXVAL(resolution_g(:,1))/MAXVAL(resol_lu(:,:,1)))+2
7953	njx=INT(MAXVAL(resolution_g(:,2))/MAXVAL(resol_lu(:,:,2)))+2
7954	nbpmax = nixnjx2
7955	WRITE(numout,*) "Projection arrays for ",callsign," : "
7956	WRITE(numout,*) "nbpmax = ",nbpmax, nix, njx
7957	ENDIF
7958	CALL bcast(nbpmax)
7959
7960	ALLOCATE(irrsub_index(nbpt, nbpmax, 2), STAT=ALLOC_ERR)
7961	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_irrigmap','Pb in allocate for irrsub_index','','')
7962	irrsub_index(:,:,:)=0
7963
7964	ALLOCATE(irrsub_area(nbpt, nbpmax), STAT=ALLOC_ERR)
7965	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_irrigmap','Pb in allocate for irrsub_area','','')
7966	irrsub_area(:,:)=zero
7967
7968	CALL aggregate_p(nbpt, lalo, neighbours, resolution, contfrac, &
7969	& iml, jml, lonrel, latrel, mask, callsign, &
7970	& nbpmax, irrsub_index, irrsub_area, ok_interpol)
7971	!
7972	!
7973	WHERE (irrsub_area < 0) irrsub_area=zero
7974	!
7975	! Test here if not all sub_area are larger than 0 if so, then we need to increase nbpmax
7976	!
7977	DO ib=1,nbpt
7978	!
7979	area_irrig = 0.0
7980	area_flood = 0.0
7981	!
7982	DO fopt=1,COUNT(irrsub_area(ib,:) > zero)
7983	!
7984	ip = irrsub_index(ib, fopt, 1)
7985	jp = irrsub_index(ib, fopt, 2)
7986	!
7987	IF (irrigated_frac(ip,jp) .LT. undef_sechiba-1.) THEN
7988	area_irrig = area_irrig + irrsub_area(ib,fopt)*irrigated_frac(ip,jp)
7989	ENDIF
7990	!
7991	DO itype=1,ntype
7992	IF (flood_fracmax(ip,jp,itype) .LT. undef_sechiba-1.) THEN
7993	area_flood(itype) = area_flood(itype) + irrsub_area(ib,fopt)*flood_fracmax(ip,jp,itype)
7994	ENDIF
7995	ENDDO
7996	ENDDO
7997	!
7998	! Put the total irrigated and flooded areas in the output variables
7999	!
8000	IF ( init_irrig ) THEN
8001	irrigated(ib) = MIN(area_irrig, resolution(ib,1)resolution(ib,2)contfrac(ib))
8002	IF ( irrigated(ib) < 0 ) THEN
8003	WRITE(numout,*) 'We have a problem here : ', irrigated(ib)
8004	WRITE(numout,*) 'resolution :', resolution(ib,1), resolution(ib,2)
8005	WRITE(numout,*) area_irrig
8006	CALL ipslerr_p(3,'routing_irrigmap','Problem with irrigated...','','')
8007	ENDIF
8008	!!$ ! Compute a diagnostic of the map.
8009	!!$ IF(contfrac(ib).GT.zero) THEN
8010	!!$ irrigmap (ib) = irrigated(ib) / ( resolution(ib,1)resolution(ib,2)contfrac(ib) )
8011	!!$ ELSE
8012	!!$ irrigmap (ib) = zero
8013	!!$ ENDIF
8014	!
8015	ENDIF
8016	!
8017	IF ( init_flood ) THEN
8018	floodplains(ib) = MIN(area_flood(iflood)+area_flood(idam)+area_flood(isal), &
8019	& resolution(ib,1)resolution(ib,2)contfrac(ib))
8020	IF ( floodplains(ib) < 0 ) THEN
8021	WRITE(numout,*) 'We have a problem here : ', floodplains(ib)
8022	WRITE(numout,*) 'resolution :', resolution(ib,1), resolution(ib,2)
8023	WRITE(numout,*) area_flood
8024	CALL ipslerr_p(3,'routing_irrigmap','Problem with floodplains..','','')
8025	ENDIF
8026	!!$ ! Compute a diagnostic of the map.
8027	!!$ IF(contfrac(ib).GT.zero) THEN
8028	!!$ floodmap(ib) = floodplains(ib) / ( resolution(ib,1)resolution(ib,2)contfrac(ib) )
8029	!!$ ELSE
8030	!!$ floodmap(ib) = 0.0
8031	!!$ ENDIF
8032	ENDIF
8033	!
8034	IF ( init_swamp ) THEN
8035	swamp(ib) = MIN(area_flood(iswamp), resolution(ib,1)resolution(ib,2)contfrac(ib))
8036	IF ( swamp(ib) < 0 ) THEN
8037	WRITE(numout,*) 'We have a problem here : ', swamp(ib)
8038	WRITE(numout,*) 'resolution :', resolution(ib,1), resolution(ib,2)
8039	WRITE(numout,*) area_flood
8040	CALL ipslerr_p(3,'routing_irrigmap','Problem with swamp...','','')
8041	ENDIF
8042	!!$ ! Compute a diagnostic of the map.
8043	!!$ IF(contfrac(ib).GT.zero) THEN
8044	!!$ swampmap(ib) = swamp(ib) / ( resolution(ib,1)resolution(ib,2)contfrac(ib) )
8045	!!$ ELSE
8046	!!$ swampmap(ib) = zero
8047	!!$ ENDIF
8048	ENDIF
8049	!
8050	!
8051	ENDDO
8052	!
8053	!
8054
8055	IF ( init_irrig ) WRITE(numout,*) "Diagnostics irrigated :", MINVAL(irrigated), MAXVAL(irrigated)
8056	IF ( init_flood ) WRITE(numout,*) "Diagnostics floodplains :", MINVAL(floodplains), MAXVAL(floodplains)
8057	IF ( init_swamp ) WRITE(numout,*) "Diagnostics swamp :", MINVAL(swamp), MAXVAL(swamp)
8058	!
8059	! No compensation is done for overlapping floodplains, swamp and irrig. At least overlapping will not
8060	! happen between floodplains and swamp alone
8061	! IF ( init_irrig .AND. init_flood ) THEN
8062	! DO ib = 1, nbpt
8063	! surp = (floodplains(ib)+swamp(ib)+irrigated(ib)) / (resolution(ib,1)resolution(ib,2)contfrac(ib))
8064	! IF ( surp .GT. un ) THEN
8065	! floodplains(ib) = floodplains(ib) / surp
8066	! swamp(ib) = swamp(ib) / surp
8067	! irrigated(ib) = irrigated(ib) / surp
8068	! ENDIF
8069	! ENDDO
8070	! ENDIF
8071	!
8072	DEALLOCATE (irrsub_area)
8073	DEALLOCATE (irrsub_index)
8074	!
8075	DEALLOCATE (mask)
8076	DEALLOCATE (resol_lu)
8077	!
8078	DEALLOCATE (lonrel)
8079	DEALLOCATE (latrel)
8080	!
8081	END SUBROUTINE routing_irrigmap
8082	!
8083	!! ================================================================================================================================
8084	!! SUBROUTINE : routing_waterbal
8085	!!
8086	!>\BRIEF This subroutine checks the water balance in the routing module.
8087	!!
8088	!! DESCRIPTION (definitions, functional, design, flags) : None
8089	!!
8090	!! RECENT CHANGE(S): None
8091	!!
8092	!! MAIN OUTPUT VARIABLE(S):
8093	!!
8094	!! REFERENCES : None
8095	!!
8096	!! FLOWCHART : None
8097	!! \n
8098	!_ ================================================================================================================================
8099
8100	SUBROUTINE routing_waterbal(nbpt, reinit, floodout, runoff, drainage, returnflow, &
8101	& reinfiltration, irrigation, riverflow, coastalflow)
8102	!
8103	IMPLICIT NONE
8104	!
8105	!! INPUT VARIABLES
8106	INTEGER(i_std), INTENT(in) :: nbpt !! Domain size (unitless)
8107	LOGICAL, INTENT(in) :: reinit !! Controls behaviour (true/false)
8108	REAL(r_std), INTENT(in) :: floodout(nbpt) !! Grid-point flow out of floodplains (kg/m^2/dt)
8109	REAL(r_std), INTENT(in) :: runoff(nbpt) !! Grid-point runoff (kg/m^2/dt)
8110	REAL(r_std), INTENT(in) :: drainage(nbpt) !! Grid-point drainage (kg/m^2/dt)
8111	REAL(r_std), INTENT(in) :: returnflow(nbpt) !! The water flow from lakes and swamps which returns to the grid box.
8112	!! This water will go back into the hydrol or hydrolc module to allow re-evaporation (kg/m^2/dt)
8113	REAL(r_std), INTENT(in) :: reinfiltration(nbpt) !! Water flow from ponds and floodplains which returns to the grid box (kg/m^2/dt)
8114	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)
8115	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)
8116	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)
8117	!
8118	! We sum-up all the water we have in the warious reservoirs
8119	!
8120	REAL(r_std), SAVE :: totw_flood !! Sum of all the water amount in the floodplains reservoirs (kg)
8121	!$OMP THREADPRIVATE(totw_flood)
8122	REAL(r_std), SAVE :: totw_stream !! Sum of all the water amount in the stream reservoirs (kg)
8123	!$OMP THREADPRIVATE(totw_stream)
8124	REAL(r_std), SAVE :: totw_fast !! Sum of all the water amount in the fast reservoirs (kg)
8125	!$OMP THREADPRIVATE(totw_fast)
8126	REAL(r_std), SAVE :: totw_slow !! Sum of all the water amount in the slow reservoirs (kg)
8127	!$OMP THREADPRIVATE(totw_slow)
8128	REAL(r_std), SAVE :: totw_lake !! Sum of all the water amount in the lake reservoirs (kg)
8129	!$OMP THREADPRIVATE(totw_lake)
8130	REAL(r_std), SAVE :: totw_pond !! Sum of all the water amount in the pond reservoirs (kg)
8131	!$OMP THREADPRIVATE(totw_pond)
8132	REAL(r_std), SAVE :: totw_in !! Sum of the water flow in to the routing scheme
8133	!$OMP THREADPRIVATE(totw_in)
8134	REAL(r_std), SAVE :: totw_out !! Sum of the water flow out to the routing scheme
8135	!$OMP THREADPRIVATE(totw_out)
8136	REAL(r_std), SAVE :: totw_return !!
8137	!$OMP THREADPRIVATE(totw_return)
8138	REAL(r_std), SAVE :: totw_irrig !!
8139	!$OMP THREADPRIVATE(totw_irrig)
8140	REAL(r_std), SAVE :: totw_river !!
8141	!$OMP THREADPRIVATE(totw_river)
8142	REAL(r_std), SAVE :: totw_coastal !!
8143	!$OMP THREADPRIVATE(totw_coastal)
8144	REAL(r_std) :: totarea !! Total area of basin (m^2)
8145	REAL(r_std) :: area !! Total area of routing (m^2)
8146	INTEGER(i_std) :: ig !!
8147	!
8148	! Just to make sure we do not get too large numbers !
8149	!
8150	!! PARAMETERS
8151	REAL(r_std), PARAMETER :: scaling = 1.0E+6 !!
8152	REAL(r_std), PARAMETER :: allowed_err = 50. !!
8153
8154	!_ ================================================================================================================================
8155	!
8156	IF ( reinit ) THEN
8157	!
8158	totw_flood = zero
8159	totw_stream = zero
8160	totw_fast = zero
8161	totw_slow = zero
8162	totw_lake = zero
8163	totw_pond = zero
8164	totw_in = zero
8165	!
8166	DO ig=1,nbpt
8167	!
8168	totarea = SUM(routing_area(ig,:))
8169	!
8170	totw_flood = totw_flood + SUM(flood_reservoir(ig,:)/scaling)
8171	totw_stream = totw_stream + SUM(stream_reservoir(ig,:)/scaling)
8172	totw_fast = totw_fast + SUM(fast_reservoir(ig,:)/scaling)
8173	totw_slow = totw_slow + SUM(slow_reservoir(ig,:)/scaling)
8174	totw_lake = totw_lake + lake_reservoir(ig)/scaling
8175	totw_pond = totw_pond + pond_reservoir(ig)/scaling
8176	!
8177	totw_in = totw_in + (runoff(ig)totarea + drainage(ig)totarea - floodout(ig)*totarea)/scaling
8178	!
8179	ENDDO
8180	!
8181	ELSE
8182	!
8183	totw_out = zero
8184	totw_return = zero
8185	totw_irrig = zero
8186	totw_river = zero
8187	totw_coastal = zero
8188	area = zero
8189	!
8190	DO ig=1,nbpt
8191	!
8192	totarea = SUM(routing_area(ig,:))
8193	!
8194	totw_flood = totw_flood - SUM(flood_reservoir(ig,:)/scaling)
8195	totw_stream = totw_stream - SUM(stream_reservoir(ig,:)/scaling)
8196	totw_fast = totw_fast - SUM(fast_reservoir(ig,:)/scaling)
8197	totw_slow = totw_slow - SUM(slow_reservoir(ig,:)/scaling)
8198	totw_lake = totw_lake - lake_reservoir(ig)/scaling
8199	totw_pond = totw_pond - pond_reservoir(ig)/scaling
8200	!
8201	totw_return = totw_return + (reinfiltration(ig)+returnflow(ig))*totarea/scaling
8202	totw_irrig = totw_irrig + irrigation(ig)*totarea/scaling
8203	totw_river = totw_river + riverflow(ig)/scaling
8204	totw_coastal = totw_coastal + coastalflow(ig)/scaling
8205	!
8206	area = area + totarea
8207	!
8208	ENDDO
8209	totw_out = totw_return + totw_irrig + totw_river + totw_coastal
8210	!
8211	! Now we have all the information to balance our water
8212	!
8213	IF ( ABS((totw_flood + totw_stream + totw_fast + totw_slow + totw_lake + totw_pond) - &
8214	& (totw_out - totw_in)) > allowed_err ) THEN
8215	WRITE(numout,*) 'WARNING : Water not conserved in routing. Limit at ', allowed_err, ' 10^6 kg'
8216	WRITE(numout,*) '--Water-- change : flood stream fast ', totw_flood, totw_stream, totw_fast
8217	WRITE(numout,*) '--Water-- change : slow, lake ', totw_slow, totw_lake
8218	WRITE(numout,*) '--Water>>> change in the routing res. : ', totw_flood + totw_stream + totw_fast + totw_slow + totw_lake
8219	WRITE(numout,*) '--Water input : ', totw_in
8220	WRITE(numout,*) '--Water output : ', totw_out
8221	WRITE(numout,*) '--Water output : return, irrig ', totw_return, totw_irrig
8222	WRITE(numout,*) '--Water output : river, coastal ',totw_river, totw_coastal
8223	WRITE(numout,*) '--Water>>> change by fluxes : ', totw_out - totw_in, ' Diff [mm/dt]: ', &
8224	& ((totw_flood + totw_stream + totw_fast + totw_slow + totw_lake) - (totw_out - totw_in))/area
8225
8226	! Stop the model
8227	CALL ipslerr_p(3, 'routing_waterbal', 'Water is not conserved in routing.','','')
8228	ENDIF
8229	!
8230	ENDIF
8231	!
8232	END SUBROUTINE routing_waterbal
8233	!
8234	!
8235	END MODULE routing

Note: See TracBrowser for help on using the repository browser.

Download in other formats: