Context Navigation

routing.f90 @ 8504

Last change on this file since 8504 was 8504, checked in by josefine.ghattas, 2 months ago
Integrated correction done in the trunk [8503] for compilation without XIOS.
Property svn:keywords set to `Revision Date HeadURL Date Author Revision`
File size: 394.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): July 2022: New irrigation scheme. Here new irrigation offer with more information from maps, and
15	!! calculation of water withdrawal.
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, routing_names, routing_xios_initialize
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(:) :: irrigdeficit_mean !! Mean irrigation deficit.
229	!! This is between irrigation and water requirement (kg/m^2/dt)
230	!$OMP THREADPRIVATE(irrigdeficit_mean)
231	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: irrigation_mean !! Mean irrigation flux.
232	!! This is the water taken from the reservoirs and beeing put into the upper layers of the soil (kg/m^2/dt)
233	!$OMP THREADPRIVATE(irrigation_mean)
234	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: irrig_gw_source_mean !! Mean groundwater irrigation flux.
235	!! This is the water taken from the GW reservoir only (kg/m^2/dt)
236	!$OMP THREADPRIVATE(irrig_gw_source_mean)
237	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: irrig_fast_source_mean !! Mean irrigation flux from fast.
238	!! This is the water taken from the fast reservoir only (kg/m^2/dt)
239	!$OMP THREADPRIVATE(irrig_fast_source_mean)
240	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: irrig_str_source_mean !! Mean streamflow irrigation flux.
241	!! This is the water taken from the streamflow reservoir only (kg/m^2/dt)
242	!$OMP THREADPRIVATE(irrig_str_source_mean)
243	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: irrigadduct_mean !! Irrigation that comes from adduction. It includes water from basins inside the grid cell
244	! and water from nearby grid cells
245	!$OMP THREADPRIVATE(irrigadduct_mean)
246	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: riverflow_mean !! Mean Outflow of the major rivers.
247	!! The flux will be located on the continental grid but this should be a coastal point (kg/dt)
248	!$OMP THREADPRIVATE(riverflow_mean)
249	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: coastalflow_mean !! Mean outflow on coastal points by small basins.
250	!! This is the water which flows in a disperse way into the ocean (kg/dt)
251	!$OMP THREADPRIVATE(coastalflow_mean)
252	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: floodtemp !! Temperature to decide if floodplains work (K)
253	!$OMP THREADPRIVATE(floodtemp)
254	INTEGER(i_std), SAVE :: floodtemp_lev !! Temperature level to decide if floodplains work (K)
255	!$OMP THREADPRIVATE(floodtemp_lev)
256	!
257	! Diagnostic variables ... well sort of !
258	!
259	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: irrig_netereq !! Irrigation requirement (water requirements by the crop for its optimal growth (kg/m^2/dt)
260	!$OMP THREADPRIVATE(irrig_netereq)
261	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: hydrographs !! Hydrographs at the outflow of the grid box for major basins (kg/dt)
262	!$OMP THREADPRIVATE(hydrographs)
263	!
264	! Diagnostics for the various reservoirs we use (Kg/m^2)
265	!
266	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: fast_diag !! Diagnostic for the fast reservoir (kg/m^2)
267	!$OMP THREADPRIVATE(fast_diag)
268	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: slow_diag !! Diagnostic for the slow reservoir (kg/m^2)
269	!$OMP THREADPRIVATE(slow_diag)
270	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: stream_diag !! Diagnostic for the stream reservoir (kg/m^2)
271	!$OMP THREADPRIVATE(stream_diag)
272	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: flood_diag !! Diagnostic for the floodplain reservoir (kg/m^2)
273	!$OMP THREADPRIVATE(flood_diag)
274	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: pond_diag !! Diagnostic for the pond reservoir (kg/m^2)
275	!$OMP THREADPRIVATE(pond_diag)
276	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: lake_diag !! Diagnostic for the lake reservoir (kg/m^2)
277	!$OMP THREADPRIVATE(lake_diag)
278
279	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: mask_coast !! Mask with coastal gridcells on local grid(1/0)
280	!$OMP THREADPRIVATE(mask_coast)
281	REAL(r_std), SAVE :: max_lake_reservoir !! Maximum limit of water in lake_reservoir [kg/m2]
282	!$OMP THREADPRIVATE(max_lake_reservoir)
283	INTEGER(i_std), SAVE :: nb_coast_gridcells !! Number of gridcells which can receive coastalflow
284	!$OMP THREADPRIVATE(nb_coast_gridcells)
285
286
287	CONTAINS
288	!! =============================================================================================================================
289	!! SUBROUTINE: routing_initialize
290	!!
291	!>\BRIEF Initialize the routing module
292	!!
293	!! DESCRIPTION: Initialize the routing module. Read from restart file or read the routing.nc file to initialize the
294	!! routing scheme.
295	!!
296	!! RECENT CHANGE(S)
297	!!
298	!! REFERENCE(S)
299	!!
300	!! FLOWCHART
301	!! \n
302	!_ ==============================================================================================================================
303
304	SUBROUTINE routing_initialize( kjit, nbpt, index, &
305	rest_id, hist_id, hist2_id, lalo, &
306	neighbours, resolution, contfrac, stempdiag, &
307	returnflow, reinfiltration, irrigation, riverflow, &
308	coastalflow, flood_frac, flood_res, soiltile, irrig_frac, &
309	veget_max, irrigated_next) !
310
311	IMPLICIT NONE
312
313	!! 0.1 Input variables
314	INTEGER(i_std), INTENT(in) :: kjit !! Time step number (unitless)
315	INTEGER(i_std), INTENT(in) :: nbpt !! Domain size (unitless)
316	INTEGER(i_std), INTENT(in) :: index(nbpt) !! Indices of the points on the map (unitless)
317	INTEGER(i_std),INTENT(in) :: rest_id !! Restart file identifier (unitless)
318	INTEGER(i_std),INTENT(in) :: hist_id !! Access to history file (unitless)
319	INTEGER(i_std),INTENT(in) :: hist2_id !! Access to history file 2 (unitless)
320	REAL(r_std), INTENT(in) :: lalo(nbpt,2) !! Vector of latitude and longitudes (beware of the order !)
321
322	INTEGER(i_std), INTENT(in) :: neighbours(nbpt,NbNeighb) !! Vector of neighbours for each grid point
323	!! (1=N, 2=NE, 3=E, 4=SE, 5=S, 6=SW, 7=W, 8=NW) (unitless)
324	REAL(r_std), INTENT(in) :: resolution(nbpt,2) !! The size of each grid box in X and Y (m)
325	REAL(r_std), INTENT(in) :: contfrac(nbpt) !! Fraction of land in each grid box (unitless;0-1)
326	REAL(r_std), INTENT(in) :: stempdiag(nbpt,nslm) !! Diagnostic soil temperature profile
327	REAL(r_std), INTENT(in) :: soiltile(nbpt,nstm) !! Fraction of each soil tile within vegtot (0-1, unitless)
328	REAL(r_std), INTENT(in) :: veget_max(nbpt,nvm) !! Maximal fraction of vegetation (unitless;0-1) !
329	REAL(r_std), INTENT(in) :: irrigated_next (nbpt) !! Dynamic irrig. area, calculated in slowproc and passed to routing!
330	REAL(r_std), INTENT(in) :: irrig_frac(nbpt) !! Irrig. fraction interpolated in routing, and saved to pass to slowproc if irrigated_soiltile = .TRUE.
331
332	!! 0.2 Output variables
333	REAL(r_std), INTENT(out) :: returnflow(nbpt) !! The water flow from lakes and swamps which returns to the grid box.
334	!! This water will go back into the hydrol module to allow re-evaporation (kg/m^2/dt)
335	REAL(r_std), INTENT(out) :: reinfiltration(nbpt) !! Water flow from ponds and floodplains which returns to the grid box (kg/m^2/dt)
336	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)
337	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)
338
339	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)
340	REAL(r_std), INTENT(out) :: flood_frac(nbpt) !! Flooded fraction of the grid box (unitless;0-1)
341	REAL(r_std), INTENT(out) :: flood_res(nbpt) !! Diagnostic of water amount in the floodplains reservoir (kg)
342
343	!! 0.3 Local variables
344	REAL(r_std), DIMENSION(nbp_glo):: mask_coast_glo !! Mask with coastal gridcells on global grid (1/0)
345	!LOGICAL :: init_irrig !! Logical to initialize the irrigation (true/false)
346	LOGICAL :: init_flood !! Logical to initialize the floodplains (true/false)
347	LOGICAL :: init_swamp !! Logical to initialize the swamps (true/false)
348	INTEGER :: ig, ib, rtg, rtb !! Index
349	INTEGER :: ier !! Error handeling
350	!_ ================================================================================================================================
351
352	!
353	! do initialisation
354	!
355	nbvmax = 440
356	! Here we will allocate the memory and get the fixed fields from the restart file.
357	! If the info is not found then we will compute the routing map.
358	!
359
360	CALL routing_init (kjit, nbpt, index, returnflow, reinfiltration, irrigation, &
361	riverflow, coastalflow, flood_frac, flood_res, stempdiag, rest_id)
362
363	routing_area => routing_area_loc
364	topo_resid => topo_resid_loc
365	route_togrid => route_togrid_loc
366	route_tobasin => route_tobasin_loc
367	global_basinid => global_basinid_loc
368	hydrodiag => hydrodiag_loc
369
370	! This routine computes the routing map if the route_togrid_glo is undefined. This means that the
371	! map has not been initialized during the restart process..
372	!
373	!! Reads in the map of the basins and flow directions to construct the catchments of each grid box
374	!
375	IF ( COUNT(route_togrid_glo .GE. undef_int) .GT. 0 ) THEN
376	CALL routing_basins_p(nbpt, lalo, neighbours, resolution, contfrac)
377	ENDIF
378
379	!! Create a mask containing all possible coastal gridcells and count total number of coastal gridcells
380	IF (is_root_prc) THEN
381	mask_coast_glo(:)=0
382	DO ib=1,nbasmax
383	DO ig=1,nbp_glo
384	rtg = route_togrid_glo(ig,ib)
385	rtb = route_tobasin_glo(ig,ib)
386	! Coastal gridcells are stored in nbasmax+2
387	IF (rtb == nbasmax+2) THEN
388	mask_coast_glo(rtg) = 1
389	END IF
390	END DO
391	END DO
392	nb_coast_gridcells=SUM(mask_coast_glo)
393	IF (printlev>=3) WRITE(numout,*) 'Number of coastal gridcells = ', nb_coast_gridcells
394	ENDIF
395	CALL bcast(nb_coast_gridcells)
396
397	ALLOCATE(mask_coast(nbpt), stat=ier)
398	IF (ier /= 0) CALL ipslerr_p(3,'routing_inititalize','Pb in allocate for mask_coast','','')
399	CALL scatter(mask_coast_glo, mask_coast)
400	CALL xios_orchidee_send_field("mask_coast",mask_coast)
401
402
403	!
404	! Do we have what we need if we want to do irrigation
405	!! Initialisation of flags for irrigated land, flood plains and swamps
406	!
407	IF ( do_irrigation ) THEN
408	irrigated(:) = irrigated_next(:)
409	END IF
410
411	init_flood = .FALSE.
412	IF ( do_floodplains ) THEN
413	IF (COUNT(floodplains .GE. undef_sechiba-1) > 0) init_flood = .TRUE.
414	END IF
415
416	init_swamp = .FALSE.
417	IF ( doswamps ) THEN
418	IF (COUNT(swamp .GE. undef_sechiba-1) > 0 ) init_swamp = .TRUE.
419	END IF
420
421	!! If we have irrigated land, flood plains or swamps then we need to interpolate the 0.5 degree
422	!! base data set to the resolution of the model.
423	!IF ( init_irrig .OR. init_flood .OR. init_swamp ) THEN
424	IF ( init_flood .OR. init_swamp ) THEN
425	CALL routing_floodmap(nbpt, index, lalo, neighbours, resolution, &
426	contfrac, init_flood, floodplains, init_swamp, swamp, hist_id, hist2_id)
427	ENDIF
428
429	IF ( do_irrigation ) THEN
430
431	IF (printlev >= 3) WRITE(numout,*) 'Verification : range of irrigated : ', MINVAL(irrigated), MAXVAL(irrigated)
432	IF (printlev >= 3) WRITE(numout,*) 'Verification : range of irrig_frac : ', MINVAL(irrig_frac), MAXVAL(irrig_frac)
433	ENDIF
434
435	IF ( doswamps ) THEN
436	CALL xios_orchidee_send_field("swampmap",swamp)
437
438	IF (printlev>=3) WRITE(numout,*) 'Verification : range of swamp : ', MINVAL(swamp), MAXVAL(swamp)
439	IF ( .NOT. almaoutput ) THEN
440	CALL histwrite_p(hist_id, 'swampmap', 1, swamp, nbpt, index)
441	ELSE
442	CALL histwrite_p(hist_id, 'SwampMap', 1, swamp, nbpt, index)
443	ENDIF
444	IF ( hist2_id > 0 ) THEN
445	IF ( .NOT. almaoutput ) THEN
446	CALL histwrite_p(hist2_id, 'swampmap', 1, swamp, nbpt, index)
447	ELSE
448	CALL histwrite_p(hist2_id, 'SwampMap', 1, swamp, nbpt, index)
449	ENDIF
450	ENDIF
451	ENDIF
452
453	!! This routine gives a diagnostic of the basins used.
454	CALL routing_diagnostic_p(nbpt, index, lalo, resolution, contfrac, hist_id, hist2_id)
455
456	END SUBROUTINE routing_initialize
457
458	!! =============================================================================================================================
459	!! SUBROUTINE: routing_xios_initialize
460	!!
461	!>\BRIEF Initialize xios dependant defintion before closing context defintion
462	!!
463	!! DESCRIPTION: Initialize xios dependant defintion before closing context defintion.
464	!! This subroutine is called before the xios context is closed.
465	!!
466	!! RECENT CHANGE(S): None
467	!!
468	!! REFERENCE(S): None
469	!!
470	!! FLOWCHART: None
471	!! \n
472	!_ ==============================================================================================================================
473
474	SUBROUTINE routing_xios_initialize
475	USE xios_orchidee
476	IMPLICIT NONE
477
478	INTEGER(i_std) ::ib
479
480	! Add axis for homogeneity between all routing schemes, these dimensions are currently not used in this scheme
481	CALL xios_orchidee_addaxis("nbhtu", nbasmax, (/(REAL(ib,r_std),ib=1,nbasmax)/))
482	CALL xios_orchidee_addaxis("nbasmon", 1, (/(REAL(ib,r_std),ib=1,1)/))
483
484	END SUBROUTINE routing_xios_initialize
485
486	!! ================================================================================================================================
487	!! SUBROUTINE : routing_main
488	!!
489	!>\BRIEF This module routes the water over the continents (runoff and
490	!! drainage produced by the hydrol module) into the oceans.
491	!!
492	!! DESCRIPTION (definitions, functional, design, flags):
493	!! The routing scheme (Polcher, 2003) carries the water from the runoff and drainage simulated by SECHIBA
494	!! to the ocean through reservoirs, with some delay. The routing scheme is based on
495	!! a parametrization of the water flow on a global scale (Miller et al., 1994; Hagemann
496	!! and Dumenil, 1998). Given the global map of the main watersheds (Oki et al., 1999;
497	!! Fekete et al., 1999; Vorosmarty et al., 2000) which delineates the boundaries of subbasins
498	!! and gives the eight possible directions of water flow within the pixel, the surface
499	!! runoff and the deep drainage are routed to the ocean. The time-step of the routing is one day.
500	!! The scheme also diagnoses how much water is retained in the foodplains and thus return to soil
501	!! moisture or is taken out of the rivers for irrigation. \n
502	!!
503	!! RECENT CHANGE(S): None
504	!!
505	!! MAIN OUTPUT VARIABLE(S):
506	!! The result of the routing are 3 fluxes :
507	!! - riverflow : The water which flows out from the major rivers. The flux will be located
508	!! on the continental grid but this should be a coastal point.
509	!! - coastalflow : This is the water which flows in a disperse way into the ocean. Essentially these
510	!! are the outflows from all of the small rivers.
511	!! - returnflow : This is the water which flows into a land-point - typically rivers which end in
512	!! the desert. This water will go back into the hydrol module to allow re-evaporation.
513	!! - irrigation : This is water taken from the reservoir and is being put into the upper
514	!! layers of the soil.
515	!! The two first fluxes are in kg/dt and the last two fluxes are in kg/(m^2dt).\n
516	!!
517	!! REFERENCE(S) :
518	!! - Miller JR, Russell GL, Caliri G (1994)
519	!! Continental-scale river flow in climate models.
520	!! J. Clim., 7:914-928
521	!! - Hagemann S and Dumenil L. (1998)
522	!! A parametrization of the lateral waterflow for the global scale.
523	!! Clim. Dyn., 14:17-31
524	!! - Oki, T., T. Nishimura, and P. Dirmeyer (1999)
525	!! Assessment of annual runoff from land surface models using total runoff integrating pathways (TRIP)
526	!! J. Meteorol. Soc. Jpn., 77, 235-255
527	!! - Fekete BM, Charles V, Grabs W (2000)
528	!! Global, composite runoff fields based on observed river discharge and simulated water balances.
529	!! Technical report, UNH/GRDC, Global Runoff Data Centre, Koblenz
530	!! - Vorosmarty, C., B. Fekete, B. Meybeck, and R. Lammers (2000)
531	!! Global system of rivers: Its role in organizing continental land mass and defining land-to-ocean linkages
532	!! Global Biogeochem. Cycles, 14, 599-621
533	!! - Vivant, A-C. (?? 2002)
534	!! DÃ©veloppement du schÃ©ma de routage et des plaines d'inondation, MSc Thesis, Paris VI University
535	!! - J. Polcher (2003)
536	!! Les processus de surface a l'echelle globale et leurs interactions avec l'atmosphere
537	!! Habilitation a diriger les recherches, Paris VI University, 67pp.
538	!!
539	!! FLOWCHART :
540	!! \latexonly
541	!! \includegraphics[scale=0.75]{routing_main_flowchart.png}
542	!! \endlatexonly
543	!! \n
544	!_ ================================================================================================================================
545
546	SUBROUTINE routing_main(kjit, nbpt, index, &
547	& lalo, neighbours, resolution, contfrac, totfrac_nobio, veget_max, floodout, runoff, &
548	& drainage, transpot, precip_rain, humrel, k_litt, flood_frac, flood_res, &
549	& stempdiag, reinf_slope, returnflow, reinfiltration, irrigation, riverflow, coastalflow, rest_id, hist_id, hist2_id,&
550	soiltile, root_deficit, irrigated_next, irrig_frac, fraction_aeirrig_sw) !
551
552	IMPLICIT NONE
553
554	!! 0.1 Input variables
555	INTEGER(i_std), INTENT(in) :: kjit !! Time step number (unitless)
556	INTEGER(i_std), INTENT(in) :: nbpt !! Domain size (unitless)
557	INTEGER(i_std),INTENT(in) :: rest_id !! Restart file identifier (unitless)
558	INTEGER(i_std),INTENT(in) :: hist_id !! Access to history file (unitless)
559	INTEGER(i_std),INTENT(in) :: hist2_id !! Access to history file 2 (unitless)
560	INTEGER(i_std), INTENT(in) :: index(nbpt) !! Indices of the points on the map (unitless)
561	REAL(r_std), INTENT(in) :: lalo(nbpt,2) !! Vector of latitude and longitudes (beware of the order !)
562	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)
563	REAL(r_std), INTENT(in) :: resolution(nbpt,2) !! The size of each grid box in X and Y (m)
564	REAL(r_std), INTENT(in) :: contfrac(nbpt) !! Fraction of land in each grid box (unitless;0-1)
565	REAL(r_std), INTENT(in) :: totfrac_nobio(nbpt) !! Total fraction of no-vegetation (continental ice, lakes ...) (unitless;0-1)
566	REAL(r_std), INTENT(in) :: veget_max(nbpt,nvm) !! Maximal fraction of vegetation (unitless;0-1)
567	REAL(r_std), INTENT(in) :: floodout(nbpt) !! Grid-point flow out of floodplains (kg/m^2/dt)
568	REAL(r_std), INTENT(in) :: runoff(nbpt) !! Grid-point runoff (kg/m^2/dt)
569	REAL(r_std), INTENT(in) :: drainage(nbpt) !! Grid-point drainage (kg/m^2/dt)
570	REAL(r_std), INTENT(in) :: transpot(nbpt,nvm) !! Potential transpiration of the vegetation (kg/m^2/dt)
571	REAL(r_std), INTENT(in) :: precip_rain(nbpt) !! Rainfall (kg/m^2/dt)
572	REAL(r_std), INTENT(in) :: k_litt(nbpt) !! Averaged conductivity for saturated infiltration in the 'litter' layer (kg/m^2/dt)
573	REAL(r_std), INTENT(in) :: humrel(nbpt,nvm) !! Soil moisture stress, root extraction potential (unitless)
574	REAL(r_std), INTENT(in) :: stempdiag(nbpt,nslm) !! Diagnostic soil temperature profile
575	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)
576	REAL(r_std), INTENT(in) :: root_deficit(nbpt) !! soil water deficit
577	REAL(r_std), INTENT(in) :: soiltile(nbpt,nstm) !! Fraction of each soil tile within vegtot (0-1, unitless)
578	REAL(r_std), INTENT(in) :: irrig_frac(nbpt) !! Irrig. fraction interpolated in routing, and saved to pass to slowproc if irrigated_soiltile = .TRUE.
579	REAL(r_std), INTENT(in) :: irrigated_next (nbpt)!! Dynamic irrig. area, calculated in slowproc and passed to routing
580	REAL(r_std), INTENT(in) :: fraction_aeirrig_sw(nbpt) !! Fraction of area equipped for irrigation from surface water, of irrig_frac
581
582	!! 0.2 Output variables
583	REAL(r_std), INTENT(out) :: returnflow(nbpt) !! The water flow from lakes and swamps which returns to the grid box.
584	!! This water will go back into the hydrol module to allow re-evaporation (kg/m^2/dt)
585	REAL(r_std), INTENT(out) :: reinfiltration(nbpt) !! Water flow from ponds and floodplains which returns to the grid box (kg/m^2/dt)
586	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)
587	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)
588	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)
589	REAL(r_std), INTENT(out) :: flood_frac(nbpt) !! Flooded fraction of the grid box (unitless;0-1)
590	REAL(r_std), INTENT(out) :: flood_res(nbpt) !! Diagnostic of water amount in the floodplains reservoir (kg)
591
592	!! 0.3 Local variables
593	CHARACTER(LEN=30) :: var_name !! To store variables names for I/O (unitless)
594	REAL(r_std), DIMENSION(1) :: tmp_day !!
595	REAL(r_std), DIMENSION(nbpt) :: return_lakes !! Water from lakes flowing back into soil moisture (kg/m^2/dt)
596
597	INTEGER(i_std) :: ig, jv !! Indices (unitless)
598	REAL(r_std), DIMENSION(nbpt) :: tot_vegfrac_nowoody !! Total fraction occupied by grass (0-1,unitless)
599
600	REAL(r_std), DIMENSION(nbpt) :: fast_diag_old !! Reservoir in the beginning of the time step
601	REAL(r_std), DIMENSION(nbpt) :: slow_diag_old !! Reservoir in the beginning of the time step
602	REAL(r_std), DIMENSION(nbpt) :: stream_diag_old !! Reservoir in the beginning of the time step
603	REAL(r_std), DIMENSION(nbpt) :: lake_diag_old !! Reservoir in the beginning of the time step
604	REAL(r_std), DIMENSION(nbpt) :: pond_diag_old !! Reservoir in the beginning of the time step
605	REAL(r_std), DIMENSION(nbpt) :: flood_diag_old !! Reservoir in the beginning of the time step
606
607	!! For water budget check in the three routing reservoirs (positive if input > output)
608	!! Net fluxes averaged over each grid cell in kg/m^2/dt
609	REAL(r_std), DIMENSION(nbpt) :: netflow_stream_diag !! Input - Output flow to stream reservoir
610	REAL(r_std), DIMENSION(nbpt) :: netflow_fast_diag !! Input - Output flow to fast reservoir
611	REAL(r_std), DIMENSION(nbpt) :: netflow_slow_diag !! Input - Output flow to slow reservoir
612
613
614	!_ ================================================================================================================================
615
616	! Save reservoirs in beginning of time step to calculate the water budget
617	fast_diag_old = fast_diag
618	slow_diag_old = slow_diag
619	stream_diag_old = stream_diag
620	lake_diag_old = lake_diag
621	pond_diag_old = pond_diag
622	flood_diag_old = flood_diag
623
624	!
625	!! Computes the variables averaged between routing time steps and which will be used in subsequent calculations
626	!
627	floodout_mean(:) = floodout_mean(:) + floodout(:)
628	runoff_mean(:) = runoff_mean(:) + runoff(:)
629	drainage_mean(:) = drainage_mean(:) + drainage(:)
630	floodtemp(:) = stempdiag(:,floodtemp_lev)
631	precip_mean(:) = precip_mean(:) + precip_rain(:)
632	!
633	!! Computes the total fraction occupied by the grasses and the crops for each grid cell
634	tot_vegfrac_nowoody(:) = zero
635	DO jv = 1, nvm
636	IF ( (jv /= ibare_sechiba) .AND. .NOT.(is_tree(jv)) ) THEN
637	tot_vegfrac_nowoody(:) = tot_vegfrac_nowoody(:) + veget_max(:,jv)
638	END IF
639	END DO
640
641	DO ig = 1, nbpt
642	IF ( tot_vegfrac_nowoody(ig) .GT. min_sechiba ) THEN
643	DO jv = 1,nvm
644	IF ( (jv /= ibare_sechiba) .AND. .NOT.(is_tree(jv)) ) THEN
645	transpot_mean(ig) = transpot_mean(ig) + transpot(ig,jv) * veget_max(ig,jv)/tot_vegfrac_nowoody(ig)
646	END IF
647	END DO
648	ELSE
649	IF (MAXVAL(veget_max(ig,2:nvm)) .GT. min_sechiba) THEN
650	DO jv = 2, nvm
651	transpot_mean(ig) = transpot_mean(ig) + transpot(ig,jv) * veget_max(ig,jv)/ SUM(veget_max(ig,2:nvm))
652	ENDDO
653	ENDIF
654	ENDIF
655	ENDDO
656
657	!
658	! Averaged variables (i.e. *dt_sechiba/dt_routing). This accounts for the difference between the shorter
659	! timestep dt_sechiba of other parts of the model and the long dt_routing timestep (set to one day at present)
660	!
661	totnobio_mean(:) = totnobio_mean(:) + totfrac_nobio(:)*dt_sechiba/dt_routing
662	k_litt_mean(:) = k_litt_mean(:) + k_litt(:)*dt_sechiba/dt_routing
663	!
664	! Only potentially vegetated surfaces are taken into account. At the start of
665	! the growing seasons we will give more weight to these areas.
666	!
667	! New irrigation scheme uses mean of vegtot with jv 1 to nvm
668	! Old scheme keeps jv 2 to nvm, even if possibly an error
669	IF ( .NOT. old_irrig_scheme ) THEN
670	DO jv=1,nvm
671	DO ig=1,nbpt
672	humrel_mean(ig) = humrel_mean(ig) + humrel(ig,jv)veget_max(ig,jv)dt_sechiba/dt_routing
673	vegtot_mean(ig) = vegtot_mean(ig) + veget_max(ig,jv)*dt_sechiba/dt_routing
674	ENDDO
675	ENDDO
676	ELSE
677	DO jv=2,nvm
678	DO ig=1,nbpt
679	humrel_mean(ig) = humrel_mean(ig) + humrel(ig,jv)veget_max(ig,jv)dt_sechiba/dt_routing
680	vegtot_mean(ig) = vegtot_mean(ig) + veget_max(ig,jv)*dt_sechiba/dt_routing
681	ENDDO
682	ENDDO
683	ENDIF
684	! Here updates irrigmap to irrigated_next from slowproc, every timestep
685	!irrigated_next is updated in slowproc when time comes
686	!irrig_frac was also updated in slowproc, here used as input variable
687
688	IF ( do_irrigation .AND. irrig_map_dynamic_flag ) THEN
689	irrigated(:) = irrigated_next(:)
690	ENDIF
691	!
692	time_counter = time_counter + dt_sechiba
693	!
694	! If the time has come we do the routing.
695	!
696	IF ( NINT(time_counter) .GE. NINT(dt_routing) ) THEN
697	!
698	!! Computes the transport of water in the various reservoirs
699	!
700	CALL routing_flow(nbpt, dt_routing, lalo, floodout_mean, runoff_mean, drainage_mean, root_deficit, soiltile, &
701	& vegtot_mean, totnobio_mean, transpot_mean, precip_mean, humrel_mean, k_litt_mean, floodtemp, reinf_slope, &
702	& lakeinflow_mean, returnflow_mean, reinfiltration_mean, irrig_frac, irrigation_mean, irrigdeficit_mean, &
703	& irrigadduct_mean, irrig_gw_source_mean, & !
704	& irrig_fast_source_mean, irrig_str_source_mean, riverflow_mean, & !
705	& coastalflow_mean, hydrographs, slowflow_diag, flood_frac, flood_res, &
706	& netflow_stream_diag, netflow_fast_diag, netflow_slow_diag, fraction_aeirrig_sw)
707	!
708	!! Responsible for storing the water in lakes
709	!
710	CALL routing_lake(nbpt, dt_routing, lakeinflow_mean, humrel_mean, return_lakes)
711	!
712	returnflow_mean(:) = returnflow_mean(:) + return_lakes(:)
713
714	time_counter = zero
715	!
716	floodout_mean(:) = zero
717	runoff_mean(:) = zero
718	drainage_mean(:) = zero
719	transpot_mean(:) = zero
720	precip_mean(:) = zero
721	!
722	humrel_mean(:) = zero
723	totnobio_mean(:) = zero
724	k_litt_mean(:) = zero
725	vegtot_mean(:) = zero
726
727	! Change the units of the routing fluxes from kg/dt_routing into kg/dt_sechiba
728	hydrographs(:) = hydrographs(:)/dt_routing*dt_sechiba
729	slowflow_diag(:) = slowflow_diag(:)/dt_routing*dt_sechiba
730
731	! Change the units of the routing fluxes from kg/m^2/dt_routing into kg/m^2/dt_sechiba
732	returnflow_mean(:) = returnflow_mean(:)/dt_routing*dt_sechiba
733	reinfiltration_mean(:) = reinfiltration_mean(:)/dt_routing*dt_sechiba
734	irrigation_mean(:) = irrigation_mean(:)/dt_routing*dt_sechiba
735	irrigdeficit_mean(:) = irrigdeficit_mean/dt_routing*dt_sechiba !
736	irrigadduct_mean(:) = irrigadduct_mean(:)/dt_routing*dt_sechiba!
737	irrig_gw_source_mean(:) = irrig_gw_source_mean(:)/dt_routing*dt_sechiba !
738	irrig_fast_source_mean(:) = irrig_fast_source_mean(:)/dt_routing*dt_sechiba !
739	irrig_str_source_mean(:) = irrig_str_source_mean(:)/dt_routing*dt_sechiba !
740	irrig_netereq(:) = irrig_netereq(:)/dt_routing*dt_sechiba
741
742	! Change units as above but at the same time transform the kg/dt_routing to m^3/dt_sechiba
743	riverflow_mean(:) = riverflow_mean(:)/dt_routing*dt_sechiba/mille
744	coastalflow_mean(:) = coastalflow_mean(:)/dt_routing*dt_sechiba/mille
745
746	! Water budget residu of the three routing reservoirs (in kg/m^2/s)
747	! Note that these diagnostics are done using local variables only calculated
748	! during the time steps when the routing is calculated
749	CALL xios_orchidee_send_field("wbr_stream",(stream_diag - stream_diag_old - netflow_stream_diag)/dt_routing)
750	CALL xios_orchidee_send_field("wbr_fast", (fast_diag - fast_diag_old - netflow_fast_diag)/dt_routing)
751	CALL xios_orchidee_send_field("wbr_slow", (slow_diag - slow_diag_old - netflow_slow_diag)/dt_routing)
752	CALL xios_orchidee_send_field("wbr_lake", (lake_diag - lake_diag_old - &
753	lakeinflow_mean + return_lakes)/dt_routing)
754	ENDIF
755
756	!
757	! Return the fraction of routed water for this time step.
758	!
759	returnflow(:) = returnflow_mean(:)
760	reinfiltration(:) = reinfiltration_mean(:)
761	irrigation(:) = irrigation_mean(:)
762	riverflow(:) = riverflow_mean(:)
763	coastalflow(:) = coastalflow_mean(:)
764
765	!
766	! Write diagnostics
767	!
768
769	! Water storage in reservoirs [kg/m^2]
770	CALL xios_orchidee_send_field("fastr",fast_diag)
771	CALL xios_orchidee_send_field("slowr",slow_diag)
772	CALL xios_orchidee_send_field("streamr",stream_diag)
773	CALL xios_orchidee_send_field("laker",lake_diag)
774	CALL xios_orchidee_send_field("pondr",pond_diag)
775	CALL xios_orchidee_send_field("floodr",flood_diag)
776	CALL xios_orchidee_send_field("floodh",flood_height)
777
778	! Difference between the end and the beginning of the routing time step [kg/m^2]
779	CALL xios_orchidee_send_field("delfastr", fast_diag - fast_diag_old)
780	CALL xios_orchidee_send_field("delslowr", slow_diag - slow_diag_old)
781	CALL xios_orchidee_send_field("delstreamr", stream_diag - stream_diag_old)
782	CALL xios_orchidee_send_field("dellaker", lake_diag - lake_diag_old)
783	CALL xios_orchidee_send_field("delpondr", pond_diag - pond_diag_old)
784	CALL xios_orchidee_send_field("delfloodr", flood_diag - flood_diag_old)
785
786	! Water fluxes converted from kg/m^2/dt_sechiba into kg/m^2/s
787	CALL xios_orchidee_send_field("irrigation",irrigation/dt_sechiba)
788	CALL xios_orchidee_send_field("irrig_deficit",irrigdeficit_mean/dt_sechiba)!
789	CALL xios_orchidee_send_field("irrig_adduct",irrigadduct_mean/dt_sechiba)!
790	CALL xios_orchidee_send_field("irrig_gw_source",irrig_gw_source_mean/dt_sechiba) !
791	CALL xios_orchidee_send_field("irrig_fast_source",irrig_fast_source_mean/dt_sechiba) !
792	CALL xios_orchidee_send_field("irrig_str_source",irrig_str_source_mean/dt_sechiba) !
793	CALL xios_orchidee_send_field("netirrig",irrig_netereq/dt_sechiba)
794	CALL xios_orchidee_send_field("riversret",returnflow/dt_sechiba)
795	CALL xios_orchidee_send_field("reinfiltration",reinfiltration/dt_sechiba)
796
797	! Transform from kg/dt_sechiba into m^3/s
798	CALL xios_orchidee_send_field("hydrographs",hydrographs/mille/dt_sechiba)
799	CALL xios_orchidee_send_field("slowflow",slowflow_diag/mille/dt_sechiba) ! previous id name: Qb
800	CALL xios_orchidee_send_field("coastalflow",coastalflow/dt_sechiba)
801	CALL xios_orchidee_send_field("riverflow",riverflow/dt_sechiba)
802
803	IF ( .NOT. almaoutput ) THEN
804	!
805	CALL histwrite_p(hist_id, 'riversret', kjit, returnflow, nbpt, index)
806	IF (do_floodplains .OR. doponds) THEN
807	CALL histwrite_p(hist_id, 'reinfiltration', kjit, reinfiltration, nbpt, index)
808	ENDIF
809	CALL histwrite_p(hist_id, 'hydrographs', kjit, hydrographs/mille, nbpt, index)
810	!
811	CALL histwrite_p(hist_id, 'fastr', kjit, fast_diag, nbpt, index)
812	CALL histwrite_p(hist_id, 'slowr', kjit, slow_diag, nbpt, index)
813	CALL histwrite_p(hist_id, 'streamr', kjit, stream_diag, nbpt, index)
814	IF ( do_floodplains ) THEN
815	CALL histwrite_p(hist_id, 'floodr', kjit, flood_diag, nbpt, index)
816	CALL histwrite_p(hist_id, 'floodh', kjit, flood_height, nbpt, index)
817	ENDIF
818	CALL histwrite_p(hist_id, 'pondr', kjit, pond_diag, nbpt, index)
819	CALL histwrite_p(hist_id, 'lakevol', kjit, lake_diag, nbpt, index)
820	!
821	IF ( do_irrigation ) THEN
822	CALL histwrite_p(hist_id, 'irrigation', kjit, irrigation, nbpt, index)
823	CALL histwrite_p(hist_id, 'returnflow', kjit, returnflow, nbpt, index)
824	CALL histwrite_p(hist_id, 'netirrig', kjit, irrig_netereq, nbpt, index)
825	ENDIF
826	!
827	ELSE
828	CALL histwrite_p(hist_id, 'SurfStor', kjit, flood_diag+pond_diag+lake_diag, nbpt, index)
829	CALL histwrite_p(hist_id, 'Dis', kjit, hydrographs/mille, nbpt, index)
830	!
831	CALL histwrite_p(hist_id, 'slowr', kjit, slow_diag, nbpt, index)
832	CALL histwrite_p(hist_id, 'fastr', kjit, fast_diag, nbpt, index)
833	CALL histwrite_p(hist_id, 'streamr', kjit, stream_diag, nbpt, index)
834	CALL histwrite_p(hist_id, 'lakevol', kjit, lake_diag, nbpt, index)
835	CALL histwrite_p(hist_id, 'pondr', kjit, pond_diag, nbpt, index)
836	!
837	IF ( do_irrigation ) THEN
838	CALL histwrite_p(hist_id, 'Qirrig', kjit, irrigation, nbpt, index)
839	CALL histwrite_p(hist_id, 'Qirrig_req', kjit, irrig_netereq, nbpt, index)
840	ENDIF
841	!
842	ENDIF
843	IF ( hist2_id > 0 ) THEN
844	IF ( .NOT. almaoutput ) THEN
845	!
846	CALL histwrite_p(hist2_id, 'riversret', kjit, returnflow, nbpt, index)
847	IF (do_floodplains .OR. doponds) THEN
848	CALL histwrite_p(hist2_id, 'reinfiltration', kjit, reinfiltration, nbpt, index)
849	ENDIF
850	CALL histwrite_p(hist2_id, 'hydrographs', kjit, hydrographs/mille, nbpt, index)
851	!
852	CALL histwrite_p(hist2_id, 'fastr', kjit, fast_diag, nbpt, index)
853	CALL histwrite_p(hist2_id, 'slowr', kjit, slow_diag, nbpt, index)
854	IF ( do_floodplains ) THEN
855	CALL histwrite_p(hist2_id, 'floodr', kjit, flood_diag, nbpt, index)
856	CALL histwrite_p(hist2_id, 'floodh', kjit, flood_height, nbpt, index)
857	ENDIF
858	CALL histwrite_p(hist2_id, 'pondr', kjit, pond_diag, nbpt, index)
859	CALL histwrite_p(hist2_id, 'streamr', kjit, stream_diag, nbpt, index)
860	CALL histwrite_p(hist2_id, 'lakevol', kjit, lake_diag, nbpt, index)
861	!
862	IF ( do_irrigation ) THEN
863	CALL histwrite_p(hist2_id, 'irrigation', kjit, irrigation, nbpt, index)
864	CALL histwrite_p(hist2_id, 'returnflow', kjit, returnflow, nbpt, index)
865	CALL histwrite_p(hist2_id, 'netirrig', kjit, irrig_netereq, nbpt, index)
866	ENDIF
867	!
868	ELSE
869	!
870	CALL histwrite_p(hist2_id, 'SurfStor', kjit, flood_diag+pond_diag+lake_diag, nbpt, index)
871	CALL histwrite_p(hist2_id, 'Dis', kjit, hydrographs/mille, nbpt, index)
872	!
873	ENDIF
874	ENDIF
875	!
876	!
877	END SUBROUTINE routing_main
878
879	!! =============================================================================================================================
880	!! SUBROUTINE: routing_finalize
881	!!
882	!>\BRIEF Write to restart file
883	!!
884	!! DESCRIPTION: Write module variables to restart file
885	!!
886	!! RECENT CHANGE(S)
887	!!
888	!! REFERENCE(S)
889	!!
890	!! FLOWCHART
891	!! \n
892	!_ ==============================================================================================================================
893
894	SUBROUTINE routing_finalize( kjit, nbpt, rest_id, flood_frac, flood_res )
895
896	IMPLICIT NONE
897
898	!! 0.1 Input variables
899	INTEGER(i_std), INTENT(in) :: kjit !! Time step number (unitless)
900	INTEGER(i_std), INTENT(in) :: nbpt !! Domain size (unitless)
901	INTEGER(i_std),INTENT(in) :: rest_id !! Restart file identifier (unitless)
902	REAL(r_std), INTENT(in) :: flood_frac(nbpt) !! Flooded fraction of the grid box (unitless;0-1)
903	REAL(r_std), INTENT(in) :: flood_res(nbpt) !! Diagnostic of water amount in the floodplains reservoir (kg)
904
905	!! 0.2 Local variables
906	REAL(r_std), DIMENSION(1) :: tmp_day
907
908	!_ ================================================================================================================================
909
910	!
911	! Write restart variables
912	!
913	tmp_day(1) = time_counter
914	IF (is_root_prc) CALL restput (rest_id, 'routingcounter', 1, 1, 1, kjit, tmp_day)
915
916	CALL restput_p (rest_id, 'routingarea', nbp_glo, nbasmax, 1, kjit, routing_area, 'scatter', nbp_glo, index_g)
917	CALL restput_p (rest_id, 'routetogrid', nbp_glo, nbasmax, 1, kjit, REAL(route_togrid,r_std), 'scatter', &
918	nbp_glo, index_g)
919	CALL restput_p (rest_id, 'routetobasin', nbp_glo, nbasmax, 1, kjit, REAL(route_tobasin,r_std), 'scatter', &
920	nbp_glo, index_g)
921	CALL restput_p (rest_id, 'basinid', nbp_glo, nbasmax, 1, kjit, REAL(global_basinid,r_std), 'scatter', &
922	nbp_glo, index_g)
923	CALL restput_p (rest_id, 'topoindex', nbp_glo, nbasmax, 1, kjit, topo_resid, 'scatter', nbp_glo, index_g)
924	CALL restput_p (rest_id, 'fastres', nbp_glo, nbasmax, 1, kjit, fast_reservoir, 'scatter', nbp_glo, index_g)
925	CALL restput_p (rest_id, 'slowres', nbp_glo, nbasmax, 1, kjit, slow_reservoir, 'scatter', nbp_glo, index_g)
926	CALL restput_p (rest_id, 'streamres', nbp_glo, nbasmax, 1, kjit, stream_reservoir, 'scatter',nbp_glo,index_g)
927	CALL restput_p (rest_id, 'floodres', nbp_glo, nbasmax, 1, kjit, flood_reservoir, 'scatter', nbp_glo, index_g)
928	CALL restput_p (rest_id, 'floodh', nbp_glo, 1, 1, kjit, flood_height, 'scatter', nbp_glo, index_g)
929	CALL restput_p (rest_id, 'flood_frac_bas', nbp_glo, nbasmax, 1, kjit, flood_frac_bas, 'scatter', nbp_glo, index_g)
930	CALL restput_p (rest_id, 'pond_frac', nbp_glo, 1, 1, kjit, pond_frac, 'scatter', nbp_glo, index_g)
931	CALL restput_p (rest_id, 'flood_frac', nbp_glo, 1, 1, kjit, flood_frac, 'scatter', nbp_glo, index_g)
932	CALL restput_p (rest_id, 'flood_res', nbp_glo, 1, 1, kjit, flood_res, 'scatter', nbp_glo, index_g)
933
934	CALL restput_p (rest_id, 'lakeres', nbp_glo, 1, 1, kjit, lake_reservoir, 'scatter', nbp_glo, index_g)
935	CALL restput_p (rest_id, 'pondres', nbp_glo, 1, 1, kjit, pond_reservoir, 'scatter', nbp_glo, index_g)
936
937	CALL restput_p (rest_id, 'lakeinflow', nbp_glo, 1, 1, kjit, lakeinflow_mean, 'scatter', nbp_glo, index_g)
938	CALL restput_p (rest_id, 'returnflow', nbp_glo, 1, 1, kjit, returnflow_mean, 'scatter', nbp_glo, index_g)
939	CALL restput_p (rest_id, 'reinfiltration', nbp_glo, 1, 1, kjit, reinfiltration_mean, 'scatter', nbp_glo, index_g)
940	CALL restput_p (rest_id, 'riverflow', nbp_glo, 1, 1, kjit, riverflow_mean, 'scatter', nbp_glo, index_g)
941	CALL restput_p (rest_id, 'coastalflow', nbp_glo, 1, 1, kjit, coastalflow_mean, 'scatter', nbp_glo, index_g)
942	CALL restput_p (rest_id, 'hydrographs', nbp_glo, 1, 1, kjit, hydrographs, 'scatter', nbp_glo, index_g)
943	CALL restput_p (rest_id, 'slowflow_diag', nbp_glo, 1, 1, kjit, slowflow_diag, 'scatter', nbp_glo, index_g)
944	!
945	! Keep track of the accumulated variables
946	!
947	CALL restput_p (rest_id, 'floodout_route', nbp_glo, 1, 1, kjit, floodout_mean, 'scatter', nbp_glo, index_g)
948	CALL restput_p (rest_id, 'runoff_route', nbp_glo, 1, 1, kjit, runoff_mean, 'scatter', nbp_glo, index_g)
949	CALL restput_p (rest_id, 'drainage_route', nbp_glo, 1, 1, kjit, drainage_mean, 'scatter', nbp_glo, index_g)
950	CALL restput_p (rest_id, 'transpot_route', nbp_glo, 1, 1, kjit, transpot_mean, 'scatter', nbp_glo, index_g)
951	CALL restput_p (rest_id, 'precip_route', nbp_glo, 1, 1, kjit, precip_mean, 'scatter', nbp_glo, index_g)
952	CALL restput_p (rest_id, 'humrel_route', nbp_glo, 1, 1, kjit, humrel_mean, 'scatter', nbp_glo, index_g)
953	CALL restput_p (rest_id, 'totnobio_route', nbp_glo, 1, 1, kjit, totnobio_mean, 'scatter', nbp_glo, index_g)
954	CALL restput_p (rest_id, 'k_litt_route', nbp_glo, 1, 1, kjit, k_litt_mean, 'scatter', nbp_glo, index_g)
955	CALL restput_p (rest_id, 'vegtot_route', nbp_glo, 1, 1, kjit, vegtot_mean, 'scatter', nbp_glo, index_g)
956
957	IF ( do_irrigation ) THEN
958	!CALL restput_p (rest_id, 'irrigated', nbp_glo, 1, 1, kjit, irrigated, 'scatter', nbp_glo, index_g)
959	CALL restput_p (rest_id, 'irrigation', nbp_glo, 1, 1, kjit, irrigation_mean, 'scatter', nbp_glo, index_g)
960	CALL restput_p (rest_id, 'irrigdeficit', nbp_glo, 1, 1, kjit, irrigdeficit_mean, 'scatter', nbp_glo, index_g)
961	CALL restput_p (rest_id, 'irrigadduct', nbp_glo, 1, 1, kjit, irrigadduct_mean, 'scatter', nbp_glo, index_g)
962	CALL restput_p (rest_id, 'irrig_gw_source', nbp_glo, 1, 1, kjit, irrig_gw_source_mean, 'scatter', nbp_glo, index_g) !
963	CALL restput_p (rest_id, 'irrig_fast_source', nbp_glo, 1, 1, kjit, irrig_fast_source_mean, 'scatter', nbp_glo, index_g) !
964	CALL restput_p (rest_id, 'irrig_str_source', nbp_glo, 1, 1, kjit, irrig_str_source_mean, 'scatter', nbp_glo, index_g) !
965	ENDIF
966
967	IF ( do_floodplains ) THEN
968	CALL restput_p (rest_id, 'floodplains', nbp_glo, 1, 1, kjit, floodplains, 'scatter', nbp_glo, index_g)
969	ENDIF
970	IF ( doswamps ) THEN
971	CALL restput_p (rest_id, 'swamp', nbp_glo, 1, 1, kjit, swamp, 'scatter', nbp_glo, index_g)
972	ENDIF
973
974	END SUBROUTINE routing_finalize
975
976	!! ================================================================================================================================
977	!! SUBROUTINE : routing_init
978	!!
979	!>\BRIEF This subroutine allocates the memory and get the fixed fields from the restart file.
980	!!
981	!! DESCRIPTION (definitions, functional, design, flags) : None
982	!!
983	!! RECENT CHANGE(S): None
984	!!
985	!! MAIN OUTPUT VARIABLE(S):
986	!!
987	!! REFERENCES : None
988	!!
989	!! FLOWCHART :None
990	!! \n
991	!_ ================================================================================================================================
992
993	SUBROUTINE routing_init(kjit, nbpt, index, returnflow, reinfiltration, irrigation, &
994	& riverflow, coastalflow, flood_frac, flood_res, stempdiag, rest_id)
995	!
996	IMPLICIT NONE
997	!
998	! interface description
999	!
1000	!! INPUT VARIABLES
1001	INTEGER(i_std), INTENT(in) :: kjit !! Time step number (unitless)
1002	INTEGER(i_std), INTENT(in) :: nbpt !! Domain size (unitless)
1003	INTEGER(i_std), DIMENSION (nbpt), INTENT(in) :: index !! Indices of the points on the map (unitless)
1004	REAL(r_std), DIMENSION(nbpt,nslm),INTENT(in) :: stempdiag !! Temperature profile in soil
1005	INTEGER(i_std), INTENT(in) :: rest_id !! Restart file identifier (unitless)
1006	!
1007	!! OUTPUT VARIABLES
1008	REAL(r_std), DIMENSION (nbpt),INTENT(out) :: returnflow !! The water flow from lakes and swamps which returns into the grid box.
1009	!! This water will go back into the hydrol module to allow re-evaporation (kg/m^2/dt)
1010	REAL(r_std), DIMENSION (nbpt),INTENT(out) :: reinfiltration !! Water flow from ponds and floodplains which returns to the grid box (kg/m^2/dt)
1011	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)
1012	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)
1013	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)
1014	REAL(r_std), DIMENSION (nbpt),INTENT(out) :: flood_frac !! Flooded fraction of the grid box (unitless;0-1)
1015	REAL(r_std), DIMENSION (nbpt),INTENT(out) :: flood_res !! Diagnostic of water amount in the floodplains reservoir (kg)
1016	!
1017	!! LOCAL VARIABLES
1018	CHARACTER(LEN=80) :: var_name !! To store variables names for I/O (unitless)
1019	REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: tmp_real_g !! A temporary real array for the integers
1020	REAL(r_std), DIMENSION(1) :: tmp_day !!
1021	REAL(r_std) :: ratio !! Diagnostic ratio to check that dt_routing is a multiple of dt_sechiba (unitless)
1022	REAL(r_std) :: totarea !! Total area of basin (m^2)
1023	INTEGER(i_std) :: ier, ig, ib, ipn(1) !! Indices (unitless)
1024
1025	!_ ================================================================================================================================
1026	!
1027	!
1028	! These variables will require the configuration infrastructure
1029	!
1030	!Config Key = DT_ROUTING
1031	!Config If = RIVER_ROUTING
1032	!Config Desc = Time step of the routing scheme
1033	!Config Def = one_day
1034	!Config Help = This values gives the time step in seconds of the routing scheme.
1035	!Config It should be multiple of the main time step of ORCHIDEE. One day
1036	!Config is a good value.
1037	!Config Units = [seconds]
1038	!
1039	dt_routing = one_day
1040	CALL getin_p('DT_ROUTING', dt_routing)
1041	!
1042	!Config Key = ROUTING_RIVERS
1043	!Config If = RIVER_ROUTING
1044	!Config Desc = Number of rivers
1045	!Config Def = 50
1046	!Config Help = This parameter chooses the number of largest river basins
1047	!Config which should be treated as independently as rivers and not
1048	!Config flow into the oceans as diffusion coastal flow.
1049	!Config Units = [-]
1050	num_largest = 50
1051	CALL getin_p('ROUTING_RIVERS', num_largest)
1052	!
1053	!Config Key = DO_FLOODINFILT
1054	!Config Desc = Should floodplains reinfiltrate into the soil
1055	!Config If = RIVER_ROUTING
1056	!Config Def = n
1057	!Config Help = This parameters allows the user to ask the model
1058	!Config to take into account the flood plains reinfiltration
1059	!Config into the soil moisture. It then can go
1060	!Config back to the slow and fast reservoirs
1061	!Config Units = [FLAG]
1062	!
1063	dofloodinfilt = .FALSE.
1064	CALL getin_p('DO_FLOODINFILT', dofloodinfilt)
1065	!
1066	!Config Key = DO_SWAMPS
1067	!Config Desc = Should we include swamp parameterization
1068	!Config If = RIVER_ROUTING
1069	!Config Def = n
1070	!Config Help = This parameters allows the user to ask the model
1071	!Config to take into account the swamps and return
1072	!Config the water into the bottom of the soil. It then can go
1073	!Config back to the atmopshere. This tried to simulate
1074	!Config internal deltas of rivers.
1075	!Config Units = [FLAG]
1076	!
1077	doswamps = .FALSE.
1078	CALL getin_p('DO_SWAMPS', doswamps)
1079	!
1080	!Config Key = DO_PONDS
1081	!Config Desc = Should we include ponds
1082	!Config If = RIVER_ROUTING
1083	!Config Def = n
1084	!Config Help = This parameters allows the user to ask the model
1085	!Config to take into account the ponds and return
1086	!Config the water into the soil moisture. It then can go
1087	!Config back to the atmopshere. This tried to simulate
1088	!Config little ponds especially in West Africa.
1089	!Config Units = [FLAG]
1090	!
1091	doponds = .FALSE.
1092	CALL getin_p('DO_PONDS', doponds)
1093
1094
1095	!Config Key = SLOW_TCST
1096	!Config Desc = Time constant for the slow reservoir
1097	!Config If = RIVER_ROUTING
1098	!Config Def = 25.0
1099	!Config Help = This parameters allows the user to fix the
1100	!Config time constant (in days) of the slow reservoir
1101	!Config in order to get better river flows for
1102	!Config particular regions.
1103	!Config Units = [days]
1104	!
1105	!> A value for property of each reservoir (in day/m) is given to compute a time constant (in day)
1106	!> for each reservoir (product of tcst and topo_resid).
1107	!> The value of tcst has been calibrated for the three reservoirs over the Senegal river basin only,
1108	!> during the 1 degree NCEP Corrected by Cru (NCC) resolution simulations (Ngo-Duc et al., 2005, Ngo-Duc et al., 2006) and
1109	!> generalized for all the basins of the world. The "slow reservoir" and the "fast reservoir"
1110	!> have the highest value in order to simulate the groundwater.
1111	!> The "stream reservoir", which represents all the water of the stream, has the lowest value.
1112	!> Those figures are the same for all the basins of the world.
1113	!> The value of slow_tcst is equal to fast_tcst when CWRR is activated.
1114	!> This assumption should be re-discussed.
1115	!
1116	CALL getin_p('SLOW_TCST', slow_tcst)
1117	!
1118	!Config Key = FAST_TCST
1119	!Config Desc = Time constant for the fast reservoir
1120	!Config If = RIVER_ROUTING
1121	!Config Def = 3.0
1122	!Config Help = This parameters allows the user to fix the
1123	!Config time constant (in days) of the fast reservoir
1124	!Config in order to get better river flows for
1125	!Config particular regions.
1126	!Config Units = [days]
1127	CALL getin_p('FAST_TCST', fast_tcst)
1128
1129	!Config Key = STREAM_TCST
1130	!Config Desc = Time constant for the stream reservoir
1131	!Config If = RIVER_ROUTING
1132	!Config Def = 0.24
1133	!Config Help = This parameters allows the user to fix the
1134	!Config time constant (in days) of the stream reservoir
1135	!Config in order to get better river flows for
1136	!Config particular regions.
1137	!Config Units = [days]
1138	CALL getin_p('STREAM_TCST', stream_tcst)
1139
1140	!Config Key = FLOOD_TCST
1141	!Config Desc = Time constant for the flood reservoir
1142	!Config If = RIVER_ROUTING
1143	!Config Def = 4.0
1144	!Config Help = This parameters allows the user to fix the
1145	!Config time constant (in days) of the flood reservoir
1146	!Config in order to get better river flows for
1147	!Config particular regions.
1148	!Config Units = [days]
1149	CALL getin_p('FLOOD_TCST', flood_tcst)
1150
1151	!Config Key = SWAMP_CST
1152	!Config Desc = Fraction of the river that flows back to swamps
1153	!Config If = RIVER_ROUTING
1154	!Config Def = 0.2
1155	!Config Help = This parameters allows the user to fix the
1156	!Config fraction of the river transport
1157	!Config that flows to swamps
1158	!Config Units = [-]
1159	CALL getin_p('SWAMP_CST', swamp_cst)
1160
1161	!Config Key = FLOOD_BETA
1162	!Config Desc = Parameter to fix the shape of the floodplain
1163	!Config If = RIVER_ROUTING
1164	!Config Def = 2.0
1165	!Config Help = Parameter to fix the shape of the floodplain
1166	!Config (>1 for convex edges, <1 for concave edges)
1167	!Config Units = [-]
1168	CALL getin_p("FLOOD_BETA", beta)
1169	!
1170	!Config Key = POND_BETAP
1171	!Config Desc = Ratio of the basin surface intercepted by ponds and the maximum surface of ponds
1172	!Config If = RIVER_ROUTING
1173	!Config Def = 0.5
1174	!Config Help =
1175	!Config Units = [-]
1176	CALL getin_p("POND_BETAP", betap)
1177	!
1178	!Config Key = FLOOD_CRI
1179	!Config Desc = Potential height for which all the basin is flooded
1180	!Config If = DO_FLOODPLAINS or DO_PONDS
1181	!Config Def = 2000.
1182	!Config Help =
1183	!Config Units = [mm]
1184	CALL getin_p("FLOOD_CRI", floodcri)
1185	!
1186	!Config Key = POND_CRI
1187	!Config Desc = Potential height for which all the basin is a pond
1188	!Config If = DO_FLOODPLAINS or DO_PONDS
1189	!Config Def = 2000.
1190	!Config Help =
1191	!Config Units = [mm]
1192	CALL getin_p("POND_CRI", pondcri)
1193
1194	!Config Key = MAX_LAKE_RESERVOIR
1195	!Config Desc = Maximum limit of water in lake_reservoir
1196	!Config If = RIVER_ROUTING
1197	!Config Def = 7000
1198	!Config Help =
1199	!Config Units = [kg/m2(routing area)]
1200	max_lake_reservoir = 7000
1201	CALL getin_p("MAX_LAKE_RESERVOIR", max_lake_reservoir)
1202
1203	!
1204	!
1205	! In order to simplify the time cascade check that dt_routing
1206	! is a multiple of dt_sechiba
1207	!
1208	ratio = dt_routing/dt_sechiba
1209	IF ( ABS(NINT(ratio) - ratio) .GT. 10*EPSILON(ratio)) THEN
1210	WRITE(numout,*) 'WARNING -- WARNING -- WARNING -- WARNING'
1211	WRITE(numout,*) "The chosen time step for the routing is not a multiple of the"
1212	WRITE(numout,*) "main time step of the model. We will change dt_routing so that"
1213	WRITE(numout,*) "this condition os fulfilled"
1214	dt_routing = NINT(ratio) * dt_sechiba
1215	WRITE(numout,*) 'THE NEW DT_ROUTING IS : ', dt_routing
1216	ENDIF
1217	!
1218	IF ( dt_routing .LT. dt_sechiba) THEN
1219	WRITE(numout,*) 'WARNING -- WARNING -- WARNING -- WARNING'
1220	WRITE(numout,*) 'The routing timestep can not be smaller than the one'
1221	WRITE(numout,*) 'of the model. We reset its value to the model''s timestep.'
1222	WRITE(numout,*) 'The old DT_ROUTING is : ', dt_routing
1223	dt_routing = dt_sechiba
1224	WRITE(numout,*) 'THE NEW DT_ROUTING IS : ', dt_routing
1225	ENDIF
1226	!
1227	var_name ="routingcounter"
1228	IF (is_root_prc) THEN
1229	CALL ioconf_setatt('UNITS', 's')
1230	CALL ioconf_setatt('LONG_NAME','Time counter for the routing scheme')
1231	CALL restget (rest_id, var_name, 1, 1, 1, kjit, .TRUE., tmp_day)
1232	IF (tmp_day(1) == val_exp) THEN
1233	! The variable was not found in restart file, initialize to zero
1234	time_counter = zero
1235	ELSE
1236	! Take the value from restart file
1237	time_counter = tmp_day(1)
1238	ENDIF
1239	ENDIF
1240	CALL bcast(time_counter)
1241
1242
1243	ALLOCATE (routing_area_loc(nbpt,nbasmax), stat=ier)
1244	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for routing_area_loc','','')
1245
1246	ALLOCATE (routing_area_glo(nbp_glo,nbasmax))
1247	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for routing_area_glo','','')
1248	var_name = 'routingarea'
1249	IF (is_root_prc) THEN
1250	CALL ioconf_setatt('UNITS', 'm^2')
1251	CALL ioconf_setatt('LONG_NAME','Area of basin')
1252	CALL restget (rest_id, var_name, nbp_glo, nbasmax, 1, kjit, .TRUE., routing_area_glo, "gather", nbp_glo, index_g)
1253	ENDIF
1254	CALL scatter(routing_area_glo,routing_area_loc)
1255	routing_area=>routing_area_loc
1256
1257	ALLOCATE (tmp_real_g(nbp_glo,nbasmax), stat=ier)
1258	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for tmp_real_g','','')
1259
1260	ALLOCATE (route_togrid_loc(nbpt,nbasmax), stat=ier)
1261	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for route_togrid_loc','','')
1262	ALLOCATE (route_togrid_glo(nbp_glo,nbasmax), stat=ier) ! used in global in routing_flow
1263	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for route_togrid_glo','','')
1264
1265	IF (is_root_prc) THEN
1266	var_name = 'routetogrid'
1267	CALL ioconf_setatt('UNITS', '-')
1268	CALL ioconf_setatt('LONG_NAME','Grid into which the basin flows')
1269	CALL restget (rest_id, var_name, nbp_glo, nbasmax, 1, kjit, .TRUE., tmp_real_g, "gather", nbp_glo, index_g)
1270	route_togrid_glo(:,:) = undef_int
1271	WHERE ( tmp_real_g .LT. val_exp )
1272	route_togrid_glo = NINT(tmp_real_g)
1273	ENDWHERE
1274	ENDIF
1275	CALL bcast(route_togrid_glo) ! used in global in routing_flow
1276	CALL scatter(route_togrid_glo,route_togrid_loc)
1277	route_togrid=>route_togrid_loc
1278	!
1279	ALLOCATE (route_tobasin_loc(nbpt,nbasmax), stat=ier)
1280	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for route_tobasin_loc','','')
1281
1282	ALLOCATE (route_tobasin_glo(nbp_glo,nbasmax), stat=ier)
1283	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for route_tobasin_glo','','')
1284
1285	IF (is_root_prc) THEN
1286	var_name = 'routetobasin'
1287	CALL ioconf_setatt('UNITS', '-')
1288	CALL ioconf_setatt('LONG_NAME','Basin in to which the water goes')
1289	CALL restget (rest_id, var_name, nbp_glo, nbasmax, 1, kjit, .TRUE., tmp_real_g, "gather", nbp_glo, index_g)
1290	route_tobasin_glo = undef_int
1291	WHERE ( tmp_real_g .LT. val_exp )
1292	route_tobasin_glo = NINT(tmp_real_g)
1293	ENDWHERE
1294	ENDIF
1295	CALL scatter(route_tobasin_glo,route_tobasin_loc)
1296	route_tobasin=>route_tobasin_loc
1297	!
1298	! nbintobasin
1299	!
1300	ALLOCATE (route_nbintobas_loc(nbpt,nbasmax), stat=ier)
1301	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for route_nbintobas_loc','','')
1302	ALLOCATE (route_nbintobas_glo(nbp_glo,nbasmax), stat=ier)
1303	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for route_nbintobas_glo','','')
1304
1305	IF (is_root_prc) THEN
1306	var_name = 'routenbintobas'
1307	CALL ioconf_setatt('UNITS', '-')
1308	CALL ioconf_setatt('LONG_NAME','Number of basin into current one')
1309	CALL restget (rest_id, var_name, nbp_glo, nbasmax, 1, kjit, .TRUE., tmp_real_g, "gather", nbp_glo, index_g)
1310	route_nbintobas_glo = undef_int
1311	WHERE ( tmp_real_g .LT. val_exp )
1312	route_nbintobas_glo = NINT(tmp_real_g)
1313	ENDWHERE
1314	ENDIF
1315	CALL scatter(route_nbintobas_glo,route_nbintobas_loc)
1316	route_nbintobas=>route_nbintobas_loc
1317	!
1318	ALLOCATE (global_basinid_loc(nbpt,nbasmax), stat=ier)
1319	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for global_basinid_loc','','')
1320	ALLOCATE (global_basinid_glo(nbp_glo,nbasmax), stat=ier)
1321	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for global_basinid_glo','','')
1322
1323	IF (is_root_prc) THEN
1324	var_name = 'basinid'
1325	CALL ioconf_setatt('UNITS', '-')
1326	CALL ioconf_setatt('LONG_NAME','ID of basin')
1327	CALL restget (rest_id, var_name, nbp_glo, nbasmax, 1, kjit, .TRUE., tmp_real_g, "gather", nbp_glo, index_g)
1328	global_basinid_glo = undef_int
1329	WHERE ( tmp_real_g .LT. val_exp )
1330	global_basinid_glo = NINT(tmp_real_g)
1331	ENDWHERE
1332	ENDIF
1333	CALL scatter(global_basinid_glo,global_basinid_loc)
1334	global_basinid=>global_basinid_loc
1335	!
1336	ALLOCATE (topo_resid_loc(nbpt,nbasmax), stat=ier)
1337	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for topo_resid_loc','','')
1338	ALLOCATE (topo_resid_glo(nbp_glo,nbasmax), stat=ier)
1339	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for topo_resid_glo','','')
1340
1341	IF (is_root_prc) THEN
1342	var_name = 'topoindex'
1343	CALL ioconf_setatt('UNITS', 'm')
1344	CALL ioconf_setatt('LONG_NAME','Topographic index of the residence time')
1345	CALL restget (rest_id, var_name, nbp_glo, nbasmax, 1, kjit, .TRUE., topo_resid_glo, "gather", nbp_glo, index_g)
1346	ENDIF
1347	CALL scatter(topo_resid_glo,topo_resid_loc)
1348	topo_resid=>topo_resid_loc
1349
1350	ALLOCATE (fast_reservoir(nbpt,nbasmax), stat=ier)
1351	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for fast_reservoir','','')
1352	var_name = 'fastres'
1353	CALL ioconf_setatt_p('UNITS', 'Kg')
1354	CALL ioconf_setatt_p('LONG_NAME','Water in the fast reservoir')
1355	CALL restget_p (rest_id, var_name, nbp_glo, nbasmax, 1, kjit, .TRUE., fast_reservoir, "gather", nbp_glo, index_g)
1356	CALL setvar_p (fast_reservoir, val_exp, 'NO_KEYWORD', zero)
1357
1358	ALLOCATE (slow_reservoir(nbpt,nbasmax), stat=ier)
1359	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for slow_reservoir','','')
1360	var_name = 'slowres'
1361	CALL ioconf_setatt_p('UNITS', 'Kg')
1362	CALL ioconf_setatt_p('LONG_NAME','Water in the slow reservoir')
1363	CALL restget_p (rest_id, var_name, nbp_glo, nbasmax, 1, kjit, .TRUE., slow_reservoir, "gather", nbp_glo, index_g)
1364	CALL setvar_p (slow_reservoir, val_exp, 'NO_KEYWORD', zero)
1365
1366	ALLOCATE (stream_reservoir(nbpt,nbasmax), stat=ier)
1367	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for stream_reservoir','','')
1368	var_name = 'streamres'
1369	CALL ioconf_setatt_p('UNITS', 'Kg')
1370	CALL ioconf_setatt_p('LONG_NAME','Water in the stream reservoir')
1371	CALL restget_p (rest_id, var_name, nbp_glo, nbasmax, 1, kjit, .TRUE., stream_reservoir, "gather", nbp_glo, index_g)
1372	CALL setvar_p (stream_reservoir, val_exp, 'NO_KEYWORD', zero)
1373
1374	ALLOCATE (flood_reservoir(nbpt,nbasmax), stat=ier)
1375	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for flood_reservoir','','')
1376	var_name = 'floodres'
1377	CALL ioconf_setatt_p('UNITS', 'Kg')
1378	CALL ioconf_setatt_p('LONG_NAME','Water in the flood reservoir')
1379	CALL restget_p (rest_id, var_name, nbp_glo, nbasmax, 1, kjit, .TRUE., flood_reservoir, "gather", nbp_glo, index_g)
1380	CALL setvar_p (flood_reservoir, val_exp, 'NO_KEYWORD', zero)
1381
1382	ALLOCATE (flood_frac_bas(nbpt,nbasmax), stat=ier)
1383	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for flood_frac_bas','','')
1384	var_name = 'flood_frac_bas'
1385	CALL ioconf_setatt_p('UNITS', '-')
1386	CALL ioconf_setatt_p('LONG_NAME','Flooded fraction per basin')
1387	CALL restget_p (rest_id, var_name, nbp_glo, nbasmax, 1, kjit, .TRUE., flood_frac_bas, "gather", nbp_glo, index_g)
1388	CALL setvar_p (flood_frac_bas, val_exp, 'NO_KEYWORD', zero)
1389
1390	ALLOCATE (flood_height(nbpt), stat=ier)
1391	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for flood_height','','')
1392	var_name = 'floodh'
1393	CALL ioconf_setatt_p('UNITS', '-')
1394	CALL ioconf_setatt_p('LONG_NAME','')
1395	CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., flood_height, "gather", nbp_glo, index_g)
1396	CALL setvar_p (flood_height, val_exp, 'NO_KEYWORD', zero)
1397
1398	ALLOCATE (pond_frac(nbpt), stat=ier)
1399	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for pond_frac','','')
1400	var_name = 'pond_frac'
1401	CALL ioconf_setatt_p('UNITS', '-')
1402	CALL ioconf_setatt_p('LONG_NAME','Pond fraction per grid box')
1403	CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., pond_frac, "gather", nbp_glo, index_g)
1404	CALL setvar_p (pond_frac, val_exp, 'NO_KEYWORD', zero)
1405
1406	var_name = 'flood_frac'
1407	CALL ioconf_setatt_p('UNITS', '-')
1408	CALL ioconf_setatt_p('LONG_NAME','Flooded fraction per grid box')
1409	CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., flood_frac, "gather", nbp_glo, index_g)
1410	CALL setvar_p (flood_frac, val_exp, 'NO_KEYWORD', zero)
1411
1412	var_name = 'flood_res'
1413	CALL ioconf_setatt_p('UNITS','mm')
1414	CALL ioconf_setatt_p('LONG_NAME','Flooded quantity (estimation)')
1415	CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., flood_res, "gather", nbp_glo, index_g)
1416	CALL setvar_p (flood_res, val_exp, 'NO_KEYWORD', zero)
1417	! flood_res = zero
1418
1419	ALLOCATE (lake_reservoir(nbpt), stat=ier)
1420	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for lake_reservoir','','')
1421	var_name = 'lakeres'
1422	CALL ioconf_setatt_p('UNITS', 'Kg')
1423	CALL ioconf_setatt_p('LONG_NAME','Water in the lake reservoir')
1424	CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., lake_reservoir, "gather", nbp_glo, index_g)
1425	CALL setvar_p (lake_reservoir, val_exp, 'NO_KEYWORD', zero)
1426
1427	ALLOCATE (pond_reservoir(nbpt), stat=ier)
1428	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for pond_reservoir','','')
1429	var_name = 'pondres'
1430	CALL ioconf_setatt_p('UNITS', 'Kg')
1431	CALL ioconf_setatt_p('LONG_NAME','Water in the pond reservoir')
1432	CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., pond_reservoir, "gather", nbp_glo, index_g)
1433	CALL setvar_p (pond_reservoir, val_exp, 'NO_KEYWORD', zero)
1434	!
1435	! Map of irrigated areas
1436	! irrigated equal to irrigated_next from slowproc. Here, we initialize to zero.
1437	! Values from slowproc given in routing_main
1438	ALLOCATE (irrigated(nbpt), stat=ier)
1439	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for irrigated','','')
1440	var_name = 'irrigated'
1441	CALL ioconf_setatt_p('UNITS', 'm^2')
1442	CALL ioconf_setatt_p('LONG_NAME','Surface of irrigated area')
1443	irrigated(:) = zero
1444
1445	IF ( do_floodplains ) THEN
1446	ALLOCATE (floodplains(nbpt), stat=ier)
1447	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for floodplains','','')
1448	var_name = 'floodplains'
1449	CALL ioconf_setatt_p('UNITS', 'm^2')
1450	CALL ioconf_setatt_p('LONG_NAME','Surface which can be flooded')
1451	CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., floodplains, "gather", nbp_glo, index_g)
1452	CALL setvar_p (floodplains, val_exp, 'NO_KEYWORD', undef_sechiba)
1453	ENDIF
1454	IF ( doswamps ) THEN
1455	ALLOCATE (swamp(nbpt), stat=ier)
1456	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for swamp','','')
1457	var_name = 'swamp'
1458	CALL ioconf_setatt_p('UNITS', 'm^2')
1459	CALL ioconf_setatt_p('LONG_NAME','Surface which can become swamp')
1460	CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., swamp, "gather", nbp_glo, index_g)
1461	CALL setvar_p (swamp, val_exp, 'NO_KEYWORD', undef_sechiba)
1462	ENDIF
1463	!
1464	! Put into the restart file the fluxes so that they can be regenerated at restart.
1465	!
1466	ALLOCATE (lakeinflow_mean(nbpt), stat=ier)
1467	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for lakeinflow_mean','','')
1468	var_name = 'lakeinflow'
1469	CALL ioconf_setatt_p('UNITS', 'Kg/dt')
1470	CALL ioconf_setatt_p('LONG_NAME','Lake inflow')
1471	CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., lakeinflow_mean, "gather", nbp_glo, index_g)
1472	CALL setvar_p (lakeinflow_mean, val_exp, 'NO_KEYWORD', zero)
1473
1474	ALLOCATE (returnflow_mean(nbpt), stat=ier)
1475	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for returnflow_mean','','')
1476	var_name = 'returnflow'
1477	CALL ioconf_setatt_p('UNITS', 'Kg/m^2/dt')
1478	CALL ioconf_setatt_p('LONG_NAME','Deep return flux')
1479	CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., returnflow_mean, "gather", nbp_glo, index_g)
1480	CALL setvar_p (returnflow_mean, val_exp, 'NO_KEYWORD', zero)
1481	returnflow(:) = returnflow_mean(:)
1482
1483	ALLOCATE (reinfiltration_mean(nbpt), stat=ier)
1484	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for reinfiltration_mean','','')
1485	var_name = 'reinfiltration'
1486	CALL ioconf_setatt_p('UNITS', 'Kg/m^2/dt')
1487	CALL ioconf_setatt_p('LONG_NAME','Top return flux')
1488	CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., reinfiltration_mean, "gather", nbp_glo, index_g)
1489	CALL setvar_p (reinfiltration_mean, val_exp, 'NO_KEYWORD', zero)
1490	reinfiltration(:) = reinfiltration_mean(:)
1491
1492	ALLOCATE (irrigation_mean(nbpt), stat=ier)
1493	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for irrigation_mean','','')
1494	ALLOCATE (irrigdeficit_mean(nbpt), stat=ier)
1495	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for irrigdeficit_mean','','')
1496	ALLOCATE (irrigadduct_mean(nbpt), stat=ier)
1497	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for irrigadduct_mean','','')
1498	ALLOCATE (irrig_netereq(nbpt), stat=ier)
1499	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for irrig_netereq','','')
1500	ALLOCATE (irrig_gw_source_mean(nbpt), stat=ier) !
1501	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for irrig_gw_source_mean','','')!
1502	ALLOCATE (irrig_fast_source_mean(nbpt), stat=ier) !
1503	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for irrig_fast_source_mean','','')!
1504	ALLOCATE (irrig_str_source_mean(nbpt), stat=ier) !
1505	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for irrig_str_source_mean','','')!
1506	irrig_netereq(:) = zero
1507
1508	IF ( do_irrigation ) THEN
1509	var_name = 'irrigation'
1510	CALL ioconf_setatt_p('UNITS', 'Kg/dt')
1511	CALL ioconf_setatt_p('LONG_NAME','Artificial irrigation flux')
1512	CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., irrigation_mean, "gather", nbp_glo, index_g)
1513	CALL setvar_p (irrigation_mean, val_exp, 'NO_KEYWORD', zero)
1514	var_name = 'irrigdeficit'
1515	CALL ioconf_setatt_p('UNITS', 'Kg/dt')
1516	CALL ioconf_setatt_p('LONG_NAME','Irrigation deficit')
1517	CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., irrigdeficit_mean, "gather", nbp_glo, index_g)
1518	CALL setvar_p (irrigdeficit_mean, val_exp, 'NO_KEYWORD', zero)
1519	var_name = 'irrigadduct'
1520	CALL ioconf_setatt_p('UNITS', 'Kg/dt')
1521	CALL ioconf_setatt_p('LONG_NAME','Artificial irrigation flux from adduction')
1522	CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., irrigadduct_mean, "gather", nbp_glo, index_g)
1523	CALL setvar_p (irrigadduct_mean, val_exp, 'NO_KEYWORD', zero)
1524	var_name = 'irrig_gw_source'!
1525	CALL ioconf_setatt_p('UNITS', 'Kg/dt')
1526	CALL ioconf_setatt_p('LONG_NAME','Irrigation from GW reservoir')
1527	CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., irrig_gw_source_mean, "gather", nbp_glo, index_g)
1528	CALL setvar_p (irrig_gw_source_mean, val_exp, 'NO_KEYWORD', zero)
1529	var_name = 'irrig_fast_source'!
1530	CALL ioconf_setatt_p('UNITS', 'Kg/dt')
1531	CALL ioconf_setatt_p('LONG_NAME','Irrigation from fast reservoir')
1532	CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., irrig_fast_source_mean, "gather", nbp_glo, index_g)
1533	CALL setvar_p (irrig_fast_source_mean, val_exp, 'NO_KEYWORD', zero)
1534	var_name = 'irrig_str_source'!
1535	CALL ioconf_setatt_p('UNITS', 'Kg/dt')
1536	CALL ioconf_setatt_p('LONG_NAME','Irrigation from stream reservoir')
1537	CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., irrig_str_source_mean, "gather", nbp_glo, index_g)
1538	CALL setvar_p (irrig_str_source_mean, val_exp, 'NO_KEYWORD', zero)
1539	ELSE
1540	irrigation_mean(:) = zero
1541	irrig_gw_source_mean(:) = zero
1542	irrig_fast_source_mean(:) = zero
1543	irrig_str_source_mean(:) = zero
1544	irrigdeficit_mean(:) = zero
1545	irrigadduct_mean(:) = zero
1546	ENDIF
1547	irrigation(:) = irrigation_mean(:)
1548
1549	ALLOCATE (riverflow_mean(nbpt), stat=ier)
1550	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for riverflow_mean','','')
1551	var_name = 'riverflow'
1552	CALL ioconf_setatt_p('UNITS', 'Kg/dt')
1553	CALL ioconf_setatt_p('LONG_NAME','River flux into the sea')
1554	CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., riverflow_mean, "gather", nbp_glo, index_g)
1555	CALL setvar_p (riverflow_mean, val_exp, 'NO_KEYWORD', zero)
1556	riverflow(:) = riverflow_mean(:)
1557
1558	ALLOCATE (coastalflow_mean(nbpt), stat=ier)
1559	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for coastalflow_mean','','')
1560	var_name = 'coastalflow'
1561	CALL ioconf_setatt_p('UNITS', 'Kg/dt')
1562	CALL ioconf_setatt_p('LONG_NAME','Diffuse flux into the sea')
1563	CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., coastalflow_mean, "gather", nbp_glo, index_g)
1564	CALL setvar_p (coastalflow_mean, val_exp, 'NO_KEYWORD', zero)
1565	coastalflow(:) = coastalflow_mean(:)
1566
1567	! Locate it at the 2m level
1568	ipn = MINLOC(ABS(diaglev-2))
1569	floodtemp_lev = ipn(1)
1570	ALLOCATE (floodtemp(nbpt), stat=ier)
1571	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for floodtemp','','')
1572	floodtemp(:) = stempdiag(:,floodtemp_lev)
1573
1574	ALLOCATE(hydrographs(nbpt), stat=ier)
1575	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for hydrographs','','')
1576	var_name = 'hydrographs'
1577	CALL ioconf_setatt_p('UNITS', 'kg/dt_sechiba')
1578	CALL ioconf_setatt_p('LONG_NAME','Hydrograph at outlow of grid')
1579	CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., hydrographs, "gather", nbp_glo, index_g)
1580	CALL setvar_p (hydrographs, val_exp, 'NO_KEYWORD', zero)
1581
1582	ALLOCATE(slowflow_diag(nbpt), stat=ier)
1583	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for slowflow_diag','','')
1584	var_name = 'slowflow_diag'
1585	CALL ioconf_setatt_p('UNITS', 'kg/dt_sechiba')
1586	CALL ioconf_setatt_p('LONG_NAME','Slowflow hydrograph at outlow of grid')
1587	CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE.,slowflow_diag, "gather", nbp_glo, index_g)
1588	CALL setvar_p (slowflow_diag, val_exp, 'NO_KEYWORD', zero)
1589
1590	!
1591	! The diagnostic variables, they are initialized from the above restart variables.
1592	!
1593	ALLOCATE(fast_diag(nbpt), slow_diag(nbpt), stream_diag(nbpt), flood_diag(nbpt), &
1594	& pond_diag(nbpt), lake_diag(nbpt), stat=ier)
1595	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for fast_diag,..','','')
1596
1597	fast_diag(:) = zero
1598	slow_diag(:) = zero
1599	stream_diag(:) = zero
1600	flood_diag(:) = zero
1601	pond_diag(:) = zero
1602	lake_diag(:) = zero
1603
1604	DO ig=1,nbpt
1605	totarea = zero
1606	DO ib=1,nbasmax
1607	totarea = totarea + routing_area(ig,ib)
1608	fast_diag(ig) = fast_diag(ig) + fast_reservoir(ig,ib)
1609	slow_diag(ig) = slow_diag(ig) + slow_reservoir(ig,ib)
1610	stream_diag(ig) = stream_diag(ig) + stream_reservoir(ig,ib)
1611	flood_diag(ig) = flood_diag(ig) + flood_reservoir(ig,ib)
1612	ENDDO
1613	!
1614	fast_diag(ig) = fast_diag(ig)/totarea
1615	slow_diag(ig) = slow_diag(ig)/totarea
1616	stream_diag(ig) = stream_diag(ig)/totarea
1617	flood_diag(ig) = flood_diag(ig)/totarea
1618	!
1619	! This is the volume of the lake scaled to the entire grid.
1620	! It would be better to scale it to the size of the lake
1621	! but this information is not yet available.
1622	!
1623	lake_diag(ig) = lake_reservoir(ig)/totarea
1624	!
1625	ENDDO
1626	!
1627	! Get from the restart the fluxes we accumulated.
1628	!
1629	ALLOCATE (floodout_mean(nbpt), stat=ier)
1630	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for floodout_mean','','')
1631	var_name = 'floodout_route'
1632	CALL ioconf_setatt_p('UNITS', 'Kg')
1633	CALL ioconf_setatt_p('LONG_NAME','Accumulated flow out of floodplains for routing')
1634	CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., floodout_mean, "gather", nbp_glo, index_g)
1635	CALL setvar_p (floodout_mean, val_exp, 'NO_KEYWORD', zero)
1636
1637	ALLOCATE (runoff_mean(nbpt), stat=ier)
1638	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for runoff_mean','','')
1639	var_name = 'runoff_route'
1640	CALL ioconf_setatt_p('UNITS', 'Kg')
1641	CALL ioconf_setatt_p('LONG_NAME','Accumulated runoff for routing')
1642	CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., runoff_mean, "gather", nbp_glo, index_g)
1643	CALL setvar_p (runoff_mean, val_exp, 'NO_KEYWORD', zero)
1644
1645	ALLOCATE(drainage_mean(nbpt), stat=ier)
1646	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for drainage_mean','','')
1647	var_name = 'drainage_route'
1648	CALL ioconf_setatt_p('UNITS', 'Kg')
1649	CALL ioconf_setatt_p('LONG_NAME','Accumulated drainage for routing')
1650	CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., drainage_mean, "gather", nbp_glo, index_g)
1651	CALL setvar_p (drainage_mean, val_exp, 'NO_KEYWORD', zero)
1652
1653	ALLOCATE(transpot_mean(nbpt), stat=ier)
1654	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for transpot_mean','','')
1655	var_name = 'transpot_route'
1656	CALL ioconf_setatt_p('UNITS', 'Kg/m^2')
1657	CALL ioconf_setatt_p('LONG_NAME','Accumulated potential transpiration for routing/irrigation')
1658	CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., transpot_mean, "gather", nbp_glo, index_g)
1659	CALL setvar_p (transpot_mean, val_exp, 'NO_KEYWORD', zero)
1660
1661	ALLOCATE(precip_mean(nbpt), stat=ier)
1662	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for precip_mean','','')
1663	var_name = 'precip_route'
1664	CALL ioconf_setatt_p('UNITS', 'Kg/m^2')
1665	CALL ioconf_setatt_p('LONG_NAME','Accumulated rain precipitation for irrigation')
1666	CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., precip_mean, "gather", nbp_glo, index_g)
1667	CALL setvar_p (precip_mean, val_exp, 'NO_KEYWORD', zero)
1668
1669	ALLOCATE(humrel_mean(nbpt), stat=ier)
1670	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for humrel_mean','','')
1671	var_name = 'humrel_route'
1672	CALL ioconf_setatt_p('UNITS', '-')
1673	CALL ioconf_setatt_p('LONG_NAME','Mean humrel for irrigation')
1674	CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., humrel_mean, "gather", nbp_glo, index_g)
1675	CALL setvar_p (humrel_mean, val_exp, 'NO_KEYWORD', un)
1676
1677	ALLOCATE(k_litt_mean(nbpt), stat=ier)
1678	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for k_litt_mean','','')
1679	var_name = 'k_litt_route'
1680	CALL ioconf_setatt_p('UNITS', '-')
1681	CALL ioconf_setatt_p('LONG_NAME','Mean cond. for litter')
1682	CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., k_litt_mean, "gather", nbp_glo, index_g)
1683	CALL setvar_p (k_litt_mean, val_exp, 'NO_KEYWORD', zero)
1684
1685	ALLOCATE(totnobio_mean(nbpt), stat=ier)
1686	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for totnobio_mean','','')
1687	var_name = 'totnobio_route'
1688	CALL ioconf_setatt_p('UNITS', '-')
1689	CALL ioconf_setatt_p('LONG_NAME','Last Total fraction of no bio for irrigation')
1690	CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., totnobio_mean, "gather", nbp_glo, index_g)
1691	CALL setvar_p (totnobio_mean, val_exp, 'NO_KEYWORD', zero)
1692
1693	ALLOCATE(vegtot_mean(nbpt), stat=ier)
1694	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for vegtot_mean','','')
1695	var_name = 'vegtot_route'
1696	CALL ioconf_setatt_p('UNITS', '-')
1697	CALL ioconf_setatt_p('LONG_NAME','Last Total fraction of vegetation')
1698	CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., vegtot_mean, "gather", nbp_glo, index_g)
1699	CALL setvar_p (vegtot_mean, val_exp, 'NO_KEYWORD', un)
1700	!
1701	!
1702	DEALLOCATE(tmp_real_g)
1703	!
1704	! Allocate diagnostic variables
1705	!
1706	ALLOCATE(hydrodiag_loc(nbpt,nbasmax),hydrodiag_glo(nbp_glo,nbasmax),stat=ier)
1707	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for hydrodiag_glo','','')
1708	hydrodiag=>hydrodiag_loc
1709
1710	ALLOCATE(hydroupbasin_loc(nbpt),hydroupbasin_glo(nbp_glo), stat=ier)
1711	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for hydroupbasin_glo','','')
1712	hydroupbasin=>hydroupbasin_loc
1713
1714	END SUBROUTINE routing_init
1715	!
1716	!! ================================================================================================================================
1717	!! SUBROUTINE : routing_clear
1718	!!
1719	!>\BRIEF : This subroutine deallocates the block memory previously allocated.
1720	!! \n
1721	!_ ================================================================================================================================
1722
1723	SUBROUTINE routing_clear()
1724
1725	IF (ALLOCATED(routing_area_loc)) DEALLOCATE(routing_area_loc)
1726	IF (ALLOCATED(route_togrid_loc)) DEALLOCATE(route_togrid_loc)
1727	IF (ALLOCATED(route_tobasin_loc)) DEALLOCATE(route_tobasin_loc)
1728	IF (ALLOCATED(route_nbintobas_loc)) DEALLOCATE(route_nbintobas_loc)
1729	IF (ALLOCATED(global_basinid_loc)) DEALLOCATE(global_basinid_loc)
1730	IF (ALLOCATED(topo_resid_loc)) DEALLOCATE(topo_resid_loc)
1731	IF (ALLOCATED(routing_area_glo)) DEALLOCATE(routing_area_glo)
1732	IF (ALLOCATED(route_togrid_glo)) DEALLOCATE(route_togrid_glo)
1733	IF (ALLOCATED(route_tobasin_glo)) DEALLOCATE(route_tobasin_glo)
1734	IF (ALLOCATED(route_nbintobas_glo)) DEALLOCATE(route_nbintobas_glo)
1735	IF (ALLOCATED(global_basinid_glo)) DEALLOCATE(global_basinid_glo)
1736	IF (ALLOCATED(topo_resid_glo)) DEALLOCATE(topo_resid_glo)
1737	IF (ALLOCATED(fast_reservoir)) DEALLOCATE(fast_reservoir)
1738	IF (ALLOCATED(slow_reservoir)) DEALLOCATE(slow_reservoir)
1739	IF (ALLOCATED(stream_reservoir)) DEALLOCATE(stream_reservoir)
1740	IF (ALLOCATED(flood_reservoir)) DEALLOCATE(flood_reservoir)
1741	IF (ALLOCATED(flood_frac_bas)) DEALLOCATE(flood_frac_bas)
1742	IF (ALLOCATED(flood_height)) DEALLOCATE(flood_height)
1743	IF (ALLOCATED(pond_frac)) DEALLOCATE(pond_frac)
1744	IF (ALLOCATED(lake_reservoir)) DEALLOCATE(lake_reservoir)
1745	IF (ALLOCATED(pond_reservoir)) DEALLOCATE(pond_reservoir)
1746	IF (ALLOCATED(returnflow_mean)) DEALLOCATE(returnflow_mean)
1747	IF (ALLOCATED(reinfiltration_mean)) DEALLOCATE(reinfiltration_mean)
1748	IF (ALLOCATED(riverflow_mean)) DEALLOCATE(riverflow_mean)
1749	IF (ALLOCATED(coastalflow_mean)) DEALLOCATE(coastalflow_mean)
1750	IF (ALLOCATED(lakeinflow_mean)) DEALLOCATE(lakeinflow_mean)
1751	IF (ALLOCATED(runoff_mean)) DEALLOCATE(runoff_mean)
1752	IF (ALLOCATED(floodout_mean)) DEALLOCATE(floodout_mean)
1753	IF (ALLOCATED(drainage_mean)) DEALLOCATE(drainage_mean)
1754	IF (ALLOCATED(transpot_mean)) DEALLOCATE(transpot_mean)
1755	IF (ALLOCATED(precip_mean)) DEALLOCATE(precip_mean)
1756	IF (ALLOCATED(humrel_mean)) DEALLOCATE(humrel_mean)
1757	IF (ALLOCATED(k_litt_mean)) DEALLOCATE(k_litt_mean)
1758	IF (ALLOCATED(totnobio_mean)) DEALLOCATE(totnobio_mean)
1759	IF (ALLOCATED(vegtot_mean)) DEALLOCATE(vegtot_mean)
1760	IF (ALLOCATED(floodtemp)) DEALLOCATE(floodtemp)
1761	IF (ALLOCATED(hydrodiag_loc)) DEALLOCATE(hydrodiag_loc)
1762	IF (ALLOCATED(hydrodiag_glo)) DEALLOCATE(hydrodiag_glo)
1763	IF (ALLOCATED(hydroupbasin_loc)) DEALLOCATE(hydroupbasin_loc)
1764	IF (ALLOCATED(hydroupbasin_glo)) DEALLOCATE(hydroupbasin_glo)
1765	IF (ALLOCATED(hydrographs)) DEALLOCATE(hydrographs)
1766	IF (ALLOCATED(slowflow_diag)) DEALLOCATE(slowflow_diag)
1767	IF (ALLOCATED(irrigation_mean)) DEALLOCATE(irrigation_mean)
1768	IF (ALLOCATED(irrigdeficit_mean)) DEALLOCATE(irrigdeficit_mean)!
1769	IF (ALLOCATED(irrigadduct_mean)) DEALLOCATE(irrigadduct_mean)!
1770	IF (ALLOCATED(irrig_gw_source_mean)) DEALLOCATE(irrig_gw_source_mean) !
1771	IF (ALLOCATED(irrig_fast_source_mean)) DEALLOCATE(irrig_fast_source_mean) !
1772	IF (ALLOCATED(irrig_str_source_mean)) DEALLOCATE(irrig_str_source_mean) !
1773	IF (ALLOCATED(irrigated)) DEALLOCATE(irrigated)
1774	IF (ALLOCATED(floodplains)) DEALLOCATE(floodplains)
1775	IF (ALLOCATED(swamp)) DEALLOCATE(swamp)
1776	IF (ALLOCATED(fast_diag)) DEALLOCATE(fast_diag)
1777	IF (ALLOCATED(slow_diag)) DEALLOCATE(slow_diag)
1778	IF (ALLOCATED(stream_diag)) DEALLOCATE(stream_diag)
1779	IF (ALLOCATED(flood_diag)) DEALLOCATE(flood_diag)
1780	IF (ALLOCATED(pond_diag)) DEALLOCATE(pond_diag)
1781	IF (ALLOCATED(lake_diag)) DEALLOCATE(lake_diag)
1782
1783	END SUBROUTINE routing_clear
1784	!
1785
1786	!! ================================================================================================================================
1787	!! SUBROUTINE : routing_flow
1788	!!
1789	!>\BRIEF This subroutine computes the transport of water in the various reservoirs
1790	!! (including ponds and floodplains) and the water withdrawals from the reservoirs for irrigation.
1791	!!
1792	!! DESCRIPTION (definitions, functional, design, flags) :
1793	!! This will first compute the amount of water which flows out of each of the 3 reservoirs using the assumption of an
1794	!! exponential decrease of water in the reservoir (see Hagemann S and Dumenil L. (1998)). Then we compute the fluxes
1795	!! for floodplains and ponds. All this will then be used in order to update each of the basins : taking water out of
1796	!! the up-stream basin and adding it to the down-stream one.
1797	!! As this step happens globaly we have to stop the parallel processing in order to exchange the information. Once
1798	!! all reservoirs are updated we deal with irrigation. The final step is to compute diagnostic fluxes. Among them
1799	!! the hydrographs of the largest rivers we have chosen to monitor.
1800	!!
1801	!! RECENT CHANGE(S): None
1802	!!
1803	!! MAIN OUTPUT VARIABLE(S): lakeinflow, returnflow, reinfiltration, irrigation, riverflow, coastalflow, hydrographs, flood_frac, flood_res
1804	!!
1805	!! REFERENCES :
1806	!! - Ngo-Duc, T., K. Laval, G. Ramillien, J. Polcher, and A. Cazenave (2007)
1807	!! Validation of the land water storage simulated by Organising Carbon and Hydrology in Dynamic Ecosystems (ORCHIDEE) with Gravity Recovery and Climate Experiment (GRACE) data.
1808	!! Water Resour. Res., 43, W04427, doi:10.1029/2006WR004941.
1809	!! * Irrigation:
1810	!! - de Rosnay, P., J. Polcher, K. Laval, and M. Sabre (2003)
1811	!! Integrated parameterization of irrigation in the land surface model ORCHIDEE. Validation over Indian Peninsula.
1812	!! Geophys. Res. Lett., 30(19), 1986, doi:10.1029/2003GL018024.
1813	!! - A.C. Vivant (2003)
1814	!! Les plaines d'inondations et l'irrigation dans ORCHIDEE, impacts de leur prise en compte.
1815	!! , , 51pp.
1816	!! - N. Culson (2004)
1817	!! Impact de l'irrigation sur le cycle de l'eau
1818	!! Master thesis, Paris VI University, 55pp.
1819	!! - X.-T. Nguyen-Vinh (2005)
1820	!! Analyse de l'impact de l'irrigation en Amerique du Nord - plaine du Mississippi - sur la climatologie regionale
1821	!! Master thesis, Paris VI University, 33pp.
1822	!! - M. Guimberteau (2006)
1823	!! Analyse et modifications proposees de la modelisation de l'irrigation dans un modele de surface.
1824	!! Master thesis, Paris VI University, 46pp.
1825	!! - Guimberteau M. (2010)
1826	!! Modelisation de l'hydrologie continentale et influences de l'irrigation sur le cycle de l'eau.
1827	!! Ph.D. thesis, Paris VI University, 195pp.
1828	!! - Guimberteau M., Laval K., Perrier A. and Polcher J. (2011).
1829	!! Global effect of irrigation and its impact on the onset of the Indian summer monsoon.
1830	!! In press, Climate Dynamics, doi: 10.1007/s00382-011-1252-5.
1831	!! * Floodplains:
1832	!! - A.C. Vivant (2002)
1833	!! L'ecoulement lateral de l'eau sur les surfaces continentales. Prise en compte des plaines d'inondations dans ORCHIDEE.
1834	!! Master thesis, Paris VI University, 46pp.
1835	!! - A.C. Vivant (2003)
1836	!! Les plaines d'inondations et l'irrigation dans ORCHIDEE, impacts de leur prise en compte.
1837	!! , , 51pp.
1838	!! - T. d'Orgeval (2006)
1839	!! Impact du changement climatique sur le cycle de l'eau en Afrique de l'Ouest: modelisation et incertitudes.
1840	!! Ph.D. thesis, Paris VI University, 188pp.
1841	!! - T. d'Orgeval, J. Polcher, and P. de Rosnay (2008)
1842	!! Sensitivity of the West African hydrological cycle in ORCHIDEE to infiltration processes.
1843	!! Hydrol. Earth Syst. Sci., 12, 1387-1401
1844	!! - M. Guimberteau, G. Drapeau, J. Ronchail, B. Sultan, J. Polcher, J.-M. Martinez, C. Prigent, J.-L. Guyot, G. Cochonneau,
1845	!! J. C. Espinoza, N. Filizola, P. Fraizy, W. Lavado, E. De Oliveira, R. Pombosa, L. Noriega, and P. Vauchel (2011)
1846	!! Discharge simulation in the sub-basins of the Amazon using ORCHIDEE forced by new datasets.
1847	!! Hydrol. Earth Syst. Sci. Discuss., 8, 11171-11232, doi:10.5194/hessd-8-11171-2011
1848	!!
1849	!! FLOWCHART :None
1850	!! \n
1851	!_ ================================================================================================================================
1852
1853	SUBROUTINE routing_flow(nbpt, dt_routing, lalo, floodout, runoff, drainage, root_deficit, soiltile, &
1854	& vegtot, totnobio, transpot_mean, precip, humrel, k_litt, floodtemp, reinf_slope, &
1855	& lakeinflow, returnflow, reinfiltration, irrig_frac, irrigation, irrigdeficit, &
1856	& irrigadduct, irrig_gw_source, &
1857	& irrig_fast_source, irrig_str_source, riverflow, & !
1858	& coastalflow, hydrographs, slowflow_diag, flood_frac, flood_res, &
1859	netflow_stream_diag, netflow_fast_diag, netflow_slow_diag, fraction_aeirrig_sw) !
1860	!
1861	IMPLICIT NONE
1862	!
1863	!! INPUT VARIABLES
1864	INTEGER(i_std), INTENT(in) :: nbpt !! Domain size (unitless)
1865	REAL(r_std), INTENT (in) :: dt_routing !! Routing time step (s)
1866	REAL(r_std), INTENT(in) :: lalo(nbpt,2) !! Vector of latitude and longitudes
1867	REAL(r_std), INTENT(in) :: runoff(nbpt) !! Grid-point runoff (kg/m^2/dt)
1868	REAL(r_std), INTENT(in) :: floodout(nbpt) !! Grid-point flow out of floodplains (kg/m^2/dt)
1869	REAL(r_std), INTENT(in) :: drainage(nbpt) !! Grid-point drainage (kg/m^2/dt)
1870	REAL(r_std), INTENT(in) :: root_deficit(nbpt) !! soil water deficit
1871	REAL(r_std), INTENT(in) :: vegtot(nbpt) !! Potentially vegetated fraction (unitless;0-1)
1872	REAL(r_std), INTENT(in) :: totnobio(nbpt) !! Other areas which can not have vegetation
1873	REAL(r_std), INTENT(in) :: transpot_mean(nbpt) !! Mean potential transpiration of the vegetation (kg/m^2/dt)
1874	REAL(r_std), INTENT(in) :: precip(nbpt) !! Rainfall (kg/m^2/dt)
1875	REAL(r_std), INTENT(in) :: humrel(nbpt) !! Soil moisture stress, root extraction potential (unitless)
1876	REAL(r_std), INTENT(in) :: k_litt(nbpt) !! Averaged conductivity for saturated infiltration in the 'litter' layer (kg/m^2/dt)
1877	REAL(r_std), INTENT(in) :: floodtemp(nbpt) !! Temperature to decide if floodplains work (K)
1878	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)
1879	REAL(r_std), INTENT(out) :: lakeinflow(nbpt) !! Water inflow to the lakes (kg/dt)
1880	REAL(r_std), INTENT(in) :: soiltile(nbpt,nstm) !! Fraction of each soil tile within vegtot (0-1, unitless)
1881	REAL(r_std), INTENT(in) :: irrig_frac(nbpt) !! Irrig. fraction interpolated in routing, and saved to pass to slowproc if irrigated_soiltile = .TRUE.
1882	REAL(r_std), INTENT(in) :: fraction_aeirrig_sw(nbpt) !! Fraction of area equipped for irrigation from surface water, of irrig_frac
1883
1884	!
1885	!! OUTPUT VARIABLES
1886	REAL(r_std), INTENT(out) :: returnflow(nbpt) !! The water flow from lakes and swamps which returns into the grid box.
1887	!! This water will go back into the hydrol module to allow re-evaporation (kg/m^2/dt_routing)
1888	REAL(r_std), INTENT(out) :: reinfiltration(nbpt) !! Water flow from ponds and floodplains which returns to the grid box (kg/m^2/dt)
1889	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)
1890	REAL(r_std), INTENT(out) :: irrigdeficit(nbpt) !! Irrigation deficit. Difference btw irrig. demand and irrigation
1891	REAL(r_std), INTENT(out) :: irrigadduct(nbpt) !! Irrigation from adducted water. Included in irrigation
1892
1893	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)
1894	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)
1895	REAL(r_std), INTENT(out) :: hydrographs(nbpt) !! Hydrographs at the outflow of the grid box for major basins (kg/dt)
1896	REAL(r_std), INTENT(out) :: slowflow_diag(nbpt) !! Hydrographs of slow_flow = routed slow_flow for major basins (kg/dt)
1897	REAL(r_std), INTENT(out) :: flood_frac(nbpt) !! Flooded fraction of the grid box (unitless;0-1)
1898	REAL(r_std), INTENT(out) :: flood_res(nbpt) !! Diagnostic of water amount in the floodplains reservoir (kg)
1899
1900	REAL(r_std), INTENT(out) :: netflow_stream_diag(nbpt) !! Input - Output flow to stream reservoir
1901	REAL(r_std), INTENT(out) :: netflow_fast_diag(nbpt) !! Input - Output flow to fast reservoir
1902	REAL(r_std), INTENT(out) :: netflow_slow_diag(nbpt) !! Input - Output flow to slow reservoir
1903
1904	REAL(r_std), INTENT(out) :: irrig_gw_source(nbpt) !! Irrigation from groundwater per cell
1905	REAL(r_std), INTENT(out) :: irrig_fast_source(nbpt) !! Irrigation from fast reservoir per cell
1906	REAL(r_std), INTENT(out) :: irrig_str_source(nbpt) !! Irrigation from stramflow per cell
1907	!
1908	!! LOCAL VARIABLES
1909	REAL(r_std), DIMENSION(nbpt, nbasmax) :: fast_flow !! Outflow from the fast reservoir (kg/dt)
1910	REAL(r_std), DIMENSION(nbpt, nbasmax) :: slow_flow !! Outflow from the slow reservoir (kg/dt)
1911	REAL(r_std), DIMENSION(nbpt, nbasmax) :: stream_flow !! Outflow from the stream reservoir (kg/dt)
1912	REAL(r_std), DIMENSION(nbpt, nbasmax) :: flood_flow !! Outflow from the floodplain reservoir (kg/dt)
1913	REAL(r_std), DIMENSION(nbpt, nbasmax) :: pond_inflow !! Inflow to the pond reservoir (kg/dt)
1914	REAL(r_std), DIMENSION(nbpt, nbasmax) :: pond_drainage !! Drainage from pond (kg/m^2/dt)
1915	REAL(r_std), DIMENSION(nbpt, nbasmax) :: flood_drainage !! Drainage from floodplains (kg/m^2/dt)
1916	REAL(r_std), DIMENSION(nbpt, nbasmax) :: return_swamp !! Inflow to the swamp (kg/dt)
1917	!
1918	! Irrigation per basin
1919	!
1920	REAL(r_std), DIMENSION(nbpt, nbasmax) :: irrig_needs !! Total irrigation requirement (water requirements by the crop for its optimal growth) (kg)
1921	REAL(r_std), DIMENSION(nbpt, nbasmax) :: irrig_actual !! Possible irrigation according to the water availability in the reservoirs (kg)
1922	REAL(r_std), DIMENSION(nbpt, nbasmax) :: irrig_deficit !! Amount of water missing for irrigation (kg)
1923	REAL(r_std), DIMENSION(nbpt, nbasmax) :: irrig_adduct !! Amount of water carried over from other basins for irrigation (kg)
1924	!
1925	REAL(r_std), DIMENSION(nbpt, 0:nbasmax+3) :: transport !! Water transport between basins (kg/dt)
1926	REAL(r_std), DIMENSION(nbp_glo, 0:nbasmax+3) :: transport_glo !! Water transport between basins (kg/dt)
1927	REAL(r_std), DIMENSION(nbpt, nbasmax) :: floods !! Water flow in to the floodplains (kg/dt)
1928	REAL(r_std), DIMENSION(nbpt, nbasmax) :: potflood !! Potential inflow to the swamps (kg/dt)
1929	REAL(r_std), DIMENSION(nbpt) :: tobeflooded !! Maximal surface which can be inundated in each grid box (m^2)
1930	REAL(r_std), DIMENSION(nbpt) :: totarea !! Total area of basin (m^2)
1931	REAL(r_std), DIMENSION(nbpt) :: totflood !! Total amount of water in the floodplains reservoir (kg)
1932	REAL(r_std), DIMENSION(nbasmax) :: pond_excessflow !!
1933	REAL(r_std) :: flow !! Outflow computation for the reservoirs (kg/dt)
1934	REAL(r_std) :: floodindex !! Fraction of grid box area inundated (unitless;0-1)
1935	REAL(r_std) :: pondex !!
1936	REAL(r_std) :: flood_frac_pot !! Total fraction of the grid box which is flooded at optimum repartition (unitless;0-1)
1937	REAL(r_std) :: stream_tot !! Total water amount in the stream reservoirs (kg)
1938	REAL(r_std) :: adduction !! Importation of water from a stream reservoir of a neighboring grid box (kg)
1939	REAL(r_std), DIMENSION(nbp_glo) :: lake_overflow_g !! Removed water from lake reservoir on global grid (kg/gridcell/dt_routing)
1940	REAL(r_std), DIMENSION(nbpt) :: lake_overflow !! Removed water from lake reservoir on local grid (kg/gridcell/dt_routing)
1941	REAL(r_std), DIMENSION(nbpt) :: lake_overflow_coast !! lake_overflow distributed on coast gridcells, only diag(kg/gridcell/dt_routing)
1942	REAL(r_std) :: total_lake_overflow !! Sum of lake_overflow over full grid (kg)
1943	REAL(r_std), DIMENSION(8,nbasmax) :: streams_around !! Stream reservoirs of the neighboring grid boxes (kg)
1944	INTEGER(i_std), DIMENSION(8) :: igrd !!
1945	INTEGER(i_std), DIMENSION(2) :: ff !!
1946	INTEGER(i_std), DIMENSION(1) :: fi !!
1947	INTEGER(i_std) :: ig, ib, ib2, ig2 !! Indices (unitless)
1948	INTEGER(i_std) :: rtg, rtb, in !! Indices (unitless)
1949	INTEGER(i_std) :: ier !! Error handling
1950	REAL(r_std), DIMENSION(nbpt) :: Count_failure_slow !! Counter times slow reserv. does not fit irrigation demand
1951	REAL(r_std), DIMENSION(nbpt) :: Count_failure_fast !! Counter times fast reserv. does not fit irrigation demand
1952	REAL(r_std), DIMENSION(nbpt) :: Count_failure_stre !! Counter times stream reserv. does not fit irrigation demand
1953	LOGICAL :: IsFail_slow !! Logical to ask if slow reserv. does not fit irrigation demand
1954	LOGICAL :: IsFail_fast !! Logical to ask if fast reserv. does not fit irrigation demand
1955	LOGICAL :: IsFail_stre !! Logical to ask if stream reserv. does not fit irrigation demand
1956	REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: fast_flow_g !! Outflow from the fast reservoir (kg/dt)
1957	REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: slow_flow_g !! Outflow from the slow reservoir (kg/dt)
1958	REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: stream_flow_g !! Outflow from the stream reservoir (kg/dt)
1959	REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: irrig_deficit_glo !! Amount of water missing for irrigation (kg)
1960	REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: stream_reservoir_glo !! Water amount in the stream reservoir (kg)
1961	REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: irrig_adduct_glo !! Amount of water carried over from other basins for irrigation (kg)
1962
1963	REAL(r_std), DIMENSION(nbpt, nbasmax) :: netflow_stream !! Input - Output flow to stream reservoir
1964	REAL(r_std), DIMENSION(nbpt, nbasmax) :: netflow_fast !! Input - Output flow to fast reservoir
1965	REAL(r_std), DIMENSION(nbpt, nbasmax) :: netflow_slow !! Input - Output flow to slow reservoir
1966
1967	REAL(r_std) :: pcent_vol_irrig !! Percentage of surface water for irrigation from total available water
1968	REAL(r_std) :: slow_wdr_dummy,fast_wdr_dummy,stre_wdr_dummy !! Dummy variables, real abstraction in each reservoir for irrigation
1969	REAL(r_std) :: pot_slow_wdr_dummy,pot_fast_wdr_dummy,pot_stre_wdr_dummy !! Dummy variables, potential abstraction in each reservoir for irrigatio
1970	!! PARAMETERS
1971	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)
1972	!_ ================================================================================================================================
1973	!
1974	transport(:,:) = zero
1975	transport_glo(:,:) = zero
1976	irrig_netereq(:) = zero
1977	irrig_needs(:,:) = zero
1978	irrig_actual(:,:) = zero
1979	irrig_deficit(:,:) = zero
1980	irrig_adduct(:,:) = zero
1981	totarea(:) = zero
1982	totflood(:) = zero
1983	irrig_gw_source(:) = zero !
1984	irrig_fast_source(:) = zero !
1985	irrig_str_source(:) = zero !
1986	Count_failure_slow(:) = zero !
1987	Count_failure_fast(:) = zero !
1988	Count_failure_stre(:) = zero !
1989	!
1990	! Compute all the fluxes
1991	!
1992	DO ib=1,nbasmax
1993	DO ig=1,nbpt
1994	!
1995	totarea(ig) = totarea(ig) + routing_area(ig,ib)
1996	totflood(ig) = totflood(ig) + flood_reservoir(ig,ib)
1997	ENDDO
1998	ENDDO
1999	!
2000	!> The outflow fluxes from the three reservoirs are computed.
2001	!> The outflow of volume of water Vi into the reservoir i is assumed to be linearly related to its volume.
2002	!> The water travel simulated by the routing scheme is dependent on the water retention index topo_resid
2003	!> given by a 0.5 degree resolution map for each pixel performed from a simplification of Manning's formula
2004	!> (Dingman, 1994; Ducharne et al., 2003).
2005	!> The resulting product of tcst (in day/m) and topo_resid (in m) represents the time constant (day)
2006	!> which is an e-folding time, the time necessary for the water amount
2007	!> in the stream reservoir to decrease by a factor e. Hence, it gives an order of
2008	!> magnitude of the travel time through this reservoir between
2009	!> the sub-basin considered and its downstream neighbor.
2010
2011	DO ib=1,nbasmax
2012	DO ig=1,nbpt
2013	IF ( route_tobasin(ig,ib) .GT. 0 ) THEN
2014	!
2015	! Each of the fluxes is limited by the water in the reservoir and a small margin
2016	! (min_reservoir) to avoid rounding errors.
2017	!
2018	flow = MIN(fast_reservoir(ig,ib)/((topo_resid(ig,ib)/1000.)fast_tcstone_day/dt_routing),&
2019	& fast_reservoir(ig,ib)-min_sechiba)
2020	fast_flow(ig,ib) = MAX(flow, zero)
2021
2022	flow = MIN(slow_reservoir(ig,ib)/((topo_resid(ig,ib)/1000.)slow_tcstone_day/dt_routing),&
2023	& slow_reservoir(ig,ib)-min_sechiba)
2024	slow_flow(ig,ib) = MAX(flow, zero)
2025
2026	flow = MIN(stream_reservoir(ig,ib)/((topo_resid(ig,ib)/1000.)stream_tcst &
2027	& MAX(un-SQRT(flood_frac_bas(ig,ib)),min_sechiba)*one_day/dt_routing),&
2028	& stream_reservoir(ig,ib)-min_sechiba)
2029	stream_flow(ig,ib) = MAX(flow, zero)
2030	!
2031	ELSE
2032	fast_flow(ig,ib) = zero
2033	slow_flow(ig,ib) = zero
2034	stream_flow(ig,ib) = zero
2035	ENDIF
2036	ENDDO
2037	ENDDO
2038	!-
2039	!- Compute the fluxes out of the floodplains and ponds if they exist.
2040	!-
2041	IF (do_floodplains .OR. doponds) THEN
2042	DO ig=1,nbpt
2043	IF (flood_frac(ig) .GT. min_sechiba) THEN
2044	!
2045	flow = MIN(floodout(ig)totarea(ig)pond_frac(ig)/flood_frac(ig), pond_reservoir(ig)+totflood(ig))
2046	pondex = MAX(flow - pond_reservoir(ig), zero)
2047	pond_reservoir(ig) = pond_reservoir(ig) - (flow - pondex)
2048	!
2049	! If demand was over reservoir size, we will take it out from floodplains
2050	!
2051	pond_excessflow(:) = zero
2052	DO ib=1,nbasmax
2053	pond_excessflow(ib) = MIN(pondex*flood_frac_bas(ig,ib)/(flood_frac(ig)-pond_frac(ig)),&
2054	& flood_reservoir(ig,ib))
2055	pondex = pondex - pond_excessflow(ib)
2056	ENDDO
2057	!
2058	IF ( pondex .GT. min_sechiba) THEN
2059	WRITE(numout,*) "Unable to redistribute the excess pond outflow over the water available in the floodplain."
2060	WRITE(numout,*) "Pondex = ", pondex
2061	WRITE(numout,*) "pond_excessflow(:) = ", pond_excessflow(:)
2062	ENDIF
2063	!
2064	DO ib=1,nbasmax
2065	!
2066	flow = floodout(ig)routing_area(ig,ib)flood_frac_bas(ig,ib)/flood_frac(ig) + pond_excessflow(ib)
2067	!
2068	flood_reservoir(ig,ib) = flood_reservoir(ig,ib) - flow
2069	!
2070	!
2071	IF (flood_reservoir(ig,ib) .LT. min_sechiba) THEN
2072	flood_reservoir(ig,ib) = zero
2073	ENDIF
2074	IF (pond_reservoir(ig) .LT. min_sechiba) THEN
2075	pond_reservoir(ig) = zero
2076	ENDIF
2077	ENDDO
2078	ENDIF
2079	ENDDO
2080	ENDIF
2081
2082	!-
2083	!- Computing the drainage and outflow from floodplains
2084	!> Drainage from floodplains is depending on a averaged conductivity (k_litt)
2085	!> for saturated infiltration in the 'litter' layer. Flood_drainage will be
2086	!> a component of the total reinfiltration that leaves the routing scheme.
2087	!-
2088	IF (do_floodplains) THEN
2089	IF (dofloodinfilt) THEN
2090	DO ib=1,nbasmax
2091	DO ig=1,nbpt
2092	flood_drainage(ig,ib) = MAX(zero, MIN(flood_reservoir(ig,ib), &
2093	& flood_frac(ig)routing_area(ig,ib)k_litt(ig)*dt_routing/one_day))
2094	flood_reservoir(ig,ib) = flood_reservoir(ig,ib) - flood_drainage(ig,ib)
2095	ENDDO
2096	ENDDO
2097	ELSE
2098	DO ib=1,nbasmax
2099	DO ig=1,nbpt
2100	flood_drainage(ig,ib) = zero
2101	ENDDO
2102	ENDDO
2103	ENDIF
2104	!> Outflow from floodplains is computed depending a delay. This delay is characterized by a time constant
2105	!> function of the surface of the floodplains and the product of topo_resid and flood_tcst. flood_tcst
2106	!> has been calibrated through observations in the Niger Inner Delta (D'Orgeval, 2006).
2107	!
2108	DO ib=1,nbasmax
2109	DO ig=1,nbpt
2110	IF ( route_tobasin(ig,ib) .GT. 0 ) THEN
2111	IF (flood_frac_bas(ig,ib) .GT. min_sechiba) THEN
2112	flow = MIN(flood_reservoir(ig,ib) &
2113	& /((topo_resid(ig,ib)/1000.)flood_tcst &
2114	& flood_frac_bas(ig,ib)*one_day/dt_routing),&
2115	& flood_reservoir(ig,ib))
2116	ELSE
2117	flow = zero
2118	ENDIF
2119	flood_flow(ig,ib) = flow
2120	ELSE
2121	flood_flow(ig,ib) = zero
2122	ENDIF
2123	ENDDO
2124	ENDDO
2125	ELSE
2126	DO ib=1,nbasmax
2127	DO ig=1,nbpt
2128	flood_drainage(ig,ib) = zero
2129	flood_flow(ig,ib) = zero
2130	flood_reservoir(ig,ib) = zero
2131	ENDDO
2132	ENDDO
2133	ENDIF
2134
2135	!-
2136	!- Computing drainage and inflow for ponds
2137	!> Drainage from ponds is computed in the same way than for floodplains.
2138	!> Reinfiltrated fraction from the runoff (i.e. the outflow from the fast reservoir)
2139	!> is the inflow of the pond reservoir.
2140	!-
2141	IF (doponds) THEN
2142	! If used, the slope coef is not used in hydrol for water2infilt
2143	DO ib=1,nbasmax
2144	DO ig=1,nbpt
2145	pond_inflow(ig,ib) = fast_flow(ig,ib) * reinf_slope(ig)
2146	pond_drainage(ig,ib) = MIN(pond_reservoir(ig)*routing_area(ig,ib)/totarea(ig), &
2147	& pond_frac(ig)routing_area(ig,ib)k_litt(ig)*dt_routing/one_day)
2148	fast_flow(ig,ib) = fast_flow(ig,ib) - pond_inflow(ig,ib)
2149	ENDDO
2150	ENDDO
2151	ELSE
2152	DO ib=1,nbasmax
2153	DO ig=1,nbpt
2154	pond_inflow(ig,ib) = zero
2155	pond_drainage(ig,ib) = zero
2156	pond_reservoir(ig) = zero
2157	ENDDO
2158	ENDDO
2159	ENDIF
2160
2161	!ym cette methode conserve les erreurs d'arrondie
2162	!ym mais n'est pas la plus efficace
2163
2164	!-
2165	!- Compute the transport from one basin to another
2166	!-
2167
2168	IF (is_root_prc) THEN
2169	ALLOCATE( fast_flow_g(nbp_glo, nbasmax), slow_flow_g(nbp_glo, nbasmax), &
2170	stream_flow_g(nbp_glo, nbasmax), stat=ier)
2171	ELSE
2172	ALLOCATE( fast_flow_g(1,1), slow_flow_g(1,1), &
2173	stream_flow_g(1, 1), stat=ier)
2174	ENDIF
2175	IF (ier /= 0) CALL ipslerr_p(3,'routing_flow','Pb in allocate for fast_flow_g','','')
2176
2177	CALL gather(fast_flow,fast_flow_g)
2178	CALL gather(slow_flow,slow_flow_g)
2179	CALL gather(stream_flow,stream_flow_g)
2180
2181	IF (is_root_prc) THEN
2182	DO ib=1,nbasmax
2183	DO ig=1,nbp_glo
2184	!
2185	rtg = route_togrid_glo(ig,ib)
2186	rtb = route_tobasin_glo(ig,ib)
2187	transport_glo(rtg,rtb) = transport_glo(rtg,rtb) + fast_flow_g(ig,ib) + slow_flow_g(ig,ib) + &
2188	& stream_flow_g(ig,ib)
2189	!
2190	ENDDO
2191	ENDDO
2192	ENDIF
2193
2194	DEALLOCATE( fast_flow_g, slow_flow_g, stream_flow_g )
2195
2196	CALL scatter(transport_glo,transport)
2197
2198	!-
2199	!- Do the floodings - First initialize
2200	!-
2201	return_swamp(:,:)=zero
2202	floods(:,:)=zero
2203	!-
2204	!> Over swamp areas, a fraction of water (return_swamp) is withdrawn from the river depending on the
2205	!> parameter swamp_cst.
2206	!> It will be transferred into soil moisture and thus does not return directly to the river.
2207	!
2208	!- 1. Swamps: Take out water from the river to put it to the swamps
2209	!-
2210	!
2211	IF ( doswamps ) THEN
2212	tobeflooded(:) = swamp(:)
2213	DO ib=1,nbasmax
2214	DO ig=1,nbpt
2215	potflood(ig,ib) = transport(ig,ib)
2216	!
2217	IF ( tobeflooded(ig) > 0. .AND. potflood(ig,ib) > 0. .AND. floodtemp(ig) > tp_00 ) THEN
2218	!
2219	IF (routing_area(ig,ib) > tobeflooded(ig)) THEN
2220	floodindex = tobeflooded(ig) / routing_area(ig,ib)
2221	ELSE
2222	floodindex = 1.0
2223	ENDIF
2224	return_swamp(ig,ib) = swamp_cst * potflood(ig,ib) * floodindex
2225	!
2226	tobeflooded(ig) = tobeflooded(ig) - routing_area(ig,ib)
2227	!
2228	ENDIF
2229	ENDDO
2230	ENDDO
2231	ENDIF
2232	!-
2233	!- 2. Floodplains: Update the reservoir with the flux computed above.
2234	!-
2235	IF ( do_floodplains ) THEN
2236	DO ig=1,nbpt
2237	IF (floodplains(ig) .GT. min_sechiba .AND. floodtemp(ig) .GT. tp_00) THEN
2238	DO ib=1,nbasmax
2239	floods(ig,ib) = transport(ig,ib) - return_swamp(ig,ib)
2240	ENDDO
2241	ENDIF
2242	ENDDO
2243	ENDIF
2244	!
2245	! Update all reservoirs
2246	!> The slow and deep reservoir (slow_reservoir) collect the deep drainage whereas the
2247	!> fast_reservoir collects the computed surface runoff. Both discharge into a third reservoir
2248	!> (stream_reservoir) of the next sub-basin downstream.
2249	!> Water from the floodplains reservoir (flood_reservoir) flows also into the stream_reservoir of the next sub-basin downstream.
2250	!> Water that flows into the pond_reservoir is withdrawn from the fast_reservoir.
2251	!
2252	DO ig=1,nbpt
2253	DO ib=1,nbasmax
2254	!
2255	fast_reservoir(ig,ib) = fast_reservoir(ig,ib) + runoff(ig)*routing_area(ig,ib) - &
2256	& fast_flow(ig,ib) - pond_inflow(ig,ib)
2257	!
2258	slow_reservoir(ig,ib) = slow_reservoir(ig,ib) + drainage(ig)*routing_area(ig,ib) - &
2259	& slow_flow(ig,ib)
2260	!
2261	stream_reservoir(ig,ib) = stream_reservoir(ig,ib) + flood_flow(ig,ib) + transport(ig,ib) - &
2262	& stream_flow(ig,ib) - return_swamp(ig,ib) - floods(ig,ib)
2263	!
2264	flood_reservoir(ig,ib) = flood_reservoir(ig,ib) + floods(ig,ib) - &
2265	& flood_flow(ig,ib)
2266	!
2267	pond_reservoir(ig) = pond_reservoir(ig) + pond_inflow(ig,ib) - pond_drainage(ig,ib)
2268	!
2269	IF ( flood_reservoir(ig,ib) .LT. zero ) THEN
2270	IF ( check_reservoir ) THEN
2271	WRITE(numout,*) "WARNING : negative flood reservoir at :", ig, ib, ". Problem is being corrected."
2272	WRITE(numout,*) "flood_reservoir, floods, flood_flow : ", flood_reservoir(ig,ib), floods(ig,ib), &
2273	& flood_flow(ig,ib)
2274	ENDIF
2275	stream_reservoir(ig,ib) = stream_reservoir(ig,ib) + flood_reservoir(ig,ib)
2276	flood_reservoir(ig,ib) = zero
2277	ENDIF
2278	!
2279	IF ( stream_reservoir(ig,ib) .LT. zero ) THEN
2280	IF ( check_reservoir ) THEN
2281	WRITE(numout,*) "WARNING : negative stream reservoir at :", ig, ib, ". Problem is being corrected."
2282	WRITE(numout,*) "stream_reservoir, flood_flow, transport : ", stream_reservoir(ig,ib), flood_flow(ig,ib), &
2283	& transport(ig,ib)
2284	WRITE(numout,*) "stream_flow, return_swamp, floods :", stream_flow(ig,ib), return_swamp(ig,ib), floods(ig,ib)
2285	ENDIF
2286	fast_reservoir(ig,ib) = fast_reservoir(ig,ib) + stream_reservoir(ig,ib)
2287	stream_reservoir(ig,ib) = zero
2288	ENDIF
2289	!
2290	IF ( fast_reservoir(ig,ib) .LT. zero ) THEN
2291	IF ( check_reservoir ) THEN
2292	WRITE(numout,*) "WARNING : negative fast reservoir at :", ig, ib, ". Problem is being corrected."
2293	WRITE(numout,*) "fast_reservoir, runoff, fast_flow, ponf_inflow : ", fast_reservoir(ig,ib), &
2294	&runoff(ig), fast_flow(ig,ib), pond_inflow(ig,ib)
2295	ENDIF
2296	slow_reservoir(ig,ib) = slow_reservoir(ig,ib) + fast_reservoir(ig,ib)
2297	fast_reservoir(ig,ib) = zero
2298	ENDIF
2299
2300	IF ( slow_reservoir(ig,ib) .LT. - min_sechiba ) THEN
2301	WRITE(numout,*) 'WARNING : There is a negative reservoir at :', ig, ib,lalo(ig,:)
2302	WRITE(numout,*) 'WARNING : slowr, slow_flow, drainage', &
2303	& slow_reservoir(ig,ib), slow_flow(ig,ib), drainage(ig)
2304	WRITE(numout,*) 'WARNING : pondr, pond_inflow, pond_drainage', &
2305	& pond_reservoir(ig), pond_inflow(ig,ib), pond_drainage(ig,ib)
2306	CALL ipslerr_p(2, 'routing_flow', 'WARNING negative slow_reservoir.','','')
2307	ENDIF
2308
2309	ENDDO
2310	ENDDO
2311
2312
2313	totflood(:) = zero
2314	DO ig=1,nbpt
2315	DO ib=1,nbasmax
2316	totflood(ig) = totflood(ig) + flood_reservoir(ig,ib)
2317	ENDDO
2318	ENDDO
2319
2320	!-
2321	!- Computes the fraction of floodplains and ponds according to their volume
2322	!-
2323	IF (do_floodplains .OR. doponds) THEN
2324	flood_frac(:) = zero
2325	flood_height(:) = zero
2326	flood_frac_bas(:,:) = zero
2327	DO ig=1, nbpt
2328	IF (totflood(ig) .GT. min_sechiba) THEN
2329	! We first compute the total fraction of the grid box which is flooded at optimum repartition
2330	flood_frac_pot = (totflood(ig) / (totarea(ig)floodcri/(beta+un)))*(beta/(beta+un))
2331	flood_frac(ig) = MIN(floodplains(ig) / totarea(ig), flood_frac_pot)
2332	! Then we diagnose the fraction for each basin with the size of its flood_reservoir
2333	! (flood_frac_bas may be > 1)
2334	DO ib=1,nbasmax
2335	IF (routing_area(ig,ib) .GT. min_sechiba) THEN
2336	flood_frac_bas(ig,ib) = flood_frac(ig) * &
2337	& (flood_reservoir(ig,ib) / totflood(ig)) / (routing_area(ig,ib) / totarea(ig))
2338	ENDIF
2339	ENDDO
2340	! We diagnose the maximum height of floodplain
2341	flood_height(ig) = (beta/(beta+1))floodcri(flood_frac(ig))*(un/beta) + totflood(ig)/(totarea(ig)flood_frac(ig))
2342	! And finally add the pond surface
2343	pond_frac(ig) = MIN(un-flood_frac(ig), ((betap+1)pond_reservoir(ig) / (pondcritotarea(ig)))**(betap/(betap+1)) )
2344	flood_frac(ig) = flood_frac(ig) + pond_frac(ig)
2345	!
2346	ENDIF
2347	ENDDO
2348	ELSE
2349	flood_frac(:) = zero
2350	flood_height(:) = zero
2351	flood_frac_bas(:,:) = zero
2352	ENDIF
2353
2354	!-
2355	!- Compute the total reinfiltration and returnflow to the grid box
2356	!> A term of returnflow is computed including the water from the swamps that does not return directly to the river
2357	!> but will be put into soil moisture (see hydrol module).
2358	!> A term of reinfiltration is computed including the water that reinfiltrated from the ponds and floodplains areas.
2359	!> It will be put into soil moisture (see hydrol module).
2360	!-
2361	IF (do_floodplains .OR. doswamps .OR. doponds) THEN
2362	returnflow(:) = zero
2363	reinfiltration(:) = zero
2364	!
2365	DO ib=1,nbasmax
2366	DO ig=1,nbpt
2367	returnflow(ig) = returnflow(ig) + return_swamp(ig,ib)
2368	reinfiltration(ig) = reinfiltration(ig) + pond_drainage(ig,ib) + flood_drainage(ig,ib)
2369	ENDDO
2370	ENDDO
2371	!
2372	DO ig=1,nbpt
2373	returnflow(ig) = returnflow(ig)/totarea(ig)
2374	reinfiltration(ig) = reinfiltration(ig)/totarea(ig)
2375	ENDDO
2376	ELSE
2377	returnflow(:) = zero
2378	reinfiltration(:) = zero
2379	ENDIF
2380
2381	!
2382	! Compute the net irrigation requirement from Univ of Kassel
2383	!
2384	! This is a very low priority process and thus only applies if
2385	! there is some water left in the reservoirs after all other things.
2386	!
2387	!> The computation of the irrigation is performed here.
2388	!> * First step
2389	!> In a first time, the water requirements (irrig_netereq) by the crops for their optimal growth are calculated
2390	!> over each irrigated fraction (irrigated(ig)/totarea(ig)). It is the difference
2391	!> between the maximal water loss by the crops (transpot_mean) and the net water amount kept by the soil
2392	!> (precipitation and reinfiltration). Transpot_mean is computed in the routines enerbil and diffuco. It
2393	!> is derived from the effective transpiration parametrization under stress-free conditions, called potential transpiration.
2394	!> Crop_coef was used by a previous parametrization of irrigation in the code. Here, its value is equal to one.
2395	!> The crop coefficient was constant in space and time to represent a mean resistance of the vegetation to the potential evaporation.
2396	!> Now, the term crop_coef*Epot is substituted by transpot_mean (see Guimberteau et al., 2011).
2397	!> * Second step
2398	!> We compute irrigation needs in order to supply Irrig_netereq. Water for irrigation (irrig_actual) is withdrawn
2399	!> from the reservoirs. The amount of water is withdrawn in priority from the stream reservoir.
2400	!> If the irrigation requirement is higher than the water availability of the reservoir, water is withdrawn
2401	!> from the fast reservoir or, in the extreme case, from the slow reservoir.
2402	!> * Third step
2403	!> We compute a deficit in water for irrigation. If it is positive, irrigation (depending on water availibility in the reservoirs)
2404	!> has not supplied the crops requirements.
2405	!
2406	IF ( do_irrigation ) THEN
2407	DO ig=1,nbpt
2408	!It enters to the new irrigation module only if there is an irrigated fraction, if not irrig_netereq = zero for that cell
2409	IF ((irrig_frac(ig) .GT. min_sechiba) .AND. .NOT. old_irrig_scheme ) THEN
2410
2411	irrig_netereq(ig) = irrig_netereq(ig) + MIN( irrig_dosmax/3600*dt_routing, &
2412	root_deficit(ig) ) * soiltile(ig, irrig_st) * vegtot(ig)
2413	! By definition, irrig_dosmax is in kg/m2 of soil tile/hour,dividing by 3600(seconds/hour) * DT_ROUTING !
2414	! = kg/m2 of soil tile/(routing timestep)
2415	! irrig_netereq(kg/m2 of grid cell / routing timstep ) is equal to
2416	! root_deficit (kg/m2 of soil tile) * soiltile*vegtot (fraction of soil tile at cell level) = kg/m2 of grid cell
2417
2418	IF (.NOT. irrigated_soiltile .AND. ( soiltile(ig,irrig_st) .GT. min_sechiba ) .AND. (vegtot(ig) .GT. min_sechiba) ) THEN
2419	! Irrigated_soiltile asks if there is an independent soil tile for irrigated crops. If not,
2420	! actual volume calculated for irrig_netereq assumed that the whole SOILTILE was irrigated, but in this case
2421	! just a fraction of the irrig_st (irrigated soil tile, by default = 3) is actually irrigated,
2422	! and irrig_netereq needs to be reduced by irrig_frac/( soiltile * vegtot ) (note that it is max = 1 thanks to irrig_frac calculation in l. 424)
2423	! Demand(ST3)irrig_frac/(soiltile(3)vegtot) = irrig_netereq_In_ST3, then
2424	!irrig_netereq_In_ST3 * (soiltile(3)vegtot) = irrig_netereq at grid scale = Demand(ST3)irrig_frac.
2425	irrig_netereq(ig) = irrig_netereq(ig) * irrig_frac(ig) / ( soiltile(ig,irrig_st) * vegtot(ig) )
2426	!irrig_netereq = kg/m2 of grid cell
2427
2428	ENDIF
2429	!Old irrigation scheme as in tag 2.0
2430	ELSE IF((vegtot(ig) .GT. min_sechiba) .AND. (humrel(ig) .LT. un-min_sechiba) .AND. &
2431	& (runoff(ig) .LT. min_sechiba) .AND. old_irrig_scheme) THEN
2432
2433	irrig_netereq(ig) = (irrigated(ig) / totarea(ig) ) * MAX(zero, transpot_mean(ig) - &
2434	& (precip(ig)+reinfiltration(ig)) )
2435
2436	ENDIF
2437
2438	DO ib=1,nbasmax
2439	IF ( routing_area(ig,ib) .GT. 0 ) THEN
2440
2441	IF (.NOT. old_irrig_scheme .AND. select_source_irrig) THEN
2442
2443	! For irrig. scheme, available_reserve gives the amount of water available for irrigation in every reservoir
2444	! --> avail_reserve is a vector of dimension=3, BY DEFINITION i=1 for streamflow, i=2 fast, and i=3 slow reservoir
2445
2446	! The new priorization scheme takes into account irrig. infrastructur according to GMIA map
2447	! It also withdraw water according to availability, it means that it wont seek for all the water in then
2448	! stream reservoir, even if this one could respond to the demand by itself
2449
2450	pot_slow_wdr_dummy = ( 1 - fraction_aeirrig_sw(ig)) * avail_reserve(3)*slow_reservoir(ig,ib)
2451	pot_fast_wdr_dummy = fraction_aeirrig_sw(ig) * avail_reserve(2)*fast_reservoir(ig,ib)
2452	pot_stre_wdr_dummy = fraction_aeirrig_sw(ig) * avail_reserve(1) * stream_reservoir(ig,ib)
2453	pcent_vol_irrig = zero
2454	IsFail_slow = .FALSE. !
2455	IsFail_fast = .FALSE. !
2456	IsFail_stre = .FALSE. !
2457	irrig_needs(ig,ib) = irrig_netereq(ig) * routing_area(ig,ib)
2458
2459	irrig_actual(ig,ib) = MIN(irrig_needs(ig,ib),&
2460	pot_stre_wdr_dummy + pot_fast_wdr_dummy + pot_slow_wdr_dummy)
2461
2462	!! additional IF to calculate pcent_vol_irrig, in the case the total avail.
2463	!! water is zero, I.E. when there is no water in surface and fraction_ae = 0,
2464	!! so GW is not taken into account
2465	!! Note on pcent_vol_irrig: It correspond to the fraction of available water in surface,
2466	!! considering environmental needs and irrigation equipement by source from map. It controls
2467	!! how the source of water withdrawl, especially when requirements < available water
2468
2469	IF ( (pot_stre_wdr_dummy + pot_fast_wdr_dummy + pot_slow_wdr_dummy) .GT. min_sechiba ) THEN
2470
2471	pcent_vol_irrig = ( pot_stre_wdr_dummy + pot_fast_wdr_dummy ) / &
2472	( pot_stre_wdr_dummy + pot_fast_wdr_dummy + pot_slow_wdr_dummy )
2473
2474	!Irrig_actual set to zero, because there is no available water.
2475	!Put to avoid negative values due to problems in the Min function
2476	irrig_actual(ig,ib) = MAX(irrig_actual(ig,ib), zero)
2477	!Already zero because pcent_vol_irrig initialized to zero
2478	!Put here to readability but not necessary
2479	!ELSE
2480	! pcent_vol_irrig = zero
2481
2482	ENDIF
2483
2484	!Note for irrig_gw_source(ig): first we add the slow_reservoir volume. Then we substract the updated slow_reservoir. It should be the
2485	!Volume used for irrigation that comes from GW
2486	! Idem for irrig_fast_source and irrig_str_source
2487
2488	slow_wdr_dummy = slow_reservoir(ig,ib)
2489	slow_reservoir(ig,ib) = MAX( (un - ( un - fraction_aeirrig_sw(ig) ) * avail_reserve(3) ) * &
2490	slow_reservoir(ig,ib), slow_reservoir(ig,ib) + &
2491	MIN( - irrig_actual(ig,ib) * (un - pcent_vol_irrig ), &
2492	avail_reserve(2) * fraction_aeirrig_sw(ig) * fast_reservoir(ig,ib) + &
2493	MIN(zero, avail_reserve(1) * fraction_aeirrig_sw(ig) * stream_reservoir(ig,ib) - &
2494	pcent_vol_irrig * irrig_actual(ig,ib) ) ) )
2495
2496	slow_wdr_dummy = slow_wdr_dummy - slow_reservoir(ig,ib)
2497	irrig_gw_source(ig) = irrig_gw_source(ig) + slow_wdr_dummy
2498
2499	fast_wdr_dummy = fast_reservoir(ig,ib)
2500	fast_reservoir(ig,ib) = MAX( (un - avail_reserve(2) * fraction_aeirrig_sw(ig) ) * fast_reservoir(ig,ib) , &
2501	fast_reservoir(ig,ib) + MIN(zero, avail_reserve(1) * fraction_aeirrig_sw(ig) * stream_reservoir(ig,ib) - &
2502	pcent_vol_irrig * irrig_actual(ig,ib) ) )
2503	fast_wdr_dummy = fast_wdr_dummy - fast_reservoir(ig,ib)
2504	irrig_fast_source(ig) = irrig_fast_source(ig) + fast_wdr_dummy
2505
2506	stre_wdr_dummy = stream_reservoir(ig,ib)
2507	stream_reservoir(ig,ib) = MAX((un - avail_reserve(1)* fraction_aeirrig_sw(ig) )*stream_reservoir(ig,ib), &
2508	stream_reservoir(ig,ib) - &
2509	pcent_vol_irrig * irrig_actual(ig,ib) )
2510	stre_wdr_dummy = stre_wdr_dummy - stream_reservoir(ig,ib)
2511	irrig_str_source(ig) = irrig_str_source(ig) + stre_wdr_dummy
2512
2513	irrig_deficit(ig,ib) = irrig_needs(ig,ib)-irrig_actual(ig,ib)
2514
2515	!A reservoir is failing to give water for infiltration if pot. req > pot. withdrawal
2516	!We assume that the pot. requirement = Needs * fraction of area equipped for SW/GW
2517	!In the case of surface. we also sustract the withdrawal from Fast/Stream, because both are
2518	! considered as surface water
2519	IsFail_slow = ( ( irrig_needs(ig,ib)*(un - fraction_aeirrig_sw(ig)) ) > pot_slow_wdr_dummy )
2520	IsFail_fast = ( ( irrig_needs(ig,ib)*fraction_aeirrig_sw(ig) - stre_wdr_dummy ) > pot_fast_wdr_dummy )
2521	IsFail_stre = ( ( irrig_needs(ig,ib)*fraction_aeirrig_sw(ig) - fast_wdr_dummy ) > pot_stre_wdr_dummy )
2522
2523	IF( IsFail_stre ) THEN
2524	Count_failure_stre(ig) = un
2525	ENDIF
2526	IF( IsFail_fast ) THEN
2527	Count_failure_fast(ig) = un
2528	ENDIF
2529	IF( IsFail_slow ) THEN
2530	Count_failure_slow(ig) = un
2531	ENDIF
2532
2533	ELSE IF (.NOT. old_irrig_scheme .AND. .NOT. select_source_irrig) THEN
2534	! For irrig. scheme, available_reserve gives the amount of water available for irrigation in every reservoir
2535	! --> avail_reserve is a vector of dimension=3, BY DEFINITION i=1 for streamflow, i=2 fast, and i=3 slow reservoir
2536	irrig_needs(ig,ib) = irrig_netereq(ig) * routing_area(ig,ib)
2537
2538	pot_slow_wdr_dummy = avail_reserve(3)*slow_reservoir(ig,ib)
2539	pot_fast_wdr_dummy = avail_reserve(2)*fast_reservoir(ig,ib)
2540	pot_stre_wdr_dummy = avail_reserve(1)*stream_reservoir(ig,ib)
2541	IsFail_slow = .FALSE. !
2542	IsFail_fast = .FALSE. !
2543	IsFail_stre = .FALSE. !
2544
2545	irrig_actual(ig,ib) = MIN(irrig_needs(ig,ib),&
2546	& pot_stre_wdr_dummy + pot_fast_wdr_dummy + pot_slow_wdr_dummy )
2547
2548	!Note for irrig_gw_source(ig): first we add the slow_reservoir volume. Then we substract the updated slow_reservoir. It should be the
2549	!Volume used for irrigation that comes from GW
2550	! Idem for irrig_fast_source and irrig_str_source
2551	slow_wdr_dummy = slow_reservoir(ig,ib)
2552	slow_reservoir(ig,ib) = MAX( (1-avail_reserve(3) )*slow_reservoir(ig,ib), slow_reservoir(ig,ib) + &
2553	& MIN(zero, avail_reserve(2)fast_reservoir(ig,ib) + MIN(zero, avail_reserve(1)stream_reservoir(ig,ib)-irrig_actual(ig,ib))))
2554	slow_wdr_dummy = slow_wdr_dummy - slow_reservoir(ig,ib)
2555	irrig_gw_source(ig) = irrig_gw_source(ig) + slow_wdr_dummy
2556
2557	fast_wdr_dummy = fast_reservoir(ig,ib)
2558	fast_reservoir(ig,ib) = MAX( (1-avail_reserve(2) )*fast_reservoir(ig,ib) , &
2559	fast_reservoir(ig,ib) + MIN(zero, avail_reserve(1)*stream_reservoir(ig,ib)-irrig_actual(ig,ib)))
2560	fast_wdr_dummy = fast_wdr_dummy - fast_reservoir(ig,ib)
2561	irrig_fast_source(ig) = irrig_fast_source(ig) + fast_wdr_dummy
2562
2563	stre_wdr_dummy = stream_reservoir(ig,ib)
2564	stream_reservoir(ig,ib) = MAX( (1-avail_reserve(1) )*stream_reservoir(ig,ib), stream_reservoir(ig,ib)-irrig_actual(ig,ib) )
2565	stre_wdr_dummy = stre_wdr_dummy - stream_reservoir(ig,ib)
2566	irrig_str_source(ig) = irrig_str_source(ig) + stre_wdr_dummy
2567
2568	irrig_deficit(ig,ib) = irrig_needs(ig,ib)-irrig_actual(ig,ib)
2569	!A reservoir is failing to give water for infiltration if pot. req > pot. withdrawal
2570	! Because it follows the old scheme, we do not separate between surface/gw, but consider that
2571	! priority is given in this order: River, Fast and Slow reservoir.
2572	IsFail_slow = ( ( irrig_needs(ig,ib) - stre_wdr_dummy - fast_wdr_dummy ) > pot_slow_wdr_dummy )
2573	IsFail_fast = ( ( irrig_needs(ig,ib) - stre_wdr_dummy ) > pot_fast_wdr_dummy )
2574	IsFail_stre = ( irrig_needs(ig,ib) > pot_stre_wdr_dummy )
2575
2576	IF( IsFail_stre ) THEN
2577	Count_failure_stre(ig) = un
2578	ENDIF
2579	IF( IsFail_fast ) THEN
2580	Count_failure_fast(ig) = un
2581	ENDIF
2582	IF( IsFail_slow ) THEN
2583	Count_failure_slow(ig) = un
2584	ENDIF
2585
2586	ELSE !Old irrigation scheme as in tag 2.0
2587	!Note for irrig_gw_source(ig): first we add the slow_reservoir volume. Then we substract the updated slow_reservoir. It should be the
2588	!Volume used for irrigation that comes from GW
2589	! Idem for irrig_fast_source and irrig_str_source
2590	irrig_needs(ig,ib) = irrig_netereq(ig) * routing_area(ig,ib)
2591
2592	pot_slow_wdr_dummy = slow_reservoir(ig,ib)
2593	pot_fast_wdr_dummy = fast_reservoir(ig,ib)
2594	pot_stre_wdr_dummy = stream_reservoir(ig,ib)
2595	IsFail_slow = .FALSE. !
2596	IsFail_fast = .FALSE. !
2597	IsFail_stre = .FALSE. !
2598	irrig_actual(ig,ib) = MIN(irrig_needs(ig,ib),&
2599	& stream_reservoir(ig,ib) + fast_reservoir(ig,ib) + slow_reservoir(ig,ib) )
2600
2601	slow_wdr_dummy = slow_reservoir(ig,ib)
2602	slow_reservoir(ig,ib) = MAX(zero, slow_reservoir(ig,ib) + &
2603	& MIN(zero, fast_reservoir(ig,ib) + MIN(zero, stream_reservoir(ig,ib)-irrig_actual(ig,ib))))
2604	slow_wdr_dummy = slow_wdr_dummy - slow_reservoir(ig,ib)
2605	irrig_gw_source(ig) = irrig_gw_source(ig) + slow_wdr_dummy
2606
2607	fast_wdr_dummy = fast_reservoir(ig,ib)
2608	fast_reservoir(ig,ib) = MAX( zero, &
2609	& fast_reservoir(ig,ib) + MIN(zero, stream_reservoir(ig,ib)-irrig_actual(ig,ib)))
2610	fast_wdr_dummy = fast_wdr_dummy - fast_reservoir(ig,ib)
2611	irrig_fast_source(ig) = irrig_fast_source(ig) + fast_wdr_dummy
2612
2613	stre_wdr_dummy = stream_reservoir(ig,ib)
2614	stream_reservoir(ig,ib) = MAX(zero, stream_reservoir(ig,ib)-irrig_actual(ig,ib) )
2615	stre_wdr_dummy = stre_wdr_dummy - stream_reservoir(ig,ib)
2616	irrig_str_source(ig) = irrig_str_source(ig) + stre_wdr_dummy
2617
2618	irrig_deficit(ig,ib) = irrig_needs(ig,ib)-irrig_actual(ig,ib)
2619	!A reservoir is failing to give water for infiltration if pot. req > pot. withdrawal
2620	! Because it follows the old scheme, we do not separate between surface/gw, but consider that
2621	! priority is given in this order: River, Fast and Slow reservoir.
2622	IsFail_slow = ( ( irrig_needs(ig,ib) - stre_wdr_dummy - fast_wdr_dummy ) > pot_slow_wdr_dummy )
2623	IsFail_fast = ( ( irrig_needs(ig,ib) - stre_wdr_dummy ) > pot_fast_wdr_dummy )
2624	IsFail_stre = ( irrig_needs(ig,ib) > pot_stre_wdr_dummy )
2625
2626	IF( IsFail_stre ) THEN
2627	Count_failure_stre(ig) = un
2628	ENDIF
2629	IF( IsFail_fast ) THEN
2630	Count_failure_fast(ig) = un
2631	ENDIF
2632	IF( IsFail_slow ) THEN
2633	Count_failure_slow(ig) = un
2634	ENDIF
2635
2636	ENDIF
2637
2638	ENDIF
2639	ENDDO
2640	!
2641	! Check if we cannot find the missing water in another basin of the same grid (stream reservoir only).
2642	! If we find that then we create some adduction from that subbasin to the one where we need it for
2643	! irrigation.
2644	!
2645	!> If crops water requirements have not been supplied (irrig_deficit>0), we check if we cannot find the missing water
2646	!> in another basin of the same grid. If there is water in the stream reservoir of this subbasin, we create some adduction
2647	!> from that subbasin to the one where we need it for irrigation.
2648	!>
2649	DO ib=1,nbasmax
2650
2651	stream_tot = a_stream_adduction * SUM(stream_reservoir(ig,:))
2652
2653	DO WHILE ( irrig_deficit(ig,ib) > min_sechiba .AND. stream_tot > min_sechiba)
2654
2655	fi = MAXLOC(stream_reservoir(ig,:))
2656	ib2 = fi(1)
2657
2658	irrig_adduct(ig,ib) = MIN(irrig_deficit(ig,ib), a_stream_adduction * stream_reservoir(ig,ib2))
2659	stream_reservoir(ig,ib2) = stream_reservoir(ig,ib2)-irrig_adduct(ig,ib)
2660	irrig_deficit(ig,ib) = irrig_deficit(ig,ib)-irrig_adduct(ig,ib)
2661
2662	stream_tot = a_stream_adduction * SUM(stream_reservoir(ig,:))
2663
2664	ENDDO
2665
2666	ENDDO
2667	!
2668	ENDDO
2669	!
2670	! If we are at higher resolution we might need to look at neighboring grid boxes to find the streams
2671	! which can feed irrigation
2672	!
2673	!> At higher resolution (grid box smaller than 100x100km), we can import water from neighboring grid boxes
2674	!> to the one where we need it for irrigation.
2675	!
2676	IF (is_root_prc) THEN
2677	ALLOCATE(irrig_deficit_glo(nbp_glo, nbasmax), stream_reservoir_glo(nbp_glo, nbasmax), &
2678	& irrig_adduct_glo(nbp_glo, nbasmax), stat=ier)
2679	ELSE
2680	ALLOCATE(irrig_deficit_glo(0, 0), stream_reservoir_glo(0, 0), &
2681	& irrig_adduct_glo(0, 0), stat=ier)
2682	ENDIF
2683	IF (ier /= 0) CALL ipslerr_p(3,'routing_flow','Pb in allocate for irrig_deficit_glo, stream_reservoir_glo,...','','')
2684
2685	CALL gather(irrig_deficit, irrig_deficit_glo)
2686	CALL gather(stream_reservoir, stream_reservoir_glo)
2687	CALL gather(irrig_adduct, irrig_adduct_glo)
2688
2689	IF (is_root_prc) THEN
2690	!
2691	DO ig=1,nbp_glo
2692	! Only work if the grid box is smaller than 100x100km. Else the piplines we build
2693	! here would be too long to be reasonable.
2694	IF ( resolution_g(ig,1) < 100000. .AND. resolution_g(ig,2) < 100000. ) THEN
2695	DO ib=1,nbasmax
2696	!
2697	IF ( irrig_deficit_glo(ig,ib) > min_sechiba ) THEN
2698	!
2699	streams_around(:,:) = zero
2700	!
2701	DO in=1,NbNeighb
2702	ig2 = neighbours_g(ig,in)
2703	IF (ig2 .GT. 0 ) THEN
2704	streams_around(in,:) = a_stream_adduction * stream_reservoir_glo(ig2,:)
2705	igrd(in) = ig2
2706	ENDIF
2707	ENDDO
2708	!
2709	IF ( MAXVAL(streams_around) .GT. zero ) THEN
2710	!
2711	ff=MAXLOC(streams_around)
2712	ig2=igrd(ff(1))
2713	ib2=ff(2)
2714	!
2715	IF ( routing_area_glo(ig2,ib2) .GT. 0 .AND. a_stream_adduction * stream_reservoir_glo(ig2,ib2) > zero ) THEN
2716	adduction = MIN(irrig_deficit_glo(ig,ib), a_stream_adduction * stream_reservoir_glo(ig2,ib2))
2717	stream_reservoir_glo(ig2,ib2) = stream_reservoir_glo(ig2,ib2) - adduction
2718	irrig_deficit_glo(ig,ib) = irrig_deficit_glo(ig,ib) - adduction
2719	irrig_adduct_glo(ig,ib) = irrig_adduct_glo(ig,ib) + adduction
2720	ENDIF
2721	!
2722	ENDIF
2723	!
2724	ENDIF
2725	!
2726	ENDDO
2727	ENDIF
2728	ENDDO
2729	!
2730	ENDIF
2731	!
2732
2733	CALL scatter(irrig_deficit_glo, irrig_deficit)
2734	CALL scatter(stream_reservoir_glo, stream_reservoir)
2735	CALL scatter(irrig_adduct_glo, irrig_adduct)
2736
2737	DEALLOCATE(irrig_deficit_glo, stream_reservoir_glo, irrig_adduct_glo)
2738
2739	ENDIF
2740
2741	!! Calculate the net water flow to each routing reservoir (in kg/dt)
2742	!! to further diagnose the corresponding water budget residu
2743	!! in routing_main
2744
2745	netflow_fast_diag(:) = zero
2746	netflow_slow_diag(:) = zero
2747	netflow_stream_diag(:) = zero
2748
2749	DO ib=1,nbasmax
2750	DO ig=1,nbpt
2751	netflow_fast_diag(ig) = netflow_fast_diag(ig) + runoff(ig)*routing_area(ig,ib) &
2752	- fast_flow(ig,ib) - pond_inflow(ig,ib)
2753	netflow_slow_diag(ig) = netflow_slow_diag(ig) + drainage(ig)*routing_area(ig,ib) &
2754	- slow_flow(ig,ib)
2755	netflow_stream_diag(ig) = netflow_stream_diag(ig) + flood_flow(ig,ib) + transport(ig,ib) &
2756	- stream_flow(ig,ib) - return_swamp(ig,ib) - floods(ig,ib)
2757	ENDDO
2758	ENDDO
2759
2760	!! Grid cell averaging
2761	DO ig=1,nbpt
2762	netflow_fast_diag(ig) = netflow_fast_diag(ig)/totarea(ig)
2763	netflow_slow_diag(ig) = netflow_slow_diag(ig)/totarea(ig)
2764	netflow_stream_diag(ig) = netflow_stream_diag(ig)/totarea(ig)
2765	ENDDO
2766
2767	!
2768	!
2769	! Compute the fluxes which leave the routing scheme
2770	!
2771	! Lakeinflow is in Kg/dt
2772	! returnflow is in Kg/m^2/dt
2773	!
2774	hydrographs(:) = zero
2775	slowflow_diag(:) = zero
2776	fast_diag(:) = zero
2777	slow_diag(:) = zero
2778	stream_diag(:) = zero
2779	flood_diag(:) = zero
2780	pond_diag(:) = zero
2781	irrigation(:) = zero
2782	irrigdeficit(:) = zero !
2783	irrigadduct(:) = zero !
2784	!
2785	!
2786	DO ib=1,nbasmax
2787	!
2788	DO ig=1,nbpt
2789	IF (hydrodiag(ig,ib) > 0 ) THEN
2790	hydrographs(ig) = hydrographs(ig) + fast_flow(ig,ib) + slow_flow(ig,ib) + &
2791	& stream_flow(ig,ib)
2792	slowflow_diag(ig) = slowflow_diag(ig) + slow_flow(ig,ib)
2793	ENDIF
2794	fast_diag(ig) = fast_diag(ig) + fast_reservoir(ig,ib)
2795	slow_diag(ig) = slow_diag(ig) + slow_reservoir(ig,ib)
2796	stream_diag(ig) = stream_diag(ig) + stream_reservoir(ig,ib)
2797	flood_diag(ig) = flood_diag(ig) + flood_reservoir(ig,ib)
2798	irrigation (ig) = irrigation (ig) + irrig_actual(ig,ib) + irrig_adduct(ig,ib)
2799	irrigdeficit(ig) = irrigdeficit(ig) + irrig_deficit(ig,ib)!
2800	irrigadduct (ig) = irrigadduct (ig) + irrig_adduct(ig,ib)!
2801	ENDDO
2802	ENDDO
2803	!
2804	DO ig=1,nbpt
2805	fast_diag(ig) = fast_diag(ig)/totarea(ig)
2806	slow_diag(ig) = slow_diag(ig)/totarea(ig)
2807	stream_diag(ig) = stream_diag(ig)/totarea(ig)
2808	flood_diag(ig) = flood_diag(ig)/totarea(ig)
2809	pond_diag(ig) = pond_reservoir(ig)/totarea(ig)
2810	!
2811	irrigation(ig) = irrigation(ig)/totarea(ig)
2812	irrigdeficit(ig) = irrigdeficit(ig)/totarea(ig)!
2813	irrigadduct(ig) = irrigadduct(ig)/totarea(ig)!
2814	irrig_gw_source(ig) = irrig_gw_source(ig)/totarea(ig)!
2815	irrig_fast_source(ig) = irrig_fast_source(ig)/totarea(ig)!
2816	irrig_str_source(ig) = irrig_str_source(ig)/totarea(ig)!
2817
2818	!
2819	! The three output types for the routing : endoheric basins,, rivers and
2820	! diffuse coastal flow.
2821	!
2822	lakeinflow(ig) = transport(ig,nbasmax+1)
2823	coastalflow(ig) = transport(ig,nbasmax+2)
2824	riverflow(ig) = transport(ig,nbasmax+3)
2825	!
2826	ENDDO
2827	!
2828	flood_res = flood_diag + pond_diag
2829
2830
2831	!! Remove water from lake reservoir if it exceeds the maximum limit and distribute it
2832	!! uniformly over all possible the coastflow gridcells
2833
2834	! Calculate lake_overflow and remove it from lake_reservoir
2835	DO ig=1,nbpt
2836	lake_overflow(ig) = MAX(0., lake_reservoir(ig) - max_lake_reservoir*totarea(ig))
2837	lake_reservoir(ig) = lake_reservoir(ig) - lake_overflow(ig)
2838	END DO
2839	! Transform lake_overflow from kg/grid-cell/dt_routing into kg/m^2/s
2840	CALL xios_orchidee_send_field("lake_overflow",lake_overflow(:)/totarea(:)/dt_routing)
2841
2842	! Calculate the sum of the lake_overflow and distribute it uniformly over all gridboxes
2843	CALL gather(lake_overflow,lake_overflow_g)
2844	IF (is_root_prc) THEN
2845	total_lake_overflow=SUM(lake_overflow_g)
2846	END IF
2847	CALL bcast(total_lake_overflow)
2848
2849	! Distribute the lake_overflow uniformly over all coastal gridcells
2850	! lake_overflow_coast is only calculated to be used as diagnostics if needed
2851	DO ig=1,nbpt
2852	coastalflow(ig) = coastalflow(ig) + total_lake_overflow/nb_coast_gridcells * mask_coast(ig)
2853	lake_overflow_coast(ig) = total_lake_overflow/nb_coast_gridcells * mask_coast(ig)
2854	END DO
2855	! Transform from kg/grid-cell/dt_routing into m^3/grid-cell/s to match output unit of coastalflow
2856	CALL xios_orchidee_send_field("lake_overflow_coast",lake_overflow_coast/mille/dt_routing)
2857
2858	! Counter of reservoir failure to assure irrigation
2859	CALL xios_orchidee_send_field("Count_failure_slow", Count_failure_slow)
2860	CALL xios_orchidee_send_field("Count_failure_fast", Count_failure_fast)
2861	CALL xios_orchidee_send_field("Count_failure_stre", Count_failure_stre)
2862
2863
2864	END SUBROUTINE routing_flow
2865	!
2866	!! ================================================================================================================================
2867	!! SUBROUTINE : routing_lake
2868	!!
2869	!>\BRIEF : This subroutine stores water in lakes so that it does not cycle through the runoff.
2870	!! For the moment it only works for endoheric lakes but I can be extended in the future.
2871	!!
2872	!! DESCRIPTION (definitions, functional, design, flags): The return flow to the soil moisture reservoir
2873	!! is based on a maximum lake evaporation rate (maxevap_lake). \n
2874	!!
2875	!! RECENT CHANGE(S): None
2876	!!
2877	!! MAIN OUTPUT VARIABLE(S):
2878	!!
2879	!! REFERENCES : None
2880	!!
2881	!! FLOWCHART :None
2882	!! \n
2883	!_ ================================================================================================================================
2884
2885	SUBROUTINE routing_lake(nbpt, dt_routing, lakeinflow, humrel, return_lakes)
2886	!
2887	IMPLICIT NONE
2888	!
2889	!! INPUT VARIABLES
2890	INTEGER(i_std), INTENT(in) :: nbpt !! Domain size (unitless)
2891	REAL(r_std), INTENT (in) :: dt_routing !! Routing time step (s)
2892	REAL(r_std), INTENT(out) :: lakeinflow(nbpt) !! Water inflow to the lakes (kg/dt)
2893	REAL(r_std), INTENT(in) :: humrel(nbpt) !! Soil moisture stress, root extraction potential (unitless)
2894	!
2895	!! OUTPUT VARIABLES
2896	REAL(r_std), INTENT(out) :: return_lakes(nbpt) !! Water from lakes flowing back into soil moisture (kg/m^2/dt)
2897	!
2898	!! LOCAL VARIABLES
2899	INTEGER(i_std) :: ig !! Indices (unitless)
2900	REAL(r_std) :: refill !!
2901	REAL(r_std) :: total_area !! Sum of all the surfaces of the basins (m^2)
2902
2903	!_ ================================================================================================================================
2904	!
2905	!
2906	DO ig=1,nbpt
2907	!
2908	total_area = SUM(routing_area(ig,:))
2909	!
2910	lake_reservoir(ig) = lake_reservoir(ig) + lakeinflow(ig)
2911
2912	IF ( doswamps ) THEN
2913	! Calculate a return flow that will be extracted from the lake reservoir and reinserted in the soil in hydrol
2914	! Uptake in Kg/dt
2915	refill = MAX(zero, maxevap_lake * (un - humrel(ig)) * dt_routing * total_area)
2916	return_lakes(ig) = MIN(refill, lake_reservoir(ig))
2917	lake_reservoir(ig) = lake_reservoir(ig) - return_lakes(ig)
2918	! Return in Kg/m^2/dt
2919	return_lakes(ig) = return_lakes(ig)/total_area
2920	ELSE
2921	return_lakes(ig) = zero
2922	ENDIF
2923
2924	! This is the volume of the lake scaled to the entire grid.
2925	! It would be better to scale it to the size of the lake
2926	! but this information is not yet available.
2927	lake_diag(ig) = lake_reservoir(ig)/total_area
2928
2929	lakeinflow(ig) = lakeinflow(ig)/total_area
2930
2931	ENDDO
2932	!
2933	END SUBROUTINE routing_lake
2934	!
2935
2936	!! ================================================================================================================================
2937	!! SUBROUTINE : routing_diagnostic_p
2938	!!
2939	!>\BRIEF This parallelized subroutine gives a diagnostic of the basins used
2940	!!
2941	!! DESCRIPTION (definitions, functional, design, flags) : None
2942	!!
2943	!! RECENT CHANGE(S): None
2944	!!
2945	!! MAIN OUTPUT VARIABLE(S):
2946	!!
2947	!! REFERENCES : None
2948	!!
2949	!! FLOWCHART : None
2950	!! \n
2951	!_ ================================================================================================================================
2952
2953	SUBROUTINE routing_diagnostic_p(nbpt, index, lalo, resolution, contfrac, hist_id, hist2_id)
2954	!
2955	IMPLICIT NONE
2956
2957	!! INPUT VARIABLES
2958	INTEGER(i_std), INTENT(in) :: nbpt !! Domain size (unitless)
2959	INTEGER(i_std), INTENT(in) :: index(nbpt) !! Indices of the points on the map (unitless)
2960	REAL(r_std), INTENT(in) :: lalo(nbpt,2) !! Vector of latitude and longitudes (beware of the order !)
2961	REAL(r_std), INTENT(in) :: resolution(nbpt,2) !! The size of each grid box in X and Y (m)
2962	REAL(r_std), INTENT(in) :: contfrac(nbpt) !! Fraction of land in each grid box (unitless;0-1)
2963	INTEGER(i_std),INTENT (in) :: hist_id !! Access to history file (unitless)
2964	INTEGER(i_std),INTENT (in) :: hist2_id !! Access to history file 2 (unitless)
2965	!
2966	!! LOCAL VARIABLES
2967	REAL(r_std), DIMENSION(nbpt) :: nbrivers !! Number of rivers in the grid (unitless)
2968	REAL(r_std), DIMENSION(nbpt) :: basinmap !! Map of basins (unitless)
2969	REAL(r_std), DIMENSION(nbp_glo) :: nbrivers_g !! Number of rivers in the grid (unitless)
2970	REAL(r_std), DIMENSION(nbp_glo) :: basinmap_g !! Map of basins (unitless)
2971
2972	!_ ================================================================================================================================
2973	routing_area => routing_area_glo
2974	topo_resid => topo_resid_glo
2975	route_togrid => route_togrid_glo
2976	route_tobasin => route_tobasin_glo
2977	route_nbintobas => route_nbintobas_glo
2978	global_basinid => global_basinid_glo
2979	hydrodiag=>hydrodiag_glo
2980	hydroupbasin=>hydroupbasin_glo
2981
2982	IF (is_root_prc) CALL routing_diagnostic(nbp_glo, index_g, lalo_g, resolution_g, contfrac_g, nbrivers_g,basinmap_g)
2983
2984	routing_area => routing_area_loc
2985	topo_resid => topo_resid_loc
2986	route_togrid => route_togrid_loc
2987	route_tobasin => route_tobasin_loc
2988	route_nbintobas => route_nbintobas_loc
2989	global_basinid => global_basinid_loc
2990	hydrodiag=>hydrodiag_loc
2991	hydroupbasin=>hydroupbasin_loc
2992
2993	CALL scatter(nbrivers_g,nbrivers)
2994	CALL scatter(basinmap_g,basinmap)
2995	CALL scatter(hydrodiag_glo,hydrodiag_loc)
2996	CALL scatter(hydroupbasin_glo,hydroupbasin_loc)
2997
2998	CALL xios_orchidee_send_field("basinmap",basinmap)
2999	CALL xios_orchidee_send_field("nbrivers",nbrivers)
3000
3001	IF ( .NOT. almaoutput ) THEN
3002	CALL histwrite_p(hist_id, 'basinmap', 1, basinmap, nbpt, index)
3003	CALL histwrite_p(hist_id, 'nbrivers', 1, nbrivers, nbpt, index)
3004	ELSE
3005	ENDIF
3006	IF ( hist2_id > 0 ) THEN
3007	IF ( .NOT. almaoutput ) THEN
3008	CALL histwrite_p(hist2_id, 'basinmap', 1, basinmap, nbpt, index)
3009	CALL histwrite_p(hist2_id, 'nbrivers', 1, nbrivers, nbpt, index)
3010	ELSE
3011	ENDIF
3012	ENDIF
3013
3014
3015	END SUBROUTINE routing_diagnostic_p
3016
3017	!! ================================================================================================================================
3018	!! SUBROUTINE : routing_diagnostic
3019	!!
3020	!>\BRIEF This non-parallelized subroutine gives a diagnostic of the basins used. This produces some information
3021	!! on the rivers which are being diagnosed.
3022	!!
3023	!! DESCRIPTION (definitions, functional, design, flags) : As not all rivers can be monitored in the model, we will only
3024	!! archive num_largest rivers. In this routine we will diagnose the num_largest largest rivers and print to the standard
3025	!! 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
3026	!! routine routing_names. As this standard output is not sufficient, we will also write it to a netCDF file with the routine
3027	!! routing_diagncfile. It is important to keep for diagnostic the fraction of the largest basins in each grid box and keep information
3028	!! how they are linked one to the other.
3029	!!
3030	!! RECENT CHANGE(S): None
3031	!!
3032	!! MAIN OUTPUT VARIABLE(S): No output variables.
3033	!!
3034	!! REFERENCES : None
3035	!!
3036	!! FLOWCHART :None
3037	!! \n
3038	!_ ================================================================================================================================
3039
3040	SUBROUTINE routing_diagnostic(nbpt, l_index, lalo, resolution, contfrac, nbrivers, basinmap)
3041	!
3042	IMPLICIT NONE
3043	!
3044	!! INPUT VARIABLES
3045	INTEGER(i_std), INTENT(in) :: nbpt !! Domain size (unitless)
3046	INTEGER(i_std), INTENT(in) :: l_index(nbpt) !! Indices of the points on the map (unitless)
3047	REAL(r_std), INTENT(in) :: lalo(nbpt,2) !! Vector of latitude and longitudes (beware of the order !)
3048	REAL(r_std), INTENT(in) :: resolution(nbpt,2) !! The size of each grid box in X and Y (m)
3049	REAL(r_std), INTENT(in) :: contfrac(nbpt) !! Fraction of land in each grid box (unitless;0-1)
3050	!
3051	!! OUTPUT VARIABLES
3052	REAL(r_std), DIMENSION(nbpt), INTENT(out) :: nbrivers !! Number of rivers in the grid (unitless)
3053	REAL(r_std), DIMENSION(nbpt), INTENT(out) :: basinmap !! Map of basins (unitless)
3054	!
3055	!! LOCAL VARIABLES
3056	INTEGER(i_std), DIMENSION(nbpt,nbasmax) :: outids !! IDs of river to which this basin contributes (unitless)
3057	INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:) :: pts !! List the points belonging to the basin (unitless)
3058	INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:) :: ptbas !! List the basin number for this point (unitless)
3059	INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:) :: outpt !! Outflow point for each basin (unitless)
3060	INTEGER(i_std), ALLOCATABLE, DIMENSION(:) :: nb_pts !! Number of points in the basin (unitless)
3061	REAL(r_std), ALLOCATABLE, DIMENSION(:) :: totarea !! Total area of basin (m^2)
3062	REAL(r_std), ALLOCATABLE, DIMENSION(:) :: tmparea !!
3063	INTEGER(i_std), ALLOCATABLE, DIMENSION(:) :: topids !! The IDs of the first num_largest basins (unitless)
3064	CHARACTER(LEN=25), ALLOCATABLE, DIMENSION(:) :: basin_names !! Names of the rivers (unitless)
3065	CHARACTER(LEN=25) :: name_str !!
3066	!
3067	LOGICAL :: river_file !! Choose to write a description of the rivers (true/false)
3068	CHARACTER(LEN=80) :: river_file_name !! Filename in which we write the description of the rivers (unitless)
3069	!
3070	CHARACTER(LEN=25), ALLOCATABLE, DIMENSION(:) :: sorted_names !!
3071	INTEGER(i_std), ALLOCATABLE, DIMENSION(:) :: streams_nb !! Number of streams in basin (unitless)
3072	INTEGER(i_std), ALLOCATABLE, DIMENSION(:) :: streams_avehops !! Average number of hops in streams (unitless)
3073	INTEGER(i_std), ALLOCATABLE, DIMENSION(:) :: streams_minhops !! Minimum number of hops in streams (unitless)
3074	INTEGER(i_std), ALLOCATABLE, DIMENSION(:) :: streams_maxhops !! Minimum number of hops in streams (unitless)
3075	REAL(r_std), ALLOCATABLE, DIMENSION(:) :: streams_resid !! Average residence time
3076	!
3077	REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: lbasin_area !!
3078	REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: lbasin_uparea !!
3079	INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:) :: lrivercode !!
3080	!
3081	INTEGER(i_std) :: ig, ib, og, ob, ign, ibn, ff(1), ic, icc, nb_small, idbas, slen, ii !! Indices (unitless)
3082	INTEGER(i_std) :: ier !! Error handling
3083	CHARACTER(LEN=3) :: nn !!
3084	INTEGER(i_std) :: name_found !!
3085	!
3086	REAL(r_std) :: averesid !!
3087	REAL(r_std), DIMENSION(nbasmax) :: tmpbas !!
3088	REAL(r_std), DIMENSION(nbpt,nbasmax) :: areaupbasin !!
3089	INTEGER(i_std), ALLOCATABLE, DIMENSION(:) :: sortedrivs !!
3090	!
3091	! Variables for the river coding
3092	!
3093	INTEGER(i_std) :: longest_river !!
3094	INTEGER(i_std) :: nbmax !!
3095	INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:) :: allstreams !!
3096	REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: upstreamchange !!
3097	INTEGER(i_std), ALLOCATABLE, DIMENSION(:) :: tstreams, tslen, tpts, tptbas, tcode !!
3098	REAL(r_std), ALLOCATABLE, DIMENSION(:) :: tuparea !!
3099	REAL(r_std), ALLOCATABLE, DIMENSION(:) :: tupstreamchange !!
3100	!
3101	LOGICAL :: err_nbpt_grid_basin !! (true/false)
3102	LOGICAL :: err_basin_number !! (true/false)
3103
3104	!_ ================================================================================================================================
3105	!
3106	!
3107	ALLOCATE(pts(num_largest, nbpt), stat=ier)
3108	IF (ier /= 0) CALL ipslerr_p(3,'routing_diagnostic','Pb in allocate for pts','','')
3109
3110	ALLOCATE(ptbas(num_largest, nbpt), stat=ier)
3111	IF (ier /= 0) CALL ipslerr_p(3,'routing_diagnostic','Pb in allocate for ptbas','','')
3112
3113	ALLOCATE(outpt(num_largest, 2), stat=ier)
3114	IF (ier /= 0) CALL ipslerr_p(3,'routing_diagnostic','Pb in allocate for outpt','','')
3115
3116	ALLOCATE(nb_pts(num_largest), stat=ier)
3117	IF (ier /= 0) CALL ipslerr_p(3,'routing_diagnostic','Pb in allocate for nb_pts','','')
3118
3119	ALLOCATE(totarea(num_largest), tmparea(num_largest), stat=ier)
3120	IF (ier /= 0) CALL ipslerr_p(3,'routing_diagnostic','Pb in allocate for totarea','','')
3121
3122	ALLOCATE(topids(num_largest), stat=ier)
3123	IF (ier /= 0) CALL ipslerr_p(3,'routing_diagnostic','Pb in allocate for topids','','')
3124
3125	ALLOCATE(sortedrivs(num_largest), stat=ier)
3126	IF (ier /= 0) CALL ipslerr_p(3,'routing_diagnostic','Pb in allocate for sortedrivs','','')
3127
3128	ALLOCATE(sorted_names(num_largest), stat=ier)
3129	IF (ier /= 0) CALL ipslerr_p(3,'routing_diagnostic','Pb in allocate for sorted_names','','')
3130
3131	ALLOCATE(streams_nb(num_largest), streams_avehops(num_largest), streams_minhops(num_largest), stat=ier)
3132	IF (ier /= 0) CALL ipslerr_p(3,'routing_diagnostic','Pb in allocate for streams_nb','','')
3133
3134	ALLOCATE(streams_maxhops(num_largest), stat=ier)
3135	IF (ier /= 0) CALL ipslerr_p(3,'routing_diagnostic','Pb in allocate for streams_maxhops','','')
3136
3137	ALLOCATE(streams_resid(num_largest), stat=ier)
3138	IF (ier /= 0) CALL ipslerr_p(3,'routing_diagnostic','Pb in allocate for streams_resid','','')
3139
3140	ALLOCATE(lbasin_area(num_largest,nbpt), lbasin_uparea(num_largest,nbpt), lrivercode(num_largest,nbpt), stat=ier)
3141	IF (ier /= 0) CALL ipslerr_p(3,'routing_diagnostic','Pb in allocate for lbasin_area','','')
3142
3143	IF ( .NOT. is_root_prc) THEN
3144	WRITE(numout,*) "routing_diagnostic is not suitable for running in parallel"
3145	WRITE(numout,*) "We are here on a non root processor. is_root_prc = ", is_root_prc
3146	WRITE(numout,*) "STOP from routing_diagnostic"
3147	CALL ipslerr_p(3,'routing_diagnostic','This routine is not suitable for running in parallel','','')
3148	ENDIF
3149
3150
3151	!Config Key = RIVER_DESC
3152	!Config Desc = Writes out a description of the rivers
3153	!Config If = RIVER_ROUTING
3154	!Config Def = n
3155	!Config Help = This flag allows to write out a file containing the list of
3156	!Config rivers which are beeing simulated. It provides location of outflow
3157	!Config drainage area, name and ID.
3158	!Config Units = [FLAG]
3159	!
3160	river_file=.FALSE.
3161	CALL getin('RIVER_DESC', river_file)
3162	!
3163	!Config Key = RIVER_DESC_FILE
3164	!Config Desc = Filename in which we write the description of the rivers. If suffix is ".nc" a netCDF file is created
3165	!Config If = RIVER_DESC
3166	!Config Def = river_desc.nc
3167	!Config Help = File name where we will write the information. If the suffix is ".nc" a netCDF file is generated. Else
3168	!Config a simple text file will contain some information. The netCDF file is valuable for post-processing the
3169	! data as it will contain the fraction of the large basins in each grid box.
3170	!Config Units = [FILE]
3171	!
3172	river_file_name="river_desc.nc"
3173	CALL getin('RIVER_DESC_FILE', river_file_name)
3174	!
3175	!
3176	! First we get the list of all river outflow points
3177	! We work under the assumption that we only have num_largest basins finishing with
3178	! nbasmax+3. This is checked in routing_truncate.
3179	!
3180	nb_small = 1
3181	outpt(:,:) = -1
3182	ic = 0
3183	DO ig=1,nbpt
3184	DO ib=1,nbasmax
3185	ign = route_togrid(ig, ib)
3186	ibn = route_tobasin(ig, ib)
3187	IF ( ibn .EQ. nbasmax+3) THEN
3188	ic = ic + 1
3189	outpt(ic,1) = ig
3190	outpt(ic,2) = ib
3191	!
3192	! Get the largest id of the basins we call a river. This is
3193	! to extract the names of all rivers.
3194	!
3195	IF ( global_basinid(ig,ib) > nb_small ) THEN
3196	nb_small = global_basinid(ig,ib)
3197	ENDIF
3198	ENDIF
3199	ENDDO
3200	ENDDO
3201
3202	nb_small = MIN(nb_small, 349)
3203
3204	ALLOCATE(basin_names(nb_small), stat=ier)
3205	IF (ier /= 0) CALL ipslerr_p(3,'routing_diagnostic','Pb in allocate for basins_names','','')
3206
3207	CALL routing_names(nb_small, basin_names)
3208	!
3209	! Go through all points and basins to see if they outflow as a river and store the
3210	! information needed in the various arrays.
3211	!
3212	nb_pts(:) = 0
3213	totarea(:) = zero
3214	hydrodiag(:,:) = 0
3215	areaupbasin(:,:) = zero
3216	outids(:,:) = -1
3217	ob = -1
3218	og = -1
3219	lbasin_area(:,:) = zero
3220	lbasin_uparea(:,:) = zero
3221	longest_river = 0
3222	!
3223	err_nbpt_grid_basin = .FALSE.
3224	loopgridbasin : DO ig=1,nbpt
3225	!
3226	DO ib=1,nbasmax
3227	IF ( routing_area(ig,ib) .GT. zero ) THEN
3228	ic = 0
3229	ign = ig
3230	ibn = ib
3231	! Locate outflow point
3232	DO WHILE (ibn .GT. 0 .AND. ibn .LE. nbasmax .AND. ic .LT. nbasmax*nbpt)
3233	ic = ic + 1
3234	og = ign
3235	ob = ibn
3236	ign = route_togrid(og, ob)
3237	ibn = route_tobasin(og, ob)
3238	areaupbasin(og, ob) = areaupbasin(og, ob) + routing_area(ig,ib)
3239	ENDDO
3240	!
3241	longest_river = MAX(longest_river, ic)
3242	!
3243	! Now that we have an outflow check if it is one of the num_largest rivers.
3244	! In this case we keeps the location so we diagnose it.
3245	!
3246	IF ( ibn .EQ. nbasmax + 3) THEN
3247	DO icc = 1,num_largest
3248	IF ( outpt(icc,1) .EQ. og .AND. outpt(icc,2) .EQ. ob ) THEN
3249	!
3250	! We only keep this point for our map if it is large enough.
3251	!
3252	nb_pts(icc) = nb_pts(icc) + 1
3253	!
3254	!
3255	IF ( nb_pts(icc) > nbpt ) THEN
3256	err_nbpt_grid_basin = .TRUE.
3257	EXIT loopgridbasin
3258	ENDIF
3259	!
3260	pts(icc, nb_pts(icc)) = ig
3261	ptbas(icc, nb_pts(icc)) = ib
3262	totarea(icc) = totarea(icc) + routing_area(ig,ib)
3263	!
3264	lbasin_area(icc,nb_pts(icc)) = routing_area(ig,ib)
3265	!
3266	! ID of the river is taken from the last point before the outflow.
3267	topids(icc) = global_basinid(og,ob)
3268	outids(ig,ib) = global_basinid(og,ob)
3269	!
3270	! On this gridbox and basin we will diagnose the hydrograph
3271	!
3272	hydrodiag(ig, ib) = 1
3273	!
3274	ENDIF
3275	ENDDO
3276	ENDIF
3277	ENDIF
3278	!
3279	ENDDO
3280	!
3281	ENDDO loopgridbasin
3282	!
3283	IF ( err_nbpt_grid_basin ) THEN
3284	WRITE(numout, *) "routing_diagnostic : The number of grid points in basin ", icc
3285	WRITE(numout, *) "routing_diagnostic : is larger than anticiped. "
3286	CALL ipslerr_p(3, 'routing_diagnostic', 'We are heading for a out of bounds in arrays pts, ptsbas and lbasin_area.',&
3287	& 'Increase the last dimension of these arrays.','')
3288	ENDIF
3289	!
3290	! Now we decide which points we will keep from the largest basins
3291	!
3292	! Temporary fix
3293	route_nbintobas(:,:) = 0
3294	!
3295	basinmap(:) = zero
3296	DO ig=1,nbpt
3297	!
3298	! Look for the dominant basin in this grid. This information only affects some
3299	! diagnostics : hydrographs and saved area upstream.
3300	!
3301	icc = 0
3302	idbas = -1
3303	!
3304	DO ib=1,nbasmax
3305	IF ( outids(ig,ib) > 0 ) THEN
3306	IF ( COUNT(outids(ig,:) == outids(ig,ib)) > icc ) THEN
3307	icc = COUNT(outids(ig,:) == outids(ig,ib))
3308	idbas = outids(ig,ib)
3309	ENDIF
3310	ENDIF
3311	ENDDO
3312	!
3313	! If we have found a point from the large basins and decided which one
3314	! takes over this grid then we note it on the map.
3315	! Clean-up a little the hydrodiag array
3316	!
3317	IF ( idbas > 0 ) THEN
3318	basinmap(ig) = REAL(idbas, r_std)
3319	ENDIF
3320	!
3321	! Now place the hydrograph diagnostic on the point closest to the
3322	! ocean.
3323	!
3324	tmpbas(:) = zero
3325	DO ib=1,nbasmax
3326	IF ( outids(ig,ib) .EQ. idbas) THEN
3327	tmpbas(ib) = areaupbasin(ig,ib)
3328	ENDIF
3329	ENDDO
3330	hydrodiag(ig,:) = 0
3331	ff=MAXLOC(tmpbas)
3332	hydrodiag(ig,ff(1)) = 1
3333	hydroupbasin(ig) = areaupbasin(ig,ff(1))
3334	!
3335	ENDDO
3336	!
3337	!
3338	!
3339	tmparea(:) = totarea(:)
3340	DO icc = 1, num_largest
3341	ff = MAXLOC(tmparea)
3342	sortedrivs(icc) = ff(1)
3343	tmparea(ff(1)) = 0.0
3344	ENDDO
3345	!
3346	! Diagnose the complexity of the basins obtained and determine their code in the Pfafstetter system
3347	!
3348	nbmax=MAXVAL(nb_pts)
3349	ALLOCATE(allstreams(nbmax, longest_river), upstreamchange(nbmax, longest_river), stat=ier)
3350	IF (ier /= 0) CALL ipslerr_p(3,'routing_diagnostic','Pb in allocate for allstreams','','')
3351
3352	ALLOCATE(tstreams(longest_river), tupstreamchange(longest_river), stat=ier)
3353	IF (ier /= 0) CALL ipslerr_p(3,'routing_diagnostic','Pb in allocate for tstreams','','')
3354
3355	ALLOCATE(tslen(nbmax), tpts(nbmax), tptbas(nbmax), tuparea(nbmax), stat=ier)
3356	IF (ier /= 0) CALL ipslerr_p(3,'routing_diagnostic','Pb in allocate for tslen','','')
3357
3358	ALLOCATE(tcode(nbmax), stat=ier)
3359	IF (ier /= 0) CALL ipslerr_p(3,'routing_diagnostic','Pb in allocate for tcode','','')
3360
3361	DO icc = 1, num_largest
3362	!
3363	! Work through the largest basins
3364	!
3365	idbas = sortedrivs(icc)
3366	!
3367	streams_nb(idbas) = 0
3368	streams_avehops(idbas) = 0
3369	streams_minhops(idbas) = undef_int
3370	streams_maxhops(idbas) = 0
3371	streams_resid(idbas) = zero
3372	tslen(:) = 0
3373	!
3374	allstreams(:,:) = 0
3375	upstreamchange(:,:) = zero
3376	!
3377	DO ii=1,nb_pts(idbas)
3378	!
3379	ig = pts(idbas, ii)
3380	ib = ptbas(idbas, ii)
3381	!
3382	lbasin_uparea(idbas,ii) = areaupbasin(ig,ib)
3383	!
3384	slen = 0
3385	ign = ig
3386	ibn = ib
3387	og = ig
3388	ob = ib
3389	!
3390	averesid = zero
3391	tupstreamchange(:) = zero
3392	! go to outflow point to count the number of hops
3393	DO WHILE (ibn .GT. 0 .AND. ibn .LE. nbasmax)
3394	! Store data
3395	slen = slen + 1
3396	tstreams(slen) = ign
3397	tupstreamchange(slen) = areaupbasin(ign,ibn)-areaupbasin(og,ob)
3398	! Move to next point
3399	og = ign
3400	ob = ibn
3401	ign = route_togrid(og, ob)
3402	ibn = route_tobasin(og, ob)
3403	averesid = averesid + topo_resid(og, ob)**2
3404	ENDDO
3405	!
3406	allstreams(ii,1:slen) = tstreams(slen:1:-1)
3407	upstreamchange(ii,1:slen) = tupstreamchange(slen:1:-1)
3408	tslen(ii) = slen
3409	!
3410	! Save diagnostics
3411	!
3412	streams_nb(idbas) = streams_nb(idbas) + 1
3413	streams_avehops(idbas) = streams_avehops(idbas) + slen
3414	streams_resid(idbas) = streams_resid(idbas) + SQRT(averesid)
3415	IF ( slen < streams_minhops(idbas) ) THEN
3416	streams_minhops(idbas) = slen
3417	ENDIF
3418	IF ( slen > streams_maxhops(idbas) ) THEN
3419	streams_maxhops(idbas) = slen
3420	ENDIF
3421	!
3422	ENDDO
3423	! build the average
3424	IF ( streams_nb(idbas) > 0 ) THEN
3425	streams_avehops(idbas) = streams_avehops(idbas)/streams_nb(idbas)
3426	streams_resid(idbas) = streams_resid(idbas)/REAL(streams_nb(idbas), r_std)
3427	ELSE
3428	! River without streams ... very rare but happens
3429	streams_avehops(idbas) = zero
3430	streams_resid(idbas) = zero
3431	streams_maxhops(idbas) = zero
3432	streams_minhops(idbas) = zero
3433	ENDIF
3434	!
3435	!
3436	ii=nb_pts(idbas)
3437	tpts(:) = 0
3438	tpts(1:ii) = pts(idbas,1:ii)
3439	tptbas(:) = 0
3440	tptbas(1:ii) = ptbas(idbas,1:ii)
3441	tuparea(:) = 0
3442	tuparea(1:ii) = lbasin_uparea(idbas,1:ii)
3443	!
3444	CALL routing_diagcode(ii, tpts, tptbas, tuparea, tslen, MAXVAL(tslen), allstreams, upstreamchange, tcode)
3445	!
3446	lrivercode(idbas,:) = 0
3447	lrivercode(idbas,1:ii) = tcode(1:ii)
3448	!
3449	ENDDO
3450	!
3451	! Create the sorted list of names
3452	!
3453	err_basin_number = .FALSE.
3454	DO icc = 1, num_largest
3455	!
3456	ib=sortedrivs(icc)
3457	!
3458	IF ( topids(ib) .GT. nb_small ) THEN
3459	IF (topids(ib) <= 99 ) THEN
3460	WRITE(sorted_names(icc), '("Nb_",I2.2)') topids(ib)
3461	ELSE IF (topids(ib) <= 999 ) THEN
3462	WRITE(sorted_names(icc), '("Nb_",I3.3)') topids(ib)
3463	ELSE IF (topids(ib) <= 9999 ) THEN
3464	WRITE(sorted_names(icc), '("Nb_",I4.4)') topids(ib)
3465	ELSE IF (topids(ib) <= 99999 ) THEN
3466	WRITE(sorted_names(icc), '("Nb_",I5.5)') topids(ib)
3467	ELSE IF (topids(ib) <= 999999 ) THEN
3468	WRITE(sorted_names(icc), '("Nb_",I6.6)') topids(ib)
3469	ELSE
3470	err_basin_number = .TRUE.
3471	EXIT
3472	ENDIF
3473
3474	ELSE
3475	IF (topids(ib) <= -1 ) THEN
3476	WRITE(sorted_names(icc), '("Ne_",I2.2)') -1*topids(ib)
3477	ELSE
3478	IF (printlev >=6) WRITE(numout,*) ">>> nb_small, ib, topids :", nb_small, ib, topids(ib)
3479	sorted_names(icc) = basin_names(topids(ib))
3480	ENDIF
3481	ENDIF
3482	!
3483	ENDDO
3484	!
3485	IF ( err_basin_number ) THEN
3486	CALL ipslerr_p(3, 'routing_diagnostic', 'We found a basin number larger than 999999.',&
3487	& 'This is impossible. Please verify your configuration.','')
3488	ENDIF
3489	!
3490	! Check for doubles and rename if needed
3491	!
3492	DO icc = 1, num_largest
3493	name_found=0
3494	DO ic=1, num_largest
3495	IF ( TRIM(sorted_names(icc)) == TRIM(sorted_names(ic)) ) THEN
3496	name_found = name_found + 1
3497	ENDIF
3498	ENDDO
3499
3500	IF ( name_found > 1 ) THEN
3501	DO ic=num_largest,1,-1
3502	IF ( TRIM(sorted_names(icc)) == TRIM(sorted_names(ic)) .AND. name_found > 1 ) THEN
3503	IF ( name_found < 10 ) THEN
3504	WRITE(nn,'(I1)') name_found
3505	ELSE IF ( name_found < 100 ) THEN
3506	WRITE(nn,'(I2)') name_found
3507	ELSE IF ( name_found < 1000 ) THEN
3508	WRITE(nn,'(I3)') name_found
3509	ELSE
3510	! Make sur to increase nn size when adding more cases
3511	CALL ipslerr_p(3, 'routing_diagnostic', &
3512	'Non of the previous values can fit in the new char', &
3513	'Add a new condition to deal with it', '')
3514	ENDIF
3515	sorted_names(ic) = TRIM(sorted_names(ic))//TRIM(nn)
3516	name_found = name_found - 1
3517	ENDIF
3518	ENDDO
3519	ENDIF
3520
3521	ENDDO
3522	!
3523	! Print to stdout on ROOT_PROC the diagnostics for the largest basins we have found.
3524	!
3525	IF (printlev>=1) THEN
3526	DO icc = 1, num_largest
3527	IF ( nb_pts(sortedrivs(icc)) .GT. 2 ) THEN
3528	name_str = sorted_names(icc)
3529	WRITE(numout,'("Basin ID ", I5," ", A15, " Area [km^2] : ", F13.4, " Nb points : ", I4)')&
3530	& topids(sortedrivs(icc)), name_str(1:15), totarea(sortedrivs(icc))/1.e6, nb_pts(sortedrivs(icc))
3531	ENDIF
3532	ENDDO
3533	END IF
3534	!
3535	! Save some of the basin information into files.
3536	!
3537	IF ( river_file ) THEN
3538
3539	IF ( INDEX(river_file_name,".nc") > 1 ) THEN
3540
3541	CALL routing_diagncfile(river_file_name, nbpt, lalo, nb_pts, topids, sorted_names, sortedrivs, &
3542	& pts, lbasin_area, lbasin_uparea, lrivercode, outpt, streams_nb, streams_avehops, &
3543	& streams_minhops, streams_maxhops, streams_resid)
3544
3545	ELSE
3546
3547	OPEN(diagunit, FILE=river_file_name)
3548	WRITE(diagunit,'(A)') "Basin ID, Area [km^2], Nb points, Lon and Lat of outflow"
3549	WRITE(diagunit,'(A)') "Nb streams, total number of hops, min, ave and max number of hops per stream"
3550	!
3551	DO icc = 1, num_largest
3552	!
3553	IF ( nb_pts(sortedrivs(icc)) .GT. 2 ) THEN
3554	!
3555	name_str = sorted_names(icc)
3556	!
3557	WRITE(diagunit,'(I5,A25,F14.5,I5,2F9.2)') topids(sortedrivs(icc)), name_str(1:15), totarea(sortedrivs(icc))/1.e6, &
3558	& nb_pts(sortedrivs(icc)), lalo(outpt(sortedrivs(icc),1),2), lalo(outpt(sortedrivs(icc),1),1)
3559	WRITE(diagunit,'(5I9,F16.4)') streams_nb(sortedrivs(icc)), &
3560	& streams_avehops(sortedrivs(icc))*streams_nb(sortedrivs(icc)), &
3561	& streams_minhops(sortedrivs(icc)), &
3562	& streams_avehops(sortedrivs(icc)), &
3563	& streams_maxhops(sortedrivs(icc)), streams_resid(sortedrivs(icc))
3564	!
3565	ENDIF
3566	!
3567	ENDDO
3568	!
3569	CLOSE(diagunit)
3570	!
3571	ENDIF
3572	!
3573	ENDIF
3574	!
3575	!
3576	nbrivers(:) = zero
3577	DO ig=1,nbpt
3578	nbrivers(ig) = COUNT(route_tobasin(ig,1:nbasmax) == nbasmax+3)
3579	ENDDO
3580	DO ig=1,nbpt
3581	IF ( nbrivers(ig) > 1 ) THEN
3582	WRITE(numout,*) 'Grid box ', ig, ' has ', NINT(nbrivers(ig)), ' outflow points.'
3583	WRITE(numout,*) 'The rivers which flow into the ocean at this point are :'
3584	DO icc=1,nbasmax
3585	IF ( route_tobasin(ig,icc) == nbasmax+3) THEN
3586	IF ( global_basinid(ig,icc) <= nb_small ) THEN
3587	WRITE(numout,*) 'ID = ',global_basinid(ig,icc), ' Name = ', basin_names(global_basinid(ig,icc))
3588	ELSE
3589	WRITE(numout,*) 'ID = ',global_basinid(ig,icc), ' Problem ===== ID is larger than possible'
3590	ENDIF
3591	ENDIF
3592	ENDDO
3593	ENDIF
3594	ENDDO
3595	!
3596	ic = COUNT(topo_resid .GT. 0.)
3597	IF (printlev>=1) THEN
3598	WRITE(numout,*) 'Maximum topographic index :', MAXVAL(topo_resid)
3599	WRITE(numout,*) 'Mean topographic index :', SUM(topo_resid, MASK=topo_resid .GT. zero)/ic
3600	WRITE(numout,*) 'Minimum topographic index :', MINVAL(topo_resid, MASK=topo_resid .GT. zero)
3601	END IF
3602
3603	DEALLOCATE(pts)
3604	DEALLOCATE(outpt)
3605	DEALLOCATE(nb_pts)
3606	DEALLOCATE(totarea, tmparea)
3607	DEALLOCATE(streams_nb, streams_avehops, streams_minhops, streams_maxhops)
3608	!
3609	DEALLOCATE(lbasin_area, lbasin_uparea, lrivercode)
3610	!
3611	DEALLOCATE(allstreams)
3612	DEALLOCATE(tstreams)
3613	DEALLOCATE(tslen, tpts, tptbas, tuparea)
3614	DEALLOCATE(tcode)
3615	!
3616	ic = COUNT(topo_resid .GT. 0.)
3617	IF (printlev>=1) THEN
3618	WRITE(numout,*) 'Maximum topographic index :', MAXVAL(topo_resid)
3619	WRITE(numout,*) 'Mean topographic index :', SUM(topo_resid, MASK=topo_resid .GT. 0.)/ic
3620	WRITE(numout,*) 'Minimum topographic index :', MINVAL(topo_resid, MASK=topo_resid .GT. 0.)
3621	END IF
3622
3623	END SUBROUTINE routing_diagnostic
3624	!
3625	!! ================================================================================================================================
3626	!! SUBROUTINE : routing_diagcode
3627	!!
3628	!>\BRIEF This subroutine determines the code in the Pfafstetter system for all points
3629	!! within the given catchment.
3630	!!
3631	!! DESCRIPTION (definitions, functional, design, flags) : None
3632	!!
3633	!! RECENT CHANGE(S): None
3634	!!
3635	!! MAIN OUTPUT VARIABLE(S): streamcode
3636	!!
3637	!! REFERENCES : None
3638	!!
3639	!! FLOWCHART :None
3640	!! \n
3641	!_ ================================================================================================================================
3642
3643	SUBROUTINE routing_diagcode(ip, tpts, tpbas, tuparea, tslen, ls, allstreams, upstreamchange, streamcode)
3644	!
3645	IMPLICIT NONE
3646	!
3647	!! INPUT VARIABLES
3648	INTEGER(i_std), INTENT(in) :: ip !!
3649	INTEGER(i_std), INTENT(in) :: ls !!
3650	INTEGER(i_std), DIMENSION(ip), INTENT(in) :: tpts !!
3651	INTEGER(i_std), DIMENSION(ip), INTENT(in) :: tpbas !!
3652	REAL(r_std), DIMENSION(ip), INTENT(in) :: tuparea !!
3653	INTEGER(i_std), DIMENSION(ip), INTENT(in) :: tslen !!
3654	INTEGER(i_std), DIMENSION(ip,ls), INTENT(in) :: allstreams !!
3655	REAL(r_std), DIMENSION(ip,ls), INTENT(in) :: upstreamchange !!
3656	!
3657	!! OUTPUT VARIABLES
3658	INTEGER(i_std), DIMENSION(ip), INTENT(out) :: streamcode !!
3659	!
3660	!! LOCAL VARIABLES
3661	INTEGER(i_std) :: ilev, cntsubbas, ib, ic, i, it, ilevmax, imaxlen, nbzero !!
3662	INTEGER(i_std) :: tstreamcode(ip)!!
3663	INTEGER(i_std) :: indsubbas(ip) !!
3664	INTEGER(i_std) :: iw(ip) !!
3665	INTEGER(i_std) :: tdiff(ip) !!
3666	INTEGER(i_std) :: tmpjunc(4) !!
3667	INTEGER(i_std) :: junction(4) !!
3668	INTEGER(i_std) :: ff(1) !!
3669	INTEGER(i_std) :: ll !!
3670	REAL(r_std) :: chguparea(ip) !!
3671	REAL(r_std) :: largest !!
3672
3673	!_ ================================================================================================================================
3674	!
3675	streamcode(:) = 0
3676	!
3677	! If we accept 4 grid boxes per coded basin then per level we need at least
3678	! 4*9=36 boxes.
3679	!
3680	ilevmax = 0
3681	it = ip
3682	DO WHILE (it >= 36)
3683	ilevmax = ilevmax+1
3684	it = it/9
3685	ENDDO
3686	!
3687	DO ilev=1,ilevmax
3688	!
3689	! Count number of sub-basins we already have
3690	!
3691	cntsubbas=0
3692	tstreamcode(:) = streamcode(:)
3693	DO WHILE ( COUNT(tstreamcode(:) >= 0) > 0 )
3694	cntsubbas=cntsubbas+1
3695	indsubbas(cntsubbas) = MAXVAL(tstreamcode(:))
3696	WHERE ( tstreamcode(:) == indsubbas(cntsubbas) ) tstreamcode = -1
3697	ENDDO
3698	!
3699	! Go through all these basins in order to find the next Pfafstetter numbers
3700	!
3701	DO ib=1,cntsubbas
3702	!
3703	! Get all the streams which have the current Pfadstetter number
3704	!
3705	it=0
3706	DO ic=1,ip
3707	IF ( streamcode(ic) == indsubbas(ib) ) THEN
3708	it =it+1
3709	iw(it)=ic
3710	ENDIF
3711	ENDDO
3712	!
3713	! Which is the longest stream in this basin ?
3714	!
3715	ff=MAXLOC(tslen(iw(1:it)))
3716	imaxlen=iw(ff(1))
3717	chguparea(:) = zero
3718	chguparea(1:tslen(imaxlen)) = upstreamchange(imaxlen, 1:tslen(imaxlen))
3719	!
3720	IF ( COUNT(chguparea(1:tslen(imaxlen)) > 0) < 4 ) THEN
3721	!
3722	! If this subbasin is too small we just set all points to zero
3723	!
3724	DO i=1,it
3725	streamcode(iw(i)) = streamcode(iw(i))*10
3726	ENDDO
3727	ELSE
3728	!
3729	! Else do the Pfafstetter numbering
3730	!
3731	!
3732	! Where do we have the 4 largest change in upstream area on this stream.
3733	! This must be the confluence of 2 rivers and thus a junction point.
3734	!
3735	largest=piR_EarthR_Earth
3736	DO i=1,4
3737	ff = MAXLOC(chguparea(1:tslen(imaxlen)), MASK = chguparea(1:tslen(imaxlen)) < largest)
3738	tmpjunc(i) = ff(1)
3739	largest=chguparea(tmpjunc(i))
3740	ENDDO
3741	! sort junctions to go from the outflow up-stream
3742	ff(1)=0
3743	DO i=1,4
3744	junction(i) = MINVAL(tmpjunc, MASK=tmpjunc > ff(1))
3745	ff(1) = junction(i)
3746	ENDDO
3747	!
3748	! Find all streams which are identical up to that junction and increase their code accordingly
3749	!
3750	DO i=1,it
3751	ll=MIN(tslen(imaxlen),tslen(iw(i)))
3752	tdiff(1:ll) = allstreams(imaxlen,1:ll)-allstreams(iw(i),1:ll)
3753	nbzero = COUNT(tdiff(1:ll) == 0)
3754	IF (nbzero < junction(1) ) THEN
3755	! Before first of the 4 largest basins
3756	streamcode(iw(i)) = streamcode(iw(i))*10+1
3757	ELSE IF (nbzero == junction(1) ) THEN
3758	! Stream part of the first largest basin
3759	streamcode(iw(i)) = streamcode(iw(i))*10+2
3760	ELSE IF (nbzero < junction(2) ) THEN
3761	! Between first and second stream
3762	streamcode(iw(i)) = streamcode(iw(i))*10+3
3763	ELSE IF (nbzero == junction(2) ) THEN
3764	! Stream part of the second basin
3765	streamcode(iw(i)) = streamcode(iw(i))*10+4
3766	ELSE IF (nbzero < junction(3) ) THEN
3767	! In between stream 2 and 3
3768	streamcode(iw(i)) = streamcode(iw(i))*10+5
3769	ELSE IF (nbzero == junction(3) ) THEN
3770	! Part of 3rd basin
3771	streamcode(iw(i)) = streamcode(iw(i))*10+6
3772	ELSE IF (nbzero < junction(4) ) THEN
3773	! In between 3 and 4th basins
3774	streamcode(iw(i)) = streamcode(iw(i))*10+7
3775	ELSE IF (nbzero == junction(4) ) THEN
3776	! Final of the 4 largest basins
3777	streamcode(iw(i)) = streamcode(iw(i))*10+8
3778	ELSE
3779	! The rest of the points and also the basin of the longest stream
3780	streamcode(iw(i)) = streamcode(iw(i))*10+9
3781	ENDIF
3782	ENDDO
3783	ENDIF
3784	ENDDO
3785	!
3786	ENDDO
3787	!
3788	!
3789	END SUBROUTINE routing_diagcode
3790	!
3791	!! ================================================================================================================================
3792	!! SUBROUTINE : routing_diagncfile
3793	!!
3794	!>\BRIEF This subroutine creates a netCDF file containing all the informations
3795	!! on the largest rivers which can be used for a refined analysis.
3796	!!
3797	!! DESCRIPTION (definitions, functional, design, flags) : None
3798	!!
3799	!! RECENT CHANGE(S): None
3800	!!
3801	!! MAIN OUTPUT VARIABLE(S): None
3802	!!
3803	!! REFERENCES : None
3804	!!
3805	!! FLOWCHART : None
3806	!! \n
3807	!_ ================================================================================================================================
3808
3809	SUBROUTINE routing_diagncfile(river_file_name, nbpt, lalo, nb_pts, topids, sorted_names, sortedrivs, &
3810	& lbasin_index, lbasin_area, lbasin_uparea, lrivercode, outpt, streams_nb, streams_avehops, &
3811	& streams_minhops, streams_maxhops, streams_resid)
3812	!
3813	USE netcdf
3814	!
3815	IMPLICIT NONE
3816	!
3817	!
3818	!! INPUT VARIABLES
3819	REAL(r_std), INTENT(in) :: lalo(nbpt,2) !! Vector of latitude and longitudes (beware of the order !)
3820
3821	!! LOCAL VARIABLES
3822	CHARACTER(LEN=80) :: river_file_name !! Filename in which we write the description of the rivers (1)
3823	INTEGER(i_std) :: nbpt !! Domain size (unitless)
3824	INTEGER(i_std), DIMENSION(num_largest) :: nb_pts !! Number of points in the basin (unitless)
3825	INTEGER(i_std), DIMENSION(num_largest) :: topids !! The IDs of the first num_largest basins (unitless)
3826	CHARACTER(LEN=25), DIMENSION(num_largest) :: sorted_names !! Names of the basins to be put into the file (unitless)
3827	INTEGER(i_std), DIMENSION(num_largest) :: sortedrivs !!
3828	INTEGER(i_std), DIMENSION(num_largest,nbpt) :: lbasin_index !!
3829	REAL(r_std), DIMENSION(num_largest,nbpt) :: lbasin_area !!
3830	REAL(r_std), DIMENSION(num_largest,nbpt) :: lbasin_uparea !!
3831	INTEGER(i_std), DIMENSION(num_largest,nbpt) :: lrivercode !!
3832	!
3833	INTEGER(i_std), DIMENSION(num_largest,2) :: outpt !! Outflow point for each basin (unitless)
3834	INTEGER(i_std), DIMENSION(num_largest) :: streams_nb !! Number of streams in basin (unitless)
3835	INTEGER(i_std), DIMENSION(num_largest) :: streams_avehops !! Average number of hops in streams (unitless)
3836	INTEGER(i_std), DIMENSION(num_largest) :: streams_minhops !! Minimum number of hops in streams (unitless)
3837	INTEGER(i_std), DIMENSION(num_largest) :: streams_maxhops !! Minimum number of hops in streams (unitless)
3838	REAL(r_std), DIMENSION(num_largest) :: streams_resid !! Average residence time
3839	!
3840	INTEGER(i_std) :: icc, fid, iret, ierr_tot, ib, ij, ik, i, j, lcc !! Indices (unitless)
3841	INTEGER(i_std) :: nlonid, nlatid, varid, varid2, varid3
3842	INTEGER(i_std) :: dims(2) !!
3843	REAL(r_std) :: lon_min, lon_max, lat_min, lat_max
3844	CHARACTER(LEN=80) :: lon_name, lat_name, var_name, long_name, nc_name, att_str
3845
3846	REAL(r_std) :: basinfrac(iim_g,jjm_g) !!
3847	REAL(r_std) :: basinuparea(iim_g,jjm_g) !!
3848	INTEGER(i_std) :: basincode(iim_g,jjm_g) !!
3849	!
3850	LOGICAL :: check=.FALSE. !! (true/false)
3851	!
3852	!! PARAMETERS
3853	INTEGER(i_std),PARAMETER :: kind_r_diag=NF90_REAL8 !!
3854	INTEGER(i_std),PARAMETER :: kind_i_diag=NF90_INT !!
3855
3856	!_ ================================================================================================================================
3857	!
3858	!
3859	! 1.0 Create the NETCDF file and store the coordinates.
3860	!
3861	iret = NF90_CREATE(TRIM(river_file_name), NF90_CLOBBER, fid)
3862	IF (iret /= NF90_NOERR) THEN
3863	CALL ipslerr_p (3,'routing_diagncfile', 'Could not create file :', &
3864	& TRIM(river_file_name), '(Problem with disk place or filename ?)')
3865	ENDIF
3866	!
3867	! 1.1 Define dimensions
3868	!
3869	IF ( grid_type == regular_lonlat ) THEN
3870	!
3871	! 1.1.1 regular grid
3872	!
3873	iret = NF90_DEF_DIM(fid, 'lon', iim_g, dims(1))
3874	IF (iret /= NF90_NOERR) THEN
3875	CALL ipslerr_p (3,'routing_diagncfile', 'Dimension "x" can not be defined for the file : ', &
3876	& TRIM(river_file_name),'(Solution ?)')
3877	ENDIF
3878	iret = NF90_DEF_DIM(fid, 'lat', jjm_g, dims(2))
3879	IF (iret /= NF90_NOERR) THEN
3880	CALL ipslerr_p (3,'routing_diagncfile', 'Dimension "y" can not be defined for the file : ', &
3881	& TRIM(river_file_name),'(Solution ?)')
3882	ENDIF
3883	ELSE
3884	!
3885	! 1.1.2 irregular grid
3886	!
3887	iret = NF90_DEF_DIM(fid, 'x', iim_g, dims(1))
3888	IF (iret /= NF90_NOERR) THEN
3889	CALL ipslerr_p (3,'routing_diagncfile', 'Dimension "x" can not be defined for the file : ', &
3890	& TRIM(river_file_name),'(Solution ?)')
3891	ENDIF
3892
3893	iret = NF90_DEF_DIM(fid, 'y', jjm_g, dims(2))
3894	IF (iret /= NF90_NOERR) THEN
3895	CALL ipslerr_p (3,'routing_diagncfile', 'Dimension "y" can not be defined for the file : ', &
3896	& TRIM(river_file_name),'(Solution ?)')
3897	ENDIF
3898	ENDIF
3899	!
3900	!
3901	! 1.2 Define variables and attributes
3902	!
3903	IF ( grid_type == regular_lonlat ) THEN
3904	!
3905	! 1.2.1 regular grid
3906	!
3907	lon_name = 'lon'
3908	!
3909	iret = NF90_DEF_VAR(fid, lon_name, kind_r_diag, dims(1), nlonid)
3910	IF (iret /= NF90_NOERR) THEN
3911	CALL ipslerr_p (3,'routing_diagncfile', 'Variable '//lon_name//' can not be defined for the file : ', &
3912	& TRIM(river_file_name),'(Solution ?)')
3913	ENDIF
3914	!
3915	lat_name = 'lat'
3916	iret = NF90_DEF_VAR(fid, lat_name, kind_r_diag, dims(2), nlatid)
3917	IF (iret /= NF90_NOERR) THEN
3918	CALL ipslerr_p (3,'routing_diagncfile', 'Variable '//lat_name//' can not be defined for the file : ', &
3919	& TRIM(river_file_name),'(Solution ?)')
3920	ENDIF
3921	!
3922	ELSE
3923	!
3924	! 1.2.2 irregular grid
3925	!
3926	lon_name = 'nav_lon'
3927	!
3928	iret = NF90_DEF_VAR(fid, lon_name, kind_r_diag, dims, nlonid)
3929	IF (iret /= NF90_NOERR) THEN
3930	CALL ipslerr_p (3,'routing_diagncfile', 'Variable '//lon_name//' can not be defined for the file : ', &
3931	& TRIM(river_file_name),'(Solution ?)')
3932	ENDIF
3933	!
3934	lat_name = 'nav_lat'
3935	iret = NF90_DEF_VAR(fid, lat_name, kind_r_diag, dims, nlatid)
3936	IF (iret /= NF90_NOERR) THEN
3937	CALL ipslerr_p (3,'routing_diagncfile', 'Variable '//lat_name//' can not be defined for the file : ', &
3938	& TRIM(river_file_name),'(Solution ?)')
3939	ENDIF
3940	!
3941	ENDIF
3942	!
3943	! 1.3 Add attributes to the coordinate variables
3944	!
3945	iret = NF90_PUT_ATT(fid, nlonid, 'units', "degrees_east")
3946	IF (iret /= NF90_NOERR) THEN
3947	CALL ipslerr_p (3,'routing_diagncfile', 'Could not add attribut to variable '//lon_name//' for the file :', &
3948	& TRIM(river_file_name),'(Solution ?)')
3949	ENDIF
3950	!
3951	lon_min = -180.
3952	lon_max = 180.
3953	!
3954	iret = NF90_PUT_ATT(fid, nlonid, 'valid_min', lon_min)
3955	IF (iret /= NF90_NOERR) THEN
3956	CALL ipslerr_p (3,'routing_diagncfile', 'Could not add attribut to variable '//lon_name//' for the file :', &
3957	& TRIM(river_file_name),'(Solution ?)')
3958	ENDIF
3959	iret = NF90_PUT_ATT(fid, nlonid, 'valid_max', lon_max)
3960	IF (iret /= NF90_NOERR) THEN
3961	CALL ipslerr_p (3,'routing_diagncfile', 'Could not add attribut to variable '//lon_name//' for the file :', &
3962	& TRIM(river_file_name),'(Solution ?)')
3963	ENDIF
3964	!
3965	iret = NF90_PUT_ATT(fid, nlonid, 'long_name', "Longitude")
3966	IF (iret /= NF90_NOERR) THEN
3967	CALL ipslerr_p (3,'routing_diagncfile', 'Could not add attribut to variable '//lon_name//' for the file :', &
3968	& TRIM(river_file_name),'(Solution ?)')
3969	ENDIF
3970	iret = NF90_PUT_ATT(fid, nlatid, 'units', "degrees_north")
3971	IF (iret /= NF90_NOERR) THEN
3972	CALL ipslerr_p (3,'routing_diagncfile', 'Could not add attribut to variable '//lat_name//' for the file :', &
3973	& TRIM(river_file_name),'(Solution ?)')
3974	ENDIF
3975	!
3976	lat_max = 90.
3977	lat_min = -90.
3978	!
3979	iret = NF90_PUT_ATT(fid, nlatid, 'valid_min', lat_min)
3980	IF (iret /= NF90_NOERR) THEN
3981	CALL ipslerr_p (3,'routing_diagncfile', 'Could not add attribut to variable '//lat_name//' for the file :', &
3982	& TRIM(river_file_name),'(Solution ?)')
3983	ENDIF
3984	iret = NF90_PUT_ATT(fid, nlatid, 'valid_max', lat_max)
3985	IF (iret /= NF90_NOERR) THEN
3986	CALL ipslerr_p (3,'routing_diagncfile', 'Could not add attribut to variable '//lat_name//' for the file :', &
3987	& TRIM(river_file_name),'(Solution ?)')
3988	ENDIF
3989	iret = NF90_PUT_ATT(fid, nlatid, 'long_name', "Latitude")
3990	IF (iret /= NF90_NOERR) THEN
3991	CALL ipslerr_p (3,'routing_diagncfile', 'Could not add attribut to variable '//lat_name//' for the file :', &
3992	& TRIM(river_file_name),'(Solution ?)')
3993	ENDIF
3994	!
3995	iret = NF90_ENDDEF(fid)
3996	IF (iret /= NF90_NOERR) THEN
3997	CALL ipslerr_p (3,'routing_diagncfile', 'Could not end definitions in the file : ', &
3998	& TRIM(river_file_name),'(Solution ?)')
3999	ENDIF
4000	!
4001	! 1.4 Write coordinates
4002	!
4003	IF ( grid_type == regular_lonlat ) THEN
4004	!
4005	! 1.4.1 regular grid
4006	!
4007	iret = NF90_PUT_VAR(fid, nlonid, lon_g(1:iim_g,1))
4008	IF (iret /= NF90_NOERR) THEN
4009	CALL ipslerr_p (3,'routing_diagncfile', 'Could not put variable nav_lon in the file : ', &
4010	& TRIM(river_file_name),'(Solution ?)')
4011	ENDIF
4012	!
4013	iret = NF90_PUT_VAR(fid, nlatid, lat_g(1,1:jjm_g))
4014	IF (iret /= NF90_NOERR) THEN
4015	CALL ipslerr_p (3,'routing_diagncfile', 'Could not put variable nav_lat in the file : ', &
4016	& TRIM(river_file_name),'(Solution ?)')
4017	ENDIF
4018	ELSE
4019	!
4020	! 1.4.2 irregular grid
4021	!
4022	iret = NF90_PUT_VAR(fid, nlonid, lon_g)
4023	IF (iret /= NF90_NOERR) THEN
4024	CALL ipslerr_p (3,'routing_diagncfile', 'Could not put variable nav_lon in the file : ', &
4025	& TRIM(river_file_name),'(Solution ?)')
4026	ENDIF
4027	!
4028	iret = NF90_PUT_VAR(fid, nlatid, lat_g)
4029	IF (iret /= NF90_NOERR) THEN
4030	CALL ipslerr_p (3,'routing_diagncfile', 'Could not put variable nav_lat in the file : ', &
4031	& TRIM(river_file_name),'(Solution ?)')
4032	ENDIF
4033	ENDIF
4034	!
4035	! 2.0 Go through all basins and wirte the information into the netCDF file.
4036	!
4037	DO icc = 1, num_largest
4038	!
4039	! 2.1 Compute the fields to be saved in the file
4040	!
4041	ib=sortedrivs(icc)
4042	!
4043	!
4044	IF ( nb_pts(ib) > 2 ) THEN
4045	!
4046	basinfrac(:,:) = zero
4047	basinuparea(:,:) = zero
4048	basincode(:,:) = zero
4049	!
4050	DO ij=1, nb_pts(ib)
4051
4052	ik=lbasin_index(ib,ij)
4053
4054	j = ((index_g(ik)-1)/iim_g) + 1
4055	i = (index_g(ik)-(j-1)*iim_g)
4056
4057	IF ( resolution_g(ik,1) == 0 ) THEN
4058	basinfrac(i,j) = basinfrac(i,j) + lbasin_area(ib,ij)/(resolution_g(ik,2)resolution_g(ik,2)pi)
4059	ELSE
4060	basinfrac(i,j) = basinfrac(i,j) + lbasin_area(ib,ij)/(resolution_g(ik,1)*resolution_g(ik,2))
4061	ENDIF
4062	basinuparea(i,j) = MAX(basinuparea(i,j), lbasin_uparea(ib,ij))
4063	basincode(i,j) = lrivercode(ib,ij)
4064
4065	ENDDO
4066	!
4067	DO i=1,iim_g
4068	DO j=1,jjm_g
4069	IF ( basinfrac(i,j) <= EPSILON(zero) ) THEN
4070	basinfrac(i,j) = undef_sechiba
4071	basinuparea(i,j) = undef_sechiba
4072	basincode(i,j) = undef_int
4073	ELSE
4074	basinfrac(i,j) = MIN(basinfrac(i,j), un)
4075	ENDIF
4076	ENDDO
4077	ENDDO
4078	!
4079	!
4080	! 2.2 Define the variables in the netCDF file
4081	!
4082	iret = NF90_REDEF(fid)
4083	IF (iret /= NF90_NOERR) THEN
4084	CALL ipslerr_p (3,'routing_diagncfile', &
4085	& 'Could not restart definitions in the file : ', &
4086	& TRIM(river_file_name),'(Solution ?)')
4087	ENDIF
4088	!
4089	! Create a name more suitable for a variable in a netCDF file
4090	!
4091	nc_name = TRIM(sorted_names(icc))
4092	! Take out all character which could cause problems
4093	lcc=LEN_TRIM(nc_name)
4094	DO ij=1,lcc
4095	IF ( nc_name(ij:ij) == " " ) nc_name(ij:ij) = "_"
4096	IF ( nc_name(ij:ij) == "(" ) nc_name(ij:ij) = "_"
4097	IF ( nc_name(ij:ij) == ")" ) nc_name(ij:ij) = "_"
4098	ENDDO
4099	! reduce redundant "__"
4100	DO ij=1,lcc
4101	IF ( nc_name(ij:ij+1) == "__" ) nc_name(ij+1:)=nc_name(ij+2:lcc)
4102	ENDDO
4103	lcc=LEN_TRIM(nc_name)
4104	IF ( nc_name(lcc:lcc) == "_" ) nc_name(lcc:lcc) = " "
4105	!
4106	!
4107	! 2.3 Fraction variable
4108	!
4109	IF (check) WRITE(numout,*) "Define Fraction variable and add attributes"
4110	!
4111	var_name = TRIM(nc_name)//"_frac"
4112	!
4113	iret = NF90_DEF_VAR(fid, TRIM(var_name), kind_r_diag, dims, varid)
4114	IF (iret /= NF90_NOERR) THEN
4115	CALL ipslerr_p (3,'routing_diagncfile', 'Variable '//TRIM(var_name)//' can not be defined for the file : ', &
4116	& TRIM(river_file_name),'(Solution ?)')
4117	ENDIF
4118	!
4119	ierr_tot = 0
4120	! Units
4121	iret = NF90_PUT_ATT(fid, varid, 'units', "-")
4122	IF (iret /= NF90_NOERR) THEN
4123	WRITE(numout,*) 'Units', iret
4124	WRITE(numout,*) TRIM(NF90_STRERROR(iret))
4125	ierr_tot = ierr_tot + 1
4126	ENDIF
4127	! Long name
4128	long_name = "Fraction of basin "//TRIM(sorted_names(icc))//" per grid box"
4129	iret = NF90_PUT_ATT(fid, varid, 'long_name', long_name)
4130	IF (iret /= NF90_NOERR) THEN
4131	WRITE(numout,*) 'Long_Name', long_name, iret
4132	WRITE(numout,*) TRIM(NF90_STRERROR(iret))
4133	ierr_tot = ierr_tot + 1
4134	ENDIF
4135	! Missing value
4136	iret = NF90_PUT_ATT(fid, varid, 'missing_value', undef_sechiba)
4137	IF (iret /= NF90_NOERR) THEN
4138	WRITE(numout,*) 'Missing value', undef_sechiba, iret
4139	WRITE(numout,*) TRIM(NF90_STRERROR(iret))
4140	ierr_tot = ierr_tot + 1
4141	ENDIF
4142	!
4143	ib=sortedrivs(icc)
4144	IF ( check ) WRITE(numout,*) "Doing basin ", icc," corrsdponding to index = ", ib, "num_largest : ", num_largest
4145	!
4146	! Nb of grid points in basin
4147	att_str='Nb_of_grid_points_in_basin'
4148	iret = NF90_PUT_ATT(fid, varid, att_str, nb_pts(ib))
4149	IF (iret /= NF90_NOERR) THEN
4150	WRITE(numout,*) 'Nb of grid points in basin', nb_pts(ib), iret
4151	WRITE(numout,*) TRIM(NF90_STRERROR(iret))
4152	ierr_tot = ierr_tot + 1
4153	ENDIF
4154	!
4155	! Longitude of outflow point
4156	att_str='Longitude_of_outflow_point'
4157	iret = NF90_PUT_ATT(fid, varid, att_str, lalo(outpt(ib,1),2))
4158	IF (iret /= NF90_NOERR) THEN
4159	WRITE(numout,*) 'Longitude of outflow point', lalo(outpt(ib,1),2), iret
4160	WRITE(numout,*) TRIM(NF90_STRERROR(iret))
4161	ierr_tot = ierr_tot + 1
4162	ENDIF
4163	!
4164	! Latitide of outflow point
4165	att_str='Latitude_of_outflow_point'
4166	iret = NF90_PUT_ATT(fid, varid, att_str, lalo(outpt(ib,1),1))
4167	IF (iret /= NF90_NOERR) THEN
4168	WRITE(numout,*) 'Latitude of outflow point', lalo(outpt(ib,1),1), iret
4169	WRITE(numout,*) TRIM(NF90_STRERROR(iret))
4170	ierr_tot = ierr_tot + 1
4171	ENDIF
4172	!
4173	! Number of streams
4174	att_str= 'Number_of_streams'
4175	iret = NF90_PUT_ATT(fid, varid, att_str, streams_nb(ib))
4176	IF (iret /= NF90_NOERR) THEN
4177	WRITE(numout,*) 'Number of streams', streams_nb(ib), iret
4178	WRITE(numout,*) TRIM(NF90_STRERROR(iret))
4179	ierr_tot = ierr_tot + 1
4180	ENDIF
4181	!
4182	! Total number of hops to go to the oceans
4183	att_str='Total_number_of_hops_to_ocean'
4184	iret = NF90_PUT_ATT(fid, varid, att_str, streams_avehops(ib)*streams_nb(ib))
4185	IF (iret /= NF90_NOERR) THEN
4186	WRITE(numout,) 'Total number of hops to go to the oceans ', streams_avehops(ib)streams_nb(ib), iret
4187	ierr_tot = ierr_tot + 1
4188	ENDIF
4189	!
4190	! Minimum number of hops to go to the ocean for any stream
4191	att_str='Minimum_number_of_hops_to_ocean_for_any_stream'
4192	iret = NF90_PUT_ATT(fid, varid, att_str, streams_minhops(ib))
4193	IF (iret /= NF90_NOERR) THEN
4194	WRITE(numout,*) 'Minimum number of hops to go tp the ocean for any stream', streams_minhops(ib), iret
4195	ierr_tot = ierr_tot + 1
4196	ENDIF
4197	!
4198	! Average number of hops to go to the ocean for any stream
4199	att_str='Average_number_of_hops_to_ocean_for_any_stream'
4200	iret = NF90_PUT_ATT(fid, varid, att_str, streams_avehops(ib))
4201	IF (iret /= NF90_NOERR) THEN
4202	WRITE(numout,*) 'Average number of hops to go tp the ocean for any stream', streams_avehops(ib), iret
4203	ierr_tot = ierr_tot + 1
4204	ENDIF
4205	!
4206	! Maximum number of hops to go to the ocean for any stream
4207	att_str='Maximum_number_of_hops_to_ocean_for_any_stream'
4208	iret = NF90_PUT_ATT(fid, varid, att_str, streams_maxhops(ib))
4209	IF (iret /= NF90_NOERR) THEN
4210	WRITE(numout,*) 'Maximum number of hops to go tp the ocean for any stream', streams_maxhops(ib), iret
4211	ierr_tot = ierr_tot + 1
4212	ENDIF
4213	!
4214	! Average residence time in the basin
4215	att_str='Average_residence_time_in_basin'
4216	iret = NF90_PUT_ATT(fid, varid, att_str, streams_resid(ib))
4217	IF (iret /= NF90_NOERR) THEN
4218	WRITE(numout,*) 'Average residence time in the basin', streams_resid(ib), iret
4219	ierr_tot = ierr_tot + 1
4220	ENDIF
4221	!
4222	IF (ierr_tot > 0 ) THEN
4223	CALL ipslerr_p (3,'routing_diagncfile', 'Could not add some attributes to variable '//var_name//' for the file :', &
4224	& TRIM(river_file_name),'(Solution ?)')
4225	ENDIF
4226	!
4227	! 2.4 Upstream area variable variable
4228	!
4229	IF (check) WRITE(numout,*) "Define Upstream variable and add attributes"
4230	!
4231	! Create a name more suitable for a variable in a netCDF file
4232	!
4233	var_name = TRIM(nc_name)//"_upstream"
4234	DO ij=1,LEN_TRIM(var_name)
4235	IF ( var_name(ij:ij) == " " ) var_name(ij:ij) = "_"
4236	ENDDO
4237	!
4238	iret = NF90_DEF_VAR(fid, TRIM(var_name), kind_r_diag, dims, varid2)
4239	IF (iret /= NF90_NOERR) THEN
4240	CALL ipslerr_p (3,'routing_diagncfile', 'Variable '//TRIM(var_name)//' can not be defined for the file : ', &
4241	& TRIM(river_file_name),'(Solution ?)')
4242	ENDIF
4243	!
4244	ierr_tot = 0
4245	! Units
4246	iret = NF90_PUT_ATT(fid, varid2, 'units', "m^2")
4247	IF (iret /= NF90_NOERR) ierr_tot = ierr_tot + 1
4248	! Long name
4249	long_name = "Upstream area of basin "//TRIM(sorted_names(icc))//" in the grid box"
4250	iret = NF90_PUT_ATT(fid, varid2, 'long_name', long_name)
4251	IF (iret /= NF90_NOERR) ierr_tot = ierr_tot + 1
4252	! Missing value
4253	iret = NF90_PUT_ATT(fid, varid2, 'missing_value', undef_sechiba)
4254	IF (iret /= NF90_NOERR) ierr_tot = ierr_tot + 1
4255	!
4256	IF (ierr_tot > 0 ) THEN
4257	CALL ipslerr_p (3,'routing_diagncfile', 'Could not add some attributes to variable '//var_name//' for the file :', &
4258	& TRIM(river_file_name),'(Solution ?)')
4259	ENDIF
4260	!
4261	! 2.5 Pfafstetter codes for basins
4262	!
4263	IF (check) WRITE(numout,*) "Define Pfafstetter codes variable and add attributes"
4264	!
4265	var_name = TRIM(nc_name)//"_coding"
4266	DO ij=1,LEN_TRIM(var_name)
4267	IF ( var_name(ij:ij) == " " ) var_name(ij:ij) = "_"
4268	ENDDO
4269	!
4270	iret = NF90_DEF_VAR(fid, TRIM(var_name), kind_i_diag, dims, varid3)
4271	IF (iret /= NF90_NOERR) THEN
4272	CALL ipslerr_p (3,'routing_diagncfile', 'Variable '//TRIM(var_name)//' can not be defined for the file : ', &
4273	& TRIM(river_file_name),'(Solution ?)')
4274	ENDIF
4275	!
4276	ierr_tot = 0
4277	! Units
4278	iret = NF90_PUT_ATT(fid, varid3, 'units', "-")
4279	IF (iret /= NF90_NOERR) ierr_tot = ierr_tot + 1
4280	! Long name
4281	long_name = "Pfafstetter codes of grid boxes in basin "//TRIM(sorted_names(icc))
4282	iret = NF90_PUT_ATT(fid, varid3, 'long_name', long_name)
4283	IF (iret /= NF90_NOERR) ierr_tot = ierr_tot + 1
4284	! Missing value
4285	iret = NF90_PUT_ATT(fid, varid3, 'missing_value', undef_int)
4286	IF (iret /= NF90_NOERR) ierr_tot = ierr_tot + 1
4287	!
4288	IF (ierr_tot > 0 ) THEN
4289	CALL ipslerr_p (3,'routing_diagncfile', 'Could not add some attributes to variable '//var_name//' for the file :', &
4290	& TRIM(river_file_name),'(Solution ?)')
4291	ENDIF
4292	!
4293	! 2.6 ENDDEF of netCDF file
4294	!
4295	IF (check) WRITE(numout,*) "END define"
4296	!
4297	iret = NF90_ENDDEF(fid)
4298	IF (iret /= NF90_NOERR) THEN
4299	CALL ipslerr_p (3,'routing_diagncfile', &
4300	& 'Could not end definitions in the file : ', &
4301	& TRIM(river_file_name),'(Solution ?)')
4302	ENDIF
4303	!
4304	! 2.7 Write the data to the file
4305	!
4306	IF (check) WRITE(numout,*) "Put basinfrac"
4307	iret = NF90_PUT_VAR(fid, varid, basinfrac)
4308	IF (iret /= NF90_NOERR) THEN
4309	CALL ipslerr_p (3,'routing_diagncfile', 'Could not put variable basinfrac in the file : ', &
4310	& TRIM(river_file_name),'(Solution ?)')
4311	ENDIF
4312
4313	IF (check) WRITE(numout,*) "Put basinuparea"
4314	iret = NF90_PUT_VAR(fid, varid2, basinuparea)
4315	IF (iret /= NF90_NOERR) THEN
4316	CALL ipslerr_p (3,'routing_diagncfile', 'Could not put variable basinuparea in the file : ', &
4317	& TRIM(river_file_name),'(Solution ?)')
4318	ENDIF
4319
4320	IF (check) WRITE(numout,*) "Put basincode"
4321	iret = NF90_PUT_VAR(fid, varid3, basincode)
4322	IF (iret /= NF90_NOERR) THEN
4323	CALL ipslerr_p (3,'routing_diagfile', 'Could not put variable basincode in the file : ', &
4324	& TRIM(river_file_name),'(Solution ?)')
4325	ENDIF
4326	!
4327	ENDIF
4328	!
4329	ENDDO
4330	!
4331	IF (check) WRITE(numout,*) "Close file"
4332	!
4333	! Close netCDF file and do some memory management.
4334	!
4335	iret = NF90_CLOSE(fid)
4336	IF (iret /= NF90_NOERR) THEN
4337	CALL ipslerr_p (3,'routing_diagncfile', &
4338	& 'Could not end definitions in the file : ', &
4339	& TRIM(river_file_name),'(Solution ?)')
4340	ENDIF
4341	!
4342	!
4343	END SUBROUTINE routing_diagncfile
4344	!
4345	!! ================================================================================================================================
4346	!! SUBROUTINE : routing_basins_p
4347	!!
4348	!>\BRIEF This parallelized subroutine computes the routing map if needed.
4349	!!
4350	!! DESCRIPTION (definitions, functional, design, flags) : None
4351	!!
4352	!! RECENT CHANGE(S): None
4353	!!
4354	!! MAIN OUTPUT VARIABLE(S):
4355	!!
4356	!! REFERENCES : None
4357	!!
4358	!! FLOWCHART : None
4359	!! \n
4360	!_ ================================================================================================================================
4361
4362	SUBROUTINE routing_basins_p(nbpt, lalo, neighbours, resolution, contfrac)
4363	!
4364	IMPLICIT NONE
4365	!
4366	!! INPUT VARIABLES
4367	INTEGER(i_std), INTENT(in) :: nbpt !! Domain size (unitless)
4368	REAL(r_std), INTENT(in) :: lalo(nbpt,2) !! Vector of latitude and longitudes (beware of the order !)
4369	INTEGER(i_std), INTENT(in) :: neighbours(nbpt,NbNeighb) !! Vector of neighbours for each grid point (1=North and then clockwise) (unitless)
4370	REAL(r_std), INTENT(in) :: resolution(nbpt,2) !! The size of each grid box in X and Y (m)
4371	REAL(r_std), INTENT(in) :: contfrac(nbpt) !! Fraction of land in each grid box (unitless;0-1)
4372
4373	!_ ================================================================================================================================
4374
4375	! INTEGER(i_std) :: neighbours_tmp(nbpt,8)
4376	! INTEGER(i_std) :: i,j
4377
4378	! DO i=1,nbp_loc
4379	! DO j=1,NbNeighb
4380	! IF (neighbours(i,j)==-1) THEN
4381	! neighbours_tmp(i,j)=neighbours(i,j)
4382	! ELSE
4383	! neighbours_tmp(i,j)=neighbours(i,j)+nbp_para_begin(mpi_rank)-1
4384	! ENDIF
4385	! ENDDO
4386	! ENDDO
4387
4388	routing_area => routing_area_glo
4389	topo_resid => topo_resid_glo
4390	route_togrid => route_togrid_glo
4391	route_tobasin => route_tobasin_glo
4392	route_nbintobas => route_nbintobas_glo
4393	global_basinid => global_basinid_glo
4394
4395	IF (is_root_prc) CALL routing_basins(nbp_glo,lalo_g, neighbours_g, resolution_g, contfrac_g)
4396
4397	routing_area => routing_area_loc
4398	topo_resid => topo_resid_loc
4399	route_togrid => route_togrid_loc
4400	route_tobasin => route_tobasin_loc
4401	route_nbintobas => route_nbintobas_loc
4402	global_basinid => global_basinid_loc
4403
4404	CALL scatter(routing_area_glo,routing_area_loc)
4405	CALL scatter(topo_resid_glo,topo_resid_loc)
4406	CALL scatter(route_togrid_glo,route_togrid_loc)
4407	CALL scatter(route_tobasin_glo,route_tobasin_loc)
4408	CALL scatter(route_nbintobas_glo,route_nbintobas_loc)
4409	CALL scatter(global_basinid_glo,global_basinid_loc)
4410
4411	END SUBROUTINE routing_basins_p
4412	!
4413
4414	!! ================================================================================================================================
4415	!! SUBROUTINE : routing_basins
4416	!!
4417	!>\BRIEF This non-parallelized subroutine reads in the map of basins and flow direction to construct
4418	!! the catchments of each grid box.
4419	!!
4420	!! DESCRIPTION (definitions, functional, design, flags) :
4421	!! The work is done in a number of steps which are performed locally on the
4422	!! GCM grid:
4423	!! 1) First we find the grid-points of the high resolution routing grid which are
4424	!! within the coarser grid of the GCM.
4425	!! 2) When we have these grid points we decompose them into basins in the routine
4426	!! routing_findbasins. A number of simplifications are done if needed.
4427	!! 3) In the routine routing_globalize we put the basin information of this grid
4428	!! into the global fields.
4429	!! Then we work on the global grid to perform the following tasks :
4430	!! 1) We link up the basins of the various grid points and check the global consistency.
4431	!! 2) The area of each outflow point is computed.
4432	!! 3) The final step is to reduce the number of basins in order to fit into the truncation.\n
4433	!!
4434	!! RECENT CHANGE(S): None
4435	!!
4436	!! MAIN OUTPUT VARIABLE(S): None, as the routine puts information into the global variables of the module.
4437	!!
4438	!! REFERENCES : None
4439	!!
4440	!! FLOWCHART : None
4441	!! \n
4442	!_ ================================================================================================================================
4443
4444	SUBROUTINE routing_basins(nbpt, lalo, neighbours, resolution, contfrac)
4445	!
4446	IMPLICIT NONE
4447	!
4448	!! INPUT VARIABLES
4449	INTEGER(i_std), INTENT(in) :: nbpt !! Domain size (unitless)
4450	REAL(r_std), INTENT(in) :: lalo(nbpt,2) !! Vector of latitude and longitudes (beware of the order !)
4451	INTEGER(i_std), INTENT(in) :: neighbours(nbpt,NbNeighb)!! Vector of neighbours for each grid point
4452	!! (1=North and then cloxkwise)
4453	REAL(r_std), INTENT(in) :: resolution(nbpt,2) !! The size of each grid box in X and Y (m)
4454	REAL(r_std), INTENT(in) :: contfrac(nbpt) !! Fraction of land in each grid box (unitless;0-1)
4455	!
4456	!! LOCAL VARIABLES
4457	CHARACTER(LEN=80) :: filename !! Name of the netcdf file (unitless)
4458	INTEGER(i_std) :: iml, jml, lml, tml, fid, ib, ip, jp, fopt !! Indices (unitless)
4459	REAL(r_std) :: lev(1), date, dt, coslat
4460	INTEGER(i_std) :: itau(1) !!
4461	REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: trip !! The trip field (unitless)
4462	REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: basins !! The basin field (unitless)
4463	REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: topoindex !! Topographic index of the residence time (m)
4464	REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: hierarchy !!
4465	REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: lat_rel !!
4466	REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: lon_rel !!
4467	!
4468	INTEGER(i_std) :: nbi, nbj !! Number of point in x and y within the grid (unitless)
4469	REAL(r_std) :: min_topoind !! The current minimum of topographic index (m)
4470	REAL(r_std) :: max_basins !!
4471	REAL(r_std) :: invented_basins !!
4472	!
4473	REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: area_bx !! Area of each small box in the grid box (m^2)
4474	REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: hierarchy_bx !! Level in the basin of the point
4475	REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: lon_bx !!
4476	REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: lat_bx !!
4477	REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: topoind_bx !! Topographic index of the residence time for each of the smaller boxes (m)
4478	INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:) :: trip_bx !! The trip field for each of the smaller boxes (unitless)
4479	INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:) :: basin_bx !!
4480	INTEGER(i_std), ALLOCATABLE, DIMENSION(:) :: coast_pts !! The coastal flow points (unitless)
4481	!
4482	INTEGER(i_std), ALLOCATABLE, DIMENSION(:) :: basin_count !!
4483	INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:) :: basin_id !!
4484	REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: basin_area !!
4485	REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: basin_hierarchy !!
4486	REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: basin_topoind !! Topographic index of the residence time for a basin (m)
4487	REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: fetch_basin !!
4488	INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:) :: basin_flowdir !! Water flow directions in the basin (unitless)
4489	INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:) :: outflow_grid !! Type of outflow on the grid box (unitless)
4490	INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:) :: outflow_basin !!
4491	INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:) :: inflow_number !!
4492	INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:,:) :: inflow_basin !!
4493	INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:,:) :: inflow_grid !!
4494	INTEGER(i_std), ALLOCATABLE, DIMENSION(:) :: nbcoastal !!
4495	INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:) :: coastal_basin !!
4496	!
4497	! Interpolation help variables
4498	!
4499	INTEGER(i_std) :: nix, njx !!
4500	CHARACTER(LEN=30) :: callsign !!
4501	REAL(r_std), ALLOCATABLE, DIMENSION(:,:,:) :: resol_lu !! Resolution
4502	INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:) :: mask !! Mask to exclude some points (unitless)
4503	REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: sub_area !! Area on the fine grid (m^2)
4504	INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:,:) :: sub_index !! Indices of the points we need on the fine grid (unitless)
4505	INTEGER(i_std), ALLOCATABLE, DIMENSION(:) :: sub_pts !! Number of high resolution points on this grid (unitless)
4506	INTEGER :: ALLOC_ERR !!
4507	LOGICAL :: ok_interpol = .FALSE. !! Flag for interpolation (true/false)
4508	!
4509	INTEGER(i_std) :: nb_basin !! Number of sub-basins (unitless)
4510	INTEGER(i_std) :: nwbas !!
4511	INTEGER(i_std), ALLOCATABLE, DIMENSION(:) :: basin_inbxid !!
4512	INTEGER(i_std), ALLOCATABLE, DIMENSION(:) :: basin_sz !!
4513	INTEGER(i_std), ALLOCATABLE, DIMENSION(:) :: basin_bxout !!
4514	INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:,:) :: basin_pts !!
4515	CHARACTER(LEN=7) :: fmt !!
4516	LOGICAL :: debug = .FALSE. !! (true/false)
4517	!
4518	INTEGER(i_std), DIMENSION(2) :: diagbox = (/ 1, 2 /) !!
4519
4520	!_ ================================================================================================================================
4521	!
4522	!
4523	IF ( .NOT. is_root_prc) THEN
4524	WRITE(numout,*) "is_root_prc = ", is_root_prc
4525	CALL ipslerr_p (3,'routing_basins', &
4526	& 'routing_basins is not suitable for running in parallel', &
4527	& 'We are here on a non root processor. ','(STOP from routing_basins)')
4528	ENDIF
4529	!
4530	! Test on diagbox and nbpt
4531	!
4532	IF (debug) THEN
4533	IF (ANY(diagbox .GT. nbpt)) THEN
4534	WRITE(numout,*) "Debug diganostics : nbpt, diagbox", nbpt, diagbox
4535	call ipslerr_p(3,'routing_basin', &
4536	& 'Problem with diagbox in debug mode.', &
4537	& 'diagbox values can''t be greater than land points number.', &
4538	& '(decrease diagbox wrong value)')
4539	ENDIF
4540	ENDIF
4541	!
4542	!
4543	! Needs to be a configurable variable
4544	!
4545	!
4546	!Config Key = ROUTING_FILE
4547	!Config Desc = Name of file which contains the routing information
4548	!Config If = RIVER_ROUTING
4549	!Config Def = routing.nc
4550	!Config Help = The file provided here should alow the routing module to
4551	!Config read the high resolution grid of basins and the flow direction
4552	!Config from one mesh to the other.
4553	!Config Units = [FILE]
4554	!
4555	filename = 'routing.nc'
4556	CALL getin('ROUTING_FILE',filename)
4557	!
4558	CALL flininfo(filename,iml, jml, lml, tml, fid)
4559	CALL flinclo(fid)
4560	!
4561	! soils_param.nc file is 1Â° soit texture file.
4562	!
4563	ALLOCATE(lat_rel(iml,jml), STAT=ALLOC_ERR)
4564	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for lat_rel','','')
4565
4566	ALLOCATE(lon_rel(iml,jml), STAT=ALLOC_ERR)
4567	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for lon_rel','','')
4568
4569	ALLOCATE (trip(iml,jml), STAT=ALLOC_ERR)
4570	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for trip','','')
4571
4572	ALLOCATE (basins(iml,jml), STAT=ALLOC_ERR)
4573	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for basins','','')
4574
4575	ALLOCATE (topoindex(iml,jml), STAT=ALLOC_ERR)
4576	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for topoindex','','')
4577
4578	ALLOCATE (hierarchy(iml,jml), STAT=ALLOC_ERR)
4579	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for hierarchy','','')
4580
4581	!
4582	CALL flinopen(filename, .FALSE., iml, jml, lml, lon_rel, lat_rel, lev, tml, itau, date, dt, fid)
4583	!!
4584	!! From the basin description data we will read the following variables :
4585	!!
4586	!! Trip : Provides the flow direction following the convention :
4587	!! trip = 1 : flow = N
4588	!! trip = 2 : flow = NE
4589	!! trip = 3 : flow = E
4590	!! trip = 4 : flow = SE
4591	!! trip = 5 : flow = S
4592	!! trip = 6 : flow = SW
4593	!! trip = 7 : flow = W
4594	!! trip = 8 : flow = NW
4595	!! trip = 97 : return flow into the ground
4596	!! trip = 98 : coastal flow (diffuse flow into the oceans)
4597	!! trip = 99 : river flow into the oceans
4598	!!
4599	!! Basins : Provides a uniqe ID for each basin. These IDs are also used to get
4600	!! the name of the basin from the table in routine routing_names.
4601	!!
4602	!! Topoind : is the topographic index for the retention time of the water in the
4603	!! grid box. It has been computed with the following formula : 1000 x sqrt(d^3/Dz)
4604	!! where d is the distance of the river from the current grid box to the next one
4605	!! as indicated by the variable trip.
4606	!! Dz the hight difference between between the two grid boxes.
4607	!! All these variables are in meters.
4608	!! Furthermore we have to limit the height difference to 5m in order to avoid any unpleasant
4609	!! surprises. If dz < 5m then dz=5.
4610	!!
4611	!
4612	CALL flinget(fid, 'trip', iml, jml, lml, tml, 1, 1, trip)
4613	!
4614	CALL flinget(fid, 'basins', iml, jml, lml, tml, 1, 1, basins)
4615	!
4616	CALL flinget(fid, 'topoind', iml, jml, lml, tml, 1, 1, topoindex)
4617	!
4618	CALL flinclo(fid)
4619	!
4620	min_topoind = MINVAL(topoindex, MASK=topoindex .LT. undef_sechiba-un)
4621	!
4622	DO ip=1,iml
4623	DO jp=1,jml
4624	IF ( trip(ip,jp) < 1.e10 .AND. topoindex(ip,jp) > 1.e10) THEN
4625	WRITE(numout,*) 'trip exists but not topoind :'
4626	WRITE(numout,*) 'ip, jp :', ip, jp
4627	WRITE(numout,*) 'trip, topoind : ', trip(ip,jp), topoindex(ip,jp)
4628	CALL ipslerr_p(3,'routing_basins','trip exists but not topoind','','')
4629	ENDIF
4630	ENDDO
4631	ENDDO
4632
4633	ALLOCATE(resol_lu(iml,jml,2), STAT=ALLOC_ERR)
4634	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for resol_lu','','')
4635
4636	ALLOCATE(mask(iml,jml), STAT=ALLOC_ERR)
4637	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for mask','','')
4638	!
4639	! Consider all points a priori
4640	!
4641	mask(:,:) = 0
4642	!
4643	DO ip=1,iml
4644	DO jp=1,jml
4645	!
4646	! Determine the land mask of the basin map read from the file ROUTING_FILE
4647	!
4648	IF ( trip(ip,jp) < 1.e10 ) THEN
4649	mask(ip,jp) = 1
4650	ENDIF
4651	!
4652	! Resolution in longitude
4653	!
4654	coslat = MAX( COS( lat_rel(ip,jp) * pi/180. ), mincos )
4655	IF ( ip .EQ. 1 ) THEN
4656	resol_lu(ip,jp,1) = ABS( lon_rel(ip+1,jp) - lon_rel(ip,jp) ) * pi/180. * R_Earth * coslat
4657	ELSEIF ( ip .EQ. iml ) THEN
4658	resol_lu(ip,jp,1) = ABS( lon_rel(ip,jp) - lon_rel(ip-1,jp) ) * pi/180. * R_Earth * coslat
4659	ELSE
4660	resol_lu(ip,jp,1) = ABS( lon_rel(ip+1,jp) - lon_rel(ip-1,jp) )/2. * pi/180. * R_Earth * coslat
4661	ENDIF
4662	!
4663	! Resolution in latitude
4664	!
4665	IF ( jp .EQ. 1 ) THEN
4666	resol_lu(ip,jp,2) = ABS( lat_rel(ip,jp) - lat_rel(ip,jp+1) ) * pi/180. * R_Earth
4667	ELSEIF ( jp .EQ. jml ) THEN
4668	resol_lu(ip,jp,2) = ABS( lat_rel(ip,jp-1) - lat_rel(ip,jp) ) * pi/180. * R_Earth
4669	ELSE
4670	resol_lu(ip,jp,2) = ABS( lat_rel(ip,jp-1) - lat_rel(ip,jp+1) )/2. * pi/180. * R_Earth
4671	ENDIF
4672	!
4673	ENDDO
4674	ENDDO
4675	!
4676	! The maximum number of points of the source map (basin description here) which can fit into
4677	! any grid point of the ORCHIDEE grid is stimated here.
4678	! Some margin is taken.
4679	!
4680	callsign = "routing_basins"
4681	ok_interpol = .FALSE.
4682	!
4683	nix=INT(MAXVAL(resolution_g(:,1))/MAXVAL(resol_lu(:,:,1)))+2
4684	njx=INT(MAXVAL(resolution_g(:,2))/MAXVAL(resol_lu(:,:,2)))+2
4685	nbvmax = nixnjx2
4686	!
4687	! We are on the root processor here as this routine is not in parallel. So no need to broadcast.
4688	!
4689	IF (printlev >=1) THEN
4690	WRITE(numout,*) "Projection arrays for ",callsign," : "
4691	WRITE(numout,*) "Routing : nbvmax = ", nbvmax
4692	END IF
4693
4694	ALLOCATE (sub_area(nbpt,nbvmax), STAT=ALLOC_ERR)
4695	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for sub_area','','')
4696	sub_area(:,:)=zero
4697
4698	ALLOCATE (sub_index(nbpt,nbvmax,2), STAT=ALLOC_ERR)
4699	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for sub_index','','')
4700	sub_index(:,:,:)=0
4701
4702	ALLOCATE (sub_pts(nbpt), STAT=ALLOC_ERR)
4703	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for sub_pts','','')
4704	sub_pts(:)=0
4705	!
4706	! routine aggregate will for each point of the ORCHIDEE grid determine which points
4707	! of the source grid (basin definitions here) fit in there and which fraction of
4708	! of the ORCHIDEE grid it represents.
4709	!
4710	CALL aggregate(nbpt, lalo, neighbours, resolution, contfrac, &
4711	& iml, jml, lon_rel, lat_rel, mask, callsign, &
4712	& nbvmax, sub_index, sub_area, ok_interpol)
4713	!
4714	WHERE (sub_area < 0) sub_area=zero
4715	!
4716	! Some verifications
4717	!
4718	DO ib=1,nbpt
4719	sub_pts(ib) = COUNT(sub_area(ib,:) > zero)
4720	DO fopt=1,sub_pts(ib)
4721	IF (sub_area(ib, fopt) == 0 ) THEN
4722	WRITE(numout,*) "Zero Area - Sub_area > 0 : ", ib, fopt
4723	WRITE(numout,*) "Zero Area - lon : ",lalo(ib,2)
4724	WRITE(numout,*) "Zero Area - lon_rel : ", lon_rel(sub_index(ib, fopt, 1),sub_index(ib, fopt, 2))
4725	WRITE(numout,*) "Zero Area - lat : ",lalo(ib,1)
4726	WRITE(numout,*) "Zero Area - lat_rel : ", lat_rel(sub_index(ib, fopt, 1),sub_index(ib, fopt, 2))
4727	ENDIF
4728	ENDDO
4729	ENDDO
4730	!
4731	! Do some memory management.
4732	!
4733	nwbas = MAX(MAXVAL(sub_pts), NbNeighb+1)
4734	!
4735	ALLOCATE (area_bx(nbvmax,nbvmax), stat=ALLOC_ERR)
4736	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for area_bx','','')
4737	ALLOCATE (hierarchy_bx(nbvmax,nbvmax), stat=ALLOC_ERR)
4738	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for hierarchy_bx','','')
4739	ALLOCATE (lon_bx(nbvmax,nbvmax), stat=ALLOC_ERR)
4740	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for lon_bx','','')
4741	ALLOCATE (lat_bx(nbvmax,nbvmax), stat=ALLOC_ERR)
4742	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for lat_bx','','')
4743	ALLOCATE (topoind_bx(nbvmax,nbvmax), stat=ALLOC_ERR)
4744	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for topoind_bx','','')
4745	ALLOCATE (trip_bx(nbvmax,nbvmax), stat=ALLOC_ERR)
4746	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for trip_bx','','')
4747	ALLOCATE (basin_bx(nbvmax,nbvmax), stat=ALLOC_ERR)
4748	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for basin_bx','','')
4749	ALLOCATE (coast_pts(nbvmax), stat=ALLOC_ERR)
4750	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for coast_pts','','')
4751	ALLOCATE (basin_inbxid(nbvmax), stat=ALLOC_ERR)
4752	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for basin_inbxid','','')
4753	ALLOCATE (basin_sz(nbvmax), stat=ALLOC_ERR)
4754	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for basin_sz','','')
4755	ALLOCATE (basin_pts(nbvmax,nbvmax,2), stat=ALLOC_ERR)
4756	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for basin_pts','','')
4757	ALLOCATE (basin_bxout(nbvmax), stat=ALLOC_ERR)
4758	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for basin_bxout','','')
4759	ALLOCATE (basin_count(nbpt), stat=ALLOC_ERR)
4760	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for basin_count','','')
4761	ALLOCATE (basin_area(nbpt,nwbas), basin_hierarchy(nbpt,nwbas), basin_topoind(nbpt,nwbas), stat=ALLOC_ERR)
4762	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for basin_area','','')
4763	ALLOCATE (fetch_basin(nbpt,nwbas), stat=ALLOC_ERR)
4764	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for fetch_basin','','')
4765	ALLOCATE (basin_id(nbpt,nwbas), basin_flowdir(nbpt,nwbas), stat=ALLOC_ERR)
4766	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for basin_id','','')
4767	ALLOCATE (outflow_grid(nbpt,nwbas),outflow_basin(nbpt,nwbas), stat=ALLOC_ERR)
4768	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for outflow_grid','','')
4769	ALLOCATE (inflow_number(nbpt,nwbas), stat=ALLOC_ERR)
4770	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for inflow_number','','')
4771	ALLOCATE (inflow_basin(nbpt,nwbas,nbvmax), inflow_grid(nbpt,nwbas,nbvmax), stat=ALLOC_ERR)
4772	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for inflow_basin','','')
4773	ALLOCATE (nbcoastal(nbpt), coastal_basin(nbpt,nwbas), stat=ALLOC_ERR)
4774	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for nbcoastal','','')
4775
4776	! Order all sub points in each grid_box and find the sub basins
4777	!
4778	! before we start we set the maps to empty
4779	!
4780	basin_id(:,:) = undef_int
4781	basin_count(:) = 0
4782	hierarchy(:,:) = undef_sechiba
4783	max_basins = MAXVAL(basins, MASK=basins .LT. 1.e10)
4784	invented_basins = max_basins
4785	nbcoastal(:) = 0
4786	!
4787	!! Finds,in each grid box, the distance to the outflow point ... this defines the order in which
4788	!! the water will go through the sub-basins and grid boxes.
4789	!
4790	CALL routing_hierarchy(iml, jml, trip, topoindex, hierarchy)
4791	!
4792	!
4793	DO ib =1, nbpt
4794	!
4795	!
4796	! extract the information for this grid box
4797	!
4798	!! Extracts from the global high resolution fields the data for the current grid box.
4799	!
4800	CALL routing_getgrid(nbpt, iml, jml, ib, sub_pts, sub_index, sub_area, max_basins, min_topoind, &
4801	& lon_rel, lat_rel, lalo, resolution, contfrac, trip, basins, topoindex, hierarchy, &
4802	& nbi, nbj, area_bx, trip_bx, basin_bx, topoind_bx, hierarchy_bx, lon_bx, lat_bx)
4803	!
4804	!! Finds the basins: returns the list of all points which are within the same basin of the grid box.
4805	!
4806	CALL routing_findbasins(nbi, nbj, trip_bx, basin_bx, hierarchy_bx, topoind_bx,&
4807	& nb_basin, basin_inbxid, basin_sz, basin_bxout, basin_pts, coast_pts)
4808	!
4809	! Deal with the case where nb_basin=0 for this grid box. In this case all goes into coastal flow.
4810	!
4811	IF ( debug .AND. (COUNT(diagbox .EQ. ib) .GT. 0) ) THEN
4812	WRITE(numout,*) '===================== IB = :', ib
4813	WRITE(numout,*) "sub_pts(ib) :", sub_pts(ib), "sub_area(ib,:) :",sub_area(ib,1:2)
4814	WRITE(numout,*) 'LON LAT of GCM :', lalo(ib,2), lalo(ib,1)
4815	WRITE(numout,*) 'Neighbor options :', neighbours(ib,1:NbNeighb)
4816	WRITE(numout,*) 'Resolution :', resolution(ib,1:2)
4817	WRITE(fmt,"('(',I3,'I6)')") nbi
4818	WRITE(numout,*) '-------------> trip ', trip_bx(1,1)
4819	DO jp=1,nbj
4820	WRITE(numout,fmt) trip_bx(1:nbi,jp)
4821	ENDDO
4822	WRITE(numout,*) '-------------> basin ',basin_bx(1,1)
4823	DO jp=1,nbj
4824	WRITE(numout,fmt) basin_bx(1:nbi,jp)
4825	ENDDO
4826	WRITE(numout,*) '-------------> hierarchy ',hierarchy_bx(1,1)
4827	DO jp=1,nbj
4828	WRITE(numout,fmt) INT(hierarchy_bx(1:nbi,jp)/1000.)
4829	ENDDO
4830	WRITE(numout,*) '-------------> topoindex ',topoind_bx(1,1)
4831	DO jp=1,nbj
4832	WRITE(numout,fmt) INT(topoind_bx(1:nbi,jp)/1000.)
4833	ENDDO
4834	!
4835	WRITE(numout,*) '------------> The basins we retain'
4836	DO jp=1,nb_basin
4837	WRITE(numout,*) 'index, size, bxout, coast :', basin_inbxid(jp), basin_sz(jp),&
4838	& basin_bxout(jp), coast_pts(jp)
4839	ENDDO
4840	!
4841	ENDIF
4842	!
4843	!! Puts the basins found for the current grid box in the context of the global map.
4844	!
4845	CALL routing_globalize(nbpt, ib, neighbours, area_bx, trip_bx, hierarchy_bx, topoind_bx, min_topoind,&
4846	& nb_basin, basin_inbxid, basin_sz, basin_pts, basin_bxout, coast_pts, nwbas, basin_count,&
4847	& basin_area, basin_hierarchy, basin_topoind, basin_id, basin_flowdir, outflow_grid,&
4848	& nbcoastal, coastal_basin)
4849	!
4850	!
4851	IF ( debug .AND. (COUNT(diagbox .EQ. ib) .GT. 0) ) THEN
4852	WRITE(numout,*) 'GLOBAL information after routing_globalize for grid ', ib
4853	DO jp=1,basin_count(ib)
4854	WRITE(numout,*) 'Basin ID : ', basin_id(ib, jp)
4855	WRITE(numout,*) 'Basin flowdir :', basin_flowdir(ib, jp)
4856	WRITE(numout,*) 'Basin hierarchy :', basin_hierarchy(ib, jp)
4857	WRITE(numout,*) 'Basin topoindex :', basin_topoind(ib, jp)
4858	WRITE(numout,*) 'Basin outflow grid :', outflow_grid(ib,jp)
4859	ENDDO
4860	ENDIF
4861	!
4862	ENDDO
4863	!
4864	!! Makes the connections between the bains and ensures global coherence.
4865	!
4866	CALL routing_linkup(nbpt, contfrac, neighbours, nwbas, basin_count, basin_area, basin_id, basin_flowdir, &
4867	& basin_hierarchy, outflow_grid, outflow_basin, inflow_number, inflow_grid, inflow_basin, &
4868	& nbcoastal, coastal_basin, invented_basins)
4869	!
4870	!
4871	IF (printlev>=1) WRITE(numout,*) 'The maximum number of basins in any grid :', MAXVAL(basin_count)
4872	!
4873	IF ( debug ) THEN
4874	DO ib=1,SIZE(diagbox)
4875	IF ( diagbox(ib) .GT. 0 ) THEN
4876	WRITE(numout,*) 'After routing_linkup information for grid ', diagbox(ib)
4877	DO jp=1,basin_count(diagbox(ib))
4878	WRITE(numout,*) 'Basin ID : ', basin_id(diagbox(ib), jp)
4879	WRITE(numout,*) 'Basin outflow_grid :', outflow_grid(diagbox(ib), jp)
4880	WRITE(numout,*) 'Basin outflow_basin:', outflow_basin(diagbox(ib), jp)
4881	WRITE(numout,*) 'Basin hierarchy :', basin_hierarchy(diagbox(ib), jp)
4882	ENDDO
4883	ENDIF
4884	ENDDO
4885	ENDIF
4886	!
4887	!! Computes the fetch of each basin, upstream area in known.
4888	!
4889	CALL routing_fetch(nbpt, resolution, contfrac, nwbas, basin_count, basin_area, basin_id, outflow_grid, &
4890	& outflow_basin, fetch_basin)
4891	!
4892	!
4893	IF (printlev >=3) WRITE(numout,*) "Start reducing the number of basins per grid to meet the required truncation."
4894	!
4895	!! Reduces the number of basins per grid to the value chosen by the user.
4896	!
4897	CALL routing_truncate(nbpt, resolution, contfrac, nwbas, basin_count, basin_area, basin_topoind,&
4898	& fetch_basin, basin_id, basin_flowdir, outflow_grid, outflow_basin, inflow_number,&
4899	& inflow_grid, inflow_basin)
4900	!
4901	DEALLOCATE (lat_rel)
4902	DEALLOCATE (lon_rel)
4903	!
4904	DEALLOCATE (trip)
4905	DEALLOCATE (basins)
4906	DEALLOCATE (topoindex)
4907	DEALLOCATE (hierarchy)
4908	!
4909	DEALLOCATE (sub_area)
4910	DEALLOCATE (sub_index)
4911	DEALLOCATE (sub_pts)
4912	!
4913	DEALLOCATE (mask)
4914	DEALLOCATE (resol_lu)
4915	!
4916	DEALLOCATE (basin_count)
4917	DEALLOCATE (basin_area, basin_hierarchy, basin_topoind, fetch_basin)
4918	DEALLOCATE (basin_id, basin_flowdir)
4919	DEALLOCATE (outflow_grid,outflow_basin)
4920	DEALLOCATE (inflow_number)
4921	DEALLOCATE (inflow_basin, inflow_grid)
4922	DEALLOCATE (nbcoastal, coastal_basin)
4923
4924	END SUBROUTINE routing_basins
4925
4926
4927	!! ================================================================================================================================
4928	!! SUBROUTINE : routing_getgrid
4929	!!
4930	!>\BRIEF This subroutine extracts from the global high resolution fields
4931	!! the data for the current grid box we are dealing with.
4932	!!
4933	!! DESCRIPTION (definitions, functional, design, flags) :
4934	!! Convention for trip on the input :
4935	!! The trip field follows the following convention for the flow of the water :
4936	!! trip = 1 : flow = N
4937	!! trip = 2 : flow = NE
4938	!! trip = 3 : flow = E
4939	!! trip = 4 : flow = SE
4940	!! trip = 5 : flow = S
4941	!! trip = 6 : flow = SW
4942	!! trip = 7 : flow = W
4943	!! trip = 8 : flow = NW
4944	!! trip = 97 : return flow into the ground
4945	!! trip = 98 : coastal flow (diffuse flow into the oceans) These values are created here
4946	!! trip = 99 : river flow into the oceans
4947	!!
4948	!! On output, the grid boxes of the basin map which flow out of the GCM grid are identified
4949	!! by numbers larger than 100 :
4950	!! trip = 101 : flow = N out of the coarse grid
4951	!! trip = 102 : flow = NE out of the coarse grid
4952	!! trip = 103 : flow = E out of the coarse grid
4953	!! trip = 104 : flow = SE out of the coarse grid
4954	!! trip = 105 : flow = S out of the coarse grid
4955	!! trip = 106 : flow = SW out of the coarse grid
4956	!! trip = 107 : flow = W out of the coarse grid
4957	!! trip = 108 : flow = NW out of the coarse grid
4958	!! Inside the grid the convention remains the same as above (ie between 1 and 99).:\n
4959	!!
4960	!! RECENT CHANGE(S): None
4961	!!
4962	!! MAIN OUTPUT VARIABLE(S):
4963	!!
4964	!! REFERENCES : None
4965	!!
4966	!! FLOWCHART : None
4967	!! \n
4968	!_ ================================================================================================================================
4969
4970	SUBROUTINE routing_getgrid(nbpt, iml, jml, ib, sub_pts, sub_index, sub_area, max_basins, min_topoind, &
4971	& lon_rel, lat_rel, lalo, resolution, contfrac, trip, basins, topoindex, hierarchy, &
4972	& nbi, nbj, area_bx, trip_bx, basin_bx, topoind_bx, hierarchy_bx, lon_bx, lat_bx)
4973	!
4974	IMPLICIT NONE
4975	!
4976	!! INPUT VARIABLES
4977	INTEGER(i_std), INTENT(in) :: nbpt !! Domain size (unitless)
4978	INTEGER(i_std), INTENT(in) :: iml !! X resolution of the high resolution grid
4979	INTEGER(i_std), INTENT(in) :: jml !! Y resolution of the high resolution grid
4980	INTEGER(i_std), INTENT(in) :: ib !! Current basin (unitless)
4981	INTEGER(i_std), INTENT(in) :: sub_pts(nbpt) !! Number of high resolution points on this grid (unitless)
4982	INTEGER(i_std), INTENT(in) :: sub_index(nbpt,nbvmax,2) !! Indices of the points we need on the fine grid (unitless)
4983	REAL(r_std), INTENT(inout) :: max_basins !! The current maximum of basins
4984	REAL(r_std), INTENT(in) :: min_topoind !! The current minimum of topographic index (m)
4985	REAL(r_std), INTENT(in) :: sub_area(nbpt,nbvmax) !! Area on the fine grid (m^2)
4986	REAL(r_std), INTENT(in) :: lon_rel(iml,jml) !!
4987	REAL(r_std), INTENT(in) :: lat_rel(iml,jml) !! coordinates of the fine grid
4988	REAL(r_std), INTENT(in) :: lalo(nbpt,2) !! Vector of latitude and longitudes (beware of the order !)
4989	REAL(r_std), INTENT(in) :: resolution(nbpt,2) !! The size of each grid box in X and Y (m)
4990	REAL(r_std), INTENT(in) :: contfrac(nbpt) !! Fraction of land in each grid box (unitless;0-1)
4991	REAL(r_std), INTENT(inout) :: trip(iml,jml) !! The trip field (unitless)
4992	REAL(r_std), INTENT(inout) :: basins(iml,jml) !! data on the fine grid
4993	REAL(r_std), INTENT(inout) :: topoindex(iml,jml) !! Topographic index of the residence time (m)
4994	REAL(r_std), INTENT(inout) :: hierarchy(iml, jml) !! data on the fine grid
4995	!
4996	!! OUTPUT VARIABLES
4997	INTEGER(i_std), INTENT(out) :: nbi, nbj !! Number of point in x and y within the grid (unitless)
4998	REAL(r_std), INTENT(out) :: area_bx(nbvmax,nbvmax) !! Area of each small box in the grid box (m^2)
4999	REAL(r_std), INTENT(out) :: hierarchy_bx(nbvmax,nbvmax) !! Level in the basin of the point
5000	REAL(r_std), INTENT(out) :: lon_bx(nbvmax,nbvmax) !!
5001	REAL(r_std), INTENT(out) :: lat_bx(nbvmax,nbvmax) !!
5002	REAL(r_std), INTENT(out) :: topoind_bx(nbvmax,nbvmax) !! Topographic index of the residence time for each of the smaller boxes (m)
5003	INTEGER(i_std), INTENT(out) :: trip_bx(nbvmax,nbvmax) !! The trip field for each of the smaller boxes (unitless)
5004	INTEGER(i_std), INTENT(out) :: basin_bx(nbvmax,nbvmax) !!
5005	!
5006	!! LOCAL VARIABLES
5007	INTEGER(i_std) :: ip, jp, ll(1), iloc, jloc !! Indices (unitless)
5008	REAL(r_std) :: lonstr(nbvmax*nbvmax) !!
5009	REAL(r_std) :: latstr(nbvmax*nbvmax) !!
5010
5011	!_ ================================================================================================================================
5012
5013	!
5014	! Set everything to undef to locate easily empty points
5015	!
5016	trip_bx(:,:) = undef_int
5017	basin_bx(:,:) = undef_int
5018	topoind_bx(:,:) = undef_sechiba
5019	area_bx(:,:) = undef_sechiba
5020	hierarchy_bx(:,:) = undef_sechiba
5021	!
5022	IF ( sub_pts(ib) > 0 ) THEN
5023	!
5024	DO ip=1,sub_pts(ib)
5025	lonstr(ip) = lon_rel(sub_index(ib, ip, 1), sub_index(ib, ip, 2))
5026	latstr(ip) = lat_rel(sub_index(ib, ip, 1), sub_index(ib, ip, 2))
5027	ENDDO
5028	!
5029	! Get the size of the area and order the coordinates to go from North to South and West to East
5030	!
5031	CALL routing_sortcoord(sub_pts(ib), lonstr, 'WE', nbi)
5032	CALL routing_sortcoord(sub_pts(ib), latstr, 'NS', nbj)
5033	!
5034	! Transfer the data in such a way that (1,1) is the North Western corner and
5035	! (nbi, nbj) the South Eastern.
5036	!
5037	DO ip=1,sub_pts(ib)
5038	ll = MINLOC(ABS(lonstr(1:nbi) - lon_rel(sub_index(ib, ip, 1), sub_index(ib, ip, 2))))
5039	iloc = ll(1)
5040	ll = MINLOC(ABS(latstr(1:nbj) - lat_rel(sub_index(ib, ip, 1), sub_index(ib, ip, 2))))
5041	jloc = ll(1)
5042	trip_bx(iloc, jloc) = NINT(trip(sub_index(ib, ip, 1), sub_index(ib, ip, 2)))
5043	basin_bx(iloc, jloc) = NINT(basins(sub_index(ib, ip, 1), sub_index(ib, ip, 2)))
5044	area_bx(iloc, jloc) = sub_area(ib, ip)
5045	topoind_bx(iloc, jloc) = topoindex(sub_index(ib, ip, 1), sub_index(ib, ip, 2))
5046	hierarchy_bx(iloc, jloc) = hierarchy(sub_index(ib, ip, 1), sub_index(ib, ip, 2))
5047	lon_bx(iloc, jloc) = lon_rel(sub_index(ib, ip, 1), sub_index(ib, ip, 2))
5048	lat_bx(iloc, jloc) = lat_rel(sub_index(ib, ip, 1), sub_index(ib, ip, 2))
5049	ENDDO
5050	ELSE
5051	!
5052	! This is the case where the model invented a continental point
5053	!
5054	nbi = 1
5055	nbj = 1
5056	iloc = 1
5057	jloc = 1
5058	trip_bx(iloc, jloc) = 98
5059	basin_bx(iloc, jloc) = NINT(max_basins + 1)
5060	max_basins = max_basins + 1
5061	! Check if we are at the poles : resolution(ib,1) = 0
5062	IF ( resolution(ib,1) == 0 ) THEN
5063	! compute the pole cell area as the circle surface
5064	area_bx(iloc, jloc) = piresolution(ib,2)resolution(ib,2)*contfrac(ib)
5065	ELSE
5066	area_bx(iloc, jloc) = resolution(ib,1)resolution(ib,2)contfrac(ib)
5067	ENDIF
5068	topoind_bx(iloc, jloc) = min_topoind
5069	hierarchy_bx(iloc, jloc) = min_topoind
5070	lon_bx(iloc, jloc) = lalo(ib,2)
5071	lat_bx(iloc, jloc) = lalo(ib,1)
5072	!
5073	ENDIF
5074	!
5075	! Tag in trip all the outflow conditions. The table is thus :
5076	! trip = 100+n : Outflow into another grid box
5077	! trip = 99 : River outflow into the ocean
5078	! trip = 98 : This will be coastal flow (not organized as a basin)
5079	! trip = 97 : return flow into the soil (local)
5080	!
5081	DO jp=1,nbj
5082	IF ( trip_bx(1,jp) .EQ. 8 .OR. trip_bx(1,jp) .EQ. 7 .OR. trip_bx(1,jp) .EQ. 6) THEN
5083	trip_bx(1,jp) = trip_bx(1,jp) + 100
5084	ENDIF
5085	IF ( trip_bx(nbi,jp) .EQ. 2 .OR. trip_bx(nbi,jp) .EQ. 3 .OR. trip_bx(nbi,jp) .EQ. 4) THEN
5086	trip_bx(nbi,jp) = trip_bx(nbi,jp) + 100
5087	ENDIF
5088	ENDDO
5089	DO ip=1,nbi
5090	IF ( trip_bx(ip,1) .EQ. 8 .OR. trip_bx(ip,1) .EQ. 1 .OR. trip_bx(ip,1) .EQ. 2) THEN
5091	trip_bx(ip,1) = trip_bx(ip,1) + 100
5092	ENDIF
5093	IF ( trip_bx(ip,nbj) .EQ. 6 .OR. trip_bx(ip,nbj) .EQ. 5 .OR. trip_bx(ip,nbj) .EQ. 4) THEN
5094	trip_bx(ip,nbj) = trip_bx(ip,nbj) + 100
5095	ENDIF
5096	ENDDO
5097	!
5098	!
5099	! We simplify the outflow. We only need the direction normal to the
5100	! box boundary and the 4 corners.
5101	!
5102	! Northern border
5103	IF ( trip_bx(1,1) .EQ. 102 ) trip_bx(1,1) = 101
5104	IF ( trip_bx(nbi,1) .EQ. 108 ) trip_bx(nbi,1) = 101
5105	DO ip=2,nbi-1
5106	IF ( trip_bx(ip,1) .EQ. 108 .OR. trip_bx(ip,1) .EQ. 102 ) trip_bx(ip,1) = 101
5107	ENDDO
5108	! Southern border
5109	IF ( trip_bx(1,nbj) .EQ. 104 ) trip_bx(1,nbj) = 105
5110	IF ( trip_bx(nbi,nbj) .EQ. 106 ) trip_bx(nbi,nbj) = 105
5111	DO ip=2,nbi-1
5112	IF ( trip_bx(ip,nbj) .EQ. 104 .OR. trip_bx(ip,nbj) .EQ. 106 ) trip_bx(ip,nbj) = 105
5113	ENDDO
5114	! Eastern border
5115	IF ( trip_bx(nbi,1) .EQ. 104) trip_bx(nbi,1) = 103
5116	IF ( trip_bx(nbi,nbj) .EQ. 102) trip_bx(nbi,nbj) = 103
5117	DO jp=2,nbj-1
5118	IF ( trip_bx(nbi,jp) .EQ. 104 .OR. trip_bx(nbi,jp) .EQ. 102 ) trip_bx(nbi,jp) = 103
5119	ENDDO
5120	! Western border
5121	IF ( trip_bx(1,1) .EQ. 106) trip_bx(1,1) = 107
5122	IF ( trip_bx(1,nbj) .EQ. 108) trip_bx(1,nbj) = 107
5123	DO jp=2,nbj-1
5124	IF ( trip_bx(1,jp) .EQ. 106 .OR. trip_bx(1,jp) .EQ. 108 ) trip_bx(1,jp) = 107
5125	ENDDO
5126	!
5127	!
5128	END SUBROUTINE routing_getgrid
5129	!
5130	!! ================================================================================================================================
5131	!! SUBROUTINE : routing_sortcoord
5132	!!
5133	!>\BRIEF This subroutines orders the coordinates to go from North to South and West to East.
5134	!!
5135	!! DESCRIPTION (definitions, functional, design, flags) : None
5136	!!
5137	!! RECENT CHANGE(S): None
5138	!!
5139	!! MAIN OUTPUT VARIABLE(S):
5140	!!
5141	!! REFERENCES : None
5142	!!
5143	!! FLOWCHART : None
5144	!! \n
5145	!_ ================================================================================================================================
5146
5147	SUBROUTINE routing_sortcoord(nb_in, coords, direction, nb_out)
5148	!
5149	IMPLICIT NONE
5150	!
5151	!! INPUT VARIABLES
5152	INTEGER(i_std), INTENT(in) :: nb_in !!
5153	REAL(r_std), INTENT(inout) :: coords(nb_in) !!
5154	!
5155	!! OUTPUT VARIABLES
5156	INTEGER(i_std), INTENT(out) :: nb_out !!
5157	!
5158	!! LOCAL VARIABLES
5159	CHARACTER(LEN=2) :: direction !!
5160	INTEGER(i_std) :: ipos !!
5161	REAL(r_std) :: coords_tmp(nb_in) !!
5162	INTEGER(i_std), DIMENSION(1) :: ll !!
5163	INTEGER(i_std) :: ind(nb_in) !!
5164
5165	!_ ================================================================================================================================
5166	!
5167	ipos = 1
5168	nb_out = nb_in
5169	!
5170	! Compress the coordinates array
5171	!
5172	DO WHILE ( ipos < nb_in )
5173	IF ( coords(ipos+1) /= undef_sechiba) THEN
5174	IF ( COUNT(coords(ipos:nb_out) == coords(ipos)) > 1 ) THEN
5175	coords(ipos:nb_out-1) = coords(ipos+1:nb_out)
5176	coords(nb_out:nb_in) = undef_sechiba
5177	nb_out = nb_out - 1
5178	ELSE
5179	ipos = ipos + 1
5180	ENDIF
5181	ELSE
5182	EXIT
5183	ENDIF
5184	ENDDO
5185	!
5186	! Sort it now
5187	!
5188	! First we get ready and adjust for the periodicity in longitude
5189	!
5190	coords_tmp(:) = undef_sechiba
5191	IF ( INDEX(direction, 'WE') == 1 .OR. INDEX(direction, 'EW') == 1) THEN
5192	IF ( MAXVAL(ABS(coords(1:nb_out))) .GT. 160 ) THEN
5193	coords_tmp(1:nb_out) = MOD(coords(1:nb_out) + 360.0, 360.0)
5194	ELSE
5195	coords_tmp(1:nb_out) = coords(1:nb_out)
5196	ENDIF
5197	ELSE IF ( INDEX(direction, 'NS') == 1 .OR. INDEX(direction, 'SN') == 1) THEN
5198	coords_tmp(1:nb_out) = coords(1:nb_out)
5199	ELSE
5200	WRITE(numout,*) 'The chosen direction (', direction,') is not recognized'
5201	CALL ipslerr_p(3,'routing_sortcoord','The chosen direction is not recognized','First section','')
5202	ENDIF
5203	!
5204	! Get it sorted out now
5205	!
5206	ipos = 1
5207	!
5208	IF ( INDEX(direction, 'WE') == 1 .OR. INDEX(direction, 'SN') == 1) THEN
5209	DO WHILE (COUNT(ABS(coords_tmp(:)-undef_sechiba) > EPSILON(undef_sechiba)*10.) >= 1)
5210	ll = MINLOC(coords_tmp(:), coords_tmp /= undef_sechiba)
5211	ind(ipos) = ll(1)
5212	coords_tmp(ll(1)) = undef_sechiba
5213	ipos = ipos + 1
5214	ENDDO
5215	ELSE IF ( INDEX(direction, 'EW') == 1 .OR. INDEX(direction, 'NS') == 1) THEN
5216	DO WHILE (COUNT(ABS(coords_tmp(:)-undef_sechiba) > EPSILON(undef_sechiba)*10.) >= 1)
5217	ll = MAXLOC(coords_tmp(:), coords_tmp /= undef_sechiba)
5218	ind(ipos) = ll(1)
5219	coords_tmp(ll(1)) = undef_sechiba
5220	ipos = ipos + 1
5221	ENDDO
5222	ELSE
5223	WRITE(numout,*) 'The chosen direction (', direction,') is not recognized (second)'
5224	CALL ipslerr_p(3,'routing_sortcoord','The chosen direction is not recognized','Second section','')
5225	ENDIF
5226	!
5227	coords(1:nb_out) = coords(ind(1:nb_out))
5228	IF (nb_out < nb_in) THEN
5229	coords(nb_out+1:nb_in) = zero
5230	ENDIF
5231	!
5232	END SUBROUTINE routing_sortcoord
5233	!
5234
5235	!! ================================================================================================================================
5236	!! SUBROUTINE : routing_findbasins
5237	!!
5238	!>\BRIEF This subroutine finds the basins and does some clean up.
5239	!! The aim is to return the list off all points which are within the
5240	!! same basin of the grid box.
5241	!!
5242	!! DESCRIPTION (definitions, functional, design, flags) :
5243	!! We will also collect all points which directly flow into the ocean in one basin
5244	!! Make sure that we do not have a basin with two outflows and other exceptions.
5245	!! At this stage no effort is made to come down to the truncation of the model.
5246	!!
5247	!! Convention for trip \n
5248	!! ------------------- \n
5249	!! Inside of the box : \n
5250	!! trip = 1 : flow = N \n
5251	!! trip = 2 : flow = NE \n
5252	!! trip = 3 : flow = E \n
5253	!! trip = 4 : flow = SE \n
5254	!! trip = 5 : flow = S \n
5255	!! trip = 6 : flow = SW \n
5256	!! trip = 7 : flow = W \n
5257	!! trip = 8 : flow = NW \n
5258	!! trip = 97 : return flow into the ground \n
5259	!! trip = 98 : coastal flow (diffuse flow into the oceans) These values are created here \n
5260	!! trip = 99 : river flow into the oceans \n
5261	!!
5262	!! Out flow from the grid : \n
5263	!! trip = 101 : flow = N out of the coarse grid \n
5264	!! trip = 102 : flow = NE out of the coarse grid \n
5265	!! trip = 103 : flow = E out of the coarse grid \n
5266	!! trip = 104 : flow = SE out of the coarse grid \n
5267	!! trip = 105 : flow = S out of the coarse grid \n
5268	!! trip = 106 : flow = SW out of the coarse grid \n
5269	!! trip = 107 : flow = W out of the coarse grid \n
5270	!! trip = 108 : flow = NW out of the coarse grid! \n
5271	!! RECENT CHANGE(S): None
5272	!!
5273	!! MAIN OUTPUT VARIABLE(S):
5274	!!
5275	!! REFERENCES : None
5276	!!
5277	!! FLOWCHART : None
5278	!! \n
5279	!_ ================================================================================================================================
5280
5281	SUBROUTINE routing_findbasins(nbi, nbj, trip, basin, hierarchy, topoind, nb_basin, basin_inbxid, basin_sz,&
5282	& basin_bxout, basin_pts, coast_pts)
5283	!
5284	IMPLICIT NONE
5285	!
5286	!! INPUT VARIABLES
5287	INTEGER(i_std), INTENT(in) :: nbi !! Number of point in x within the grid (unitless)
5288	INTEGER(i_std), INTENT(in) :: nbj !! Number of point in y within the grid (unitless)
5289	REAL(r_std), INTENT(in) :: hierarchy(:,:) !!
5290	REAL(r_std), INTENT(in) :: topoind(:,:) !! Topographic index of the residence time (m)
5291	!
5292	! Modified
5293	INTEGER(i_std), INTENT(inout) :: trip(:,:) !! The trip field (unitless)
5294	INTEGER(i_std), INTENT(inout) :: basin(:,:) !!
5295	!
5296	!! OUTPUT VARIABLES
5297	INTEGER(i_std), INTENT(out) :: nb_basin !! Number of sub-basins (unitless)
5298	INTEGER(i_std), INTENT(out) :: basin_inbxid(nbvmax) !!
5299	INTEGER(i_std), INTENT(out) :: basin_sz(nbvmax) !!
5300	INTEGER(i_std), INTENT(out) :: basin_bxout(nbvmax) !!
5301	INTEGER(i_std), INTENT(out) :: basin_pts(nbvmax, nbvmax, 2) !!
5302	INTEGER(i_std), INTENT(out) :: coast_pts(nbvmax) !! The coastal flow points (unitless)
5303	!
5304	!! LOCAL VARIABLES
5305	INTEGER(i_std) :: ibas, ilf, nbb, nb_in !!
5306	INTEGER(i_std) :: bname(nbvmax) !!
5307	INTEGER(i_std) :: sz(nbvmax) !!
5308	INTEGER(i_std) :: pts(nbvmax,nbvmax,2) !!
5309	INTEGER(i_std) :: nbout(nbvmax) !!
5310	INTEGER(i_std) :: new_nb !!
5311	INTEGER(i_std) :: new_bname(nbvmax) !!
5312	INTEGER(i_std) :: new_sz(nbvmax) !!
5313	INTEGER(i_std) :: new_pts(nbvmax,nbvmax,2) !!
5314	INTEGER(i_std) :: itrans !!
5315	INTEGER(i_std) :: trans(nbvmax) !!
5316	INTEGER(i_std) :: outdir(nbvmax) !!
5317	INTEGER(i_std) :: tmpsz(nbvmax) !!
5318	INTEGER(i_std) :: ip, jp, jpp(1), ipb !!
5319	INTEGER(i_std) :: sortind(nbvmax) !!
5320	CHARACTER(LEN=7) :: fmt !!
5321
5322	!_ ================================================================================================================================
5323	!
5324	nbb = 0
5325	ibas = -1
5326	bname(:) = undef_int
5327	sz(:) = 0
5328	nbout(:) = 0
5329	new_pts(:,:,:) = 0
5330	!
5331	! 1.0 Find all basins within this grid box
5332	! Sort the variables per basin so that we can more easily
5333	! access data from the same basin (The variables are :
5334	! bname, sz, pts, nbout)
5335	!
5336	DO ip=1,nbi
5337	DO jp=1,nbj
5338	IF ( basin(ip,jp) .LT. undef_int) THEN
5339	IF ( COUNT(basin(ip,jp) .EQ. bname(:)) .EQ. 0 ) THEN
5340	nbb = nbb + 1
5341	IF ( nbb .GT. nbvmax ) CALL ipslerr_p(3,'routing_findbasins','nbvmax too small','first section','')
5342	bname(nbb) = basin(ip,jp)
5343	sz(nbb) = 0
5344	ENDIF
5345	!
5346	DO ilf=1,nbb
5347	IF ( basin(ip,jp) .EQ. bname(ilf) ) THEN
5348	ibas = ilf
5349	ENDIF
5350	ENDDO
5351	!
5352	sz(ibas) = sz(ibas) + 1
5353	IF ( sz(ibas) .GT. nbvmax ) CALL ipslerr_p(3,'routing_findbasins','nbvmax too small','second section','')
5354	pts(ibas, sz(ibas), 1) = ip
5355	pts(ibas, sz(ibas), 2) = jp
5356	! We deal only with outflow and leave flow back into the grid box for later.
5357	IF ( trip(ip,jp) .GE. 97 ) THEN
5358	nbout(ibas) = nbout(ibas) + 1
5359	ENDIF
5360	!
5361	ENDIF
5362	!
5363	ENDDO
5364	ENDDO
5365	!
5366	! 2.0 All basins which have size 1 and flow to the ocean are put together.
5367	!
5368	itrans = 0
5369	coast_pts(:) = undef_int
5370	! Get all the points we can collect
5371	DO ip=1,nbb
5372	IF ( sz(ip) .EQ. 1 .AND. trip(pts(ip,1,1),pts(ip,1,2)) .EQ. 99) THEN
5373	itrans = itrans + 1
5374	trans(itrans) = ip
5375	trip(pts(ip,1,1),pts(ip,1,2)) = 98
5376	ENDIF
5377	ENDDO
5378	! put everything in the first basin
5379	IF ( itrans .GT. 1) THEN
5380	ipb = trans(1)
5381	coast_pts(sz(ipb)) = bname(ipb)
5382	bname(ipb) = -1
5383	DO ip=2,itrans
5384	sz(ipb) = sz(ipb) + 1
5385	coast_pts(sz(ipb)) = bname(trans(ip))
5386	sz(trans(ip)) = 0
5387	pts(ipb, sz(ipb), 1) = pts(trans(ip), 1, 1)
5388	pts(ipb, sz(ipb), 2) = pts(trans(ip), 1, 2)
5389	ENDDO
5390	ENDIF
5391	!
5392	! 3.0 Make sure that we have only one outflow point in each basin
5393	!
5394	! nbb is the number of basins on this grid box.
5395	new_nb = 0
5396	DO ip=1,nbb
5397	! We only do this for grid-points which have more than one outflow
5398	IF ( sz(ip) .GT. 1 .AND. nbout(ip) .GT. 1) THEN
5399	!
5400	! Pick up all points needed and store them in trans
5401	!
5402	itrans = 0
5403	DO jp=1,sz(ip)
5404	IF ( trip(pts(ip,jp,1),pts(ip,jp,2)) .GE. 97) THEN
5405	itrans = itrans + 1
5406	trans(itrans) = trip(pts(ip,jp,1),pts(ip,jp,2))
5407	ENDIF
5408	ENDDO
5409	!
5410	! First issue : We have more than one point of the basin which flows into
5411	! the ocean. In this case we put everything into coastal flow. It will go into
5412	! a separate basin in the routing_globalize routine.
5413	!
5414	IF ( (COUNT(trans(1:itrans) .EQ. 99) + COUNT(trans(1:itrans) .EQ. 98)) .GT. 1) THEN
5415	DO jp=1,sz(ip)
5416	IF ( trip(pts(ip,jp,1),pts(ip,jp,2)) .EQ. 99 ) THEN
5417	trip(pts(ip,jp,1),pts(ip,jp,2)) = 98
5418	trans(itrans) = trip(pts(ip,jp,1),pts(ip,jp,2))
5419	ENDIF
5420	ENDDO
5421	ENDIF
5422	!
5423	! Second issue : We have redundant outflows at the boundaries. That is two small grid
5424	! boxes flowing into the same GCM grid box.
5425	!
5426	IF ( COUNT(trans(1:itrans) .GT. 100) .GE. 1) THEN
5427	CALL routing_simplify(nbi, nbj, trip, basin, hierarchy, bname(ip))
5428	itrans = 0
5429	DO jp=1,sz(ip)
5430	IF ( trip(pts(ip,jp,1),pts(ip,jp,2)) .GE. 9) THEN
5431	itrans = itrans + 1
5432	trans(itrans) = trip(pts(ip,jp,1),pts(ip,jp,2))
5433	ENDIF
5434	ENDDO
5435	ENDIF
5436	!
5437	! Third issue : we have more than one outflow from the boxes. This could be
5438	! - flow into 2 or more neighboring GCM grids
5439	! - flow into a neighboring GCM grids and into the ocean or be a return flow (=97. =98, =99)
5440	! - flow into a neighboring GCM grids or ocean and back into the same GCM grid box
5441	! The only solution is to cut the basin up in as many parts.
5442	!
5443	IF ( COUNT(trans(1:itrans) .GE. 97) .GT. 1) THEN
5444	!
5445	nb_in = new_nb
5446	CALL routing_cutbasin(nbi, nbj, nbb, trip, basin, bname(ip), new_nb, new_bname, new_sz, new_pts)
5447	!
5448	! If we have split the basin then we need to cancel the old one
5449	!
5450	IF ( nb_in .NE. new_nb) THEN
5451	sz(ip) = 0
5452	ENDIF
5453	!
5454	ENDIF
5455	!
5456	ENDIF
5457	ENDDO
5458	!
5459	! Add the new basins to the end of the list
5460	!
5461	If ( nbb+new_nb .LE. nbvmax) THEN
5462	DO ip=1,new_nb
5463	bname(nbb+ip) = new_bname(ip)
5464	sz(nbb+ip) = new_sz(ip)
5465	pts(nbb+ip,:,:) = new_pts(ip,:,:)
5466	ENDDO
5467	nbb = nbb+new_nb
5468	ELSE
5469	WRITE(numout,*) 'Increase nbvmax. It is too small to contain all the basins (routing_findbasins)'
5470	CALL ipslerr_p(3,'routing_findbasins','Increase nbvmax.','It is too small to contain all the basins','')
5471	ENDIF
5472	!
5473	! Keep the output direction
5474	!
5475	DO ip=1,nbb
5476	IF ( sz(ip) .GT. 0 ) THEN
5477	trans(:) = 0
5478	DO jp=1,sz(ip)
5479	trans(jp) = trip(pts(ip,jp,1),pts(ip,jp,2))
5480	ENDDO
5481	outdir(ip) = MAXVAL(trans(1:sz(ip)))
5482	IF ( outdir(ip) .GE. 97 ) THEN
5483	outdir(ip) = outdir(ip) - 100
5484	ELSE
5485	WRITE(numout,*) 'Why are we here and can not find a trip larger than 96'
5486	WRITE(numout,*) 'Does this mean that the basin does not have any outflow ', ip, bname(ip)
5487	WRITE(fmt,"('(',I3,'I9)')") nbi
5488	WRITE(numout,*) '-----------------------> trip'
5489	DO jp=1,nbj
5490	WRITE(numout,fmt) trip(1:nbi,jp)
5491	ENDDO
5492	WRITE(numout,*) '-----------------------> basin'
5493	DO jp=1,nbj
5494	WRITE(numout,fmt) basin(1:nbi,jp)
5495	ENDDO
5496	CALL ipslerr_p(3,'routing_findbasins','Probleme finding trip','','')
5497	ENDIF
5498	ENDIF
5499	ENDDO
5500	!
5501	!
5502	! Sort the output by size of the various basins.
5503	!
5504	nb_basin = COUNT(sz(1:nbb) .GT. 0)
5505	tmpsz(:) = -1
5506	tmpsz(1:nbb) = sz(1:nbb)
5507	DO ip=1,nbb
5508	jpp = MAXLOC(tmpsz(:))
5509	IF ( sz(jpp(1)) .GT. 0) THEN
5510	sortind(ip) = jpp(1)
5511	tmpsz(jpp(1)) = -1
5512	ENDIF
5513	ENDDO
5514	basin_inbxid(1:nb_basin) = bname(sortind(1:nb_basin))
5515	basin_sz(1:nb_basin) = sz(sortind(1:nb_basin))
5516	basin_pts(1:nb_basin,:,:) = pts(sortind(1:nb_basin),:,:)
5517	basin_bxout(1:nb_basin) = outdir(sortind(1:nb_basin))
5518	!
5519	! We can only check if we have at least as many outflows as basins
5520	!
5521	ip = COUNT(trip(1:nbi,1:nbj) .GE. 97 .AND. trip(1:nbi,1:nbj) .LT. undef_int)
5522	!! ip = ip + COUNT(trip(1:nbi,1:nbj) .EQ. 97)
5523	!! IF ( COUNT(trip(1:nbi,1:nbj) .EQ. 98) .GT. 0) ip = ip + 1
5524	IF ( ip .LT. nb_basin ) THEN
5525	WRITE(numout,*) 'We have less outflow points than basins :', ip
5526	WRITE(fmt,"('(',I3,'I9)')") nbi
5527	WRITE(numout,*) '-----------------------> trip'
5528	DO jp=1,nbj
5529	WRITE(numout,fmt) trip(1:nbi,jp)
5530	ENDDO
5531	WRITE(numout,*) '-----------------------> basin'
5532	DO jp=1,nbj
5533	WRITE(numout,fmt) basin(1:nbi,jp)
5534	ENDDO
5535	WRITE(numout,*) 'nb_basin :', nb_basin
5536	WRITE(numout,*) 'Basin sized :', basin_sz(1:nb_basin)
5537	CALL ipslerr_p(3,'routing_findbasins','Probleme less outflow points than basins','','')
5538	ENDIF
5539
5540	END SUBROUTINE routing_findbasins
5541	!
5542	!! ================================================================================================================================
5543	!! SUBROUTINE : routing_simplify
5544	!!
5545	!>\BRIEF This subroutine symplifies the routing out of each basin by taking
5546	!! out redundancies at the borders of the GCM box.
5547	!! The aim is to have only one outflow point per basin and grid box.
5548	!! But here we will not change the direction of the outflow.
5549	!!
5550	!! DESCRIPTION (definitions, functional, design, flags) : None
5551	!!
5552	!! RECENT CHANGE(S): None
5553	!!
5554	!! MAIN OUTPUT VARIABLE(S):
5555	!!
5556	!! REFERENCES : None
5557	!!
5558	!! FLOWCHART : None
5559	!! \n
5560	!_ ================================================================================================================================
5561
5562	SUBROUTINE routing_simplify(nbi, nbj, trip, basin, hierarchy, basin_inbxid)
5563	!
5564	IMPLICIT NONE
5565	!
5566	!! LOCAL VARIABLES
5567	INTEGER(i_std) :: nbi !! Number of point in x within the grid (unitless)
5568	INTEGER(i_std) :: nbj !! Number of point in y within the grid (unitless)
5569	INTEGER(i_std) :: trip(:,:) !! The trip field (unitless)
5570	INTEGER(i_std) :: basin(:,:) !!
5571	REAL(r_std) :: hierarchy(:,:) !!
5572	INTEGER(i_std) :: basin_inbxid !!
5573	!
5574	INTEGER(i_std) :: ip, jp, nbout, basin_sz, iborder !!
5575	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)
5576	INTEGER(i_std), DIMENSION(nbvmax,nbvmax,2) :: trip_flow !!
5577	INTEGER(i_std), DIMENSION(nbvmax,2) :: outflow !!
5578	INTEGER(i_std), DIMENSION(nbvmax) :: outsz !!
5579	CHARACTER(LEN=7) :: fmt !!
5580	!
5581	INTEGER(i_std), DIMENSION(8,2) :: inc !!
5582	INTEGER(i_std) :: itodo, ill(1), icc, ismall, ibas, iip, jjp, ib, id !! Indices (unitless)
5583	INTEGER(i_std), DIMENSION(nbvmax) :: todopt !!
5584	!!$, todosz
5585	REAL(r_std), DIMENSION(nbvmax) :: todohi !!
5586	LOGICAL :: not_found, debug = .FALSE. !! (true/false)
5587
5588	!_ ================================================================================================================================
5589	!
5590	!
5591	! The routing code (i=1, j=2)
5592	!
5593	inc(1,1) = 0
5594	inc(1,2) = -1
5595	inc(2,1) = 1
5596	inc(2,2) = -1
5597	inc(3,1) = 1
5598	inc(3,2) = 0
5599	inc(4,1) = 1
5600	inc(4,2) = 1
5601	inc(5,1) = 0
5602	inc(5,2) = 1
5603	inc(6,1) = -1
5604	inc(6,2) = 1
5605	inc(7,1) = -1
5606	inc(7,2) = 0
5607	inc(8,1) = -1
5608	inc(8,2) = -1
5609	!
5610	!
5611	! Symplify the outflow conditions first. We are only interested in the
5612	! outflows which go to different GCM grid boxes.
5613	!
5614	IF ( debug ) THEN
5615	WRITE(numout,*) '+++++++++++++++++++ BEFORE ANYTHING ++++++++++++++++++++'
5616	WRITE(fmt,"('(',I3,'I6)')") nbi
5617	DO jp=1,nbj
5618	WRITE(numout,fmt) trip_tmp(1:nbi,jp)
5619	ENDDO
5620	ENDIF
5621	!
5622	! transfer the trips into an array which only contains the basin we are interested in
5623	!
5624	trip_tmp(:,:) = -1
5625	basin_sz = 0
5626	DO ip=1,nbi
5627	DO jp=1,nbj
5628	IF ( basin(ip,jp) .EQ. basin_inbxid) THEN
5629	trip_tmp(ip,jp) = trip(ip,jp)
5630	basin_sz = basin_sz + 1
5631	ENDIF
5632	ENDDO
5633	ENDDO
5634	!
5635	! Determine for each point where it flows to
5636	!
5637	CALL routing_findrout(nbi, nbj, trip_tmp, basin_sz, basin_inbxid, nbout, outflow, trip_flow, outsz)
5638	!
5639	!
5640	!
5641	!
5642	! Over the width of a GCM grid box we can have many outflows but we are interested
5643	! in only one for each basin. Thus we wish to collect them all to form only one outflow
5644	! to the neighboring grid box.
5645	!
5646	DO iborder = 101,107,2
5647	!
5648	! If we have more than one of these outflows then we need to merge the sub-basins
5649	!
5650	icc = COUNT(trip_tmp .EQ. iborder)-1
5651	DO WHILE ( icc .GT. 0)
5652	! Pick out all the points we will have to do
5653	itodo = 0
5654	DO ip=1,nbout
5655	IF (trip_tmp(outflow(ip,1),outflow(ip,2)) .EQ. iborder) THEN
5656	itodo = itodo + 1
5657	todopt(itodo) = ip
5658	!!$ todosz(itodo) = outsz(ip)
5659	! We take the hierarchy of the outflow point as we will try to
5660	! minimize if for the outflow of the entire basin.
5661	todohi(itodo) = hierarchy(outflow(ip,1),outflow(ip,2))
5662	ENDIF
5663	ENDDO
5664	!
5665	! We change the direction of the smallest basin.
5666	!
5667	ill=MAXLOC(todohi(1:itodo))
5668	ismall = todopt(ill(1))
5669	!
5670	DO ip=1,nbi
5671	DO jp=1,nbj
5672	IF ( trip_flow(ip,jp,1) .EQ. outflow(ismall,1) .AND.&
5673	& trip_flow(ip,jp,2) .EQ. outflow(ismall,2) ) THEN
5674	! Now that we have found a point of the smallest sub-basin we
5675	! look around for another sub-basin
5676	ib = 1
5677	not_found = .TRUE.
5678	DO WHILE ( not_found .AND. ib .LE. itodo )
5679	IF ( ib .NE. ill(1) ) THEN
5680	ibas = todopt(ib)
5681	DO id=1,8
5682	iip = ip + inc(id,1)
5683	jjp = jp + inc(id,2)
5684	! Can we look at this points or is there any need to ?
5685	IF ( iip .GE. 1 .AND. iip .LE. nbi .AND. &
5686	& jjp .GE. 1 .AND. jjp .LE. nbj .AND. not_found) THEN
5687	! Is this point the one we look for ?
5688	IF ( trip_flow(iip,jjp,1) .EQ. outflow(ibas,1) .AND. &
5689	& trip_flow(iip,jjp,2) .EQ. outflow(ibas,2)) THEN
5690	trip_flow(ip,jp,1) = outflow(ibas,1)
5691	trip_flow(ip,jp,2) = outflow(ibas,2)
5692	trip_tmp(ip,jp) = id
5693	! This last line ensures that we do not come back to this point
5694	! and that in the end the outer while will stop
5695	not_found = .FALSE.
5696	ENDIF
5697	ENDIF
5698	ENDDO
5699	ENDIF
5700	ib = ib + 1
5701	ENDDO
5702	ENDIF
5703	ENDDO
5704	ENDDO
5705	!
5706	icc = icc - 1
5707	ENDDO
5708	!
5709	!
5710	ENDDO
5711	!
5712	IF ( debug ) THEN
5713	WRITE(numout,*) '+++++++++++++++++++ AFTER +++++++++++++++++++++++++++++'
5714	WRITE(fmt,"('(',I3,'I6)')") nbi
5715	DO jp=1,nbj
5716	WRITE(numout,fmt) trip_tmp(1:nbi,jp)
5717	ENDDO
5718	ENDIF
5719	!
5720	! Put trip_tmp back into trip
5721	!
5722	DO ip=1,nbi
5723	DO jp=1,nbj
5724	IF ( trip_tmp(ip,jp) .GT. 0) THEN
5725	trip(ip,jp) = trip_tmp(ip,jp)
5726	ENDIF
5727	ENDDO
5728	ENDDO
5729	!
5730	END SUBROUTINE routing_simplify
5731	!
5732	!! ================================================================================================================================
5733	!! SUBROUTINE : routing_cutbasin
5734	!!
5735	!>\BRIEF This subroutine cuts the original basin which has more than one outflow
5736	!! into as many subbasins as outflow directions.
5737	!!
5738	!! DESCRIPTION (definitions, functional, design, flags) : None
5739	!!
5740	!! RECENT CHANGE(S): None
5741	!!
5742	!! MAIN OUTPUT VARIABLE(S):
5743	!!
5744	!! REFERENCES : None
5745	!!
5746	!! FLOWCHART : None
5747	!! \n
5748	!_ ================================================================================================================================
5749
5750	SUBROUTINE routing_cutbasin (nbi, nbj, nbbasins, trip, basin, basin_inbxid, nb, bname, sz, pts)
5751	!
5752	IMPLICIT NONE
5753	!
5754	!! INPUT VARIABLES
5755	INTEGER(i_std), INTENT(in) :: nbi, nbj !! Number of point in x and y within the grid (unitless)
5756	INTEGER(i_std), INTENT(in) :: nbbasins !!
5757	INTEGER(i_std), INTENT(in) :: basin_inbxid !!
5758	!
5759	! Modified
5760	INTEGER(i_std), INTENT(inout) :: trip(:,:) !! The trip field (unitless)
5761	INTEGER(i_std), INTENT(inout) :: basin(:,:) !!
5762	!
5763	!! OUTPUT VARIABLES
5764	INTEGER(i_std), INTENT(out) :: nb !!
5765	INTEGER(i_std), INTENT(out) :: bname(nbvmax) !!
5766	INTEGER(i_std), INTENT(out) :: sz(nbvmax) !!
5767	INTEGER(i_std), INTENT(out) :: pts(nbvmax,nbvmax,2) !!
5768	!
5769	!! LOCAL VARIABLES
5770	INTEGER(i_std) :: ip, jp, iip, jjp, ib, ibb, id, nbout !! Indices (unitless)
5771	INTEGER(i_std) :: basin_sz !!
5772	INTEGER(i_std) :: nb_in !!
5773	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)
5774	INTEGER(i_std), DIMENSION(nbvmax,nbvmax,2) :: trip_flow !!
5775	INTEGER(i_std), DIMENSION(nbvmax,2) :: outflow !!
5776	INTEGER(i_std), DIMENSION(nbvmax) :: outsz !!
5777	CHARACTER(LEN=7) :: fmt !!
5778	LOGICAL :: not_found !! (true/false)
5779	LOGICAL :: debug=.FALSE. !! (true/false)
5780	!
5781	INTEGER(i_std), DIMENSION(8,2) :: inc !!
5782
5783	!_ ================================================================================================================================
5784	!
5785	!
5786	! The routing code (i=1, j=2)
5787	!
5788	inc(1,1) = 0
5789	inc(1,2) = -1
5790	inc(2,1) = 1
5791	inc(2,2) = -1
5792	inc(3,1) = 1
5793	inc(3,2) = 0
5794	inc(4,1) = 1
5795	inc(4,2) = 1
5796	inc(5,1) = 0
5797	inc(5,2) = 1
5798	inc(6,1) = -1
5799	inc(6,2) = 1
5800	inc(7,1) = -1
5801	inc(7,2) = 0
5802	inc(8,1) = -1
5803	inc(8,2) = -1
5804	!
5805	! Set up a temporary trip field which only contains the values
5806	! for the basin on which we currently work.
5807	!
5808	trip_tmp(:,:) = -1
5809	basin_sz = 0
5810	DO ip=1,nbi
5811	DO jp=1,nbj
5812	IF ( basin(ip,jp) .EQ. basin_inbxid) THEN
5813	trip_tmp(ip,jp) = trip(ip,jp)
5814	basin_sz = basin_sz + 1
5815	ENDIF
5816	ENDDO
5817	ENDDO
5818	!
5819	CALL routing_findrout(nbi, nbj, trip_tmp, basin_sz, basin_inbxid, nbout, outflow, trip_flow, outsz)
5820	!
5821	! IF ( debug ) THEN
5822	! DO ib = nb_in+1,nb
5823	! DO ip=1,sz(ib)
5824	! trip_tmp(pts(ib, ip, 1),pts(ib, ip, 2)) = ib*(-1)-900
5825	! ENDDO
5826	! ENDDO
5827	! WRITE(fmt,"('(',I3,'I6)')") nbi
5828	! WRITE(numout,*) 'BEFORE ------------> New basins '
5829	! WRITE(numout,*) nb, ' sz :', sz(1:nb)
5830	! DO jp=1,nbj
5831	! WRITE(numout,fmt) trip_tmp(1:nbi,jp)
5832	! ENDDO
5833	! ENDIF
5834	!
5835	! Take out the small sub-basins. That is those which have only one grid box
5836	! This is only done if we need to save space in the number of basins. Else we
5837	! can take it easy and keep diverging sub-basins for the moment.
5838	!
5839	IF ( nbbasins .GE. nbasmax ) THEN
5840	DO ib=1,nbout
5841	! If the sub-basin is of size one and its larger neighbor is flowing into another
5842	! direction then we put them together.
5843	IF ( outsz(ib) .EQ. 1 .AND. trip(outflow(ib,1), outflow(ib,2)) .GT. 99 ) THEN
5844	!
5845	not_found = .TRUE.
5846	DO id=1,8
5847	ip = outflow(ib,1)
5848	jp = outflow(ib,2)
5849	iip = ip + inc(id,1)
5850	jjp = jp + inc(id,2)
5851	! Can we look at this points ?
5852	IF ( iip .GE. 1 .AND. iip .LE. nbi .AND. &
5853	& jjp .GE. 1 .AND. jjp .LE. nbj .AND. not_found) THEN
5854	! Did we find a direct neighbor which is an outflow point ?
5855	IF ( trip_tmp(iip,jjp) .GT. 100 ) THEN
5856	! IF so direct the flow towards it and update the tables.
5857	not_found = .FALSE.
5858	trip(ip,jp) = id
5859	trip_tmp(ip,jp) = id
5860	outsz(ib) = 0
5861	! update the table of this basin
5862	DO ibb=1,nbout
5863	IF ( iip .EQ. outflow(ibb,1) .AND. jjp .EQ. outflow(ibb,2) ) THEN
5864	outsz(ibb) = outsz(ibb)+1
5865	trip_flow(ip,jp,1) = outflow(ibb,1)
5866	trip_flow(ip,jp,2) = outflow(ibb,2)
5867	ENDIF
5868	ENDDO
5869	ENDIF
5870	ENDIF
5871	ENDDO
5872	ENDIF
5873	ENDDO
5874	ENDIF
5875	!
5876	!
5877	! Cut the basin if we have more than 1 left.
5878	!
5879	!
5880	IF ( COUNT(outsz(1:nbout) .GT. 0) .GT. 1 ) THEN
5881	!
5882	nb_in = nb
5883	!
5884	DO ib = 1,nbout
5885	IF ( outsz(ib) .GT. 0) THEN
5886	nb = nb+1
5887	IF ( nb .GT. nbvmax) THEN
5888	WRITE(numout,*) 'nbvmax too small, increase it (routing_cutbasin)'
5889	ENDIF
5890	bname(nb) = basin_inbxid
5891	sz(nb) = 0
5892	DO ip=1,nbi
5893	DO jp=1,nbj
5894	IF ( (trip_flow(ip,jp,1) + trip_flow(ip,jp,1)) .GT. 0 .AND. &
5895	& trip_flow(ip,jp,1) .EQ. outflow(ib,1) .AND. &
5896	& trip_flow(ip,jp,2) .EQ. outflow(ib,2) ) THEN
5897	sz(nb) = sz(nb) + 1
5898	pts(nb, sz(nb), 1) = ip
5899	pts(nb, sz(nb), 2) = jp
5900	ENDIF
5901	ENDDO
5902	ENDDO
5903	ENDIF
5904	ENDDO
5905	! A short verification
5906	IF ( SUM(sz(nb_in+1:nb)) .NE. basin_sz) THEN
5907	WRITE(numout,*) 'Lost some points while spliting the basin'
5908	WRITE(numout,*) 'nbout :', nbout
5909	DO ib = nb_in+1,nb
5910	WRITE(numout,*) 'ib, SZ :', ib, sz(ib)
5911	ENDDO
5912	WRITE(fmt,"('(',I3,'I6)')") nbi
5913	WRITE(numout,*) '-------------> trip '
5914	DO jp=1,nbj
5915	WRITE(numout,fmt) trip_tmp(1:nbi,jp)
5916	ENDDO
5917	CALL ipslerr_p(3,'routing_cutbasin','Lost some points while spliting the basin','','')
5918	ENDIF
5919
5920	IF ( debug ) THEN
5921	DO ib = nb_in+1,nb
5922	DO ip=1,sz(ib)
5923	trip_tmp(pts(ib, ip, 1),pts(ib, ip, 2)) = ib*(-1)-900
5924	ENDDO
5925	ENDDO
5926	WRITE(fmt,"('(',I3,'I6)')") nbi
5927	WRITE(numout,*) 'AFTER-------------> New basins '
5928	WRITE(numout,*) nb, ' sz :', sz(1:nb)
5929	DO jp=1,nbj
5930	WRITE(numout,fmt) trip_tmp(1:nbi,jp)
5931	ENDDO
5932	IF ( MAXVAl(trip_tmp(1:nbi,1:nbj)) .GT. 0) THEN
5933	CALL ipslerr_p(3,'routing_cutbasin','Error in debug checking','','')
5934	ENDIF
5935	ENDIF
5936	ENDIF
5937	!
5938	END SUBROUTINE routing_cutbasin
5939	!
5940	!! ================================================================================================================================
5941	!! SUBROUTINE : routing_hierarchy
5942	!!
5943	!>\BRIEF This subroutine finds, for each point, the distance to the outflow
5944	!! point along the flowlines of the basin.
5945	!!
5946	!! DESCRIPTION (definitions, functional, design, flags) : None
5947	!!
5948	!! RECENT CHANGE(S): None
5949	!!
5950	!! MAIN OUTPUT VARIABLE(S):
5951	!!
5952	!! REFERENCES : None
5953	!!
5954	!! FLOWCHART : None
5955	!! \n
5956	!_ ================================================================================================================================
5957
5958	SUBROUTINE routing_hierarchy(iml, jml, trip, topoindex, hierarchy)
5959	!
5960	IMPLICIT NONE
5961	!
5962	!! LOCAL VARIABLES
5963	INTEGER(i_std) :: iml !! X resolution of the high resolution grid
5964	INTEGER(i_std) :: jml !! Y resolution of the high resolution grid
5965	REAL(r_std), DIMENSION(iml,jml) :: trip !! The trip field (unitless)
5966	REAL(r_std), DIMENSION(iml,jml) :: hierarchy !!
5967	REAL(r_std), DIMENSION(iml,jml) :: topoindex !! Topographic index of the residence time (m)
5968	!
5969	INTEGER(i_std), DIMENSION(8,2) :: inc !!
5970	INTEGER(i_std) :: ip, jp, ib, ntripi, ntripj, cnt, trp !!
5971	REAL(r_std) :: topohier !! The new value of topographically weighted hierarchy (m)
5972	REAL(r_std) :: topohier_old !! The old value of topographically weighted hierarchy (m)
5973	CHARACTER(LEN=7) :: fmt !!
5974
5975	!_ ================================================================================================================================
5976	!
5977	! The routing code (i=1, j=2)
5978	!
5979	inc(1,1) = 0
5980	inc(1,2) = -1
5981	inc(2,1) = 1
5982	inc(2,2) = -1
5983	inc(3,1) = 1
5984	inc(3,2) = 0
5985	inc(4,1) = 1
5986	inc(4,2) = 1
5987	inc(5,1) = 0
5988	inc(5,2) = 1
5989	inc(6,1) = -1
5990	inc(6,2) = 1
5991	inc(7,1) = -1
5992	inc(7,2) = 0
5993	inc(8,1) = -1
5994	inc(8,2) = -1
5995	!
5996	DO ip=1,iml
5997	DO jp=1,jml
5998	IF ( trip(ip,jp) .LT. undef_sechiba ) THEN
5999	ntripi = ip
6000	ntripj = jp
6001	trp = NINT(trip(ip,jp))
6002	cnt = 1
6003	! Warn for extreme numbers
6004	IF ( topoindex(ip,jp) .GT. 1.e10 ) THEN
6005	WRITE(numout,*) 'We have a very large topographic index for point ', ip, jp
6006	WRITE(numout,*) 'This can not be right :', topoindex(ip,jp)
6007	CALL ipslerr_p(3,'routing_hierarchy','Too large topographic index','','')
6008	ELSE
6009	topohier = topoindex(ip,jp)
6010	ENDIF
6011	!
6012	DO WHILE ( trp .GT. 0 .AND. trp .LT. 9 .AND. cnt .LT. iml*jml)
6013	cnt = cnt + 1
6014	ntripi = ntripi + inc(trp,1)
6015	IF ( ntripi .LT. 1) ntripi = iml
6016	IF ( ntripi .GT. iml) ntripi = 1
6017	ntripj = ntripj + inc(trp,2)
6018	topohier_old = topohier
6019	topohier = topohier + topoindex(ntripi, ntripj)
6020	IF ( topohier_old .GT. topohier) THEN
6021	WRITE(numout,*) 'Big Problem, how comes we climb up a hill ?'
6022	WRITE(numout,*) 'The old value of topographicaly weighted hierarchy was : ', topohier_old
6023	WRITE(numout,*) 'The new one is :', topohier
6024	CALL ipslerr_p(3,'routing_hierarchy','Big Problem, how comes we climb up a hill ?','','')
6025	ENDIF
6026	trp = NINT(trip(ntripi, ntripj))
6027	ENDDO
6028
6029	IF ( cnt .EQ. iml*jml) THEN
6030	WRITE(numout,*) 'We could not route point (routing_findrout) :', ip, jp
6031	WRITE(numout,*) '-------------> trip '
6032	WRITE(fmt,"('(',I3,'I6)')") iml
6033	DO ib=1,jml
6034	WRITE(numout,fmt) trip(1:iml,ib)
6035	ENDDO
6036	CALL ipslerr_p(3,'routing_hierarchy','We could not route point','','')
6037	ENDIF
6038
6039	hierarchy(ip,jp) = topohier
6040
6041	ENDIF
6042	ENDDO
6043	ENDDO
6044	!
6045	!
6046	END SUBROUTINE routing_hierarchy
6047	!
6048	!! ================================================================================================================================
6049	!! SUBROUTINE : routing_findrout
6050	!!
6051	!>\BRIEF This subroutine simply computes the route to each outflow point
6052	!! and returns the outflow point for each point in the basin.
6053	!!
6054	!! DESCRIPTION (definitions, functional, design, flags) : None
6055	!!
6056	!! RECENT CHANGE(S): None
6057	!!
6058	!! MAIN OUTPUT VARIABLE(S):
6059	!!
6060	!! REFERENCES : None
6061	!!
6062	!! FLOWCHART : None
6063	!! \n
6064	!_ ================================================================================================================================
6065
6066	SUBROUTINE routing_findrout(nbi, nbj, trip, basin_sz, basinid, nbout, outflow, trip_flow, outsz)
6067	!
6068	IMPLICIT NONE
6069	!
6070	!! INPUT VARIABLES
6071	INTEGER(i_std) :: nbi !! Number of point in x within the grid (unitless)
6072	INTEGER(i_std) :: nbj !! Number of point in y within the grid (unitless)
6073	INTEGER(i_std), DIMENSION(nbvmax,nbvmax) :: trip !! The trip field (unitless)
6074	INTEGER(i_std) :: basin_sz !!
6075	INTEGER(i_std) :: basinid !!
6076	!
6077	!! OUTPUT VARIABLES
6078	INTEGER(i_std), DIMENSION(nbvmax,2), INTENT(out) :: outflow !!
6079	INTEGER(i_std), DIMENSION(nbvmax,nbvmax,2), INTENT(out) :: trip_flow !!
6080	INTEGER(i_std), INTENT(out) :: nbout !!
6081	INTEGER(i_std), DIMENSION(nbvmax), INTENT(out) :: outsz !!
6082	!
6083	!! LOCAL VARIABLES
6084	INTEGER(i_std), DIMENSION(8,2) :: inc !!
6085	INTEGER(i_std) :: ip, jp, ib, cnt, trp, totsz !! Indices (unitless)
6086	CHARACTER(LEN=7) :: fmt !!
6087
6088	!_ ================================================================================================================================
6089	!
6090	!
6091	! The routing code (i=1, j=2)
6092	!
6093	inc(1,1) = 0
6094	inc(1,2) = -1
6095	inc(2,1) = 1
6096	inc(2,2) = -1
6097	inc(3,1) = 1
6098	inc(3,2) = 0
6099	inc(4,1) = 1
6100	inc(4,2) = 1
6101	inc(5,1) = 0
6102	inc(5,2) = 1
6103	inc(6,1) = -1
6104	inc(6,2) = 1
6105	inc(7,1) = -1
6106	inc(7,2) = 0
6107	inc(8,1) = -1
6108	inc(8,2) = -1
6109	!
6110	!
6111	! Get the outflows and determine for each point to which outflow point it belong
6112	!
6113	nbout = 0
6114	trip_flow(:,:,:) = 0
6115	DO ip=1,nbi
6116	DO jp=1,nbj
6117	IF ( trip(ip,jp) .GT. 9) THEN
6118	nbout = nbout + 1
6119	outflow(nbout,1) = ip
6120	outflow(nbout,2) = jp
6121	ENDIF
6122	IF ( trip(ip,jp) .GT. 0) THEN
6123	trip_flow(ip,jp,1) = ip
6124	trip_flow(ip,jp,2) = jp
6125	ENDIF
6126	ENDDO
6127	ENDDO
6128	!
6129	! Follow the flow of the water
6130	!
6131	DO ip=1,nbi
6132	DO jp=1,nbj
6133	IF ( (trip_flow(ip,jp,1) + trip_flow(ip,jp,2)) .GT. 0) THEN
6134	trp = trip(trip_flow(ip,jp,1), trip_flow(ip,jp,2))
6135	cnt = 0
6136	DO WHILE ( trp .GT. 0 .AND. trp .LT. 9 .AND. cnt .LT. nbi*nbj)
6137	cnt = cnt + 1
6138	trip_flow(ip,jp,1) = trip_flow(ip,jp,1) + inc(trp,1)
6139	trip_flow(ip,jp,2) = trip_flow(ip,jp,2) + inc(trp,2)
6140	trp = trip(trip_flow(ip,jp,1), trip_flow(ip,jp,2))
6141	ENDDO
6142	IF ( cnt .EQ. nbi*nbj) THEN
6143	WRITE(numout,*) 'We could not route point (routing_findrout) :', ip, jp
6144	WRITE(numout,*) '-------------> trip '
6145	WRITE(fmt,"('(',I3,'I6)')") nbi
6146	DO ib=1,nbj
6147	WRITE(numout,fmt) trip(1:nbi,ib)
6148	ENDDO
6149	CALL ipslerr_p(3,'routing_findrout','We could not route point','','')
6150	ENDIF
6151	ENDIF
6152	ENDDO
6153	ENDDO
6154	!
6155	! What is the size of the region behind each outflow point ?
6156	!
6157	totsz = 0
6158	DO ip=1,nbout
6159	outsz(ip) = COUNT(trip_flow(:,:,1) .EQ. outflow(ip,1) .AND. trip_flow(:,:,2) .EQ. outflow(ip,2))
6160	totsz = totsz + outsz(ip)
6161	ENDDO
6162	IF ( basin_sz .NE. totsz) THEN
6163	WRITE(numout,*) 'Water got lost while I tried to follow it '
6164	WRITE(numout,*) basin_sz, totsz
6165	WRITE(numout,*) 'Basin id :', basinid
6166	DO ip=1,nbout
6167	WRITE(numout,*) 'ip :', ip, ' outsz :', outsz(ip), ' outflow :', outflow(ip,1), outflow(ip,2)
6168	ENDDO
6169	WRITE(numout,*) '-------------> trip '
6170	WRITE(fmt,"('(',I3,'I6)')") nbi
6171	DO jp=1,nbj
6172	WRITE(numout,fmt) trip(1:nbi,jp)
6173	ENDDO
6174	CALL ipslerr_p(3,'routing_findrout','Water got lost while I tried to follow it','','')
6175	ENDIF
6176	!
6177	END SUBROUTINE routing_findrout
6178	!
6179	!! ================================================================================================================================
6180	!! SUBROUTINE : routing_globalize
6181	!!
6182	!>\BRIEF This subroutine puts the basins found for grid box in the global map.
6183	!! Connection can only be made later when all information is together.
6184	!!
6185	!! DESCRIPTION (definitions, functional, design, flags) : None
6186	!!
6187	!! RECENT CHANGE(S): None
6188	!!
6189	!! MAIN OUTPUT VARIABLE(S):
6190	!! One of the outputs is basin_flowdir. Its convention is 1-8 for the directions from North to North
6191	!! West going through South. The negative values will be -3 for return flow, -2 for coastal flow
6192	!!
6193	!! REFERENCES : None
6194	!!
6195	!! FLOWCHART : None
6196	!! \n
6197	!_ ================================================================================================================================
6198
6199	SUBROUTINE routing_globalize(nbpt, ib, neighbours, area_bx, trip_bx, hierarchy_bx, topoind_bx, min_topoind,&
6200	& nb_basin, basin_inbxid, basin_sz, basin_pts, basin_bxout, coast_pts, nwbas, basin_count,&
6201	& basin_area, basin_hierarchy, basin_topoind, basin_id, basin_flowdir, outflow_grid,&
6202	& nbcoastal, coastal_basin)
6203	!
6204	IMPLICIT NONE
6205	!
6206	!! INPUT VARIABLES
6207	INTEGER(i_std), INTENT (in) :: nbpt !! Domain size (unitless)
6208	INTEGER(i_std), INTENT (in) :: ib !! Current basin (unitless)
6209	INTEGER(i_std), INTENT(in) :: neighbours(nbpt,NbNeighb)!! Vector of neighbours for each grid point
6210	!! (1=North and then clockwise)
6211	!! LOCAL VARIABLES
6212	REAL(r_std), DIMENSION(nbvmax,nbvmax) :: area_bx !! Area of each small box in the grid box (m^2)
6213	INTEGER(i_std), DIMENSION(nbvmax,nbvmax) :: trip_bx !! The trip field for each of the smaller boxes (unitless)
6214	REAL(r_std), DIMENSION(nbvmax,nbvmax) :: hierarchy_bx !! Level in the basin of the point
6215	REAL(r_std), DIMENSION(nbvmax,nbvmax) :: topoind_bx !! Topographic index of the residence time for each of the smaller boxes (m)
6216	REAL(r_std) :: min_topoind !! The current minimum of topographic index (m)
6217	INTEGER(i_std) :: nb_basin !! Number of sub-basins (unitless)
6218	INTEGER(i_std), DIMENSION(nbvmax) :: basin_inbxid, basin_sz !! ID of basin, number of points in the basin
6219	INTEGER(i_std), DIMENSION(nbvmax,nbvmax,2) :: basin_pts !! Points in each basin
6220	INTEGER(i_std), DIMENSION(nbvmax) :: basin_bxout !! outflow direction
6221	INTEGER(i_std) :: coast_pts(nbvmax) !! The coastal flow points (unitless)
6222	! global maps
6223	INTEGER(i_std) :: nwbas !!
6224	INTEGER(i_std), DIMENSION(nbpt) :: basin_count !!
6225	INTEGER(i_std), DIMENSION(nbpt,nwbas) :: basin_id !!
6226	INTEGER(i_std), DIMENSION(nbpt,nwbas) :: basin_flowdir !! Water flow directions in the basin (unitless)
6227	REAL(r_std), DIMENSION(nbpt,nwbas) :: basin_area !!
6228	REAL(r_std), DIMENSION(nbpt,nwbas) :: basin_hierarchy !!
6229	REAL(r_std), DIMENSION(nbpt,nwbas) :: basin_topoind !! Topographic index of the residence time for a basin (m)
6230	INTEGER(i_std), DIMENSION(nbpt,nwbas) :: outflow_grid !! Type of outflow on the grid box (unitless)
6231	INTEGER(i_std), DIMENSION(nbpt) :: nbcoastal !!
6232	INTEGER(i_std), DIMENSION(nbpt,nwbas) :: coastal_basin !!
6233	!
6234	INTEGER(i_std) :: ij, iz !! Indices (unitless)
6235	CHARACTER(LEN=4) :: hierar_method = 'OUTP' !!
6236
6237	!_ ================================================================================================================================
6238	!
6239	!
6240	DO ij=1, nb_basin
6241	!
6242	! Count the basins and keep their ID
6243	!
6244	basin_count(ib) = basin_count(ib)+1
6245	if (basin_count(ib) > nwbas) then
6246	WRITE(numout,*) 'ib=',ib
6247	call ipslerr_p(3,'routing_globalize', &
6248	& 'Problem with basin_count : ', &
6249	& 'It is greater than number of allocated basin nwbas.', &
6250	& '(stop to count basins)')
6251	endif
6252	basin_id(ib,basin_count(ib)) = basin_inbxid(ij)
6253	!
6254	! Transfer the list of basins which flow into the ocean as coastal flow.
6255	!
6256	IF ( basin_id(ib,basin_count(ib)) .LT. 0) THEN
6257	nbcoastal(ib) = basin_sz(ij)
6258	coastal_basin(ib,1:nbcoastal(ib)) = coast_pts(1:nbcoastal(ib))
6259	ENDIF
6260	!
6261	!
6262	! Compute the area of the basin
6263	!
6264	basin_area(ib,ij) = zero
6265	basin_hierarchy(ib,ij) = zero
6266	!
6267	SELECT CASE (hierar_method)
6268	!
6269	CASE("MINI")
6270	basin_hierarchy(ib,ij) = undef_sechiba
6271	!
6272	END SELECT
6273	basin_topoind(ib,ij) = zero
6274	!
6275	DO iz=1,basin_sz(ij)
6276	!
6277	basin_area(ib,ij) = basin_area(ib,ij) + area_bx(basin_pts(ij,iz,1),basin_pts(ij,iz,2))
6278	basin_topoind(ib,ij) = basin_topoind(ib,ij) + topoind_bx(basin_pts(ij,iz,1),basin_pts(ij,iz,2))
6279	!
6280	! There are a number of ways to determine the hierarchy of the entire basin.
6281	! We allow for three here :
6282	! - Take the mean value
6283	! - Take the minimum value within the basin
6284	! - Take the value at the outflow point
6285	! Probably taking the value of the outflow point is the best solution.
6286	!
6287	SELECT CASE (hierar_method)
6288	!
6289	CASE("MEAN")
6290	! Mean hierarchy of the basin
6291	basin_hierarchy(ib,ij) = basin_hierarchy(ib,ij) + &
6292	& hierarchy_bx(basin_pts(ij,iz,1),basin_pts(ij,iz,2))
6293	CASE("MINI")
6294	! The smallest value of the basin
6295	IF ( hierarchy_bx(basin_pts(ij,iz,1),basin_pts(ij,iz,2)) .LT. basin_hierarchy(ib,ij)) THEN
6296	basin_hierarchy(ib,ij) = hierarchy_bx(basin_pts(ij,iz,1),basin_pts(ij,iz,2))
6297	ENDIF
6298	CASE("OUTP")
6299	! Value at the outflow point
6300	IF ( trip_bx(basin_pts(ij,iz,1),basin_pts(ij,iz,2)) .GT. 100 ) THEN
6301	basin_hierarchy(ib,ij) = hierarchy_bx(basin_pts(ij,iz,1),basin_pts(ij,iz,2))
6302	ENDIF
6303	CASE DEFAULT
6304	WRITE(numout,*) 'Unknown method for computing the hierarchy of the basin'
6305	CALL ipslerr_p(3,'routing_globalize','Unknown method for computing the hierarchy of the basin','','')
6306	END SELECT
6307	!
6308	ENDDO
6309	!
6310	basin_topoind(ib,ij) = basin_topoind(ib,ij)/REAL(basin_sz(ij),r_std)
6311	!
6312	SELECT CASE (hierar_method)
6313	!
6314	CASE("MEAN")
6315	basin_hierarchy(ib,ij) = basin_hierarchy(ib,ij)/REAL(basin_sz(ij),r_std)
6316	!
6317	END SELECT
6318	!
6319	! To make sure that it has the lowest number if this is an outflow point we reset basin_hierarchy
6320	!
6321	IF (basin_bxout(ij) .LT. 0) THEN
6322	basin_hierarchy(ib,ij) = min_topoind
6323	basin_topoind(ib,ij) = min_topoind
6324	ENDIF
6325	!
6326	!
6327	! Keep the outflow boxes and basin
6328	!
6329	basin_flowdir(ib,ij) = basin_bxout(ij)
6330	IF (basin_bxout(ij) .GT. 0) THEN
6331	outflow_grid(ib,ij) = neighbours(ib,basin_bxout(ij))
6332	ELSE
6333	outflow_grid(ib,ij) = basin_bxout(ij)
6334	ENDIF
6335	!
6336	!
6337	ENDDO
6338	!
6339
6340	!
6341	END SUBROUTINE routing_globalize
6342	!
6343	!! ================================================================================================================================
6344	!! SUBROUTINE : routing_linkup
6345	!!
6346	!>\BRIEF This subroutine makes the connections between the basins and ensure global coherence.
6347	!!
6348	!! DESCRIPTION (definitions, functional, design, flags) :
6349	!! The convention for outflow_grid is :
6350	!! outflow_grid = -1 : River flow
6351	!! outflow_grid = -2 : Coastal flow
6352	!! outflow_grid = -3 : Return flow\n
6353	!!
6354	!! RECENT CHANGE(S): None
6355	!!
6356	!! MAIN OUTPUT VARIABLE(S):
6357	!!
6358	!! REFERENCES : None
6359	!!
6360	!! FLOWCHART : None
6361	!! \n
6362	!_ ================================================================================================================================
6363
6364	SUBROUTINE routing_linkup(nbpt, contfrac, neighbours, nwbas, basin_count, basin_area, basin_id, basin_flowdir, &
6365	& basin_hierarchy, outflow_grid, outflow_basin, inflow_number, inflow_grid, inflow_basin, nbcoastal,&
6366	& coastal_basin, invented_basins)
6367	!
6368	IMPLICIT NONE
6369	!
6370	!! INPUT VARIABLES
6371	INTEGER(i_std), INTENT (in) :: nbpt !! Domain size (unitless)
6372	REAL(r_std), DIMENSION(nbpt) :: contfrac
6373	INTEGER(i_std), DIMENSION(nbpt,NbNeighb), INTENT (in) :: neighbours !!
6374	REAL(r_std), INTENT(in) :: invented_basins !!
6375	!
6376	INTEGER(i_std) :: nwbas !!
6377	INTEGER(i_std), DIMENSION(nbpt) :: basin_count !!
6378	INTEGER(i_std), DIMENSION(nbpt,nwbas) :: basin_id !!
6379	INTEGER(i_std), DIMENSION(nbpt,nwbas) :: basin_flowdir !! Water flow directions in the basin (unitless)
6380	REAL(r_std), DIMENSION(nbpt,nwbas) :: basin_area !!
6381	REAL(r_std), DIMENSION(nbpt,nwbas) :: basin_hierarchy !!
6382	INTEGER(i_std), DIMENSION(nbpt,nwbas) :: outflow_grid !! Type of outflow on the grid box (unitless)
6383	INTEGER(i_std), DIMENSION(nbpt,nwbas) :: outflow_basin !!
6384	INTEGER(i_std), DIMENSION(nbpt,nwbas) :: inflow_number !!
6385	INTEGER(i_std), DIMENSION(nbpt,nwbas,nbvmax) :: inflow_basin !!
6386	INTEGER(i_std), DIMENSION(nbpt,nwbas,nbvmax) :: inflow_grid !!
6387	INTEGER(i_std), DIMENSION(nbpt) :: nbcoastal !!
6388	INTEGER(i_std), DIMENSION(nbpt,nwbas) :: coastal_basin !!
6389	!
6390	!! LOCAL VARIABLES
6391	INTEGER(i_std) :: sp, sb, sbl, inp, bid, outdm1, outdp1 !! Indices (unitless)
6392	INTEGER(i_std) :: dp1, dm1, dm1i, dp1i, bp1, bm1 !! Indices (unitless)
6393	INTEGER(i_std) :: dop, bop !!
6394	INTEGER(i_std) :: fbas(nwbas), nbfbas !!
6395	REAL(r_std) :: fbas_hierarchy(nwbas) !!
6396	REAL(r_std) :: angle
6397	INTEGER(i_std) :: ff(1) !!
6398	!
6399	! ERRORS
6400	LOGICAL :: error1, error2, error3, error4, error5 !! (true/false)
6401	!
6402	!! PARAMETERS
6403	LOGICAL, PARAMETER :: check = .TRUE. !! (true/false)
6404
6405	!_ ================================================================================================================================
6406	error1=.FALSE.
6407	error2=.FALSE.
6408	error3=.FALSE.
6409	error4=.FALSE.
6410	error5=.FALSE.
6411
6412	outflow_basin(:,:) = undef_int
6413	inflow_number(:,:) = 0
6414	!
6415	DO sp=1,nbpt
6416	DO sb=1,basin_count(sp)
6417	!
6418	inp = outflow_grid(sp,sb)
6419	bid = basin_id(sp,sb)
6420	!
6421	! We only work on this point if it does not flow into the ocean
6422	! At this point any of the outflows is designated by a negative values in
6423	! outflow_grid
6424	!
6425	IF ( inp .GT. 0 ) THEN
6426	!
6427	! Now find the basin in the onflow point (inp)
6428	!
6429	nbfbas = 0
6430	!
6431	!
6432	DO sbl=1,basin_count(inp)
6433	!
6434	! Either it is a standard basin or one aggregated from ocean flow points.
6435	! If we flow into a another grid box we have to make sure that its hierarchy in the
6436	! basin is lower.
6437	!
6438	!
6439	IF ( basin_id(inp,sbl) .GT. 0 ) THEN
6440	IF ( basin_id(inp,sbl) .EQ. bid .OR. basin_id(inp,sbl) .GT. invented_basins) THEN
6441	nbfbas =nbfbas + 1
6442	fbas(nbfbas) = sbl
6443	fbas_hierarchy(nbfbas) = basin_hierarchy(inp,sbl)
6444	ENDIF
6445	ELSE
6446	IF ( COUNT(coastal_basin(inp,1:nbcoastal(inp)) .EQ. bid) .GT. 0 ) THEN
6447	nbfbas =nbfbas + 1
6448	fbas(nbfbas) = sbl
6449	fbas_hierarchy(nbfbas) = basin_hierarchy(inp,sbl)
6450	ENDIF
6451	ENDIF
6452	!
6453	ENDDO
6454	!
6455	! If we have more than one basin we will take the one which is lowest
6456	! in the hierarchy.
6457	!
6458	IF (nbfbas .GE. 1) THEN
6459	ff = MINLOC(fbas_hierarchy(1:nbfbas))
6460	sbl = fbas(ff(1))
6461	!
6462	bop = undef_int
6463	IF ( basin_hierarchy(inp,sbl) .LE. basin_hierarchy(sp,sb) ) THEN
6464	IF ( basin_hierarchy(inp,sbl) .LT. basin_hierarchy(sp,sb) ) THEN
6465	bop = sbl
6466	ELSE
6467	! The same hierarchy is allowed if both grids flow in about
6468	! the same direction :
6469	IF ( ( MOD(basin_flowdir(inp,sbl)+1-1, 8)+1 .EQ. basin_flowdir(sp,sb)).OR. &
6470	& ( basin_flowdir(inp,sbl) .EQ. basin_flowdir(sp,sb)).OR. &
6471	& ( MOD(basin_flowdir(inp,sbl)+7-1, 8)+1 .EQ. basin_flowdir(sp,sb)) ) THEN
6472	bop = sbl
6473	ENDIF
6474	ENDIF
6475	ENDIF
6476	!
6477	! If the basin is suitable (bop < undef_int) then take it
6478	!
6479	IF ( bop .LT. undef_int ) THEN
6480	outflow_basin(sp,sb) = bop
6481	inflow_number(inp,bop) = inflow_number(inp,bop) + 1
6482	IF ( inflow_number(inp,bop) .LE. nbvmax ) THEN
6483	inflow_grid(inp, bop, inflow_number(inp,bop)) = sp
6484	inflow_basin(inp, bop, inflow_number(inp,bop)) = sb
6485	ELSE
6486	error1=.TRUE.
6487	EXIT
6488	ENDIF
6489	ENDIF
6490	ENDIF
6491	!
6492	!
6493	ENDIF
6494	!
6495	!
6496	!
6497	! Did we find it ?
6498	!
6499	! In case the outflow point was ocean or we did not find the correct basin we start to look
6500	! around. We find two options for the outflow direction (dp1 & dm1) and the corresponding
6501	! basin index (bp1 & bm1).
6502	!
6503	!
6504	IF ( outflow_basin(sp,sb) .EQ. undef_int &
6505	& .AND. basin_flowdir(sp,sb) .GT. 0) THEN
6506	!
6507	dp1i = MOD(basin_flowdir(sp,sb)+1-1, NbNeighb)+1
6508	dp1 = neighbours(sp,dp1i)
6509	dm1i = MOD(basin_flowdir(sp,sb)+7-1, NbNeighb)+1
6510	IF ( dm1i .LT. 1 ) dm1i = 8
6511	dm1 = neighbours(sp,dm1i)
6512	!
6513	!
6514	bp1 = -1
6515	IF ( dp1 .GT. 0 ) THEN
6516	DO sbl=1,basin_count(dp1)
6517	IF (basin_id(dp1,sbl) .EQ. bid .AND.&
6518	& basin_hierarchy(sp,sb) .GE. basin_hierarchy(dp1,sbl) .AND. &
6519	& bp1 .LT. 0) THEN
6520	IF ( basin_hierarchy(sp,sb) .GT. basin_hierarchy(dp1,sbl) ) THEN
6521	bp1 = sbl
6522	ELSE
6523	! The same hierarchy is allowed if both grids flow in about
6524	! the same direction :
6525	angle=MODULO(basin_flowdir(dp1,sbl)-basin_flowdir(sp,sb)+8,8)
6526	IF ( angle >= 4 ) angle = angle-8
6527	!
6528	IF ( ABS(angle) <= 1 ) THEN
6529	bp1 = sbl
6530	ENDIF
6531	ENDIF
6532	ENDIF
6533	ENDDO
6534	ENDIF
6535	!
6536	bm1 = -1
6537	IF ( dm1 .GT. 0 ) THEN
6538	DO sbl=1,basin_count(dm1)
6539	IF (basin_id(dm1,sbl) .EQ. bid .AND.&
6540	& basin_hierarchy(sp,sb) .GE. basin_hierarchy(dm1,sbl) .AND. &
6541	& bm1 .LT. 0) THEN
6542	IF ( basin_hierarchy(sp,sb) .GT. basin_hierarchy(dm1,sbl) ) THEN
6543	bm1 = sbl
6544	ELSE
6545	! The same hierarchy is allowed if both grids flow in about
6546	! the same direction :
6547	angle=MODULO(basin_flowdir(dm1,sbl)-basin_flowdir(sp,sb)+8,8)
6548	IF ( angle >= 4 ) angle = angle-8
6549	!
6550	IF ( ABS(angle) <= 1 ) THEN
6551	bm1 = sbl
6552	ENDIF
6553	ENDIF
6554	ENDIF
6555	ENDDO
6556	ENDIF
6557	!
6558	!
6559	! First deal with the case on land.
6560	!
6561	! For that we need to check if the water will be able to flow out of the grid dp1 or dm1
6562	! and not return to our current grid. If it is the current grid
6563	! then we can not do anything with that neighbour. Thus we set the
6564	! value of outdm1 and outdp1 back to -1
6565	!
6566	outdp1 = undef_int
6567	IF ( dp1 .GT. 0 .AND. bp1 .GT. 0 ) THEN
6568	! if the outflow is into the ocean then we put something less than undef_int in outdp1!
6569	IF (basin_flowdir(dp1,bp1) .GT. 0) THEN
6570	outdp1 = neighbours(dp1,basin_flowdir(dp1,bp1))
6571	IF ( outdp1 .EQ. sp ) outdp1 = undef_int
6572	ELSE
6573	outdp1 = nbpt + 1
6574	ENDIF
6575	ENDIF
6576	outdm1 = undef_int
6577	IF ( dm1 .GT. 0 .AND. bm1 .GT. 0 ) THEN
6578	IF (basin_flowdir(dm1,bm1) .GT. 0) THEN
6579	outdm1 = neighbours(dm1,basin_flowdir(dm1,bm1))
6580	IF ( outdm1 .EQ. sp ) outdm1 = undef_int
6581	ELSE
6582	outdm1 = nbpt + 1
6583	ENDIF
6584	ENDIF
6585	!
6586	! Now that we know our options we need go through them.
6587	!
6588	dop = undef_int
6589	bop = undef_int
6590	IF ( outdp1 .LT. undef_int .AND. outdm1 .LT. undef_int) THEN
6591	!
6592	! In this case we let the current basin flow into the smaller one
6593	!
6594	IF ( basin_area(dp1,bp1) .LT. basin_area(dm1,bm1) ) THEN
6595	dop = dp1
6596	bop = bp1
6597	ELSE
6598	dop = dm1
6599	bop = bm1
6600	ENDIF
6601	!
6602	!
6603	ELSE IF ( outdp1 .LT. undef_int ) THEN
6604	! If only the first one is possible
6605	dop = dp1
6606	bop = bp1
6607	ELSE IF ( outdm1 .LT. undef_int ) THEN
6608	! If only the second one is possible
6609	dop = dm1
6610	bop = bm1
6611	ELSE
6612	!
6613	! Now we are at the point where none of the neighboring points is suitable
6614	! or we have a coastal point.
6615	!
6616	! If there is an option to put the water into the ocean go for it.
6617	!
6618	IF ( outflow_grid(sp,sb) .LT. 0 .OR. dm1 .LT. 0 .OR. dp1 .LT. 0 ) THEN
6619	dop = -1
6620	ELSE
6621	!
6622	! If we are on a land point with only land neighbors but no one suitable to let the
6623	! water flow into we have to look for a solution in the current grid box.
6624	!
6625	!
6626	IF ( bp1 .LT. 0 .AND. bm1 .LT. 0 ) THEN
6627	!
6628	! Do we have more than one basin with the same ID ?
6629	!
6630	IF ( COUNT(basin_id(sp,1:basin_count(sp)) .EQ. bid) .GE. 2) THEN
6631	!
6632	! Now we can try the option of flowing into the basin of the same grid box.
6633	!
6634	DO sbl=1,basin_count(sp)
6635	IF (sbl .NE. sb .AND. basin_id(sp,sbl) .EQ. bid) THEN
6636	! In case this basin has a lower hierarchy or flows into a totaly
6637	! different direction we go for it.
6638	IF ( (basin_hierarchy(sp,sb) .GE. basin_hierarchy(sp,sbl)) .OR. &
6639	& (basin_flowdir(sp,sbl) .LT. dm1i .AND.&
6640	& basin_flowdir(sp,sbl) .GT. dp1i) ) THEN
6641	dop = sp
6642	bop = sbl
6643	IF (check) THEN
6644	IF (basin_hierarchy(sp,sb) .LT. basin_hierarchy(sp,sbl)) THEN
6645	WRITE(numout,*) '>>>>>>> POINT CORRECTED against hierarchy :',&
6646	& sp, sb, 'into', sbl
6647	ENDIF
6648	ENDIF
6649	ENDIF
6650	!
6651	ENDIF
6652	ENDDO
6653	!
6654	ENDIF
6655	ENDIF
6656	ENDIF
6657	!
6658	IF ( dop .EQ. undef_int .AND. bop .EQ. undef_int ) THEN
6659	IF (check) THEN
6660	WRITE(numout,*) 'Why are we here with point ', sp, sb
6661	WRITE(numout,*) 'Coordinates : (lon,lat) = ', lalo_g(sp,2), lalo_g(sp,1)
6662	WRITE(numout,*) 'neighbours :', neighbours_g(sp,:)
6663	WRITE(numout,*) 'Contfrac : = ', contfrac(sp)
6664	WRITE(numout,*) 'Local Basin ID :', basin_id(sp,1:basin_count(sp))
6665	WRITE(numout,*) 'Local hierarchies :', basin_hierarchy(sp,1:basin_count(sp))
6666	WRITE(numout,*) 'Local basin_flowdir :', basin_flowdir(sp,1:basin_count(sp))
6667	WRITE(numout,*) 'Local outflowgrid :', outflow_grid(sp,1:basin_count(sp))
6668	WRITE(numout,*) 'outflow_grid :', inp
6669	WRITE(numout,*) 'Coodinates outflow : (lon,lat) = ', lalo_g(inp,2), lalo_g(inp,1)
6670	WRITE(numout,*) 'Contfrac : = ', contfrac(inp)
6671	WRITE(numout,*) 'Outflow Basin ID :', basin_id(inp,1:basin_count(inp))
6672	WRITE(numout,*) 'Outflow hierarchies :', basin_hierarchy(inp,1:basin_count(inp))
6673	WRITE(numout,*) 'Outflow basin_flowdir :', basin_flowdir(inp,1:basin_count(inp))
6674	WRITE(numout,*) 'Explored options +1 :', dp1, bp1, outdp1
6675	WRITE(numout,*) 'Explored +1 Basin ID :', basin_id(dp1,1:basin_count(dp1))
6676	WRITE(numout,*) 'Explored +1 hierarchies :', basin_hierarchy(dp1,1:basin_count(dp1))
6677	WRITE(numout,*) 'Explored +1 basin_flowdir :', basin_flowdir(dp1,1:basin_count(dp1))
6678	WRITE(numout,*) 'Explored options -1 :', dm1, bm1, outdm1
6679	WRITE(numout,*) 'Explored -1 Basin ID :', basin_id(dm1,1:basin_count(dm1))
6680	WRITE(numout,*) 'Explored -1 hierarchies :', basin_hierarchy(dm1,1:basin_count(dm1))
6681	WRITE(numout,*) 'Explored -1 basin_flowdir :', basin_flowdir(dm1,1:basin_count(dm1))
6682	WRITE(numout,) '***************************'
6683	CALL FLUSH(numout)
6684	ENDIF
6685	IF ( contfrac(sp) > 0.01 ) THEN
6686	error2=.TRUE.
6687	EXIT
6688	ENDIF
6689	ENDIF
6690	!
6691	ENDIF
6692	!
6693	! Now that we know where we want the water to flow to we write the
6694	! the information in the right fields.
6695	!
6696	IF ( dop .GT. 0 .AND. dop .NE. undef_int ) THEN
6697	outflow_grid(sp,sb) = dop
6698	outflow_basin(sp,sb) = bop
6699	inflow_number(dop,bop) = inflow_number(dop,bop) + 1
6700	IF ( inflow_number(dop,bop) .LE. nbvmax ) THEN
6701	inflow_grid(dop, bop, inflow_number(dop,bop)) = sp
6702	inflow_basin(dop, bop, inflow_number(dop,bop)) = sb
6703	ELSE
6704	error3=.TRUE.
6705	EXIT
6706	ENDIF
6707	!
6708	ELSE
6709	outflow_grid(sp,sb) = -2
6710	outflow_basin(sp,sb) = undef_int
6711	ENDIF
6712	!
6713	ENDIF
6714	!
6715	!
6716	! If we still have not found anything then we have to check that there is not a basin
6717	! within the same grid box which has a lower hierarchy.
6718	!
6719	!
6720	IF ( outflow_grid(sp,sb) .GT. 0 .AND. outflow_basin(sp,sb) .EQ. undef_int &
6721	& .AND. basin_flowdir(sp,sb) .GT. 0) THEN
6722	!
6723
6724	IF (check) &
6725	WRITE(numout,*) 'There is no reason to here, this part of the code should be dead :', sp,sb
6726	!
6727	DO sbl=1,basin_count(sp)
6728	!
6729	! Three conditions are needed to let the water flow into another basin of the
6730	! same grid :
6731	! - another basin than the current one
6732	! - same ID
6733	! - of lower hierarchy.
6734	!
6735	IF ( (sbl .NE. sb) .AND. (basin_id(sp,sbl) .EQ. bid)&
6736	& .AND. (basin_hierarchy(sp,sb) .GT. basin_hierarchy(sp,sbl)) ) THEN
6737	outflow_basin(sp,sb) = sbl
6738	inflow_number(sp,sbl) = inflow_number(sp,sbl) + 1
6739	IF ( inflow_number(sp,sbl) .LE. nbvmax ) THEN
6740	IF ( sp .EQ. 42 .AND. sbl .EQ. 1) THEN
6741	IF (check) &
6742	WRITE(numout,*) 'ADD INFLOW (3):', sp, sb
6743	ENDIF
6744	inflow_grid(sp, sbl, inflow_number(sp,sbl)) = sp
6745	inflow_basin(sp, sbl, inflow_number(sp,sbl)) = sb
6746	ELSE
6747	error4=.TRUE.
6748	EXIT
6749	ENDIF
6750	ENDIF
6751	ENDDO
6752	ENDIF
6753	!
6754	! Ok that is it, we give up :-)
6755	!
6756	IF ( outflow_grid(sp,sb) .GT. 0 .AND. outflow_basin(sp,sb) .EQ. undef_int &
6757	& .AND. basin_flowdir(sp,sb) .GT. 0) THEN
6758	!
6759	error5=.TRUE.
6760	EXIT
6761	ENDIF
6762	ENDDO
6763	!
6764	ENDDO
6765	IF (error1) THEN
6766	WRITE(numout,*) " routing_linkup : bop .LT. undef_int",bop
6767	CALL ipslerr_p(3,'routing_linkup', &
6768	"bop .LT. undef_int",'Increase nbvmax','stop routing_linkup')
6769	ENDIF
6770	IF (error2) THEN
6771	CALL ipslerr_p(3,'routing_linkup', &
6772	& 'In the routine which make connections between the basins and ensure global coherence,', &
6773	& 'there is a problem with outflow linkup without any valid direction. Try with check=.TRUE.', &
6774	& '(Perhaps there is a problem with the grid.)')
6775	ENDIF
6776	IF (error3) THEN
6777	WRITE(numout,*) " routing_linkup : dop .GT. 0 .AND. dop .NE. undef_int",dop
6778	CALL ipslerr_p(3,'routing_linkup', &
6779	"dop .GT. 0 .AND. dop .NE. undef_int",'Increase nbvmax. Try with check=.TRUE.','stop routing_linkup')
6780	ENDIF
6781	IF (error4) THEN
6782	WRITE(numout,*) " routing_linkup : (sbl .NE. sb) .AND. (basin_id(sp,sbl) .EQ. bid) ", &
6783	& " .AND. (basin_hierarchy(sp,sb) .GT. basin_hierarchy(sp,sbl))",sbl,sb,basin_id(sp,sbl),bid, &
6784	& basin_hierarchy(sp,sb),basin_hierarchy(sp,sbl)
6785	CALL ipslerr_p(3,'routing_linkup', &
6786	"(sbl .NE. sb) .AND. (basin_id(sp,sbl) .EQ. bid) .AND. (basin_hierarchy(sp,sb) .GT. basin_hierarchy(sp,sbl))" &
6787	,'Increase nbvmax. Try with check=.TRUE.','stop routing_linkup')
6788	ENDIF
6789	IF (error5) THEN
6790	WRITE(numout,*) 'We could not find the basin into which we need to flow'
6791	WRITE(numout,*) 'Grid point ', sp, ' and basin ', sb
6792	WRITE(numout,*) 'Explored neighbours :', dm1, dp1
6793	WRITE(numout,*) 'Outflow direction :', basin_flowdir(sp,sb)
6794	WRITE(numout,*) 'Outlfow grid :', outflow_grid(sp,sb)
6795	WRITE(numout,*) 'Outlfow basin :',outflow_basin(sp,sb)
6796	WRITE(numout,*) 'basin ID:',basin_id(sp,sb)
6797	WRITE(numout,*) 'Hierarchy :', basin_hierarchy(sp,sb)
6798	CALL ipslerr_p(3,'routing_linkup', &
6799	"We could not find the basin into which we need to flow",'Try with check=.TRUE.','stop routing_linkup')
6800	ENDIF
6801	!
6802	! Check for each outflow basin that it exists
6803	!
6804	DO sp=1,nbpt
6805	DO sb=1,basin_count(sp)
6806	!
6807	inp = outflow_grid(sp,sb)
6808	sbl = outflow_basin(sp,sb)
6809	IF ( inp .GE. 0 ) THEN
6810	IF ( basin_count(inp) .LT. sbl ) THEN
6811	WRITE(numout,*) 'point :', sp, ' basin :', sb
6812	WRITE(numout,*) 'Flows into point :', inp, ' basin :', sbl
6813	WRITE(numout,*) 'But it flows into now here as basin count = ', basin_count(inp)
6814	CALL ipslerr_p(3,'routing_linkup','Problem with outflow','','')
6815	ENDIF
6816	ENDIF
6817	ENDDO
6818	ENDDO
6819	!
6820	END SUBROUTINE routing_linkup
6821	!
6822	!! ================================================================================================================================
6823	!! SUBROUTINE : routing_fetch
6824	!!
6825	!>\BRIEF This subroutine computes the fetch of each basin. This means that for each basin we
6826	!! will know how much area is upstream. It will help decide how to procede with the
6827	!! the truncation later and allow to set correctly in outflow_grid the distinction
6828	!! between coastal and river flow.
6829	!!
6830	!! DESCRIPTION (definitions, functional, design, flags) : None
6831	!!
6832	!! RECENT CHANGE(S): None
6833	!!
6834	!! MAIN OUTPUT VARIABLE(S):
6835	!!
6836	!! REFERENCES : None
6837	!!
6838	!! FLOWCHART : None
6839	!! \n
6840	!_ ================================================================================================================================
6841
6842	SUBROUTINE routing_fetch(nbpt, resolution, contfrac, nwbas, basin_count, basin_area, basin_id,&
6843	& outflow_grid, outflow_basin, fetch_basin)
6844	!
6845	IMPLICIT NONE
6846	!
6847	!! INPUT VARIABLES
6848	INTEGER(i_std), INTENT(in) :: nbpt !! Domain size (unitless)
6849	!
6850	REAL(r_std), DIMENSION(nbpt,2), INTENT(in) :: resolution !! The size of each grid box in X and Y (m)
6851	REAL(r_std), DIMENSION(nbpt), INTENT(in) :: contfrac !! Fraction of land in each grid box (unitless;0-1)
6852	!
6853	INTEGER(i_std) :: nwbas !!
6854	INTEGER(i_std), DIMENSION(nbpt), INTENT(in) :: basin_count !!
6855	REAL(r_std), DIMENSION(nbpt,nwbas), INTENT(inout) :: basin_area !!
6856	INTEGER(i_std), DIMENSION(nbpt,nwbas), INTENT(in) :: basin_id !!
6857	INTEGER(i_std), DIMENSION(nbpt,nwbas), INTENT(inout) :: outflow_grid !! Type of outflow on the grid box (unitless)
6858	INTEGER(i_std), DIMENSION(nbpt,nwbas), INTENT(in) :: outflow_basin !!
6859	!
6860	!! OUTPUT VARIABLES
6861	REAL(r_std), DIMENSION(nbpt,nwbas), INTENT(out) :: fetch_basin !!
6862	!
6863	!! LOCAL VARIABLES
6864	INTEGER(i_std) :: ib, ij, ff(1), it, itt, igrif, ibasf, nboutflow !! Indices (unitless)
6865	REAL(r_std) :: contarea !!
6866	REAL(r_std) :: totbasins !!
6867	REAL(r_std), DIMENSION(nbpt*nbvmax) :: tmp_area !!
6868	INTEGER(i_std), DIMENSION(nbpt*nbvmax,2) :: tmpindex !!
6869
6870	!_ ================================================================================================================================
6871	!
6872	!
6873	! Normalize the area of all basins
6874	!
6875	DO ib=1,nbpt
6876	!
6877	totbasins = SUM(basin_area(ib,1:basin_count(ib)))
6878	! Check if we are at the poles (resolution(ib,1) = 0
6879	IF ( resolution(ib,1) == 0 ) THEN
6880	! Hack to approximate the pole cell area by a circle
6881	contarea = piresolution(ib,2)resolution(ib,2)*contfrac(ib)
6882	ELSE
6883	contarea = resolution(ib,1)resolution(ib,2)contfrac(ib)
6884	ENDIF
6885	!
6886	DO ij=1,basin_count(ib)
6887	basin_area(ib,ij) = basin_area(ib,ij)/totbasins*contarea
6888	ENDDO
6889	!
6890	ENDDO
6891	WRITE(numout,*) 'Normalization done'
6892	!
6893	! Compute the area upstream of each basin
6894	!
6895	fetch_basin(:,:) = zero
6896	!
6897	!
6898	DO ib=1,nbpt
6899	!
6900	DO ij=1,basin_count(ib)
6901	!
6902	fetch_basin(ib, ij) = fetch_basin(ib, ij) + basin_area(ib,ij)
6903	!
6904	igrif = outflow_grid(ib,ij)
6905	ibasf = outflow_basin(ib,ij)
6906	!
6907	itt = 0
6908	DO WHILE (igrif .GT. 0)
6909	fetch_basin(igrif,ibasf) = fetch_basin(igrif,ibasf) + basin_area(ib, ij)
6910	it = outflow_grid(igrif, ibasf)
6911	ibasf = outflow_basin(igrif, ibasf)
6912	igrif = it
6913	itt = itt + 1
6914	IF ( itt .GT. 500) THEN
6915	WRITE(numout,&
6916	"('Grid ',I5, ' and basin ',I5, 'did not converge after iteration ',I5)") ib, ij, itt
6917	WRITE(numout,*) 'Basin ID :', basin_id(igrif,ibasf)
6918	WRITE(numout,&
6919	"('We are stuck with the flow into grid ',I5,' and basin ',I5)") igrif, ibasf
6920	WRITE(numout,*) "Coordinates : ", lalo_g(igrif,2), lalo_g(igrif,1)
6921	IF ( itt .GT. 510) THEN
6922	CALL ipslerr_p(3,'routing_fetch','Problem...','','')
6923	ENDIF
6924	ENDIF
6925	ENDDO
6926	!
6927	ENDDO
6928	!
6929	ENDDO
6930	!
6931	WRITE(numout,*) 'The smallest FETCH :', MINVAL(fetch_basin)
6932	WRITE(numout,*) 'The largest FETCH :', MAXVAL(fetch_basin)
6933	!
6934	! Now we set for the 'num_largest' largest basins the outflow condition as stream flow
6935	! (i.e. outflow_grid = -1) and all other outflow basins are set to coastal flow
6936	! (i.e. outflow_grid = -2). The return flow is not touched.
6937	!
6938	nboutflow = 0
6939	!
6940	DO ib=1,nbpt
6941	!
6942	DO ij=1,basin_count(ib)
6943	!
6944	! We do not need any more the river flow flag as we are going to reset it.
6945	!
6946	IF ( outflow_grid(ib,ij) .EQ. -1) THEN
6947	outflow_grid(ib,ij) = -2
6948	ENDIF
6949	!
6950	IF ( outflow_grid(ib,ij) .EQ. -2) THEN
6951	!
6952	nboutflow = nboutflow + 1
6953	tmp_area(nboutflow) = fetch_basin(ib,ij)
6954	tmpindex(nboutflow,1) = ib
6955	tmpindex(nboutflow,2) = ij
6956	!
6957	ENDIF
6958	!
6959	ENDDO
6960	ENDDO
6961	!
6962	DO ib=1, num_largest
6963	ff = MAXLOC(tmp_area(1:nboutflow))
6964	outflow_grid(tmpindex(ff(1),1), tmpindex(ff(1),2)) = -1
6965	tmp_area(ff(1)) = zero
6966	ENDDO
6967	!
6968	END SUBROUTINE routing_fetch
6969	!
6970	!! ================================================================================================================================
6971	!! SUBROUTINE : routing_truncate
6972	!!
6973	!>\BRIEF This subroutine reduces the number of basins per grid to the value chosen by the user.
6974	!! It also computes the final field which will be used to route the water at the
6975	!! requested truncation.
6976	!!
6977	!! DESCRIPTION (definitions, functional, design, flags) :
6978	!! Truncate if needed and find the path closest to the high resolution data.
6979	!!
6980	!! The algorithm :
6981	!!
6982	!! We only go through this procedure only as many times as there are basins to take out at most.
6983	!! This is important as it allows the simplifications to spread from one grid to the other.
6984	!! The for each step of the iteration and at each grid point we check the following options for
6985	!! simplifying the pathways of water :
6986	!! 1) If the basin of a grid flows into another basin of the same grid. Kill the one which only
6987	!! served as a transition
6988	!! 2) If in one grid box we have a number of basins which flow into the ocean as coastal flow.
6989	!! We kill the smallest one and put into the largest basin. There is no need to manage many
6990	!! basins going into the ocean as coastal flows.
6991	!! 3) If we have streams run in parallel from one gird box to the others (that is these are
6992	!! different basins) we will put the smaller one in the larger one. This may hapen at any
6993	!! level of the flow but in theory it should propagate downstream.
6994	!! 4) If we have two basins with the same ID but flow into different grid boxes we sacrifice
6995	!! the smallest one and route it through the largest.
6996	!!
6997	!! Obviously if any of the options find something then we skip the rest and take out the basin.:\n
6998	!!
6999	!! RECENT CHANGE(S): None
7000	!!
7001	!! MAIN OUTPUT VARIABLE(S):
7002	!!
7003	!! REFERENCES : None
7004	!!
7005	!! FLOWCHART : None
7006	!! \n
7007	!_ ================================================================================================================================
7008
7009	SUBROUTINE routing_truncate(nbpt, resolution, contfrac, nwbas, basin_count, basin_area, basin_topoind,&
7010	& fetch_basin, basin_id, basin_flowdir, outflow_grid, outflow_basin, inflow_number,&
7011	& inflow_grid, inflow_basin)
7012	!
7013	IMPLICIT NONE
7014	!
7015	!! PARAMETERS
7016	INTEGER(i_std), PARAMETER :: pickmax = 200 !!
7017
7018	!! INPUT VARIABLES
7019	INTEGER(i_std) :: nbpt !! Domain size (unitless)
7020	!
7021	REAL(r_std), DIMENSION(nbpt,2) :: resolution !! The size of each grid box in X and Y (m)
7022	REAL(r_std), DIMENSION(nbpt), INTENT(in) :: contfrac !! Fraction of land in each grid box (unitless;0-1)
7023	!
7024	INTEGER(i_std) :: nwbas !!
7025	INTEGER(i_std), DIMENSION(nbpt) :: basin_count !!
7026	INTEGER(i_std), DIMENSION(nbpt,nwbas) :: basin_id !!
7027	INTEGER(i_std), DIMENSION(nbpt,nwbas) :: basin_flowdir !! Water flow directions in the basin (unitless)
7028	REAL(r_std), DIMENSION(nbpt,nwbas) :: basin_area !!
7029	REAL(r_std), DIMENSION(nbpt,nwbas) :: basin_topoind !! Topographic index of the residence time for a basin (m)
7030	REAL(r_std), DIMENSION(nbpt,nwbas) :: fetch_basin !!
7031	INTEGER(i_std), DIMENSION(nbpt,nwbas) :: outflow_grid !! Type of outflow on the grid box (unitless)
7032	INTEGER(i_std), DIMENSION(nbpt,nwbas) :: outflow_basin !!
7033	INTEGER(i_std), DIMENSION(nbpt,nwbas) :: inflow_number !!
7034	INTEGER(i_std), DIMENSION(nbpt,nwbas,nwbas) :: inflow_basin !!
7035	INTEGER(i_std), DIMENSION(nbpt,nwbas,nwbas) :: inflow_grid !!
7036	!
7037	!! LOCAL VARIABLES
7038	INTEGER(i_std) :: ib, ij, ibf, ijf, igrif, ibasf, cnt, pold, bold, ff(2) !! Indices (unitless)
7039	INTEGER(i_std) :: ii, kbas, sbas, ik, iter, ibt, obj !! Indices (unitless)
7040	REAL(r_std), DIMENSION(nbpt,nbasmax) :: floflo !!
7041	REAL(r_std), DIMENSION(nbpt) :: gridarea !!
7042	REAL(r_std), DIMENSION(nbpt) :: gridbasinarea !!
7043	REAL(r_std) :: ratio !!
7044	INTEGER(i_std), DIMENSION(pickmax,2) :: largest_basins !!
7045	INTEGER(i_std), DIMENSION(pickmax) :: tmp_ids !!
7046	INTEGER(i_std) :: multbas !!
7047	INTEGER(i_std) :: iml(1) !! X resolution of the high resolution grid
7048	INTEGER(i_std), DIMENSION(pickmax) :: multbas_sz !!
7049	REAL(r_std), DIMENSION(pickmax) :: tmp_area !!
7050	INTEGER(i_std), DIMENSION(pickmax,pickmax) :: multbas_list !!
7051	!
7052	INTEGER(i_std) :: nbtruncate !!
7053	INTEGER(i_std), SAVE, ALLOCATABLE, DIMENSION(:) :: indextrunc !!
7054	!$OMP THREADPRIVATE(indextrunc)
7055
7056	!_ ================================================================================================================================
7057	!
7058	!
7059	IF ( .NOT. ALLOCATED(indextrunc)) THEN
7060	ALLOCATE(indextrunc(nbpt))
7061	ENDIF
7062	!
7063	! We have to go through the grid as least as often as we have to reduce the number of basins
7064	! For good measure we add 3 more passages.
7065	!
7066	!
7067	DO iter = 1, MAXVAL(basin_count) - nbasmax +3
7068	!
7069	! Get the points over which we wish to truncate
7070	!
7071	nbtruncate = 0
7072	DO ib = 1, nbpt
7073	IF ( basin_count(ib) .GT. nbasmax ) THEN
7074	nbtruncate = nbtruncate + 1
7075	indextrunc(nbtruncate) = ib
7076	ENDIF
7077	ENDDO
7078	!
7079	! Go through the basins which need to be truncated.
7080	!
7081	DO ibt=1,nbtruncate
7082	!
7083	ib = indextrunc(ibt)
7084	!
7085	! Check if we have basin which flows into a basin in the same grid
7086	! kbas = basin we will have to kill
7087	! sbas = basin which takes over kbas
7088	!
7089	kbas = 0
7090	sbas = 0
7091	!
7092	! 1) Can we find a basin which flows into a basin of the same grid ?
7093	!
7094	DO ij=1,basin_count(ib)
7095	DO ii=1,basin_count(ib)
7096	IF ( outflow_grid(ib,ii) .EQ. ib .AND. outflow_basin(ib, ii) .EQ. ij .AND. kbas*sbas .NE. 0) THEN
7097	kbas = ii
7098	sbas = ij
7099	ENDIF
7100	ENDDO
7101	ENDDO
7102	!
7103	! 2) Merge two basins which flow into the ocean as coastal or return flow
7104	! (outflow_grid = -2 or -3). Well obviously only if we have more than 1 and
7105	! have not found anything yet!
7106	!
7107	IF ( (COUNT(outflow_grid(ib,1:basin_count(ib)) .EQ. -2) .GT. 1 .OR.&
7108	& COUNT(outflow_grid(ib,1:basin_count(ib)) .EQ. -3) .GT. 1) .AND.&
7109	& kbas*sbas .EQ. 0) THEN
7110	!
7111	multbas = 0
7112	multbas_sz(:) = 0
7113	!
7114	IF ( COUNT(outflow_grid(ib,1:basin_count(ib)) .EQ. -2) .GT. 1 ) THEN
7115	obj = -2
7116	ELSE
7117	obj = -3
7118	ENDIF
7119	!
7120	! First we get the list of all basins which go out as coastal or return flow (obj)
7121	!
7122	DO ij=1,basin_count(ib)
7123	IF ( outflow_grid(ib,ij) .EQ. obj ) THEN
7124	multbas = multbas + 1
7125	multbas_sz(multbas) = ij
7126	tmp_area(multbas) = fetch_basin(ib,ij)
7127	ENDIF
7128	ENDDO
7129	!
7130	! Now the take the smallest to be transfered to the largest
7131	!
7132	iml = MAXLOC(tmp_area(1:multbas), MASK = tmp_area(1:multbas) .GT. zero)
7133	sbas = multbas_sz(iml(1))
7134	iml = MINLOC(tmp_area(1:multbas), MASK = tmp_area(1:multbas) .GT. zero)
7135	kbas = multbas_sz(iml(1))
7136	!
7137	ENDIF
7138	!
7139	! 3) If we have basins flowing into the same grid but different basins then we put them
7140	! together. Obviously we first work with the grid which has most streams running into it
7141	! and putting the smallest in the largests catchments.
7142	!
7143	IF ( kbas*sbas .EQ. 0) THEN
7144	!
7145	tmp_ids(1:basin_count(ib)) = outflow_grid(ib,1:basin_count(ib))
7146	multbas = 0
7147	multbas_sz(:) = 0
7148	!
7149	! First obtain the list of basins which flow into the same basin
7150	!
7151	DO ij=1,basin_count(ib)
7152	IF ( outflow_grid(ib,ij) .GT. 0 .AND.&
7153	& COUNT(tmp_ids(1:basin_count(ib)) .EQ. outflow_grid(ib,ij)) .GT. 1) THEN
7154	multbas = multbas + 1
7155	DO ii=1,basin_count(ib)
7156	IF ( tmp_ids(ii) .EQ. outflow_grid(ib,ij)) THEN
7157	multbas_sz(multbas) = multbas_sz(multbas) + 1
7158	multbas_list(multbas,multbas_sz(multbas)) = ii
7159	tmp_ids(ii) = -99
7160	ENDIF
7161	ENDDO
7162	ELSE
7163	tmp_ids(ij) = -99
7164	ENDIF
7165	ENDDO
7166	!
7167	! Did we come up with any basins to deal with this way ?
7168	!
7169	IF ( multbas .GT. 0 ) THEN
7170	!
7171	iml = MAXLOC(multbas_sz(1:multbas))
7172	ik = iml(1)
7173	!
7174	! Take the smallest and largest of these basins !
7175	!
7176	DO ii=1,multbas_sz(ik)
7177	tmp_area(ii) = fetch_basin(ib, multbas_list(ik,ii))
7178	ENDDO
7179	!
7180	iml = MAXLOC(tmp_area(1:multbas_sz(ik)), MASK = tmp_area(1:multbas_sz(ik)) .GT. zero)
7181	sbas = multbas_list(ik,iml(1))
7182	iml = MINLOC(tmp_area(1:multbas_sz(ik)), MASK = tmp_area(1:multbas_sz(ik)) .GT. zero)
7183	kbas = multbas_list(ik,iml(1))
7184	!
7185	ENDIF
7186	!
7187	ENDIF
7188	!
7189	! 4) If we have twice the same basin we put them together even if they flow into different
7190	! directions. If one of them goes to the ocean it takes the advantage.
7191	!
7192	IF ( kbas*sbas .EQ. 0) THEN
7193	!
7194	tmp_ids(1:basin_count(ib)) = basin_id(ib,1:basin_count(ib))
7195	multbas = 0
7196	multbas_sz(:) = 0
7197	!
7198	! First obtain the list of basins which have sub-basins in this grid box.
7199	! (these are identified by their IDs)
7200	!
7201	DO ij=1,basin_count(ib)
7202	IF ( COUNT(tmp_ids(1:basin_count(ib)) .EQ. basin_id(ib,ij)) .GT. 1) THEN
7203	multbas = multbas + 1
7204	DO ii=1,basin_count(ib)
7205	IF ( tmp_ids(ii) .EQ. basin_id(ib,ij)) THEN
7206	multbas_sz(multbas) = multbas_sz(multbas) + 1
7207	multbas_list(multbas,multbas_sz(multbas)) = ii
7208	tmp_ids(ii) = -99
7209	ENDIF
7210	ENDDO
7211	ELSE
7212	tmp_ids(ij) = -99
7213	ENDIF
7214	ENDDO
7215	!
7216	! We are going to work on the basin with the largest number of sub-basins.
7217	! (IF we have a basin which has subbasins !)
7218	!
7219	IF ( multbas .GT. 0 ) THEN
7220	!
7221	iml = MAXLOC(multbas_sz(1:multbas))
7222	ik = iml(1)
7223	!
7224	! If one of the basins goes to the ocean then it is going to have the priority
7225	!
7226	tmp_area(:) = zero
7227	IF ( COUNT(outflow_grid(ib,multbas_list(ik,1:multbas_sz(ik))) .LT. 0) .GT. 0) THEN
7228	DO ii=1,multbas_sz(ik)
7229	IF ( outflow_grid(ib,multbas_list(ik,ii)) .LT. 0 .AND. sbas .EQ. 0 ) THEN
7230	sbas = multbas_list(ik,ii)
7231	ELSE
7232	tmp_area(ii) = fetch_basin(ib, multbas_list(ik,ii))
7233	ENDIF
7234	ENDDO
7235	! take the smallest of the subbasins
7236	iml = MINLOC(tmp_area(1:multbas_sz(ik)), MASK = tmp_area(1:multbas_sz(ik)) .GT. zero)
7237	kbas = multbas_list(ik,iml(1))
7238	ELSE
7239	!
7240	! Else we take simply the largest and smallest
7241	!
7242	DO ii=1,multbas_sz(ik)
7243	tmp_area(ii) = fetch_basin(ib, multbas_list(ik,ii))
7244	ENDDO
7245	iml = MAXLOC(tmp_area(1:multbas_sz(ik)), MASK = tmp_area(1:multbas_sz(ik)) .GT. zero)
7246	sbas = multbas_list(ik,iml(1))
7247	iml = MINLOC(tmp_area(1:multbas_sz(ik)), MASK = tmp_area(1:multbas_sz(ik)) .GT. zero)
7248	kbas = multbas_list(ik,iml(1))
7249	!
7250	ENDIF
7251	!
7252	!
7253	ENDIF
7254	ENDIF
7255	!
7256	!
7257	!
7258	! Then we call routing_killbas to clean up the basins in this grid
7259	!
7260	IF ( kbas .GT. 0 .AND. sbas .GT. 0 ) THEN
7261	CALL routing_killbas(nbpt, ib, kbas, sbas, nwbas, basin_count, basin_area, basin_topoind,&
7262	& fetch_basin, basin_id, basin_flowdir, outflow_grid, outflow_basin, inflow_number,&
7263	& inflow_grid, inflow_basin)
7264	ENDIF
7265	!
7266	ENDDO
7267	!
7268	!
7269	ENDDO
7270	!
7271	! If there are any grids left with too many basins we need to take out the big hammer !
7272	! We will only do it if this represents less than 5% of all points.
7273	!
7274	IF ( COUNT(basin_count .GT. nbasmax) .GT. 0 ) THEN
7275	!
7276	!
7277	IF ( COUNT(basin_count .GT. nbasmax)/nbpt*100 .GT. 5 ) THEN
7278	WRITE(numout,) 'We have ', COUNT(basin_count .GT. nbasmax)/nbpt100, '% of all points which do not yet'
7279	WRITE(numout,*) 'have the right trunctaction. That is too much to apply a brutal method'
7280	DO ib = 1, nbpt
7281	IF ( basin_count(ib) .GT. nbasmax ) THEN
7282	!
7283	WRITE(numout,*) 'We did not find a basin which could be supressed. We will'
7284	WRITE(numout,*) 'not be able to reduce the truncation in grid ', ib
7285	DO ij=1,basin_count(ib)
7286	WRITE(numout,*) 'grid, basin nb and id :', ib, ij, basin_id(ib,ij)
7287	WRITE(numout,*) 'Outflow grid and basin ->', outflow_grid(ib,ij), outflow_basin(ib, ij)
7288	ENDDO
7289	ENDIF
7290	ENDDO
7291	CALL ipslerr_p(3,'routing_truncate','No basin found which could be supressed.','','')
7292	ELSE
7293	!
7294	!
7295	DO ib = 1,nbpt
7296	DO WHILE ( basin_count(ib) .GT. nbasmax )
7297	!
7298	IF (printlev>=3) WRITE(numout,*) 'HAMMER, ib, basin_count :', ib, basin_count(ib)
7299	!
7300	! Here we simply put the smallest basins into the largest ones. It is really a brute force
7301	! method but it will only be applied if everything has failed.
7302	!
7303	DO ii = 1,basin_count(ib)
7304	tmp_area(ii) = fetch_basin(ib, ii)
7305	ENDDO
7306	!
7307	iml = MAXLOC(tmp_area(1:basin_count(ib)), MASK = tmp_area(1:basin_count(ib)) .GT. 0.)
7308	sbas =iml(1)
7309	iml = MINLOC(tmp_area(1:basin_count(ib)), MASK = tmp_area(1:basin_count(ib)) .GT. 0.)
7310	kbas = iml(1)
7311	!
7312	IF ( kbas .GT. 0 .AND. sbas .GT. 0 ) THEN
7313	CALL routing_killbas(nbpt, ib, kbas, sbas, nwbas, basin_count, basin_area, basin_topoind,&
7314	& fetch_basin, basin_id, basin_flowdir, outflow_grid, outflow_basin, inflow_number,&
7315	& inflow_grid, inflow_basin)
7316	ENDIF
7317	ENDDO
7318	ENDDO
7319	!
7320	ENDIF
7321	!
7322	!
7323	ENDIF
7324	!
7325	! Now that we have reached the right truncation (resolution) we will start
7326	! to produce the variables we will use to route the water.
7327	!
7328	DO ib=1,nbpt
7329	!
7330	! For non existing basins the route_tobasin variable is put to zero. This will allow us
7331	! to pick up the number of basin afterwards.
7332	!
7333	route_togrid(ib,:) = ib
7334	route_tobasin(ib,:) = 0
7335	routing_area(ib,:) = zero
7336	!
7337	ENDDO
7338	!
7339	! Transfer the info into the definitive variables
7340	!
7341	DO ib=1,nbpt
7342	DO ij=1,basin_count(ib)
7343	routing_area(ib,ij) = basin_area(ib,ij)
7344	topo_resid(ib,ij) = basin_topoind(ib,ij)
7345	global_basinid(ib,ij) = basin_id(ib,ij)
7346	route_togrid(ib,ij) = outflow_grid(ib,ij)
7347	route_tobasin(ib,ij) = outflow_basin(ib,ij)
7348	ENDDO
7349	ENDDO
7350	!
7351	!
7352	! Set the new convention for the outflow conditions
7353	! Now it is based in the outflow basin and the outflow grid will
7354	! be the same as the current.
7355	! returnflow to the grid : nbasmax + 1
7356	! coastal flow : nbasmax + 2
7357	! river outflow : nbasmax + 3
7358	!
7359	! Here we put everything here in coastal flow. It is later where we will
7360	! put the largest basins into river outflow.
7361	!
7362	DO ib=1,nbpt
7363	DO ij=1,basin_count(ib)
7364	! River flows
7365	IF ( route_togrid(ib,ij) .EQ. -1 ) THEN
7366	route_tobasin(ib,ij) = nbasmax + 2
7367	route_togrid(ib,ij) = ib
7368	! Coastal flows
7369	ELSE IF ( route_togrid(ib,ij) .EQ. -2 ) THEN
7370	route_tobasin(ib,ij) = nbasmax + 2
7371	route_togrid(ib,ij) = ib
7372	! Return flow
7373	ELSE IF ( route_togrid(ib,ij) .EQ. -3 ) THEN
7374	route_tobasin(ib,ij) = nbasmax + 1
7375	route_togrid(ib,ij) = ib
7376	ENDIF
7377	ENDDO
7378	ENDDO
7379	!
7380	! A second check on the data. Just make sure that each basin flows somewhere.
7381	!
7382	DO ib=1,nbpt
7383	DO ij=1,basin_count(ib)
7384	ibf = route_togrid(ib,ij)
7385	ijf = route_tobasin(ib,ij)
7386	IF ( ijf .GT. basin_count(ibf) .AND. ijf .LE. nbasmax) THEN
7387	WRITE(numout,*) 'Second check'
7388	WRITE(numout,*) 'point :', ib, ' basin :', ij
7389	WRITE(numout,*) 'Flows into point :', ibf, ' basin :', ijf
7390	WRITE(numout,*) 'But it flows into now here as basin count = ', basin_count(ibf)
7391	CALL ipslerr_p(3,'routing_truncate','Problem with routing..','','')
7392	ENDIF
7393	ENDDO
7394	ENDDO
7395	!
7396	! Verify areas of the continents
7397	!
7398	floflo(:,:) = zero
7399	! if we are at the poles : resolution(:,1) = 0
7400	WHERE (resolution(:,1) == 0)
7401	! compute grid area as the circle of radius resolution(:,2)
7402	gridarea(:) = contfrac(:)piresolution(:,2)*resolution(:,2)
7403	ELSEWHERE
7404	gridarea(:) = contfrac(:)resolution(:,1)resolution(:,2)
7405	END WHERE
7406	DO ib=1,nbpt
7407	gridbasinarea(ib) = SUM(routing_area(ib,:))
7408	ENDDO
7409	!
7410	DO ib=1,nbpt
7411	DO ij=1,basin_count(ib)
7412	cnt = 0
7413	igrif = ib
7414	ibasf = ij
7415	DO WHILE (ibasf .LE. nbasmax .AND. cnt .LT. nbasmax*nbpt)
7416	cnt = cnt + 1
7417	pold = igrif
7418	bold = ibasf
7419	igrif = route_togrid(pold, bold)
7420	ibasf = route_tobasin(pold, bold)
7421	IF ( ibasf .GT. basin_count(igrif) .AND. ibasf .LE. nbasmax) THEN
7422	WRITE(numout,*) 'We should not be here as the basin flows into the pampa'
7423	WRITE(numout,*) 'Last correct point :', pold, bold
7424	WRITE(numout,*) 'It pointed to in the new variables :', route_togrid(pold, bold),route_tobasin(pold, bold)
7425	WRITE(numout,*) 'The old variables gave :', outflow_grid(pold, bold), outflow_basin(pold, bold)
7426	WRITE(numout,*) 'Where we ended up :', igrif,ibasf
7427	CALL ipslerr_p(3,'routing_truncate','Problem with routing..','','')
7428	ENDIF
7429	ENDDO
7430	!
7431	IF ( ibasf .GT. nbasmax ) THEN
7432	floflo(igrif,bold) = floflo(igrif,bold) + routing_area(ib,ij)
7433	ELSE
7434	WRITE(numout,*) 'The flow did not end up in the ocean or in the grid cell.'
7435	WRITE(numout,*) 'For grid ', ib, ' and basin ', ij
7436	WRITE(numout,*) 'The last grid was ', igrif, ' and basin ', ibasf
7437	CALL ipslerr_p(3,'routing_truncate','Problem with routing..','','')
7438	ENDIF
7439	ENDDO
7440	ENDDO
7441	!
7442	DO ib=1,nbpt
7443	IF ( gridbasinarea(ib) > zero ) THEN
7444	ratio = gridarea(ib)/gridbasinarea(ib)
7445	routing_area(ib,:) = routing_area(ib,:)*ratio
7446	ELSE
7447	WRITE(numout,*) 'gridbasinarea(ib) <= zero. We should stop here :', ib
7448	ENDIF
7449	ENDDO
7450	!
7451	WRITE(numout,*) 'Sum of area of all outflow areas :',SUM(routing_area)
7452	WRITE(numout,*) 'Surface of all continents :', SUM(gridarea)
7453	!
7454	! Redo the the distinction between river outflow and coastal flow. We can not
7455	! take into account the return flow points.
7456	!
7457	ibf = 0
7458	DO ib=1, pickmax
7459	ff = MAXLOC(floflo)
7460	! tdo - To take into account rivers that do not flow to the oceans
7461	IF ( route_tobasin(ff(1), ff(2)) .GT. nbasmax ) THEN
7462	! IF ( route_tobasin(ff(1), ff(2)) .EQ. nbasmax + 2) THEN
7463	ibf = ibf + 1
7464	largest_basins(ibf,:) = ff(:)
7465	ENDIF
7466	floflo(ff(1), ff(2)) = zero
7467	ENDDO
7468	!
7469	! Put the largest basins into river flows.
7470	!
7471	IF ( ibf .LT. num_largest) THEN
7472	WRITE(numout,*) 'Not enough basins to choose the ', num_largest, 'largest'
7473	CALL ipslerr_p(3,'routing_truncate','Not enough basins','','')
7474	ENDIF
7475	!
7476	!
7477	!
7478	DO ib=1, num_largest
7479	route_tobasin(largest_basins(ib,1),largest_basins(ib,2)) = nbasmax + 3
7480	ENDDO
7481	!
7482	WRITE(numout,*) 'NUMBER OF RIVERS :', COUNT(route_tobasin .GE. nbasmax + 3)
7483	!
7484	END SUBROUTINE routing_truncate
7485	!
7486	!! ================================================================================================================================
7487	!! SUBROUTINE : routing_killbas
7488	!!
7489	!>\BRIEF The aim of this subroutine is to kill a basin (that is put into another larger one).
7490	!! When we do this we need to be careful and change all associated variables.
7491	!!
7492	!! DESCRIPTION (definitions, functional, design, flags) : None
7493	!!
7494	!! RECENT CHANGE(S): None
7495	!!
7496	!! MAIN OUTPUT VARIABLE(S):
7497	!!
7498	!! REFERENCES : None
7499	!!
7500	!! FLOWCHART : None
7501	!! \n
7502	!_ ================================================================================================================================
7503
7504	SUBROUTINE routing_killbas(nbpt, ib, tokill, totakeover, nwbas, basin_count, basin_area, basin_topoind,&
7505	& fetch_basin, basin_id, basin_flowdir, outflow_grid, outflow_basin, inflow_number,&
7506	& inflow_grid, inflow_basin)
7507	!
7508	!
7509	IMPLICIT NONE
7510	!
7511	INTEGER(i_std) :: tokill !!
7512	INTEGER(i_std) :: totakeover !!
7513	INTEGER(i_std) :: nbpt !! Domain size (unitless)
7514	INTEGER(i_std) :: ib !! Current basin (unitless)
7515	!
7516	INTEGER(i_std) :: nwbas !!
7517	INTEGER(i_std), DIMENSION(nbpt) :: basin_count !!
7518	INTEGER(i_std), DIMENSION(nbpt,nwbas) :: basin_id !!
7519	INTEGER(i_std), DIMENSION(nbpt,nwbas) :: basin_flowdir !! Water flow directions in the basin (unitless)
7520	REAL(r_std), DIMENSION(nbpt,nwbas) :: basin_area !!
7521	REAL(r_std), DIMENSION(nbpt,nwbas) :: basin_topoind !! Topographic index of the residence time for a basin (m)
7522	REAL(r_std), DIMENSION(nbpt,nwbas) :: fetch_basin !!
7523	INTEGER(i_std), DIMENSION(nbpt,nwbas) :: outflow_grid !! Type of outflow on the grid box (unitless)
7524	INTEGER(i_std), DIMENSION(nbpt,nwbas) :: outflow_basin !!
7525	INTEGER(i_std), DIMENSION(nbpt,nwbas) :: inflow_number !!
7526	INTEGER(i_std), DIMENSION(nbpt,nwbas,nwbas) :: inflow_basin !!
7527	INTEGER(i_std), DIMENSION(nbpt,nwbas,nwbas) :: inflow_grid !!
7528	!
7529	!! LOCAL VARIABLES
7530	INTEGER(i_std) :: inf, ibs, ing, inb, ibasf, igrif, it !! Indices (unitless)
7531	LOGICAL :: doshift !! (true/false)
7532
7533	!_ ================================================================================================================================
7534	!
7535	! Update the information needed in the basin "totakeover"
7536	! For the moment only area
7537	!
7538	IF (printlev>=3) THEN
7539	WRITE(numout,*) 'KILL BASIN :', ib, tokill, totakeover, basin_id(ib,tokill), basin_id(ib,totakeover)
7540	END IF
7541	!
7542	basin_area(ib, totakeover) = basin_area(ib, totakeover) + basin_area(ib, tokill)
7543	basin_topoind(ib, totakeover) = (basin_topoind(ib, totakeover) + basin_topoind(ib, tokill))/2.0
7544	!
7545	! Add the fetch of the basin will kill to the one which gets the water
7546	!
7547	fetch_basin(ib, totakeover) = fetch_basin(ib, totakeover) + fetch_basin(ib, tokill)
7548	igrif = outflow_grid(ib,totakeover)
7549	ibasf = outflow_basin(ib,totakeover)
7550	!
7551	inf = 0
7552	DO WHILE (igrif .GT. 0)
7553	fetch_basin(igrif,ibasf) = fetch_basin(igrif,ibasf) + fetch_basin(ib, tokill)
7554	it = outflow_grid(igrif, ibasf)
7555	ibasf = outflow_basin(igrif, ibasf)
7556	igrif = it
7557	inf = inf + 1
7558	ENDDO
7559	!
7560	! Take out the basin we have just rerouted from the fetch of the basins in which it used to flow.
7561	!
7562	igrif = outflow_grid(ib,tokill)
7563	ibasf = outflow_basin(ib,tokill)
7564	!
7565	DO WHILE (igrif .GT. 0)
7566	fetch_basin(igrif,ibasf) = fetch_basin(igrif,ibasf) - fetch_basin(ib, tokill)
7567	it = outflow_grid(igrif, ibasf)
7568	ibasf = outflow_basin(igrif, ibasf)
7569	igrif = it
7570	ENDDO
7571	!
7572	! Redirect the flows which went into the basin to be killed before we change everything
7573	!
7574	DO inf = 1, inflow_number(ib, tokill)
7575	outflow_basin(inflow_grid(ib, tokill, inf), inflow_basin(ib, tokill, inf)) = totakeover
7576	inflow_number(ib, totakeover) = inflow_number(ib, totakeover) + 1
7577	inflow_grid(ib, totakeover, inflow_number(ib, totakeover)) = inflow_grid(ib, tokill, inf)
7578	inflow_basin(ib, totakeover, inflow_number(ib, totakeover)) = inflow_basin(ib, tokill, inf)
7579	ENDDO
7580	!
7581	! Take out the basin to be killed from the list of inflow basins of the downstream basin
7582	! (In case the basin does not flow into an ocean or lake)
7583	!
7584	IF ( outflow_grid(ib,tokill) .GT. 0) THEN
7585	!
7586	ing = outflow_grid(ib, tokill)
7587	inb = outflow_basin(ib, tokill)
7588	doshift = .FALSE.
7589	!
7590	DO inf = 1, inflow_number(ing, inb)
7591	IF ( doshift ) THEN
7592	inflow_grid(ing, inb, inf-1) = inflow_grid(ing, inb, inf)
7593	inflow_basin(ing, inb, inf-1) = inflow_basin(ing, inb, inf)
7594	ENDIF
7595	IF ( inflow_grid(ing, inb, inf) .EQ. ib .AND. inflow_basin(ing, inb, inf) .EQ. tokill) THEN
7596	doshift = .TRUE.
7597	ENDIF
7598	ENDDO
7599	!
7600	! This is only to allow for the last check
7601	!
7602	inf = inflow_number(ing, inb)
7603	IF ( inflow_grid(ing, inb, inf) .EQ. ib .AND. inflow_basin(ing, inb, inf) .EQ. tokill) THEN
7604	doshift = .TRUE.
7605	ENDIF
7606	!
7607	IF ( .NOT. doshift ) THEN
7608	WRITE(numout,*) 'Strange we did not find the basin to kill in the downstream basin'
7609	CALL ipslerr_p(3,'routing_killbas','Basin not found','','')
7610	ENDIF
7611	inflow_number(ing, inb) = inflow_number(ing, inb) - 1
7612
7613	ENDIF
7614	!
7615	! Now remove from the arrays the information of basin "tokill"
7616	!
7617	basin_id(ib, tokill:basin_count(ib)-1) = basin_id(ib, tokill+1:basin_count(ib))
7618	basin_flowdir(ib, tokill:basin_count(ib)-1) = basin_flowdir(ib, tokill+1:basin_count(ib))
7619	basin_area(ib, tokill:basin_count(ib)-1) = basin_area(ib, tokill+1:basin_count(ib))
7620	basin_area(ib, basin_count(ib):nwbas) = zero
7621	basin_topoind(ib, tokill:basin_count(ib)-1) = basin_topoind(ib, tokill+1:basin_count(ib))
7622	basin_topoind(ib, basin_count(ib):nwbas) = zero
7623	fetch_basin(ib, tokill:basin_count(ib)-1) = fetch_basin(ib, tokill+1:basin_count(ib))
7624	fetch_basin(ib, basin_count(ib):nwbas) = zero
7625	!
7626	! Before we remove the information from the outflow fields we have to correct the corresponding inflow fields
7627	! of the grids into which the flow goes
7628	!
7629	DO ibs = tokill+1,basin_count(ib)
7630	ing = outflow_grid(ib, ibs)
7631	inb = outflow_basin(ib, ibs)
7632	IF ( ing .GT. 0 ) THEN
7633	DO inf = 1, inflow_number(ing, inb)
7634	IF ( inflow_grid(ing,inb,inf) .EQ. ib .AND. inflow_basin(ing,inb,inf) .EQ. ibs) THEN
7635	inflow_basin(ing,inb,inf) = ibs - 1
7636	ENDIF
7637	ENDDO
7638	ENDIF
7639	ENDDO
7640	outflow_grid(ib, tokill:basin_count(ib)-1) = outflow_grid(ib, tokill+1:basin_count(ib))
7641	outflow_basin(ib, tokill:basin_count(ib)-1) = outflow_basin(ib, tokill+1:basin_count(ib))
7642	!
7643	! Basins which moved down also need to redirect their incoming flows.
7644	!
7645	DO ibs=tokill+1, basin_count(ib)
7646	DO inf = 1, inflow_number(ib, ibs)
7647	outflow_basin(inflow_grid(ib, ibs, inf), inflow_basin(ib, ibs, inf)) = ibs-1
7648	ENDDO
7649	ENDDO
7650	!
7651	! Shift the inflow basins
7652	!
7653	DO it = tokill+1,basin_count(ib)
7654	inflow_grid(ib, it-1, 1:inflow_number(ib,it)) = inflow_grid(ib, it, 1:inflow_number(ib,it))
7655	inflow_basin(ib, it-1, 1:inflow_number(ib,it)) = inflow_basin(ib, it, 1:inflow_number(ib,it))
7656	inflow_number(ib,it-1) = inflow_number(ib,it)
7657	ENDDO
7658	!
7659	basin_count(ib) = basin_count(ib) - 1
7660	!
7661	END SUBROUTINE routing_killbas
7662	!
7663	!! ================================================================================================================================
7664	!! SUBROUTINE : routing_names
7665	!!
7666	!>\BRIEF This subroutine lists the name of the largest basins which are explicitly listed in the basin
7667	!! description file used by ORCHIDEE.
7668	!!
7669	!! DESCRIPTION (definitions, functional, design, flags) : None
7670	!!
7671	!! RECENT CHANGE(S): None
7672	!!
7673	!! MAIN OUTPUT VARIABLE(S):
7674	!!
7675	!! REFERENCES : None
7676	!!
7677	!! FLOWCHART : None
7678	!! \n
7679	!_ ================================================================================================================================
7680
7681	SUBROUTINE routing_names(numlar, basin_names)
7682	!
7683	IMPLICIT NONE
7684	!
7685	! Arguments
7686	!
7687	INTEGER(i_std), INTENT(in) :: numlar !!
7688	CHARACTER(LEN=*), INTENT(inout) :: basin_names(numlar) !! Name of the basins (unitless)
7689	!! PARAMETERS
7690	INTEGER(i_std), PARAMETER :: listleng=349 !!
7691	!
7692	!! LOCAL VARIABLES
7693	INTEGER(i_std) :: lenstr, i !!
7694	CHARACTER(LEN=60), DIMENSION(listleng) :: list_names !!
7695	CHARACTER(LEN=60) :: tmp_str !!
7696
7697	!_ ================================================================================================================================
7698	!
7699
7700	lenstr = LEN(basin_names(1))
7701	!
7702	list_names(1) = "Amazon"
7703	list_names(2) = "Nile"
7704	list_names(3) = "Zaire"
7705	list_names(4) = "Mississippi"
7706	list_names(5) = "Amur"
7707	list_names(6) = "Parana"
7708	list_names(7) = "Yenisei"
7709	list_names(8) = "Ob"
7710	list_names(9) = "Lena"
7711	list_names(10) = "Niger"
7712	list_names(11) = "Zambezi"
7713	list_names(12) = "Erg Iguidi (Sahara)"
7714	list_names(13) = "Chang Jiang (Yangtze)"
7715	list_names(14) = "Mackenzie"
7716	list_names(15) = "Ganges"
7717	list_names(16) = "Chari"
7718	list_names(17) = "Volga"
7719	list_names(18) = "St. Lawrence"
7720	list_names(19) = "Indus"
7721	list_names(20) = "Syr-Darya"
7722	list_names(21) = "Nelson"
7723	list_names(22) = "Orinoco"
7724	list_names(23) = "Murray"
7725	list_names(24) = "Great Artesian Basin"
7726	list_names(25) = "Shatt el Arab"
7727	list_names(26) = "Orange"
7728	list_names(27) = "Huang He"
7729	list_names(28) = "Yukon"
7730	list_names(29) = "Senegal"
7731	list_names(30) = "Chott Jerid"
7732	list_names(31) = "Jubba"
7733	list_names(32) = "Colorado (Ari)"
7734	list_names(33) = "Rio Grande (US)"
7735	list_names(34) = "Danube"
7736	list_names(35) = "Mekong"
7737	list_names(36) = "Tocantins"
7738	list_names(37) = "Wadi al Farigh"
7739	list_names(38) = "Tarim"
7740	list_names(39) = "Columbia"
7741	list_names(40) = "Komadugu Yobe (Tchad)"
7742	list_names(41) = "Kolyma"
7743	list_names(42) = "Sao Francisco"
7744	list_names(43) = "Amu-Darya"
7745	list_names(44) = "GHAASBasin51"
7746	list_names(45) = "Dnepr"
7747	list_names(46) = "GHAASBasin61"
7748	list_names(47) = "Don"
7749	list_names(48) = "Colorado (Arg)"
7750	list_names(49) = "Limpopo"
7751	list_names(50) = "GHAASBasin50"
7752	list_names(51) = "Zhujiang"
7753	list_names(52) = "Irrawaddy"
7754	list_names(53) = "Volta"
7755	list_names(54) = "GHAASBasin54"
7756	list_names(55) = "Farah"
7757	list_names(56) = "Khatanga"
7758	list_names(57) = "Dvina"
7759	list_names(58) = "Urugay"
7760	list_names(59) = "Qarqan"
7761	list_names(60) = "GHAASBasin75"
7762	list_names(61) = "Parnaiba"
7763	list_names(62) = "GHAASBasin73"
7764	list_names(63) = "Indigirka"
7765	list_names(64) = "Churchill (Hud)"
7766	list_names(65) = "Godavari"
7767	list_names(66) = "Pur - Taz"
7768	list_names(67) = "Pechora"
7769	list_names(68) = "Baker"
7770	list_names(69) = "Ural"
7771	list_names(70) = "Neva"
7772	list_names(71) = "Liao"
7773	list_names(72) = "Salween"
7774	list_names(73) = "GHAASBasin73"
7775	list_names(74) = "Jordan"
7776	list_names(75) = "GHAASBasin78"
7777	list_names(76) = "Magdalena"
7778	list_names(77) = "Krishna"
7779	list_names(78) = "Salado"
7780	list_names(79) = "Fraser"
7781	list_names(80) = "Hai Ho"
7782	list_names(81) = "Huai"
7783	list_names(82) = "Yana"
7784	list_names(83) = "GHAASBasin95"
7785	list_names(84) = "GHAASBasin105"
7786	list_names(85) = "Kura"
7787	list_names(86) = "Olenek"
7788	list_names(87) = "Ogooue"
7789	list_names(88) = "Taymyr"
7790	list_names(89) = "Negro Arg"
7791	list_names(90) = "Chubut"
7792	list_names(91) = "GHAASBasin91"
7793	list_names(92) = "GHAASBasin122"
7794	list_names(93) = "GHAASBasin120"
7795	list_names(94) = "Sacramento"
7796	list_names(95) = "Fitzroy West"
7797	list_names(96) = "Grande de Santiago"
7798	list_names(97) = "Rufiji"
7799	list_names(98) = "Wisla"
7800	list_names(99) = "GHAASBasin47"
7801	list_names(100) = "GHAASBasin127"
7802	list_names(101) = "Hong"
7803	list_names(102) = "GHAASBasin97"
7804	list_names(103) = "Swan-Avon"
7805	list_names(104) = "Rhine"
7806	list_names(105) = "Cuanza"
7807	list_names(106) = "GHAASBasin106"
7808	list_names(107) = "GHAASBasin142"
7809	list_names(108) = "Roviuna"
7810	list_names(109) = "Essequibo"
7811	list_names(110) = "Elbe"
7812	list_names(111) = "Koksoak"
7813	list_names(112) = "Chao Phraya"
7814	list_names(113) = "Brahmani"
7815	list_names(114) = "GHAASBasin165"
7816	list_names(115) = "Pyasina"
7817	list_names(116) = "Fitzroy East"
7818	list_names(117) = "GHAASBasin173"
7819	list_names(118) = "Albany"
7820	list_names(119) = "Sanaga"
7821	list_names(120) = "GHAASBasin120"
7822	list_names(121) = "GHAASBasin178"
7823	list_names(122) = "GHAASBasin148"
7824	list_names(123) = "Brazos (Tex)"
7825	list_names(124) = "GHAASBasin124"
7826	list_names(125) = "Alabama"
7827	list_names(126) = "GHAASBasin174"
7828	list_names(127) = "GHAASBasin179"
7829	list_names(128) = "Balsas"
7830	list_names(129) = "GHAASBasin172"
7831	list_names(130) = "Burdekin"
7832	list_names(131) = "Colorado (Texas)"
7833	list_names(132) = "GHAASBasin150"
7834	list_names(133) = "Odra"
7835	list_names(134) = "Loire"
7836	list_names(135) = "GHAASBasin98"
7837	list_names(136) = "Galana"
7838	list_names(137) = "Kuskowin"
7839	list_names(138) = "Moose"
7840	list_names(139) = "Narmada"
7841	list_names(140) = "GHAASBasin140"
7842	list_names(141) = "GHAASBasin141"
7843	list_names(142) = "Flinders"
7844	list_names(143) = "Kizil Irmak"
7845	list_names(144) = "GHAASBasin144"
7846	list_names(145) = "Save"
7847	list_names(146) = "Roper"
7848	list_names(147) = "Churchill (Atlantic)"
7849	list_names(148) = "GHAASBasin148"
7850	list_names(149) = "Victoria"
7851	list_names(150) = "Back"
7852	list_names(151) = "Bandama"
7853	list_names(152) = "Severn (Can)"
7854	list_names(153) = "Po"
7855	list_names(154) = "GHAASBasin154"
7856	list_names(155) = "GHAASBasin155"
7857	list_names(156) = "GHAASBasin156"
7858	list_names(157) = "Rhone"
7859	list_names(158) = "Tana (Ken)"
7860	list_names(159) = "La Grande"
7861	list_names(160) = "GHAASBasin160"
7862	list_names(161) = "Cunene"
7863	list_names(162) = "Douro"
7864	list_names(163) = "GHAASBasin163"
7865	list_names(164) = "Nemanus"
7866	list_names(165) = "GHAASBasin165"
7867	list_names(166) = "Anabar"
7868	list_names(167) = "Hayes"
7869	list_names(168) = "Mearim"
7870	list_names(169) = "GHAASBasin169"
7871	list_names(170) = "Panuco"
7872	list_names(171) = "GHAASBasin171"
7873	list_names(172) = "Doce"
7874	list_names(173) = "Gasgoyne"
7875	list_names(174) = "GHAASBasin174"
7876	list_names(175) = "GHAASBasin175"
7877	list_names(176) = "Ashburton"
7878	list_names(177) = "GHAASBasin177"
7879	list_names(178) = "Peel"
7880	list_names(179) = "Daugava"
7881	list_names(180) = "GHAASBasin180"
7882	list_names(181) = "Ebro"
7883	list_names(182) = "Comoe"
7884	list_names(183) = "Jacui"
7885	list_names(184) = "GHAASBasin184"
7886	list_names(185) = "Kapuas"
7887	list_names(186) = "GHAASBasin186"
7888	list_names(187) = "Penzhina"
7889	list_names(188) = "Cauweri"
7890	list_names(189) = "GHAASBasin189"
7891	list_names(190) = "Mamberamo"
7892	list_names(191) = "Sepik"
7893	list_names(192) = "GHAASBasin192"
7894	list_names(193) = "Sassandra"
7895	list_names(194) = "GHAASBasin194"
7896	list_names(195) = "GHAASBasin195"
7897	list_names(196) = "Nottaway"
7898	list_names(197) = "Barito"
7899	list_names(198) = "GHAASBasin198"
7900	list_names(199) = "Seine"
7901	list_names(200) = "Tejo"
7902	list_names(201) = "GHAASBasin201"
7903	list_names(202) = "Gambia"
7904	list_names(203) = "Susquehanna"
7905	list_names(204) = "Dnestr"
7906	list_names(205) = "Murchinson"
7907	list_names(206) = "Deseado"
7908	list_names(207) = "Mitchell"
7909	list_names(208) = "Mahakam"
7910	list_names(209) = "GHAASBasin209"
7911	list_names(210) = "Pangani"
7912	list_names(211) = "GHAASBasin211"
7913	list_names(212) = "GHAASBasin212"
7914	list_names(213) = "GHAASBasin213"
7915	list_names(214) = "GHAASBasin214"
7916	list_names(215) = "GHAASBasin215"
7917	list_names(216) = "Bug"
7918	list_names(217) = "GHAASBasin217"
7919	list_names(218) = "Usumacinta"
7920	list_names(219) = "Jequitinhonha"
7921	list_names(220) = "GHAASBasin220"
7922	list_names(221) = "Corantijn"
7923	list_names(222) = "Fuchun Jiang"
7924	list_names(223) = "Copper"
7925	list_names(224) = "Tapti"
7926	list_names(225) = "Menjiang"
7927	list_names(226) = "Karun"
7928	list_names(227) = "Mezen"
7929	list_names(228) = "Guadiana"
7930	list_names(229) = "Maroni"
7931	list_names(230) = "GHAASBasin230"
7932	list_names(231) = "Uda"
7933	list_names(232) = "GHAASBasin232"
7934	list_names(233) = "Kuban"
7935	list_names(234) = "Colville"
7936	list_names(235) = "Thaane"
7937	list_names(236) = "Alazeya"
7938	list_names(237) = "Paraiba do Sul"
7939	list_names(238) = "GHAASBasin238"
7940	list_names(239) = "Fortesque"
7941	list_names(240) = "GHAASBasin240"
7942	list_names(241) = "GHAASBasin241"
7943	list_names(242) = "Winisk"
7944	list_names(243) = "GHAASBasin243"
7945	list_names(244) = "GHAASBasin244"
7946	list_names(245) = "Ikopa"
7947	list_names(246) = "Gilbert"
7948	list_names(247) = "Kouilou"
7949	list_names(248) = "Fly"
7950	list_names(249) = "GHAASBasin249"
7951	list_names(250) = "GHAASBasin250"
7952	list_names(251) = "GHAASBasin251"
7953	list_names(252) = "Mangoky"
7954	list_names(253) = "Damodar"
7955	list_names(254) = "Onega"
7956	list_names(255) = "Moulouya"
7957	list_names(256) = "GHAASBasin256"
7958	list_names(257) = "Ord"
7959	list_names(258) = "GHAASBasin258"
7960	list_names(259) = "GHAASBasin259"
7961	list_names(260) = "GHAASBasin260"
7962	list_names(261) = "GHAASBasin261"
7963	list_names(262) = "Narva"
7964	list_names(263) = "GHAASBasin263"
7965	list_names(264) = "Seal"
7966	list_names(265) = "Cheliff"
7967	list_names(266) = "Garonne"
7968	list_names(267) = "Rupert"
7969	list_names(268) = "GHAASBasin268"
7970	list_names(269) = "Brahmani"
7971	list_names(270) = "Sakarya"
7972	list_names(271) = "Gourits"
7973	list_names(272) = "Sittang"
7974	list_names(273) = "Rajang"
7975	list_names(274) = "Evros"
7976	list_names(275) = "Appalachicola"
7977	list_names(276) = "Attawapiskat"
7978	list_names(277) = "Lurio"
7979	list_names(278) = "Daly"
7980	list_names(279) = "Penner"
7981	list_names(280) = "GHAASBasin280"
7982	list_names(281) = "GHAASBasin281"
7983	list_names(282) = "Guadalquivir"
7984	list_names(283) = "Nadym"
7985	list_names(284) = "GHAASBasin284"
7986	list_names(285) = "Saint John"
7987	list_names(286) = "GHAASBasin286"
7988	list_names(287) = "Cross"
7989	list_names(288) = "Omoloy"
7990	list_names(289) = "Oueme"
7991	list_names(290) = "GHAASBasin290"
7992	list_names(291) = "Gota"
7993	list_names(292) = "Nueces"
7994	list_names(293) = "Stikine"
7995	list_names(294) = "Yalu"
7996	list_names(295) = "Arnaud"
7997	list_names(296) = "GHAASBasin296"
7998	list_names(297) = "Jequitinhonha"
7999	list_names(298) = "Kamchatka"
8000	list_names(299) = "GHAASBasin299"
8001	list_names(300) = "Grijalva"
8002	list_names(301) = "GHAASBasin301"
8003	list_names(302) = "Kemijoki"
8004	list_names(303) = "Olifants"
8005	list_names(304) = "GHAASBasin304"
8006	list_names(305) = "Tsiribihina"
8007	list_names(306) = "Coppermine"
8008	list_names(307) = "GHAASBasin307"
8009	list_names(308) = "GHAASBasin308"
8010	list_names(309) = "Kovda"
8011	list_names(310) = "Trinity"
8012	list_names(311) = "Glama"
8013	list_names(312) = "GHAASBasin312"
8014	list_names(313) = "Luan"
8015	list_names(314) = "Leichhardt"
8016	list_names(315) = "GHAASBasin315"
8017	list_names(316) = "Gurupi"
8018	list_names(317) = "GR Baleine"
8019	list_names(318) = "Aux Feuilles"
8020	list_names(319) = "GHAASBasin319"
8021	list_names(320) = "Weser"
8022	list_names(321) = "GHAASBasin321"
8023	list_names(322) = "GHAASBasin322"
8024	list_names(323) = "Yesil"
8025	list_names(324) = "Incomati"
8026	list_names(325) = "GHAASBasin325"
8027	list_names(326) = "GHAASBasin326"
8028	list_names(327) = "Pungoe"
8029	list_names(328) = "GHAASBasin328"
8030	list_names(329) = "Meuse"
8031	list_names(330) = "Eastmain"
8032	list_names(331) = "Araguari"
8033	list_names(332) = "Hudson"
8034	list_names(333) = "GHAASBasin333"
8035	list_names(334) = "GHAASBasin334"
8036	list_names(335) = "GHAASBasin335"
8037	list_names(336) = "GHAASBasin336"
8038	list_names(337) = "Kobuk"
8039	list_names(338) = "Altamaha"
8040	list_names(339) = "GHAASBasin339"
8041	list_names(340) = "Mand"
8042	list_names(341) = "Santee"
8043	list_names(342) = "GHAASBasin342"
8044	list_names(343) = "GHAASBasin343"
8045	list_names(344) = "GHAASBasin344"
8046	list_names(345) = "Hari"
8047	list_names(346) = "GHAASBasin346"
8048	list_names(347) = "Wami"
8049	list_names(348) = "GHAASBasin348"
8050	list_names(349) = "GHAASBasin349"
8051	!
8052	basin_names(:) = ' '
8053	!
8054	DO i=1,numlar
8055	tmp_str = list_names(i)
8056	basin_names(i) = tmp_str(1:MIN(lenstr,LEN_TRIM(tmp_str)))
8057	ENDDO
8058	!
8059	END SUBROUTINE routing_names
8060	!
8061	!! ================================================================================================================================
8062	!! SUBROUTINE : routing_floodmap
8063	!!
8064	!>\BRIEF This subroutine interpolates the 0.5x0.5 degree based map of irrigated areas to the resolution of the model.
8065	!!
8066	!! DESCRIPTION (definitions, functional, design, flags) : None
8067	!!
8068	!! RECENT CHANGE(S): Irrigated is interpolated from slowproc as irrigated_next
8069	!!
8070	!! MAIN OUTPUT VARIABLE(S):
8071	!!
8072	!! REFERENCES : None
8073	!!
8074	!! FLOWCHART : None
8075	!! \n
8076	!_ ================================================================================================================================
8077
8078	SUBROUTINE routing_floodmap (nbpt, index, lalo, neighbours, resolution, contfrac, &
8079	& init_flood, floodplains, init_swamp, swamp, hist_id, hist2_id)
8080	!
8081	IMPLICIT NONE
8082	!
8083	!! PARAMETERS
8084	INTEGER(i_std), PARAMETER :: ilake = 1 !! Number of type of lakes area (unitless)
8085	INTEGER(i_std), PARAMETER :: idam = 2 !! Number of type of dams area (unitless)
8086	INTEGER(i_std), PARAMETER :: iflood = 3 !! Number of type of floodplains area (unitless)
8087	INTEGER(i_std), PARAMETER :: iswamp = 4 !! Number of type of swamps area (unitless)
8088	INTEGER(i_std), PARAMETER :: isal = 5 !! Number of type of salines area (unitless)
8089	INTEGER(i_std), PARAMETER :: ipond = 6 !! Number of type of ponds area (unitless)
8090	INTEGER(i_std), PARAMETER :: ntype = 6 !! Number of types of flooded surfaces (unitless)
8091
8092	!! INPUT VARIABLES
8093	INTEGER(i_std), INTENT(in) :: nbpt !! Domain size (unitless)
8094	INTEGER(i_std), INTENT(in) :: index(nbpt) !! Index on the global map.
8095	REAL(r_std), INTENT(in) :: lalo(nbpt,2) !! Vector of latitude and longitudes (beware of the order !)
8096	INTEGER(i_std), INTENT(in) :: neighbours(nbpt,NbNeighb)!! Vector of neighbours for each grid point
8097	REAL(r_std), INTENT(in) :: resolution(nbpt,2) !! The size of each grid box in X and Y (m)
8098	REAL(r_std), INTENT(in) :: contfrac(nbpt) !! Fraction of land in each grid box (unitless;0-1)
8099	INTEGER(i_std), INTENT(in) :: hist_id !! Access to history file (unitless)
8100	INTEGER(i_std), INTENT(in) :: hist2_id !! Access to history file 2 (unitless)
8101
8102	LOGICAL, INTENT(in) :: init_flood !! Logical to initialize the floodplains (true/false)
8103	LOGICAL, INTENT(in) :: init_swamp !! Logical to initialize the swamps (true/false)
8104	!
8105	!! OUTPUT VARIABLES
8106
8107	REAL(r_std), INTENT(out) :: floodplains(:) !! Surface which can be inundated in each grid box (m^2)
8108	REAL(r_std), INTENT(out) :: swamp(:) !! Surface which can be swamp in each grid box (m^2)
8109	!
8110	!! LOCAL VARIABLES
8111	! Interpolation variables
8112	!
8113	INTEGER(i_std) :: nbpmax, nix, njx, fopt !!
8114	CHARACTER(LEN=30) :: callsign !!
8115	REAL(r_std), ALLOCATABLE, DIMENSION(:,:,:) :: resol_lu !! Resolution read on the map
8116	INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:) :: mask !! Mask to exclude some points (unitless)
8117	REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: irrsub_area !! Area on the fine grid (m^2)
8118	INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:,:) :: irrsub_index !! Indices of the points we need on the fine grid (unitless)
8119	INTEGER :: ALLOC_ERR !!
8120	LOGICAL :: ok_interpol = .FALSE. !! Flag for interpolation (true/false)
8121	!
8122	CHARACTER(LEN=80) :: filename !! Name of the netcdf file (unitless)
8123	INTEGER(i_std) :: iml, jml, lml, tml, fid, ib, ip, jp, itype !! Indices (unitless)
8124	REAL(r_std) :: lev(1), date, dt, coslat !!
8125	INTEGER(i_std) :: itau(1) !!
8126	REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: latrel !! Latitude
8127	REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: lonrel !! Longitude
8128
8129	REAL(r_std), ALLOCATABLE, DIMENSION(:,:,:) :: flood_fracmax !! Maximal flooded fraction of the grid box (unitless;0-1)
8130
8131	REAL(r_std) :: area_flood(ntype) !! Flooded surface in the grid box (m^2)
8132	REAL(r_std) :: resolution_1 !! temporary variable
8133	!!$ REAL(r_std) :: irrigmap(nbpt)
8134	!!$ REAL(r_std) :: floodmap(nbpt)
8135	!!$ REAL(r_std) :: swampmap(nbpt)
8136
8137	!_ ================================================================================================================================
8138
8139	!
8140	!Config Key = IRRIGATION_FILE
8141	!Config Desc = Name of file which contains the map of irrigated areas
8142	!Config Def = floodplains.nc
8143	!Config If = DO_IRRIGATION OR DO_FLOODPLAINS
8144	!Config Help = The name of the file to be opened to read the field
8145	!Config with the area in m^2 of the area irrigated within each
8146	!Config 0.5 0.5 deg grid box. The map currently used is the one
8147	!Config developed by the Center for Environmental Systems Research
8148	!Config in Kassel (1995).
8149	!Config Units = [FILE]
8150	!
8151	filename = 'floodplains.nc'
8152	CALL getin_p('IRRIGATION_FILE',filename)
8153	!
8154	IF (is_root_prc) THEN
8155	CALL flininfo(filename,iml, jml, lml, tml, fid)
8156	CALL flinclo(fid)
8157	ELSE
8158	iml = 0
8159	jml = 0
8160	lml = 0
8161	tml = 0
8162	ENDIF
8163	!
8164	CALL bcast(iml)
8165	CALL bcast(jml)
8166	CALL bcast(lml)
8167	CALL bcast(tml)
8168	!
8169	!
8170	!
8171	ALLOCATE (latrel(iml,jml), STAT=ALLOC_ERR)
8172	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_floodmap','Pb in allocate for latrel','','')
8173
8174	ALLOCATE (lonrel(iml,jml), STAT=ALLOC_ERR)
8175	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_floodmap','Pb in allocate for lonrel','','')
8176
8177	ALLOCATE (flood_fracmax(iml,jml,ntype), STAT=ALLOC_ERR)
8178	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_floodmap','Pb in allocate for flood_fracmax','','')
8179
8180	IF (is_root_prc) CALL flinopen(filename, .FALSE., iml, jml, lml, lonrel, latrel, lev, tml, itau, date, dt, fid)
8181
8182	CALL bcast(lonrel)
8183	CALL bcast(latrel)
8184	!
8185	IF (is_root_prc) CALL flinget(fid, 'lake', iml, jml, lml, tml, 1, 1, flood_fracmax(:,:,ilake))
8186	IF (is_root_prc) CALL flinget(fid, 'dam', iml, jml, lml, tml, 1, 1, flood_fracmax(:,:,idam))
8187	IF (is_root_prc) CALL flinget(fid, 'flood', iml, jml, lml, tml, 1, 1, flood_fracmax(:,:,iflood))
8188	IF (is_root_prc) CALL flinget(fid, 'swamp', iml, jml, lml, tml, 1, 1, flood_fracmax(:,:,iswamp))
8189	IF (is_root_prc) CALL flinget(fid, 'saline', iml, jml, lml, tml, 1, 1, flood_fracmax(:,:,isal))
8190	IF (is_root_prc) CALL flinget(fid, 'pond', iml, jml, lml, tml, 1, 1, flood_fracmax(:,:,ipond))
8191	CALL bcast(flood_fracmax)
8192	!
8193	IF (is_root_prc) CALL flinclo(fid)
8194	!
8195	! Set to zero all fraction which are less than 0.5%
8196	!
8197	DO ip=1,iml
8198	DO jp=1,jml
8199
8200	DO itype=1,ntype
8201	IF ( flood_fracmax(ip,jp,itype) .LT. undef_sechiba-1.) THEN
8202	flood_fracmax(ip,jp,itype) = flood_fracmax(ip,jp,itype)/100
8203	IF ( flood_fracmax(ip,jp,itype) < 0.005 ) flood_fracmax(ip,jp,itype) = zero
8204	ENDIF
8205	ENDDO
8206	!
8207	ENDDO
8208	ENDDO
8209
8210	IF (printlev>=2) THEN
8211	WRITE(numout,*) 'lonrel : ', MAXVAL(lonrel), MINVAL(lonrel)
8212	WRITE(numout,*) 'latrel : ', MAXVAL(latrel), MINVAL(latrel)
8213
8214	WRITE(numout,*) 'flood_fracmax : ', MINVAL(flood_fracmax, MASK=flood_fracmax .GT. 0), &
8215	MAXVAL(flood_fracmax, MASK=flood_fracmax .LT. undef_sechiba)
8216	END IF
8217
8218	! Consider all points a priori
8219	!
8220	ALLOCATE(resol_lu(iml,jml,2), STAT=ALLOC_ERR)
8221	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_floodmap','Pb in allocate for resol_lu','','')
8222
8223	ALLOCATE(mask(iml,jml), STAT=ALLOC_ERR)
8224	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_floodmap','Pb in allocate for mask','','')
8225	mask(:,:) = 0
8226
8227	DO ip=1,iml
8228	DO jp=1,jml
8229	!
8230	! Exclude the points where we are close to the missing value.
8231	!
8232	!MG This condition cannot be applied in floodplains/swamps configuration because
8233	! the same mask would be used for the interpolation of irrigation, floodplains and swamps maps.
8234	! IF ( irrigated_frac(ip,jp) < undef_sechiba ) THEN
8235	mask(ip,jp) = 1
8236	! ENDIF
8237	!
8238	! Resolution in longitude
8239	!
8240	coslat = MAX( COS( latrel(ip,jp) * pi/180. ), mincos )
8241	IF ( ip .EQ. 1 ) THEN
8242	resol_lu(ip,jp,1) = ABS( lonrel(ip+1,jp) - lonrel(ip,jp) ) * pi/180. * R_Earth * coslat
8243	ELSEIF ( ip .EQ. iml ) THEN
8244	resol_lu(ip,jp,1) = ABS( lonrel(ip,jp) - lonrel(ip-1,jp) ) * pi/180. * R_Earth * coslat
8245	ELSE
8246	resol_lu(ip,jp,1) = ABS( lonrel(ip+1,jp) - lonrel(ip-1,jp) )/2. * pi/180. * R_Earth * coslat
8247	ENDIF
8248	!
8249	! Resolution in latitude
8250	!
8251	IF ( jp .EQ. 1 ) THEN
8252	resol_lu(ip,jp,2) = ABS( latrel(ip,jp) - latrel(ip,jp+1) ) * pi/180. * R_Earth
8253	ELSEIF ( jp .EQ. jml ) THEN
8254	resol_lu(ip,jp,2) = ABS( latrel(ip,jp-1) - latrel(ip,jp) ) * pi/180. * R_Earth
8255	ELSE
8256	resol_lu(ip,jp,2) = ABS( latrel(ip,jp-1) - latrel(ip,jp+1) )/2. * pi/180. * R_Earth
8257	ENDIF
8258	!
8259	ENDDO
8260	ENDDO
8261	!
8262	! The number of maximum vegetation map points in the GCM grid is estimated.
8263	! Some lmargin is taken.
8264	!
8265	callsign = 'Flood map'
8266	ok_interpol = .FALSE.
8267	IF (is_root_prc) THEN
8268	nix=INT(MAXVAL(resolution_g(:,1))/MAXVAL(resol_lu(:,:,1)))+2
8269	njx=INT(MAXVAL(resolution_g(:,2))/MAXVAL(resol_lu(:,:,2)))+2
8270	nbpmax = nixnjx2
8271	IF (printlev>=1) THEN
8272	WRITE(numout,*) "Projection arrays for ",callsign," : "
8273	WRITE(numout,*) "nbpmax = ",nbpmax, nix, njx
8274	END IF
8275	ENDIF
8276	CALL bcast(nbpmax)
8277
8278	ALLOCATE(irrsub_index(nbpt, nbpmax, 2), STAT=ALLOC_ERR)
8279	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_floodmap','Pb in allocate for irrsub_index','','')
8280	irrsub_index(:,:,:)=0
8281
8282	ALLOCATE(irrsub_area(nbpt, nbpmax), STAT=ALLOC_ERR)
8283	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_floodmap','Pb in allocate for irrsub_area','','')
8284	irrsub_area(:,:)=zero
8285
8286	CALL aggregate_p(nbpt, lalo, neighbours, resolution, contfrac, &
8287	& iml, jml, lonrel, latrel, mask, callsign, &
8288	& nbpmax, irrsub_index, irrsub_area, ok_interpol)
8289	!
8290	!
8291	WHERE (irrsub_area < 0) irrsub_area=zero
8292	!
8293	! Test here if not all sub_area are larger than 0 if so, then we need to increase nbpmax
8294	!
8295	DO ib=1,nbpt
8296	!
8297	area_flood = 0.0
8298	!
8299	DO fopt=1,COUNT(irrsub_area(ib,:) > zero)
8300	!
8301	ip = irrsub_index(ib, fopt, 1)
8302	jp = irrsub_index(ib, fopt, 2)
8303	!
8304	DO itype=1,ntype
8305	IF (flood_fracmax(ip,jp,itype) .LT. undef_sechiba-1.) THEN
8306	area_flood(itype) = area_flood(itype) + irrsub_area(ib,fopt)*flood_fracmax(ip,jp,itype)
8307	ENDIF
8308	ENDDO
8309	ENDDO
8310	!
8311	! Put the total flooded areas in the output variables
8312	!
8313	!
8314	IF ( init_flood ) THEN
8315	! if we are at the poles resolution(ib,1) = 0
8316	IF (resolution(ib,1) == 0) THEN
8317	! use pi*resolution(ib,2) to get the disc area
8318	resolution_1 = pi*resolution(ib,2)
8319	ELSE
8320	resolution_1 = resolution(ib,1)
8321	END IF
8322	floodplains(ib) = MIN(area_flood(iflood)+area_flood(idam)+area_flood(isal), &
8323	& resolution_1resolution(ib,2)contfrac(ib))
8324	IF ( floodplains(ib) < 0 ) THEN
8325	WRITE(numout,*) 'We have a problem here : ', floodplains(ib)
8326	WRITE(numout,*) 'resolution :', resolution_1, resolution(ib,2)
8327	WRITE(numout,*) area_flood
8328	CALL ipslerr_p(3,'routing_floodmap','Problem with floodplains..','','')
8329	ENDIF
8330	!!$ ! Compute a diagnostic of the map.
8331	!!$ IF(contfrac(ib).GT.zero) THEN
8332	!!$ floodmap(ib) = floodplains(ib) / ( resolution(ib,1)resolution(ib,2)contfrac(ib) )
8333	!!$ ELSE
8334	!!$ floodmap(ib) = 0.0
8335	!!$ ENDIF
8336	ENDIF
8337	!
8338	IF ( init_swamp ) THEN
8339	! if we are at the poles resolution(ib,1) = 0
8340	IF (resolution(ib,1) == 0) THEN
8341	! use pi*resolution(ib,2) to get the disc area
8342	resolution_1 = pi*resolution(ib,2)
8343	ELSE
8344	resolution_1 = resolution(ib,1)
8345	END IF
8346	swamp(ib) = MIN(area_flood(iswamp), resolution_1resolution(ib,2)contfrac(ib))
8347	IF ( swamp(ib) < 0 ) THEN
8348	WRITE(numout,*) 'We have a problem here : ', swamp(ib)
8349	WRITE(numout,*) 'resolution :', resolution_1, resolution(ib,2)
8350	WRITE(numout,*) area_flood
8351	CALL ipslerr_p(3,'routing_floodmap','Problem with swamp...','','')
8352	ENDIF
8353	!!$ ! Compute a diagnostic of the map.
8354	!!$ IF(contfrac(ib).GT.zero) THEN
8355	!!$ swampmap(ib) = swamp(ib) / ( resolution(ib,1)resolution(ib,2)contfrac(ib) )
8356	!!$ ELSE
8357	!!$ swampmap(ib) = zero
8358	!!$ ENDIF
8359	ENDIF
8360	!
8361	!
8362	ENDDO
8363	!
8364	!
8365
8366	IF (printlev>=1) THEN
8367	IF ( init_flood ) WRITE(numout,*) "Diagnostics floodplains :", MINVAL(floodplains), MAXVAL(floodplains)
8368	IF ( init_swamp ) WRITE(numout,*) "Diagnostics swamp :", MINVAL(swamp), MAXVAL(swamp)
8369	END IF
8370
8371	! No compensation is done for overlapping floodplains, swamp and irrig. At least overlapping will not
8372	! happen between floodplains and swamp alone
8373	! IF ( init_irrig .AND. init_flood ) THEN
8374	! DO ib = 1, nbpt
8375	! surp = (floodplains(ib)+swamp(ib)+irrigated(ib)) / (resolution(ib,1)resolution(ib,2)contfrac(ib))
8376	! IF ( surp .GT. un ) THEN
8377	! floodplains(ib) = floodplains(ib) / surp
8378	! swamp(ib) = swamp(ib) / surp
8379	! irrigated(ib) = irrigated(ib) / surp
8380	! ENDIF
8381	! ENDDO
8382	! ENDIF
8383	!
8384	DEALLOCATE (irrsub_area)
8385	DEALLOCATE (irrsub_index)
8386	!
8387	DEALLOCATE (mask)
8388	DEALLOCATE (resol_lu)
8389	!
8390	DEALLOCATE (lonrel)
8391	DEALLOCATE (latrel)
8392	!
8393	END SUBROUTINE routing_floodmap
8394	!
8395	!! ================================================================================================================================
8396	!! SUBROUTINE : routing_waterbal
8397	!!
8398	!>\BRIEF This subroutine checks the water balance in the routing module.
8399	!!
8400	!! DESCRIPTION (definitions, functional, design, flags) : None
8401	!!
8402	!! RECENT CHANGE(S): None
8403	!!
8404	!! MAIN OUTPUT VARIABLE(S):
8405	!!
8406	!! REFERENCES : None
8407	!!
8408	!! FLOWCHART : None
8409	!! \n
8410	!_ ================================================================================================================================
8411
8412	SUBROUTINE routing_waterbal(nbpt, reinit, floodout, runoff, drainage, returnflow, &
8413	& reinfiltration, irrigation, riverflow, coastalflow)
8414	!
8415	IMPLICIT NONE
8416	!
8417	!! INPUT VARIABLES
8418	INTEGER(i_std), INTENT(in) :: nbpt !! Domain size (unitless)
8419	LOGICAL, INTENT(in) :: reinit !! Controls behaviour (true/false)
8420	REAL(r_std), INTENT(in) :: floodout(nbpt) !! Grid-point flow out of floodplains (kg/m^2/dt)
8421	REAL(r_std), INTENT(in) :: runoff(nbpt) !! Grid-point runoff (kg/m^2/dt)
8422	REAL(r_std), INTENT(in) :: drainage(nbpt) !! Grid-point drainage (kg/m^2/dt)
8423	REAL(r_std), INTENT(in) :: returnflow(nbpt) !! The water flow from lakes and swamps which returns to the grid box.
8424	!! This water will go back into the hydrol module to allow re-evaporation (kg/m^2/dt)
8425	REAL(r_std), INTENT(in) :: reinfiltration(nbpt) !! Water flow from ponds and floodplains which returns to the grid box (kg/m^2/dt)
8426	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)
8427	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)
8428	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)
8429	!
8430	! We sum-up all the water we have in the warious reservoirs
8431	!
8432	REAL(r_std), SAVE :: totw_flood !! Sum of all the water amount in the floodplains reservoirs (kg)
8433	!$OMP THREADPRIVATE(totw_flood)
8434	REAL(r_std), SAVE :: totw_stream !! Sum of all the water amount in the stream reservoirs (kg)
8435	!$OMP THREADPRIVATE(totw_stream)
8436	REAL(r_std), SAVE :: totw_fast !! Sum of all the water amount in the fast reservoirs (kg)
8437	!$OMP THREADPRIVATE(totw_fast)
8438	REAL(r_std), SAVE :: totw_slow !! Sum of all the water amount in the slow reservoirs (kg)
8439	!$OMP THREADPRIVATE(totw_slow)
8440	REAL(r_std), SAVE :: totw_lake !! Sum of all the water amount in the lake reservoirs (kg)
8441	!$OMP THREADPRIVATE(totw_lake)
8442	REAL(r_std), SAVE :: totw_pond !! Sum of all the water amount in the pond reservoirs (kg)
8443	!$OMP THREADPRIVATE(totw_pond)
8444	REAL(r_std), SAVE :: totw_in !! Sum of the water flow in to the routing scheme
8445	!$OMP THREADPRIVATE(totw_in)
8446	REAL(r_std), SAVE :: totw_out !! Sum of the water flow out to the routing scheme
8447	!$OMP THREADPRIVATE(totw_out)
8448	REAL(r_std), SAVE :: totw_return !!
8449	!$OMP THREADPRIVATE(totw_return)
8450	REAL(r_std), SAVE :: totw_irrig !!
8451	!$OMP THREADPRIVATE(totw_irrig)
8452	REAL(r_std), SAVE :: totw_river !!
8453	!$OMP THREADPRIVATE(totw_river)
8454	REAL(r_std), SAVE :: totw_coastal !!
8455	!$OMP THREADPRIVATE(totw_coastal)
8456	REAL(r_std) :: totarea !! Total area of basin (m^2)
8457	REAL(r_std) :: area !! Total area of routing (m^2)
8458	INTEGER(i_std) :: ig !!
8459	!
8460	! Just to make sure we do not get too large numbers !
8461	!
8462	!! PARAMETERS
8463	REAL(r_std), PARAMETER :: scaling = 1.0E+6 !!
8464	REAL(r_std), PARAMETER :: allowed_err = 50. !!
8465
8466	!_ ================================================================================================================================
8467	!
8468	IF ( reinit ) THEN
8469	!
8470	totw_flood = zero
8471	totw_stream = zero
8472	totw_fast = zero
8473	totw_slow = zero
8474	totw_lake = zero
8475	totw_pond = zero
8476	totw_in = zero
8477	!
8478	DO ig=1,nbpt
8479	!
8480	totarea = SUM(routing_area(ig,:))
8481	!
8482	totw_flood = totw_flood + SUM(flood_reservoir(ig,:)/scaling)
8483	totw_stream = totw_stream + SUM(stream_reservoir(ig,:)/scaling)
8484	totw_fast = totw_fast + SUM(fast_reservoir(ig,:)/scaling)
8485	totw_slow = totw_slow + SUM(slow_reservoir(ig,:)/scaling)
8486	totw_lake = totw_lake + lake_reservoir(ig)/scaling
8487	totw_pond = totw_pond + pond_reservoir(ig)/scaling
8488	!
8489	totw_in = totw_in + (runoff(ig)totarea + drainage(ig)totarea - floodout(ig)*totarea)/scaling
8490	!
8491	ENDDO
8492	!
8493	ELSE
8494	!
8495	totw_out = zero
8496	totw_return = zero
8497	totw_irrig = zero
8498	totw_river = zero
8499	totw_coastal = zero
8500	area = zero
8501	!
8502	DO ig=1,nbpt
8503	!
8504	totarea = SUM(routing_area(ig,:))
8505	!
8506	totw_flood = totw_flood - SUM(flood_reservoir(ig,:)/scaling)
8507	totw_stream = totw_stream - SUM(stream_reservoir(ig,:)/scaling)
8508	totw_fast = totw_fast - SUM(fast_reservoir(ig,:)/scaling)
8509	totw_slow = totw_slow - SUM(slow_reservoir(ig,:)/scaling)
8510	totw_lake = totw_lake - lake_reservoir(ig)/scaling
8511	totw_pond = totw_pond - pond_reservoir(ig)/scaling
8512	!
8513	totw_return = totw_return + (reinfiltration(ig)+returnflow(ig))*totarea/scaling
8514	totw_irrig = totw_irrig + irrigation(ig)*totarea/scaling
8515	totw_river = totw_river + riverflow(ig)/scaling
8516	totw_coastal = totw_coastal + coastalflow(ig)/scaling
8517	!
8518	area = area + totarea
8519	!
8520	ENDDO
8521	totw_out = totw_return + totw_irrig + totw_river + totw_coastal
8522	!
8523	! Now we have all the information to balance our water
8524	!
8525	IF ( ABS((totw_flood + totw_stream + totw_fast + totw_slow + totw_lake + totw_pond) - &
8526	& (totw_out - totw_in)) > allowed_err ) THEN
8527	WRITE(numout,*) 'WARNING : Water not conserved in routing. Limit at ', allowed_err, ' 10^6 kg'
8528	WRITE(numout,*) '--Water-- change : flood stream fast ', totw_flood, totw_stream, totw_fast
8529	WRITE(numout,*) '--Water-- change : slow, lake ', totw_slow, totw_lake
8530	WRITE(numout,*) '--Water>>> change in the routing res. : ', totw_flood + totw_stream + totw_fast + totw_slow + totw_lake
8531	WRITE(numout,*) '--Water input : ', totw_in
8532	WRITE(numout,*) '--Water output : ', totw_out
8533	WRITE(numout,*) '--Water output : return, irrig ', totw_return, totw_irrig
8534	WRITE(numout,*) '--Water output : river, coastal ',totw_river, totw_coastal
8535	WRITE(numout,*) '--Water>>> change by fluxes : ', totw_out - totw_in, ' Diff [mm/dt]: ', &
8536	& ((totw_flood + totw_stream + totw_fast + totw_slow + totw_lake) - (totw_out - totw_in))/area
8537
8538	! Stop the model
8539	CALL ipslerr_p(3, 'routing_waterbal', 'Water is not conserved in routing.','','')
8540	ENDIF
8541	!
8542	ENDIF
8543	!
8544	END SUBROUTINE routing_waterbal
8545	!
8546	!
8547	END MODULE routing

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

Context Navigation

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

Download in other formats: