Context Navigation

source: branches/publications/ORCHIDEE_3_r6863/ORCHIDEE/src_sechiba/routing.f90

Last change on this file was 6190, checked in by josefine.ghattas, 5 years ago

Added more subroutines included in the interfaces for restget/restput/histwrite_p to be able to handle more dimensions.
For more information, see ticket #596

Done by A. Jornet

Property svn:keywords set to Revision Date HeadURL Date Author Revision

File size: 369.7 KB

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

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

Download in other formats: