Context Navigation

source: branches/publications/ORCHIDEE_gmd-2018-57/src_sechiba/routing.f90 @ 5143

Last change on this file since 5143 was 3965, checked in by jan.polcher, 8 years ago

Merge with trunk at revision3959.
This includes all the developments made for CMIP6 and passage to XIOS2.
All conflicts are resolved and the code compiles.

But it still does not link because of an "undefined reference to `_intel_fast_memmove'"

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

File size: 384.2 KB

Line
1	! =================================================================================================================================
2	! MODULE : routing
3	!
4	! CONTACT : orchidee-help _at_ ipsl.jussieu.fr
5	!
6	! LICENCE : IPSL (2006)
7	! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
8	!
9	!>\BRIEF This module routes the water over the continents into the oceans and computes the water
10	!! stored in floodplains or taken for irrigation.
11	!!
12	!!\n DESCRIPTION: None
13	!!
14	!! RECENT CHANGE(S): None
15	!!
16	!! REFERENCE(S) :
17	!!
18	!! SVN :
19	!! $HeadURL$
20	!! $Date$
21	!! $Revision$
22	!! \n
23	!_ ================================================================================================================================
24	!
25	!
26	! Histoire Salee
27	!---------------
28	! La douce riviere
29	! Sortant de son lit
30	! S'est jetee ma chere
31	! dans les bras mais oui
32	! du beau fleuve
33	!
34	! L'eau coule sous les ponts
35	! Et puis les flots s'emeuvent
36	! - N'etes vous pas au courant ?
37	! Il parait que la riviere
38	! Va devenir mer
39	! Roland Bacri
40	!
41
42
43	MODULE routing
44
45	USE ioipsl
46	USE xios_orchidee
47	USE ioipsl_para
48	USE constantes
49	USE constantes_soil
50	USE pft_parameters
51	USE sechiba_io
52	USE interpol_help
53	USE grid_var
54	USE grid
55	USE mod_orchidee_para
56
57	USE routing_tools
58
59	IMPLICIT NONE
60	PRIVATE
61	PUBLIC :: routing_main, routing_initialize, routing_finalize, routing_clear
62
63	!! PARAMETERS
64	INTEGER(i_std), PARAMETER :: nbasmax=5 !! The maximum number of basins we wish to have per grid box (truncation of the model) (unitless)
65	INTEGER(i_std), SAVE :: nbvmax !! The maximum number of basins we can handle at any time during the generation of the maps (unitless)
66	!$OMP THREADPRIVATE(nbvmax)
67	REAL(r_std), PARAMETER :: slow_tcst_cwrr = 25.0 !! Property of the slow reservoir, when CWRR hydrology is activated (day/m)
68	REAL(r_std), PARAMETER :: fast_tcst_cwrr = 3.0 !! Property of the fast reservoir, when CWRR hydrology is activated (day/m)
69	REAL(r_std), PARAMETER :: stream_tcst_cwrr = 0.24 !! Property of the stream reservoir, when CWRR hydrology is activated (day/m)
70	REAL(r_std), PARAMETER :: flood_tcst_cwrr = 4.0 !! Property of the floodplains reservoir, when CWRR hydrology is activated (day/m)
71	REAL(r_std), PARAMETER :: swamp_cst_cwrr = 0.2 !! Fraction of the river transport that flows to the swamps, when CWRR hydrology is activated (unitless;0-1)
72	!
73	REAL(r_std), PARAMETER :: slow_tcst_chois = 25.0 !! Property of the slow reservoir, when Choisnel hydrology is activated (day/m)
74	REAL(r_std), PARAMETER :: fast_tcst_chois = 3.0 !! Property of the fast reservoir, when Choisnel hydrology is activated (day/m)
75	REAL(r_std), PARAMETER :: stream_tcst_chois = 0.24 !! Property of the stream reservoir, when Choisnel hydrology is activated (day/m)
76	REAL(r_std), PARAMETER :: flood_tcst_chois = 4.0 !! Property of the floodplains reservoir, when Choisnel hydrology is activated (day/m)
77	REAL(r_std), PARAMETER :: swamp_cst_chois = 0.2 !! Fraction of the river transport that flows to the swamps, when Choisnel hydrology is activated (unitless;0-1)
78	!
79	REAL(r_std), SAVE :: fast_tcst !! Property of the fast reservoir, (day/m)
80	!$OMP THREADPRIVATE(fast_tcst)
81	REAL(r_std), SAVE :: slow_tcst !! Property of the slow reservoir, (day/m)
82	!$OMP THREADPRIVATE(slow_tcst)
83	REAL(r_std), SAVE :: stream_tcst !! Property of the stream reservoir, (day/m)
84	!$OMP THREADPRIVATE(stream_tcst)
85	REAL(r_std), SAVE :: flood_tcst !! Property of the floodplains reservoir, (day/m)
86	!$OMP THREADPRIVATE(flood_tcst)
87	REAL(r_std), SAVE :: swamp_cst !! Fraction of the river transport that flows to the swamps (unitless;0-1)
88	!$OMP THREADPRIVATE(swamp_cst)
89	!
90	! Relation between volume and fraction of floodplains
91	!
92	REAL(r_std), SAVE :: beta = 2.0 !! Parameter to fix the shape of the floodplain (>1 for convex edges, <1 for concave edges) (unitless)
93	!$OMP THREADPRIVATE(beta)
94	REAL(r_std), SAVE :: betap = 0.5 !! Ratio of the basin surface intercepted by ponds and the maximum surface of ponds (unitless;0-1)
95	!$OMP THREADPRIVATE(betap)
96	REAL(r_std), SAVE :: floodcri = 2000.0 !! Potential height for which all the basin is flooded (mm)
97	!$OMP THREADPRIVATE(floodcri)
98	!
99	! Relation between maximum surface of ponds and basin surface, and drainage (mm/j) to the slow_res
100	!
101	REAL(r_std), PARAMETER :: pond_bas = 50.0 !! [DISPENSABLE] - not used
102	REAL(r_std), SAVE :: pondcri = 2000.0 !! Potential height for which all the basin is a pond (mm)
103	!$OMP THREADPRIVATE(pondcri)
104	!
105	REAL(r_std), PARAMETER :: maxevap_lake = 7.5/86400. !! Maximum evaporation rate from lakes (kg/m^2/s)
106	!
107	REAL(r_std),SAVE :: dt_routing !! Routing time step (s)
108	!$OMP THREADPRIVATE(dt_routing)
109	!
110	INTEGER(i_std), SAVE :: diagunit = 87 !! Diagnostic file unit (unitless)
111	!$OMP THREADPRIVATE(diagunit)
112	!
113	! Logicals to control model configuration
114	!
115	LOGICAL, SAVE :: dofloodinfilt = .FALSE. !! Logical to choose if floodplains infiltration is activated or not (true/false)
116	!$OMP THREADPRIVATE(dofloodinfilt)
117	LOGICAL, SAVE :: doswamps = .FALSE. !! Logical to choose if swamps are activated or not (true/false)
118	!$OMP THREADPRIVATE(doswamps)
119	LOGICAL, SAVE :: doponds = .FALSE. !! Logical to choose if ponds are activated or not (true/false)
120	!$OMP THREADPRIVATE(doponds)
121	!
122	! The variables describing the basins and their routing, need to be in the restart file.
123	!
124	INTEGER(i_std), SAVE :: num_largest !! Number of largest river basins which should be treated as independently as rivers
125	!! (not flow into ocean as diffusion coastal flow) (unitless)
126	!$OMP THREADPRIVATE(num_largest)
127	REAL(r_std), SAVE :: time_counter !! Time counter (s)
128	!$OMP THREADPRIVATE(time_counter)
129	REAL(r_std), SAVE, ALLOCATABLE, TARGET, DIMENSION(:,:) :: routing_area_loc !! Surface of basin (m^2)
130	!$OMP THREADPRIVATE(routing_area_loc)
131	REAL(r_std), SAVE, ALLOCATABLE, TARGET, DIMENSION(:,:) :: topo_resid_loc !! Topographic index of the retention time (m)
132	!$OMP THREADPRIVATE(topo_resid_loc)
133	INTEGER(i_std), SAVE, ALLOCATABLE, TARGET, DIMENSION(:,:) :: route_togrid_loc !! Grid into which the basin flows (unitless)
134	!$OMP THREADPRIVATE(route_togrid_loc)
135	INTEGER(i_std), SAVE, ALLOCATABLE, TARGET, DIMENSION(:,:) :: route_tobasin_loc !! Basin in to which the water goes (unitless)
136	!$OMP THREADPRIVATE(route_tobasin_loc)
137	INTEGER(i_std), SAVE, ALLOCATABLE, TARGET, DIMENSION(:,:) :: route_nbintobas_loc !! Number of basin into current one (unitless)
138	!$OMP THREADPRIVATE(route_nbintobas_loc)
139	INTEGER(i_std), SAVE, ALLOCATABLE, TARGET, DIMENSION(:,:) :: global_basinid_loc !! ID of basin (unitless)
140	!$OMP THREADPRIVATE(global_basinid_loc)
141	INTEGER(i_std), SAVE, ALLOCATABLE, TARGET, DIMENSION(:,:) :: hydrodiag_loc !! Variable to diagnose the hydrographs
142	!$OMP THREADPRIVATE(hydrodiag_loc)
143	REAL(r_std), SAVE, ALLOCATABLE, TARGET, DIMENSION(:) :: hydroupbasin_loc !! The area upstream of the gauging station (m^2)
144	!$OMP THREADPRIVATE(hydroupbasin_loc)
145	!
146	! parallelism
147	REAL(r_std), SAVE, ALLOCATABLE, TARGET, DIMENSION(:,:) :: routing_area_glo !! Surface of basin (m^2)
148	!$OMP THREADPRIVATE(routing_area_glo)
149	REAL(r_std), SAVE, ALLOCATABLE, TARGET, DIMENSION(:,:) :: topo_resid_glo !! Topographic index of the retention time (m)
150	!$OMP THREADPRIVATE(topo_resid_glo)
151	INTEGER(i_std), SAVE, ALLOCATABLE, TARGET, DIMENSION(:,:) :: route_togrid_glo !! Grid into which the basin flows (unitless)
152	!$OMP THREADPRIVATE(route_togrid_glo)
153	INTEGER(i_std), SAVE, ALLOCATABLE, TARGET, DIMENSION(:,:) :: route_tobasin_glo !! Basin in to which the water goes (unitless)
154	!$OMP THREADPRIVATE(route_tobasin_glo)
155	INTEGER(i_std), SAVE, ALLOCATABLE, TARGET, DIMENSION(:,:) :: route_nbintobas_glo !! Number of basin into current one (unitless)
156	!$OMP THREADPRIVATE(route_nbintobas_glo)
157	INTEGER(i_std), SAVE, ALLOCATABLE, TARGET, DIMENSION(:,:) :: global_basinid_glo !! ID of basin (unitless)
158	!$OMP THREADPRIVATE(global_basinid_glo)
159	INTEGER(i_std), SAVE, ALLOCATABLE, TARGET, DIMENSION(:,:) :: hydrodiag_glo !! Variable to diagnose the hydrographs
160	!$OMP THREADPRIVATE(hydrodiag_glo)
161	REAL(r_std), SAVE, ALLOCATABLE, TARGET, DIMENSION(:) :: hydroupbasin_glo !! The area upstream of the gauging station (m^2)
162	!$OMP THREADPRIVATE(hydroupbasin_glo)
163	!
164	REAL(r_std), SAVE, POINTER, DIMENSION(:,:) :: routing_area !! Surface of basin (m^2)
165	!$OMP THREADPRIVATE(routing_area)
166	REAL(r_std), SAVE, POINTER, DIMENSION(:,:) :: topo_resid !! Topographic index of the retention time (m)
167	!$OMP THREADPRIVATE(topo_resid)
168	INTEGER(i_std), SAVE, POINTER, DIMENSION(:,:) :: route_togrid !! Grid into which the basin flows (unitless)
169	!$OMP THREADPRIVATE(route_togrid)
170	INTEGER(i_std), SAVE, POINTER, DIMENSION(:,:) :: route_tobasin !! Basin in to which the water goes (unitless)
171	!$OMP THREADPRIVATE(route_tobasin)
172	INTEGER(i_std), SAVE, POINTER, DIMENSION(:,:) :: route_nbintobas !! Number of basin into current one (unitless)
173	!$OMP THREADPRIVATE(route_nbintobas)
174	INTEGER(i_std), SAVE, POINTER, DIMENSION(:,:) :: global_basinid !! ID of basin (unitless)
175	!$OMP THREADPRIVATE(global_basinid)
176	INTEGER(i_std), SAVE, POINTER, DIMENSION(:,:) :: hydrodiag !! Variable to diagnose the hydrographs
177	!$OMP THREADPRIVATE(hydrodiag)
178	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: slowflow_diag !! Diagnostic slow flow hydrographs (kg/dt)
179	!$OMP THREADPRIVATE(slowflow_diag)
180	REAL(r_std), SAVE, POINTER, DIMENSION(:) :: hydroupbasin !! The area upstream of the gauging station (m^2)
181	!$OMP THREADPRIVATE(hydroupbasin)
182	!
183	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: irrigated !! Area equipped for irrigation in each grid box (m^2)
184	!$OMP THREADPRIVATE(irrigated)
185	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: floodplains !! Maximal surface which can be inundated in each grid box (m^2)
186	!$OMP THREADPRIVATE(floodplains)
187	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: swamp !! Maximal surface of swamps in each grid box (m^2)
188	!$OMP THREADPRIVATE(swamp)
189	!
190	! The reservoirs, also to be put into the restart file.
191	!
192	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:,:) :: fast_reservoir !! Water amount in the fast reservoir (kg)
193	!$OMP THREADPRIVATE(fast_reservoir)
194	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:,:) :: slow_reservoir !! Water amount in the slow reservoir (kg)
195	!$OMP THREADPRIVATE(slow_reservoir)
196	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:,:) :: stream_reservoir !! Water amount in the stream reservoir (kg)
197	!$OMP THREADPRIVATE(stream_reservoir)
198	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:,:) :: flood_reservoir !! Water amount in the floodplains reservoir (kg)
199	!$OMP THREADPRIVATE(flood_reservoir)
200	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: lake_reservoir !! Water amount in the lake reservoir (kg)
201	!$OMP THREADPRIVATE(lake_reservoir)
202	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: pond_reservoir !! Water amount in the pond reservoir (kg)
203	!$OMP THREADPRIVATE(pond_reservoir)
204	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:,:) :: flood_frac_bas !! Flooded fraction per basin (unitless;0-1)
205	!$OMP THREADPRIVATE(flood_frac_bas)
206	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: pond_frac !! Pond fraction per grid box (unitless;0-1)
207	!$OMP THREADPRIVATE(pond_frac)
208	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: flood_height !! Floodplain height (mm)
209	!$OMP THREADPRIVATE(flood_height)
210	!
211	! The accumulated fluxes.
212	!
213	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: floodout_mean !! Accumulated flow out of floodplains (kg/m^2/dt)
214	!$OMP THREADPRIVATE(floodout_mean)
215	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: runoff_mean !! Accumulated runoff (kg/m^2/dt)
216	!$OMP THREADPRIVATE(runoff_mean)
217	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: drainage_mean !! Accumulated drainage (kg/m^2/dt)
218	!$OMP THREADPRIVATE(drainage_mean)
219	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: transpot_mean !! Mean potential transpiration from the plants (kg/m^2/dt)
220	!$OMP THREADPRIVATE(transpot_mean)
221	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: precip_mean !! Accumulated precipitation (kg/m^2/dt)
222	!$OMP THREADPRIVATE(precip_mean)
223	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: humrel_mean !! Mean soil moisture stress, mean root extraction potential (unitless)
224	!$OMP THREADPRIVATE(humrel_mean)
225	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: totnobio_mean !! Mean last total fraction of no bio (unitless;0-1)
226	!$OMP THREADPRIVATE(totnobio_mean)
227	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: vegtot_mean !! Mean potentially vegetated fraction (unitless;0-1)
228	!$OMP THREADPRIVATE(vegtot_mean)
229	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: k_litt_mean !! Mean averaged conductivity for saturated infiltration in the 'litter' layer (kg/m^2/dt)
230	!$OMP THREADPRIVATE(k_litt_mean)
231	!
232	! The averaged outflow fluxes.
233	!
234	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: lakeinflow_mean !! Mean lake inflow (kg/m^2/dt)
235	!$OMP THREADPRIVATE(lakeinflow_mean)
236	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: returnflow_mean !! Mean water flow from lakes and swamps which returns to the grid box.
237	!! This water will go back into the hydrol or hydrolc module to allow re-evaporation (kg/m^2/dt)
238	!$OMP THREADPRIVATE(returnflow_mean)
239	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: reinfiltration_mean !! Mean water flow which returns to the grid box (kg/m^2/dt)
240	!$OMP THREADPRIVATE(reinfiltration_mean)
241	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: irrigation_mean !! Mean irrigation flux.
242	!! This is the water taken from the reservoirs and beeing put into the upper layers of the soil (kg/m^2/dt)
243	!$OMP THREADPRIVATE(irrigation_mean)
244	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: riverflow_mean !! Mean Outflow of the major rivers.
245	!! The flux will be located on the continental grid but this should be a coastal point (kg/dt)
246	!$OMP THREADPRIVATE(riverflow_mean)
247	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: coastalflow_mean !! Mean outflow on coastal points by small basins.
248	!! This is the water which flows in a disperse way into the ocean (kg/dt)
249	!$OMP THREADPRIVATE(coastalflow_mean)
250	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: floodtemp !! Temperature to decide if floodplains work (K)
251	!$OMP THREADPRIVATE(floodtemp)
252	INTEGER(i_std), SAVE :: floodtemp_lev !! Temperature level to decide if floodplains work (K)
253	!$OMP THREADPRIVATE(floodtemp_lev)
254	!
255	! Diagnostic variables ... well sort of !
256	!
257	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: irrig_netereq !! Irrigation requirement (water requirements by the crop for its optimal growth (kg/m^2/dt)
258	!$OMP THREADPRIVATE(irrig_netereq)
259	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: hydrographs !! Hydrographs at the outflow of the grid box for major basins (kg/dt)
260	!$OMP THREADPRIVATE(hydrographs)
261	!
262	! Diagnostics for the various reservoirs we use (Kg/m^2)
263	!
264	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: fast_diag !! Diagnostic for the fast reservoir (kg/m^2)
265	!$OMP THREADPRIVATE(fast_diag)
266	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: slow_diag !! Diagnostic for the slow reservoir (kg/m^2)
267	!$OMP THREADPRIVATE(slow_diag)
268	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: stream_diag !! Diagnostic for the stream reservoir (kg/m^2)
269	!$OMP THREADPRIVATE(stream_diag)
270	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: flood_diag !! Diagnostic for the floodplain reservoir (kg/m^2)
271	!$OMP THREADPRIVATE(flood_diag)
272	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: pond_diag !! Diagnostic for the pond reservoir (kg/m^2)
273	!$OMP THREADPRIVATE(pond_diag)
274	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: lake_diag !! Diagnostic for the lake reservoir (kg/m^2)
275	!$OMP THREADPRIVATE(lake_diag)
276
277	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: mask_coast !! Mask with coastal gridcells on local grid(1/0)
278	!$OMP THREADPRIVATE(mask_coast)
279	REAL(r_std), SAVE :: max_lake_reservoir !! Maximum limit of water in lake_reservoir [kg/m2]
280	!$OMP THREADPRIVATE(max_lake_reservoir)
281	INTEGER(i_std), SAVE :: nb_coast_gridcells !! Number of gridcells which can receive coastalflow
282
283
284	CONTAINS
285	!! =============================================================================================================================
286	!! SUBROUTINE: routing_initialize
287	!!
288	!>\BRIEF Initialize the routing module
289	!!
290	!! DESCRIPTION: Initialize the routing module. Read from restart file or read the routing.nc file to initialize the
291	!! routing scheme.
292	!!
293	!! RECENT CHANGE(S)
294	!!
295	!! REFERENCE(S)
296	!!
297	!! FLOWCHART
298	!! \n
299	!_ ==============================================================================================================================
300
301	SUBROUTINE routing_initialize( kjit, nbpt, index, &
302	rest_id, hist_id, hist2_id, lalo, &
303	neighbours, resolution, contfrac, stempdiag, &
304	returnflow, reinfiltration, irrigation, riverflow, &
305	coastalflow, flood_frac, flood_res )
306
307	IMPLICIT NONE
308
309	!! 0.1 Input variables
310	INTEGER(i_std), INTENT(in) :: kjit !! Time step number (unitless)
311	INTEGER(i_std), INTENT(in) :: nbpt !! Domain size (unitless)
312	INTEGER(i_std), INTENT(in) :: index(nbpt) !! Indices of the points on the map (unitless)
313	INTEGER(i_std),INTENT(in) :: rest_id !! Restart file identifier (unitless)
314	INTEGER(i_std),INTENT(in) :: hist_id !! Access to history file (unitless)
315	INTEGER(i_std),INTENT(in) :: hist2_id !! Access to history file 2 (unitless)
316	REAL(r_std), INTENT(in) :: lalo(nbpt,2) !! Vector of latitude and longitudes (beware of the order !)
317
318	INTEGER(i_std), INTENT(in) :: neighbours(nbpt,NbNeighb) !! Vector of neighbours for each grid point
319	!! (1=N, 2=NE, 3=E, 4=SE, 5=S, 6=SW, 7=W, 8=NW) (unitless)
320	REAL(r_std), INTENT(in) :: resolution(nbpt,2) !! The size of each grid box in X and Y (m)
321	REAL(r_std), INTENT(in) :: contfrac(nbpt) !! Fraction of land in each grid box (unitless;0-1)
322	REAL(r_std), INTENT(in) :: stempdiag(nbpt,nbdl) !! Diagnostic soil temperature profile
323
324	!! 0.2 Output variables
325	REAL(r_std), INTENT(out) :: returnflow(nbpt) !! The water flow from lakes and swamps which returns to the grid box.
326	!! This water will go back into the hydrol or hydrolc module to allow re-evaporation (kg/m^2/dt)
327	REAL(r_std), INTENT(out) :: reinfiltration(nbpt) !! Water flow from ponds and floodplains which returns to the grid box (kg/m^2/dt)
328	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)
329	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)
330
331	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)
332	REAL(r_std), INTENT(out) :: flood_frac(nbpt) !! Flooded fraction of the grid box (unitless;0-1)
333	REAL(r_std), INTENT(out) :: flood_res(nbpt) !! Diagnostic of water amount in the floodplains reservoir (kg)
334
335	!! 0.3 Local variables
336	REAL(r_std), DIMENSION(nbp_glo):: mask_coast_glo !! Mask with coastal gridcells on global grid (1/0)
337	LOGICAL :: init_irrig !! Logical to initialize the irrigation (true/false)
338	LOGICAL :: init_flood !! Logical to initialize the floodplains (true/false)
339	LOGICAL :: init_swamp !! Logical to initialize the swamps (true/false)
340	INTEGER :: ig, ib, rtg, rtb !! Index
341	INTEGER :: ier !! Error handeling
342	!_ ================================================================================================================================
343
344	!
345	! do initialisation
346	!
347	nbvmax = 440
348	! Here we will allocate the memory and get the fixed fields from the restart file.
349	! If the info is not found then we will compute the routing map.
350	!
351
352	CALL routing_init (kjit, nbpt, index, returnflow, reinfiltration, irrigation, &
353	riverflow, coastalflow, flood_frac, flood_res, stempdiag, rest_id)
354
355	routing_area => routing_area_loc
356	topo_resid => topo_resid_loc
357	route_togrid => route_togrid_loc
358	route_tobasin => route_tobasin_loc
359	global_basinid => global_basinid_loc
360	hydrodiag => hydrodiag_loc
361
362	! This routine computes the routing map if the route_togrid_glo is undefined. This means that the
363	! map has not been initialized during the restart process..
364	!
365	!! Reads in the map of the basins and flow directions to construct the catchments of each grid box
366	!
367	IF ( COUNT(route_togrid_glo .GE. undef_int) .GT. 0 ) THEN
368	CALL routing_basins_p(nbpt, lalo, neighbours, resolution, contfrac)
369	ENDIF
370
371	!! Create a mask containing all possible coastal gridcells and count total number of coastal gridcells
372	IF (is_root_prc) THEN
373	mask_coast_glo(:)=0
374	DO ib=1,nbasmax
375	DO ig=1,nbp_glo
376	rtg = route_togrid_glo(ig,ib)
377	rtb = route_tobasin_glo(ig,ib)
378	! Coastal gridcells are stored in nbasmax+2
379	IF (rtb == nbasmax+2) THEN
380	mask_coast_glo(rtg) = 1
381	END IF
382	END DO
383	END DO
384	nb_coast_gridcells=SUM(mask_coast_glo)
385	IF (printlev>=3) WRITE(numout,*) 'Number of coastal gridcells = ', nb_coast_gridcells
386	ENDIF
387	CALL bcast(nb_coast_gridcells)
388
389	ALLOCATE(mask_coast(nbpt), stat=ier)
390	IF (ier /= 0) CALL ipslerr_p(3,'routing_inititalize','Pb in allocate for mask_coast','','')
391	CALL scatter(mask_coast_glo, mask_coast)
392	CALL xios_orchidee_send_field("mask_coast",mask_coast)
393
394
395	!
396	! Do we have what we need if we want to do irrigation
397	!! Initialisation of flags for irrigated land, flood plains and swamps
398	!
399	init_irrig = .FALSE.
400	IF ( do_irrigation ) THEN
401	IF (COUNT(irrigated .GE. undef_sechiba-1) > 0) init_irrig = .TRUE.
402	END IF
403
404	init_flood = .FALSE.
405	IF ( do_floodplains ) THEN
406	IF (COUNT(floodplains .GE. undef_sechiba-1) > 0) init_flood = .TRUE.
407	END IF
408
409	init_swamp = .FALSE.
410	IF ( doswamps ) THEN
411	IF (COUNT(swamp .GE. undef_sechiba-1) > 0 ) init_swamp = .TRUE.
412	END IF
413
414	!! If we have irrigated land, flood plains or swamps then we need to interpolate the 0.5 degree
415	!! base data set to the resolution of the model.
416
417	IF ( init_irrig .OR. init_flood .OR. init_swamp ) THEN
418	CALL routing_irrigmap(nbpt, index, lalo, neighbours, resolution, &
419	contfrac, init_irrig, irrigated, init_flood, floodplains, init_swamp, swamp, hist_id, hist2_id)
420	ENDIF
421
422	IF ( do_irrigation ) THEN
423	CALL xios_orchidee_send_field("irrigmap",irrigated)
424
425	WRITE(numout,*) 'Verification : range of irrigated : ', MINVAL(irrigated), MAXVAL(irrigated)
426	IF ( .NOT. almaoutput ) THEN
427	CALL histwrite_p(hist_id, 'irrigmap', 1, irrigated, nbpt, index)
428	ELSE
429	CALL histwrite_p(hist_id, 'IrrigationMap', 1, irrigated, nbpt, index)
430	ENDIF
431	IF ( hist2_id > 0 ) THEN
432	IF ( .NOT. almaoutput ) THEN
433	CALL histwrite_p(hist2_id, 'irrigmap', 1, irrigated, nbpt, index)
434	ELSE
435	CALL histwrite_p(hist2_id, 'IrrigationMap', 1, irrigated, nbpt, index)
436	ENDIF
437	ENDIF
438	ENDIF
439
440	IF ( do_floodplains ) THEN
441	CALL xios_orchidee_send_field("floodmap",floodplains)
442
443	WRITE(numout,*) 'Verification : range of floodplains : ', MINVAL(floodplains), MAXVAL(floodplains)
444	IF ( .NOT. almaoutput ) THEN
445	CALL histwrite_p(hist_id, 'floodmap', 1, floodplains, nbpt, index)
446	ELSE
447	CALL histwrite_p(hist_id, 'FloodplainsMap', 1, floodplains, nbpt, index)
448	ENDIF
449	IF ( hist2_id > 0 ) THEN
450	IF ( .NOT. almaoutput ) THEN
451	CALL histwrite_p(hist2_id, 'floodmap', 1, floodplains, nbpt, index)
452	ELSE
453	CALL histwrite_p(hist2_id, 'FloodplainsMap', 1, floodplains, nbpt, index)
454	ENDIF
455	ENDIF
456	ENDIF
457
458	IF ( doswamps ) THEN
459	CALL xios_orchidee_send_field("swampmap",swamp)
460
461	WRITE(numout,*) 'Verification : range of swamp : ', MINVAL(swamp), MAXVAL(swamp)
462	IF ( .NOT. almaoutput ) THEN
463	CALL histwrite_p(hist_id, 'swampmap', 1, swamp, nbpt, index)
464	ELSE
465	CALL histwrite_p(hist_id, 'SwampMap', 1, swamp, nbpt, index)
466	ENDIF
467	IF ( hist2_id > 0 ) THEN
468	IF ( .NOT. almaoutput ) THEN
469	CALL histwrite_p(hist2_id, 'swampmap', 1, swamp, nbpt, index)
470	ELSE
471	CALL histwrite_p(hist2_id, 'SwampMap', 1, swamp, nbpt, index)
472	ENDIF
473	ENDIF
474	ENDIF
475
476	!! This routine gives a diagnostic of the basins used.
477	CALL routing_diagnostic_p(nbpt, index, lalo, resolution, contfrac, hist_id, hist2_id)
478
479	END SUBROUTINE routing_initialize
480
481	!! ================================================================================================================================
482	!! SUBROUTINE : routing_main
483	!!
484	!>\BRIEF This module routes the water over the continents (runoff and
485	!! drainage produced by the hydrolc or hydrol module) into the oceans.
486	!!
487	!! DESCRIPTION (definitions, functional, design, flags):
488	!! The routing scheme (Polcher, 2003) carries the water from the runoff and drainage simulated by SECHIBA
489	!! to the ocean through reservoirs, with some delay. The routing scheme is based on
490	!! a parametrization of the water flow on a global scale (Miller et al., 1994; Hagemann
491	!! and Dumenil, 1998). Given the global map of the main watersheds (Oki et al., 1999;
492	!! Fekete et al., 1999; Vorosmarty et al., 2000) which delineates the boundaries of subbasins
493	!! and gives the eight possible directions of water flow within the pixel, the surface
494	!! runoff and the deep drainage are routed to the ocean. The time-step of the routing is one day.
495	!! The scheme also diagnoses how much water is retained in the foodplains and thus return to soil
496	!! moisture or is taken out of the rivers for irrigation. \n
497	!!
498	!! RECENT CHANGE(S): None
499	!!
500	!! MAIN OUTPUT VARIABLE(S):
501	!! The result of the routing are 3 fluxes :
502	!! - riverflow : The water which flows out from the major rivers. The flux will be located
503	!! on the continental grid but this should be a coastal point.
504	!! - coastalflow : This is the water which flows in a disperse way into the ocean. Essentially these
505	!! are the outflows from all of the small rivers.
506	!! - returnflow : This is the water which flows into a land-point - typically rivers which end in
507	!! the desert. This water will go back into the hydrol module to allow re-evaporation.
508	!! - irrigation : This is water taken from the reservoir and is being put into the upper
509	!! layers of the soil.
510	!! The two first fluxes are in kg/dt and the last two fluxes are in kg/(m^2dt).\n
511	!!
512	!! REFERENCE(S) :
513	!! - Miller JR, Russell GL, Caliri G (1994)
514	!! Continental-scale river flow in climate models.
515	!! J. Clim., 7:914-928
516	!! - Hagemann S and Dumenil L. (1998)
517	!! A parametrization of the lateral waterflow for the global scale.
518	!! Clim. Dyn., 14:17-31
519	!! - Oki, T., T. Nishimura, and P. Dirmeyer (1999)
520	!! Assessment of annual runoff from land surface models using total runoff integrating pathways (TRIP)
521	!! J. Meteorol. Soc. Jpn., 77, 235-255
522	!! - Fekete BM, Charles V, Grabs W (2000)
523	!! Global, composite runoff fields based on observed river discharge and simulated water balances.
524	!! Technical report, UNH/GRDC, Global Runoff Data Centre, Koblenz
525	!! - Vorosmarty, C., B. Fekete, B. Meybeck, and R. Lammers (2000)
526	!! Global system of rivers: Its role in organizing continental land mass and defining land-to-ocean linkages
527	!! Global Biogeochem. Cycles, 14, 599-621
528	!! - Vivant, A-C. (?? 2002)
529	!! DÃ©veloppement du schÃ©ma de routage et des plaines d'inondation, MSc Thesis, Paris VI University
530	!! - J. Polcher (2003)
531	!! Les processus de surface a l'echelle globale et leurs interactions avec l'atmosphere
532	!! Habilitation a diriger les recherches, Paris VI University, 67pp.
533	!!
534	!! FLOWCHART :
535	!! \latexonly
536	!! \includegraphics[scale=0.75]{routing_main_flowchart.png}
537	!! \endlatexonly
538	!! \n
539	!_ ================================================================================================================================
540
541	SUBROUTINE routing_main(kjit, nbpt, index, &
542	& lalo, neighbours, resolution, contfrac, totfrac_nobio, veget_max, floodout, runoff, &
543	& drainage, transpot, precip_rain, humrel, k_litt, flood_frac, flood_res, &
544	& stempdiag, reinf_slope, returnflow, reinfiltration, irrigation, riverflow, coastalflow, rest_id, hist_id, hist2_id)
545
546	IMPLICIT NONE
547
548	!! 0.1 Input variables
549	INTEGER(i_std), INTENT(in) :: kjit !! Time step number (unitless)
550	INTEGER(i_std), INTENT(in) :: nbpt !! Domain size (unitless)
551	INTEGER(i_std),INTENT(in) :: rest_id !! Restart file identifier (unitless)
552	INTEGER(i_std),INTENT(in) :: hist_id !! Access to history file (unitless)
553	INTEGER(i_std),INTENT(in) :: hist2_id !! Access to history file 2 (unitless)
554	INTEGER(i_std), INTENT(in) :: index(nbpt) !! Indices of the points on the map (unitless)
555	REAL(r_std), INTENT(in) :: lalo(nbpt,2) !! Vector of latitude and longitudes (beware of the order !)
556	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)
557	REAL(r_std), INTENT(in) :: resolution(nbpt,2) !! The size of each grid box in X and Y (m)
558	REAL(r_std), INTENT(in) :: contfrac(nbpt) !! Fraction of land in each grid box (unitless;0-1)
559	REAL(r_std), INTENT(in) :: totfrac_nobio(nbpt) !! Total fraction of no-vegetation (continental ice, lakes ...) (unitless;0-1)
560	REAL(r_std), INTENT(in) :: veget_max(nbpt,nvm) !! Maximal fraction of vegetation (unitless;0-1)
561	REAL(r_std), INTENT(in) :: floodout(nbpt) !! Grid-point flow out of floodplains (kg/m^2/dt)
562	REAL(r_std), INTENT(in) :: runoff(nbpt) !! Grid-point runoff (kg/m^2/dt)
563	REAL(r_std), INTENT(in) :: drainage(nbpt) !! Grid-point drainage (kg/m^2/dt)
564	REAL(r_std), INTENT(in) :: transpot(nbpt,nvm) !! Potential transpiration of the vegetation (kg/m^2/dt)
565	REAL(r_std), INTENT(in) :: precip_rain(nbpt) !! Rainfall (kg/m^2/dt)
566	REAL(r_std), INTENT(in) :: k_litt(nbpt) !! Averaged conductivity for saturated infiltration in the 'litter' layer (kg/m^2/dt)
567	REAL(r_std), INTENT(in) :: humrel(nbpt,nvm) !! Soil moisture stress, root extraction potential (unitless)
568	REAL(r_std), INTENT(in) :: stempdiag(nbpt,nbdl) !! Diagnostic soil temperature profile
569	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)
570
571	!! 0.2 Output variables
572	REAL(r_std), INTENT(out) :: returnflow(nbpt) !! The water flow from lakes and swamps which returns to the grid box.
573	!! This water will go back into the hydrol or hydrolc module to allow re-evaporation (kg/m^2/dt)
574	REAL(r_std), INTENT(out) :: reinfiltration(nbpt) !! Water flow from ponds and floodplains which returns to the grid box (kg/m^2/dt)
575	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)
576	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)
577	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)
578	REAL(r_std), INTENT(out) :: flood_frac(nbpt) !! Flooded fraction of the grid box (unitless;0-1)
579	REAL(r_std), INTENT(out) :: flood_res(nbpt) !! Diagnostic of water amount in the floodplains reservoir (kg)
580
581	!! 0.3 Local variables
582	CHARACTER(LEN=30) :: var_name !! To store variables names for I/O (unitless)
583	REAL(r_std), DIMENSION(1) :: tmp_day !!
584	REAL(r_std), DIMENSION(nbpt) :: return_lakes !! Water from lakes flowing back into soil moisture (kg/m^2/dt)
585
586	INTEGER(i_std) :: ig, jv !! Indices (unitless)
587	REAL(r_std), DIMENSION(nbpt) :: tot_vegfrac_nowoody !! Total fraction occupied by grass (0-1,unitless)
588
589	REAL(r_std), DIMENSION(nbpt) :: fast_diag_old !! Reservoir in the beginning of the time step
590	REAL(r_std), DIMENSION(nbpt) :: slow_diag_old !! Reservoir in the beginning of the time step
591	REAL(r_std), DIMENSION(nbpt) :: stream_diag_old !! Reservoir in the beginning of the time step
592	REAL(r_std), DIMENSION(nbpt) :: lake_diag_old !! Reservoir in the beginning of the time step
593	REAL(r_std), DIMENSION(nbpt) :: pond_diag_old !! Reservoir in the beginning of the time step
594	REAL(r_std), DIMENSION(nbpt) :: flood_diag_old !! Reservoir in the beginning of the time step
595
596	!! For water budget check in the three routing reservoirs (positive if input > output)
597	!! Net fluxes averaged over each grid cell in kg/m^2/dt
598	REAL(r_std), DIMENSION(nbpt) :: netflow_stream_diag !! Input - Output flow to stream reservoir
599	REAL(r_std), DIMENSION(nbpt) :: netflow_fast_diag !! Input - Output flow to fast reservoir
600	REAL(r_std), DIMENSION(nbpt) :: netflow_slow_diag !! Input - Output flow to slow reservoir
601
602
603	!_ ================================================================================================================================
604
605	! Save reservoirs in beginning of time step to calculate the water budget
606	fast_diag_old = fast_diag
607	slow_diag_old = slow_diag
608	stream_diag_old = stream_diag
609	lake_diag_old = lake_diag
610	pond_diag_old = pond_diag
611	flood_diag_old = flood_diag
612
613	!
614	!! Computes the variables averaged between routing time steps and which will be used in subsequent calculations
615	!
616	floodout_mean(:) = floodout_mean(:) + floodout(:)
617	runoff_mean(:) = runoff_mean(:) + runoff(:)
618	drainage_mean(:) = drainage_mean(:) + drainage(:)
619	floodtemp(:) = stempdiag(:,floodtemp_lev)
620	precip_mean(:) = precip_mean(:) + precip_rain(:)
621	!
622	!! Computes the total fraction occupied by the grasses and the crops for each grid cell
623	tot_vegfrac_nowoody(:) = zero
624	DO jv = 1, nvm
625	IF ( (jv /= ibare_sechiba) .AND. .NOT.(is_tree(jv)) ) THEN
626	tot_vegfrac_nowoody(:) = tot_vegfrac_nowoody(:) + veget_max(:,jv)
627	END IF
628	END DO
629
630	DO ig = 1, nbpt
631	IF ( tot_vegfrac_nowoody(ig) .GT. min_sechiba ) THEN
632	DO jv = 1,nvm
633	IF ( (jv /= ibare_sechiba) .AND. .NOT.(is_tree(jv)) ) THEN
634	transpot_mean(ig) = transpot_mean(ig) + transpot(ig,jv) * veget_max(ig,jv)/tot_vegfrac_nowoody(ig)
635	END IF
636	END DO
637	ELSE
638	IF (MAXVAL(veget_max(ig,2:nvm)) .GT. min_sechiba) THEN
639	DO jv = 2, nvm
640	transpot_mean(ig) = transpot_mean(ig) + transpot(ig,jv) * veget_max(ig,jv)/ SUM(veget_max(ig,2:nvm))
641	ENDDO
642	ENDIF
643	ENDIF
644	ENDDO
645
646	!
647	! Averaged variables (i.e. *dt_sechiba/dt_routing). This accounts for the difference between the shorter
648	! timestep dt_sechiba of other parts of the model and the long dt_routing timestep (set to one day at present)
649	!
650	totnobio_mean(:) = totnobio_mean(:) + totfrac_nobio(:)*dt_sechiba/dt_routing
651	k_litt_mean(:) = k_litt_mean(:) + k_litt(:)*dt_sechiba/dt_routing
652	!
653	! Only potentially vegetated surfaces are taken into account. At the start of
654	! the growing seasons we will give more weight to these areas.
655	!
656	DO jv=2,nvm
657	DO ig=1,nbpt
658	humrel_mean(ig) = humrel_mean(ig) + humrel(ig,jv)veget_max(ig,jv)dt_sechiba/dt_routing
659	vegtot_mean(ig) = vegtot_mean(ig) + veget_max(ig,jv)*dt_sechiba/dt_routing
660	ENDDO
661	ENDDO
662	!
663	time_counter = time_counter + dt_sechiba
664	!
665	! If the time has come we do the routing.
666	!
667	IF ( NINT(time_counter) .GE. NINT(dt_routing) ) THEN
668	!
669	! Check the water balance if needed
670	!
671	IF ( check_waterbal ) THEN
672	CALL routing_waterbal(nbpt, .TRUE., floodout_mean, runoff_mean, drainage_mean, returnflow_mean, &
673	& reinfiltration_mean, irrigation_mean, riverflow_mean, coastalflow_mean)
674	ENDIF
675	!
676	! Make sure we do not flood north of 49N as there freezing processes start to play a role and they
677	! are not yet well treated in ORCHIDEE.
678	!
679	DO ig=1,nbpt
680	IF ( lalo(ig,1) > 49.0 ) THEN
681	floodtemp(ig) = tp_00 - un
682	ENDIF
683	ENDDO
684	!
685	!! Computes the transport of water in the various reservoirs
686	!
687	CALL routing_flow(nbpt, dt_routing, lalo, floodout_mean, runoff_mean, drainage_mean, &
688	& vegtot_mean, totnobio_mean, transpot_mean, precip_mean, humrel_mean, k_litt_mean, floodtemp, reinf_slope, &
689	& lakeinflow_mean, returnflow_mean, reinfiltration_mean, irrigation_mean, riverflow_mean, &
690	& coastalflow_mean, hydrographs, slowflow_diag, flood_frac, flood_res, &
691	& netflow_stream_diag, netflow_fast_diag, netflow_slow_diag)
692	!
693	!! Responsible for storing the water in lakes
694	!
695	CALL routing_lake(nbpt, dt_routing, lakeinflow_mean, humrel_mean, return_lakes)
696	!
697	returnflow_mean(:) = returnflow_mean(:) + return_lakes(:)
698	!
699	!! Check the water balance in the routing scheme
700	!
701	IF ( check_waterbal ) THEN
702	CALL routing_waterbal(nbpt, .FALSE., floodout_mean, runoff_mean, drainage_mean, returnflow_mean, &
703	& reinfiltration_mean, irrigation_mean, riverflow_mean, coastalflow_mean)
704	ENDIF
705	!
706	time_counter = zero
707	!
708	floodout_mean(:) = zero
709	runoff_mean(:) = zero
710	drainage_mean(:) = zero
711	transpot_mean(:) = zero
712	precip_mean(:) = zero
713	!
714	humrel_mean(:) = zero
715	totnobio_mean(:) = zero
716	k_litt_mean(:) = zero
717	vegtot_mean(:) = zero
718
719	! Change the units of the routing fluxes from kg/dt_routing into kg/dt_sechiba
720	hydrographs(:) = hydrographs(:)/dt_routing*dt_sechiba
721	slowflow_diag(:) = slowflow_diag(:)/dt_routing*dt_sechiba
722
723	! Change the units of the routing fluxes from kg/m^2/dt_routing into kg/m^2/dt_sechiba
724	returnflow_mean(:) = returnflow_mean(:)/dt_routing*dt_sechiba
725	reinfiltration_mean(:) = reinfiltration_mean(:)/dt_routing*dt_sechiba
726	irrigation_mean(:) = irrigation_mean(:)/dt_routing*dt_sechiba
727	irrig_netereq(:) = irrig_netereq(:)/dt_routing*dt_sechiba
728
729	! Change units as above but at the same time transform the kg/dt_routing to m^3/dt_sechiba
730	riverflow_mean(:) = riverflow_mean(:)/dt_routing*dt_sechiba/mille
731	coastalflow_mean(:) = coastalflow_mean(:)/dt_routing*dt_sechiba/mille
732
733	! Water budget residu of the three routing reservoirs (in kg/m^2/s)
734	! Note that these diagnostics are done using local variables only calculated
735	! during the time steps when the routing is calculated
736	CALL xios_orchidee_send_field("wbr_stream",(stream_diag - stream_diag_old - netflow_stream_diag)/dt_routing)
737	CALL xios_orchidee_send_field("wbr_fast", (fast_diag - fast_diag_old - netflow_fast_diag)/dt_routing)
738	CALL xios_orchidee_send_field("wbr_slow", (slow_diag - slow_diag_old - netflow_slow_diag)/dt_routing)
739	CALL xios_orchidee_send_field("wbr_lake", (lake_diag - lake_diag_old - &
740	lakeinflow_mean + return_lakes)/dt_routing)
741	ENDIF
742
743	!
744	! Return the fraction of routed water for this time step.
745	!
746	returnflow(:) = returnflow_mean(:)
747	reinfiltration(:) = reinfiltration_mean(:)
748	irrigation(:) = irrigation_mean(:)
749	riverflow(:) = riverflow_mean(:)
750	coastalflow(:) = coastalflow_mean(:)
751
752	!
753	! Write diagnostics
754	!
755
756	! Water storage in reservoirs [kg/m^2]
757	CALL xios_orchidee_send_field("fastr",fast_diag)
758	CALL xios_orchidee_send_field("slowr",slow_diag)
759	CALL xios_orchidee_send_field("streamr",stream_diag)
760	CALL xios_orchidee_send_field("laker",lake_diag)
761	CALL xios_orchidee_send_field("pondr",pond_diag)
762	CALL xios_orchidee_send_field("floodr",flood_diag)
763	CALL xios_orchidee_send_field("floodh",flood_height)
764
765	! Difference between the end and the beginning of the routing time step [kg/m^2]
766	CALL xios_orchidee_send_field("delfastr", fast_diag - fast_diag_old)
767	CALL xios_orchidee_send_field("delslowr", slow_diag - slow_diag_old)
768	CALL xios_orchidee_send_field("delstreamr", stream_diag - stream_diag_old)
769	CALL xios_orchidee_send_field("dellaker", lake_diag - lake_diag_old)
770	CALL xios_orchidee_send_field("delpondr", pond_diag - pond_diag_old)
771	CALL xios_orchidee_send_field("delfloodr", flood_diag - flood_diag_old)
772
773	! Water fluxes converted from kg/m^2/dt_sechiba into kg/m^2/s
774	CALL xios_orchidee_send_field("irrigation",irrigation/dt_sechiba)
775	CALL xios_orchidee_send_field("netirrig",irrig_netereq/dt_sechiba)
776	CALL xios_orchidee_send_field("riversret",returnflow/dt_sechiba)
777	CALL xios_orchidee_send_field("reinfiltration",reinfiltration/dt_sechiba)
778
779	! Transform from kg/dt_sechiba into m^3/s
780	CALL xios_orchidee_send_field("hydrographs",hydrographs/mille/dt_sechiba)
781	CALL xios_orchidee_send_field("slowflow",slowflow_diag/mille/dt_sechiba) ! previous id name: Qb
782	CALL xios_orchidee_send_field("coastalflow",coastalflow/dt_sechiba)
783	CALL xios_orchidee_send_field("riverflow",riverflow/dt_sechiba)
784
785	IF ( .NOT. almaoutput ) THEN
786	!
787	CALL histwrite_p(hist_id, 'riversret', kjit, returnflow, nbpt, index)
788	IF (do_floodplains .OR. doponds) THEN
789	CALL histwrite_p(hist_id, 'reinfiltration', kjit, reinfiltration, nbpt, index)
790	ENDIF
791	CALL histwrite_p(hist_id, 'hydrographs', kjit, hydrographs/mille, nbpt, index)
792	!
793	CALL histwrite_p(hist_id, 'fastr', kjit, fast_diag, nbpt, index)
794	CALL histwrite_p(hist_id, 'slowr', kjit, slow_diag, nbpt, index)
795	CALL histwrite_p(hist_id, 'streamr', kjit, stream_diag, nbpt, index)
796	IF ( do_floodplains ) THEN
797	CALL histwrite_p(hist_id, 'floodr', kjit, flood_diag, nbpt, index)
798	CALL histwrite_p(hist_id, 'floodh', kjit, flood_height, nbpt, index)
799	ENDIF
800	CALL histwrite_p(hist_id, 'pondr', kjit, pond_diag, nbpt, index)
801	CALL histwrite_p(hist_id, 'lakevol', kjit, lake_diag, nbpt, index)
802	!
803	IF ( do_irrigation ) THEN
804	CALL histwrite_p(hist_id, 'irrigation', kjit, irrigation, nbpt, index)
805	CALL histwrite_p(hist_id, 'returnflow', kjit, returnflow, nbpt, index)
806	CALL histwrite_p(hist_id, 'netirrig', kjit, irrig_netereq, nbpt, index)
807	ENDIF
808	!
809	ELSE
810	CALL histwrite_p(hist_id, 'SurfStor', kjit, flood_diag+pond_diag+lake_diag, nbpt, index)
811	CALL histwrite_p(hist_id, 'Dis', kjit, hydrographs/mille, nbpt, index)
812	!
813	CALL histwrite_p(hist_id, 'slowr', kjit, slow_diag, nbpt, index)
814	CALL histwrite_p(hist_id, 'fastr', kjit, fast_diag, nbpt, index)
815	CALL histwrite_p(hist_id, 'streamr', kjit, stream_diag, nbpt, index)
816	CALL histwrite_p(hist_id, 'lakevol', kjit, lake_diag, nbpt, index)
817	CALL histwrite_p(hist_id, 'pondr', kjit, pond_diag, nbpt, index)
818	!
819	IF ( do_irrigation ) THEN
820	CALL histwrite_p(hist_id, 'Qirrig', kjit, irrigation, nbpt, index)
821	CALL histwrite_p(hist_id, 'Qirrig_req', kjit, irrig_netereq, nbpt, index)
822	ENDIF
823	!
824	ENDIF
825	IF ( hist2_id > 0 ) THEN
826	IF ( .NOT. almaoutput ) THEN
827	!
828	CALL histwrite_p(hist2_id, 'riversret', kjit, returnflow, nbpt, index)
829	IF (do_floodplains .OR. doponds) THEN
830	CALL histwrite_p(hist2_id, 'reinfiltration', kjit, reinfiltration, nbpt, index)
831	ENDIF
832	CALL histwrite_p(hist2_id, 'hydrographs', kjit, hydrographs/mille, nbpt, index)
833	!
834	CALL histwrite_p(hist2_id, 'fastr', kjit, fast_diag, nbpt, index)
835	CALL histwrite_p(hist2_id, 'slowr', kjit, slow_diag, nbpt, index)
836	IF ( do_floodplains ) THEN
837	CALL histwrite_p(hist2_id, 'floodr', kjit, flood_diag, nbpt, index)
838	CALL histwrite_p(hist2_id, 'floodh', kjit, flood_height, nbpt, index)
839	ENDIF
840	CALL histwrite_p(hist2_id, 'pondr', kjit, pond_diag, nbpt, index)
841	CALL histwrite_p(hist2_id, 'streamr', kjit, stream_diag, nbpt, index)
842	CALL histwrite_p(hist2_id, 'lakevol', kjit, lake_diag, nbpt, index)
843	!
844	IF ( do_irrigation ) THEN
845	CALL histwrite_p(hist2_id, 'irrigation', kjit, irrigation, nbpt, index)
846	CALL histwrite_p(hist2_id, 'returnflow', kjit, returnflow, nbpt, index)
847	CALL histwrite_p(hist2_id, 'netirrig', kjit, irrig_netereq, nbpt, index)
848	ENDIF
849	!
850	ELSE
851	!
852	CALL histwrite_p(hist2_id, 'SurfStor', kjit, flood_diag+pond_diag+lake_diag, nbpt, index)
853	CALL histwrite_p(hist2_id, 'Dis', kjit, hydrographs/mille, nbpt, index)
854	!
855	ENDIF
856	ENDIF
857	!
858	!
859	END SUBROUTINE routing_main
860
861	!! =============================================================================================================================
862	!! SUBROUTINE: routing_finalize
863	!!
864	!>\BRIEF Write to restart file
865	!!
866	!! DESCRIPTION: Write module variables to restart file
867	!!
868	!! RECENT CHANGE(S)
869	!!
870	!! REFERENCE(S)
871	!!
872	!! FLOWCHART
873	!! \n
874	!_ ==============================================================================================================================
875
876	SUBROUTINE routing_finalize( kjit, nbpt, rest_id, flood_frac, flood_res )
877
878	IMPLICIT NONE
879
880	!! 0.1 Input variables
881	INTEGER(i_std), INTENT(in) :: kjit !! Time step number (unitless)
882	INTEGER(i_std), INTENT(in) :: nbpt !! Domain size (unitless)
883	INTEGER(i_std),INTENT(in) :: rest_id !! Restart file identifier (unitless)
884	REAL(r_std), INTENT(in) :: flood_frac(nbpt) !! Flooded fraction of the grid box (unitless;0-1)
885	REAL(r_std), INTENT(in) :: flood_res(nbpt) !! Diagnostic of water amount in the floodplains reservoir (kg)
886
887	!! 0.2 Local variables
888	REAL(r_std), DIMENSION(1) :: tmp_day
889
890	!_ ================================================================================================================================
891
892	!
893	! Write restart variables
894	!
895	tmp_day(1) = time_counter
896	IF (is_root_prc) CALL restput (rest_id, 'routingcounter', 1, 1, 1, kjit, tmp_day)
897
898	CALL restput_p (rest_id, 'routingarea', nbp_glo, nbasmax, 1, kjit, routing_area, 'scatter', nbp_glo, index_g)
899	CALL restput_p (rest_id, 'routetogrid', nbp_glo, nbasmax, 1, kjit, REAL(route_togrid,r_std), 'scatter', &
900	nbp_glo, index_g)
901	CALL restput_p (rest_id, 'routetobasin', nbp_glo, nbasmax, 1, kjit, REAL(route_tobasin,r_std), 'scatter', &
902	nbp_glo, index_g)
903	CALL restput_p (rest_id, 'basinid', nbp_glo, nbasmax, 1, kjit, REAL(global_basinid,r_std), 'scatter', &
904	nbp_glo, index_g)
905	CALL restput_p (rest_id, 'topoindex', nbp_glo, nbasmax, 1, kjit, topo_resid, 'scatter', nbp_glo, index_g)
906	CALL restput_p (rest_id, 'fastres', nbp_glo, nbasmax, 1, kjit, fast_reservoir, 'scatter', nbp_glo, index_g)
907	CALL restput_p (rest_id, 'slowres', nbp_glo, nbasmax, 1, kjit, slow_reservoir, 'scatter', nbp_glo, index_g)
908	CALL restput_p (rest_id, 'streamres', nbp_glo, nbasmax, 1, kjit, stream_reservoir, 'scatter',nbp_glo,index_g)
909	CALL restput_p (rest_id, 'floodres', nbp_glo, nbasmax, 1, kjit, flood_reservoir, 'scatter', nbp_glo, index_g)
910	CALL restput_p (rest_id, 'floodh', nbp_glo, 1, 1, kjit, flood_height, 'scatter', nbp_glo, index_g)
911	CALL restput_p (rest_id, 'flood_frac_bas', nbp_glo, nbasmax, 1, kjit, flood_frac_bas, 'scatter', nbp_glo, index_g)
912	CALL restput_p (rest_id, 'pond_frac', nbp_glo, 1, 1, kjit, pond_frac, 'scatter', nbp_glo, index_g)
913	CALL restput_p (rest_id, 'flood_frac', nbp_glo, 1, 1, kjit, flood_frac, 'scatter', nbp_glo, index_g)
914	CALL restput_p (rest_id, 'flood_res', nbp_glo, 1, 1, kjit, flood_res, 'scatter', nbp_glo, index_g)
915
916	CALL restput_p (rest_id, 'lakeres', nbp_glo, 1, 1, kjit, lake_reservoir, 'scatter', nbp_glo, index_g)
917	CALL restput_p (rest_id, 'pondres', nbp_glo, 1, 1, kjit, pond_reservoir, 'scatter', nbp_glo, index_g)
918
919	CALL restput_p (rest_id, 'lakeinflow', nbp_glo, 1, 1, kjit, lakeinflow_mean, 'scatter', nbp_glo, index_g)
920	CALL restput_p (rest_id, 'returnflow', nbp_glo, 1, 1, kjit, returnflow_mean, 'scatter', nbp_glo, index_g)
921	CALL restput_p (rest_id, 'reinfiltration', nbp_glo, 1, 1, kjit, reinfiltration_mean, 'scatter', nbp_glo, index_g)
922	CALL restput_p (rest_id, 'riverflow', nbp_glo, 1, 1, kjit, riverflow_mean, 'scatter', nbp_glo, index_g)
923	CALL restput_p (rest_id, 'coastalflow', nbp_glo, 1, 1, kjit, coastalflow_mean, 'scatter', nbp_glo, index_g)
924	CALL restput_p (rest_id, 'hydrographs', nbp_glo, 1, 1, kjit, hydrographs, 'scatter', nbp_glo, index_g)
925	CALL restput_p (rest_id, 'slowflow_diag', nbp_glo, 1, 1, kjit, slowflow_diag, 'scatter', nbp_glo, index_g)
926	!
927	! Keep track of the accumulated variables
928	!
929	CALL restput_p (rest_id, 'floodout_route', nbp_glo, 1, 1, kjit, floodout_mean, 'scatter', nbp_glo, index_g)
930	CALL restput_p (rest_id, 'runoff_route', nbp_glo, 1, 1, kjit, runoff_mean, 'scatter', nbp_glo, index_g)
931	CALL restput_p (rest_id, 'drainage_route', nbp_glo, 1, 1, kjit, drainage_mean, 'scatter', nbp_glo, index_g)
932	CALL restput_p (rest_id, 'transpot_route', nbp_glo, 1, 1, kjit, transpot_mean, 'scatter', nbp_glo, index_g)
933	CALL restput_p (rest_id, 'precip_route', nbp_glo, 1, 1, kjit, precip_mean, 'scatter', nbp_glo, index_g)
934	CALL restput_p (rest_id, 'humrel_route', nbp_glo, 1, 1, kjit, humrel_mean, 'scatter', nbp_glo, index_g)
935	CALL restput_p (rest_id, 'totnobio_route', nbp_glo, 1, 1, kjit, totnobio_mean, 'scatter', nbp_glo, index_g)
936	CALL restput_p (rest_id, 'k_litt_route', nbp_glo, 1, 1, kjit, k_litt_mean, 'scatter', nbp_glo, index_g)
937	CALL restput_p (rest_id, 'vegtot_route', nbp_glo, 1, 1, kjit, vegtot_mean, 'scatter', nbp_glo, index_g)
938
939	IF ( do_irrigation ) THEN
940	CALL restput_p (rest_id, 'irrigated', nbp_glo, 1, 1, kjit, irrigated, 'scatter', nbp_glo, index_g)
941	CALL restput_p (rest_id, 'irrigation', nbp_glo, 1, 1, kjit, irrigation_mean, 'scatter', nbp_glo, index_g)
942	ENDIF
943
944	IF ( do_floodplains ) THEN
945	CALL restput_p (rest_id, 'floodplains', nbp_glo, 1, 1, kjit, floodplains, 'scatter', nbp_glo, index_g)
946	ENDIF
947	IF ( doswamps ) THEN
948	CALL restput_p (rest_id, 'swamp', nbp_glo, 1, 1, kjit, swamp, 'scatter', nbp_glo, index_g)
949	ENDIF
950
951	END SUBROUTINE routing_finalize
952
953	!! ================================================================================================================================
954	!! SUBROUTINE : routing_init
955	!!
956	!>\BRIEF This subroutine allocates the memory and get the fixed fields from the restart file.
957	!!
958	!! DESCRIPTION (definitions, functional, design, flags) : None
959	!!
960	!! RECENT CHANGE(S): None
961	!!
962	!! MAIN OUTPUT VARIABLE(S):
963	!!
964	!! REFERENCES : None
965	!!
966	!! FLOWCHART :None
967	!! \n
968	!_ ================================================================================================================================
969
970	SUBROUTINE routing_init(kjit, nbpt, index, returnflow, reinfiltration, irrigation, &
971	& riverflow, coastalflow, flood_frac, flood_res, stempdiag, rest_id)
972	!
973	IMPLICIT NONE
974	!
975	! interface description
976	!
977	!! INPUT VARIABLES
978	INTEGER(i_std), INTENT(in) :: kjit !! Time step number (unitless)
979	INTEGER(i_std), INTENT(in) :: nbpt !! Domain size (unitless)
980	INTEGER(i_std), DIMENSION (nbpt), INTENT(in) :: index !! Indices of the points on the map (unitless)
981	REAL(r_std), DIMENSION(nbpt,nbdl),INTENT(in) :: stempdiag !! Temperature profile in soil
982	INTEGER(i_std), INTENT(in) :: rest_id !! Restart file identifier (unitless)
983	!
984	!! OUTPUT VARIABLES
985	REAL(r_std), DIMENSION (nbpt),INTENT(out) :: returnflow !! The water flow from lakes and swamps which returns into the grid box.
986	!! This water will go back into the hydrol or hydrolc module to allow re-evaporation (kg/m^2/dt)
987	REAL(r_std), DIMENSION (nbpt),INTENT(out) :: reinfiltration !! Water flow from ponds and floodplains which returns to the grid box (kg/m^2/dt)
988	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)
989	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)
990	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)
991	REAL(r_std), DIMENSION (nbpt),INTENT(out) :: flood_frac !! Flooded fraction of the grid box (unitless;0-1)
992	REAL(r_std), DIMENSION (nbpt),INTENT(out) :: flood_res !! Diagnostic of water amount in the floodplains reservoir (kg)
993	!
994	!! LOCAL VARIABLES
995	CHARACTER(LEN=80) :: var_name !! To store variables names for I/O (unitless)
996	REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: tmp_real_g !! A temporary real array for the integers
997	REAL(r_std), DIMENSION(1) :: tmp_day !!
998	REAL(r_std) :: ratio !! Diagnostic ratio to check that dt_routing is a multiple of dt_sechiba (unitless)
999	REAL(r_std) :: totarea !! Total area of basin (m^2)
1000	INTEGER(i_std) :: ier, ig, ib, ipn(1) !! Indices (unitless)
1001
1002	!_ ================================================================================================================================
1003	!
1004	!
1005	! These variables will require the configuration infrastructure
1006	!
1007	!Config Key = DT_ROUTING
1008	!Config If = RIVER_ROUTING
1009	!Config Desc = Time step of the routing scheme
1010	!Config Def = one_day
1011	!Config Help = This values gives the time step in seconds of the routing scheme.
1012	!Config It should be multiple of the main time step of ORCHIDEE. One day
1013	!Config is a good value.
1014	!Config Units = [seconds]
1015	!
1016	dt_routing = one_day
1017	CALL getin_p('DT_ROUTING', dt_routing)
1018	!
1019	!Config Key = ROUTING_RIVERS
1020	!Config If = RIVER_ROUTING
1021	!Config Desc = Number of rivers
1022	!Config Def = 50
1023	!Config Help = This parameter chooses the number of largest river basins
1024	!Config which should be treated as independently as rivers and not
1025	!Config flow into the oceans as diffusion coastal flow.
1026	!Config Units = [-]
1027	num_largest = 50
1028	CALL getin_p('ROUTING_RIVERS', num_largest)
1029	!
1030	!Config Key = DO_FLOODINFILT
1031	!Config Desc = Should floodplains reinfiltrate into the soil
1032	!Config If = RIVER_ROUTING
1033	!Config Def = n
1034	!Config Help = This parameters allows the user to ask the model
1035	!Config to take into account the flood plains reinfiltration
1036	!Config into the soil moisture. It then can go
1037	!Config back to the slow and fast reservoirs
1038	!Config Units = [FLAG]
1039	!
1040	dofloodinfilt = .FALSE.
1041	CALL getin_p('DO_FLOODINFILT', dofloodinfilt)
1042	!
1043	!Config Key = DO_SWAMPS
1044	!Config Desc = Should we include swamp parameterization
1045	!Config If = RIVER_ROUTING
1046	!Config Def = n
1047	!Config Help = This parameters allows the user to ask the model
1048	!Config to take into account the swamps and return
1049	!Config the water into the bottom of the soil. It then can go
1050	!Config back to the atmopshere. This tried to simulate
1051	!Config internal deltas of rivers.
1052	!Config Units = [FLAG]
1053	!
1054	doswamps = .FALSE.
1055	CALL getin_p('DO_SWAMPS', doswamps)
1056	!
1057	!Config Key = DO_PONDS
1058	!Config Desc = Should we include ponds
1059	!Config If = RIVER_ROUTING
1060	!Config Def = n
1061	!Config Help = This parameters allows the user to ask the model
1062	!Config to take into account the ponds and return
1063	!Config the water into the soil moisture. It then can go
1064	!Config back to the atmopshere. This tried to simulate
1065	!Config little ponds especially in West Africa.
1066	!Config Units = [FLAG]
1067	!
1068	doponds = .FALSE.
1069	CALL getin_p('DO_PONDS', doponds)
1070	!
1071	! Fix the time constants according to hydrol_cwrr flag
1072	!
1073	!
1074	!Config Key = SLOW_TCST
1075	!Config Desc = Time constant for the slow reservoir
1076	!Config If = RIVER_ROUTING
1077	!Config Def = n
1078	!Config Help = This parameters allows the user to fix the
1079	!Config time constant (in days) of the slow reservoir
1080	!Config in order to get better river flows for
1081	!Config particular regions.
1082	!Config Units = [days]
1083	!
1084	!> A value for property of each reservoir (in day/m) is given to compute a time constant (in day)
1085	!> for each reservoir (product of tcst and topo_resid).
1086	!> The value of tcst has been calibrated for the three reservoirs over the Senegal river basin only,
1087	!> during the 1 degree NCEP Corrected by Cru (NCC) resolution simulations (Ngo-Duc et al., 2005, Ngo-Duc et al., 2006) and
1088	!> generalized for all the basins of the world. The "slow reservoir" and the "fast reservoir"
1089	!> have the highest value in order to simulate the groundwater.
1090	!> The "stream reservoir", which represents all the water of the stream, has the lowest value.
1091	!> Those figures are the same for all the basins of the world.
1092	!> The value of slow_tcst is equal to fast_tcst when CWRR is activated.
1093	!> This assumption should be re-discussed.
1094	!
1095	IF ( hydrol_cwrr ) THEN
1096	slow_tcst = slow_tcst_cwrr
1097	ELSE
1098	slow_tcst = slow_tcst_chois
1099	ENDIF
1100	CALL getin_p('SLOW_TCST', slow_tcst)
1101	!
1102	!Config Key = FAST_TCST
1103	!Config Desc = Time constant for the fast reservoir
1104	!Config If = RIVER_ROUTING
1105	!Config Def = fast_tcst_cwrr or fast_tcst_chois depending on flag HYDROL_CWRR
1106	!Config Help = This parameters allows the user to fix the
1107	!Config time constant (in days) of the fast reservoir
1108	!Config in order to get better river flows for
1109	!Config particular regions.
1110	!Config Units = [days]
1111	!
1112	IF ( hydrol_cwrr ) THEN
1113	fast_tcst = fast_tcst_cwrr
1114	ELSE
1115	fast_tcst = fast_tcst_chois
1116	ENDIF
1117	CALL getin_p('FAST_TCST', fast_tcst)
1118	!
1119	!Config Key = STREAM_TCST
1120	!Config Desc = Time constant for the stream reservoir
1121	!Config If = RIVER_ROUTING
1122	!Config Def = stream_tcst_cwrr or stream_tcst_chois depending on flag HYDROL_CWRR
1123	!Config Help = This parameters allows the user to fix the
1124	!Config time constant (in days) of the stream reservoir
1125	!Config in order to get better river flows for
1126	!Config particular regions.
1127	!Config Units = [days]
1128	!
1129	IF ( hydrol_cwrr ) THEN
1130	stream_tcst = stream_tcst_cwrr
1131	ELSE
1132	stream_tcst = stream_tcst_chois
1133	ENDIF
1134	CALL getin_p('STREAM_TCST', stream_tcst)
1135	!
1136	!Config Key = FLOOD_TCST
1137	!Config Desc = Time constant for the flood reservoir
1138	!Config If = RIVER_ROUTING
1139	!Config Def = 4.0
1140	!Config Help = This parameters allows the user to fix the
1141	!Config time constant (in days) of the flood reservoir
1142	!Config in order to get better river flows for
1143	!Config particular regions.
1144	!Config Units = [days]
1145	!
1146	IF ( hydrol_cwrr ) THEN
1147	flood_tcst = flood_tcst_cwrr
1148	ELSE
1149	flood_tcst = flood_tcst_chois
1150	ENDIF
1151	CALL getin_p('FLOOD_TCST', flood_tcst)
1152	!
1153	!Config Key = SWAMP_CST
1154	!Config Desc = Fraction of the river that flows back to swamps
1155	!Config If = RIVER_ROUTING
1156	!Config Def = 0.2
1157	!Config Help = This parameters allows the user to fix the
1158	!Config fraction of the river transport
1159	!Config that flows to swamps
1160	!Config Units = [-]
1161	!
1162	IF ( hydrol_cwrr ) THEN
1163	swamp_cst = swamp_cst_cwrr
1164	ELSE
1165	swamp_cst = swamp_cst_chois
1166	ENDIF
1167	CALL getin_p('SWAMP_CST', swamp_cst)
1168	!
1169	!Config Key = FLOOD_BETA
1170	!Config Desc = Parameter to fix the shape of the floodplain
1171	!Config If = RIVER_ROUTING
1172	!Config Def = 2.0
1173	!Config Help = Parameter to fix the shape of the floodplain
1174	!Config (>1 for convex edges, <1 for concave edges)
1175	!Config Units = [-]
1176	CALL getin_p("FLOOD_BETA", beta)
1177	!
1178	!Config Key = POND_BETAP
1179	!Config Desc = Ratio of the basin surface intercepted by ponds and the maximum surface of ponds
1180	!Config If = RIVER_ROUTING
1181	!Config Def = 0.5
1182	!Config Help =
1183	!Config Units = [-]
1184	CALL getin_p("POND_BETAP", betap)
1185	!
1186	!Config Key = FLOOD_CRI
1187	!Config Desc = Potential height for which all the basin is flooded
1188	!Config If = DO_FLOODPLAINS or DO_PONDS
1189	!Config Def = 2000.
1190	!Config Help =
1191	!Config Units = [mm]
1192	CALL getin_p("FLOOD_CRI", floodcri)
1193	!
1194	!Config Key = POND_CRI
1195	!Config Desc = Potential height for which all the basin is a pond
1196	!Config If = DO_FLOODPLAINS or DO_PONDS
1197	!Config Def = 2000.
1198	!Config Help =
1199	!Config Units = [mm]
1200	CALL getin_p("POND_CRI", pondcri)
1201
1202	!Config Key = MAX_LAKE_RESERVOIR
1203	!Config Desc = Maximum limit of water in lake_reservoir
1204	!Config If = RIVER_ROUTING
1205	!Config Def = 7000
1206	!Config Help =
1207	!Config Units = [kg/m2(routing area)]
1208	max_lake_reservoir = 7000
1209	CALL getin_p("MAX_LAKE_RESERVOIR", max_lake_reservoir)
1210
1211	!
1212	!
1213	! In order to simplify the time cascade check that dt_routing
1214	! is a multiple of dt_sechiba
1215	!
1216	ratio = dt_routing/dt_sechiba
1217	IF ( ABS(NINT(ratio) - ratio) .GT. 10*EPSILON(ratio)) THEN
1218	WRITE(numout,*) 'WARNING -- WARNING -- WARNING -- WARNING'
1219	WRITE(numout,*) "The chosen time step for the routing is not a multiple of the"
1220	WRITE(numout,*) "main time step of the model. We will change dt_routing so that"
1221	WRITE(numout,*) "this condition os fulfilled"
1222	dt_routing = NINT(ratio) * dt_sechiba
1223	WRITE(numout,*) 'THE NEW DT_ROUTING IS : ', dt_routing
1224	ENDIF
1225	!
1226	IF ( dt_routing .LT. dt_sechiba) THEN
1227	WRITE(numout,*) 'WARNING -- WARNING -- WARNING -- WARNING'
1228	WRITE(numout,*) 'The routing timestep can not be smaller than the one'
1229	WRITE(numout,*) 'of the model. We reset its value to the model''s timestep.'
1230	WRITE(numout,*) 'The old DT_ROUTING is : ', dt_routing
1231	dt_routing = dt_sechiba
1232	WRITE(numout,*) 'THE NEW DT_ROUTING IS : ', dt_routing
1233	ENDIF
1234	!
1235	var_name ="routingcounter"
1236	IF (is_root_prc) THEN
1237	CALL ioconf_setatt('UNITS', 's')
1238	CALL ioconf_setatt('LONG_NAME','Time counter for the routing scheme')
1239	CALL restget (rest_id, var_name, 1, 1, 1, kjit, .TRUE., tmp_day)
1240	IF (tmp_day(1) == val_exp) THEN
1241	time_counter = zero
1242	ELSE
1243	time_counter = tmp_day(1)
1244	ENDIF
1245	CALL setvar (time_counter, val_exp, 'NO_KEYWORD', zero)
1246	ENDIF
1247	CALL bcast(time_counter)
1248	!!$ CALL setvar_p (time_counter, val_exp, 'NO_KEYWORD', zero)
1249
1250
1251	ALLOCATE (routing_area_loc(nbpt,nbasmax), stat=ier)
1252	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for routing_area_loc','','')
1253
1254	ALLOCATE (routing_area_glo(nbp_glo,nbasmax))
1255	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for routing_area_glo','','')
1256	var_name = 'routingarea'
1257	IF (is_root_prc) THEN
1258	CALL ioconf_setatt('UNITS', 'm^2')
1259	CALL ioconf_setatt('LONG_NAME','Area of basin')
1260	CALL restget (rest_id, var_name, nbp_glo, nbasmax, 1, kjit, .TRUE., routing_area_glo, "gather", nbp_glo, index_g)
1261	ENDIF
1262	CALL scatter(routing_area_glo,routing_area_loc)
1263	routing_area=>routing_area_loc
1264
1265	ALLOCATE (tmp_real_g(nbp_glo,nbasmax), stat=ier)
1266	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for tmp_real_g','','')
1267
1268	ALLOCATE (route_togrid_loc(nbpt,nbasmax), stat=ier)
1269	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for route_togrid_loc','','')
1270	ALLOCATE (route_togrid_glo(nbp_glo,nbasmax), stat=ier) ! used in global in routing_flow
1271	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for route_togrid_glo','','')
1272
1273	IF (is_root_prc) THEN
1274	var_name = 'routetogrid'
1275	CALL ioconf_setatt('UNITS', '-')
1276	CALL ioconf_setatt('LONG_NAME','Grid into which the basin flows')
1277	CALL restget (rest_id, var_name, nbp_glo, nbasmax, 1, kjit, .TRUE., tmp_real_g, "gather", nbp_glo, index_g)
1278	route_togrid_glo(:,:) = undef_int
1279	WHERE ( tmp_real_g .LT. val_exp )
1280	route_togrid_glo = NINT(tmp_real_g)
1281	ENDWHERE
1282	ENDIF
1283	CALL bcast(route_togrid_glo) ! used in global in routing_flow
1284	CALL scatter(route_togrid_glo,route_togrid_loc)
1285	route_togrid=>route_togrid_loc
1286	!
1287	ALLOCATE (route_tobasin_loc(nbpt,nbasmax), stat=ier)
1288	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for route_tobasin_loc','','')
1289
1290	ALLOCATE (route_tobasin_glo(nbp_glo,nbasmax), stat=ier)
1291	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for route_tobasin_glo','','')
1292
1293	IF (is_root_prc) THEN
1294	var_name = 'routetobasin'
1295	CALL ioconf_setatt('UNITS', '-')
1296	CALL ioconf_setatt('LONG_NAME','Basin in to which the water goes')
1297	CALL restget (rest_id, var_name, nbp_glo, nbasmax, 1, kjit, .TRUE., tmp_real_g, "gather", nbp_glo, index_g)
1298	route_tobasin_glo = undef_int
1299	WHERE ( tmp_real_g .LT. val_exp )
1300	route_tobasin_glo = NINT(tmp_real_g)
1301	ENDWHERE
1302	ENDIF
1303	CALL scatter(route_tobasin_glo,route_tobasin_loc)
1304	route_tobasin=>route_tobasin_loc
1305	!
1306	! nbintobasin
1307	!
1308	ALLOCATE (route_nbintobas_loc(nbpt,nbasmax), stat=ier)
1309	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for route_nbintobas_loc','','')
1310	ALLOCATE (route_nbintobas_glo(nbp_glo,nbasmax), stat=ier)
1311	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for route_nbintobas_glo','','')
1312
1313	IF (is_root_prc) THEN
1314	var_name = 'routenbintobas'
1315	CALL ioconf_setatt('UNITS', '-')
1316	CALL ioconf_setatt('LONG_NAME','Number of basin into current one')
1317	CALL restget (rest_id, var_name, nbp_glo, nbasmax, 1, kjit, .TRUE., tmp_real_g, "gather", nbp_glo, index_g)
1318	route_nbintobas_glo = undef_int
1319	WHERE ( tmp_real_g .LT. val_exp )
1320	route_nbintobas_glo = NINT(tmp_real_g)
1321	ENDWHERE
1322	ENDIF
1323	CALL scatter(route_nbintobas_glo,route_nbintobas_loc)
1324	route_nbintobas=>route_nbintobas_loc
1325	!
1326	ALLOCATE (global_basinid_loc(nbpt,nbasmax), stat=ier)
1327	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for global_basinid_loc','','')
1328	ALLOCATE (global_basinid_glo(nbp_glo,nbasmax), stat=ier)
1329	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for global_basinid_glo','','')
1330
1331	IF (is_root_prc) THEN
1332	var_name = 'basinid'
1333	CALL ioconf_setatt('UNITS', '-')
1334	CALL ioconf_setatt('LONG_NAME','ID of basin')
1335	CALL restget (rest_id, var_name, nbp_glo, nbasmax, 1, kjit, .TRUE., tmp_real_g, "gather", nbp_glo, index_g)
1336	global_basinid_glo = undef_int
1337	WHERE ( tmp_real_g .LT. val_exp )
1338	global_basinid_glo = NINT(tmp_real_g)
1339	ENDWHERE
1340	ENDIF
1341	CALL scatter(global_basinid_glo,global_basinid_loc)
1342	global_basinid=>global_basinid_loc
1343	!
1344	ALLOCATE (topo_resid_loc(nbpt,nbasmax), stat=ier)
1345	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for topo_resid_loc','','')
1346	ALLOCATE (topo_resid_glo(nbp_glo,nbasmax), stat=ier)
1347	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for topo_resid_glo','','')
1348
1349	IF (is_root_prc) THEN
1350	var_name = 'topoindex'
1351	CALL ioconf_setatt('UNITS', 'm')
1352	CALL ioconf_setatt('LONG_NAME','Topographic index of the residence time')
1353	CALL restget (rest_id, var_name, nbp_glo, nbasmax, 1, kjit, .TRUE., topo_resid_glo, "gather", nbp_glo, index_g)
1354	ENDIF
1355	CALL scatter(topo_resid_glo,topo_resid_loc)
1356	topo_resid=>topo_resid_loc
1357
1358	ALLOCATE (fast_reservoir(nbpt,nbasmax), stat=ier)
1359	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for fast_reservoir','','')
1360	var_name = 'fastres'
1361	CALL ioconf_setatt_p('UNITS', 'Kg')
1362	CALL ioconf_setatt_p('LONG_NAME','Water in the fast reservoir')
1363	CALL restget_p (rest_id, var_name, nbp_glo, nbasmax, 1, kjit, .TRUE., fast_reservoir, "gather", nbp_glo, index_g)
1364	CALL setvar_p (fast_reservoir, val_exp, 'NO_KEYWORD', zero)
1365
1366	ALLOCATE (slow_reservoir(nbpt,nbasmax), stat=ier)
1367	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for slow_reservoir','','')
1368	var_name = 'slowres'
1369	CALL ioconf_setatt_p('UNITS', 'Kg')
1370	CALL ioconf_setatt_p('LONG_NAME','Water in the slow reservoir')
1371	CALL restget_p (rest_id, var_name, nbp_glo, nbasmax, 1, kjit, .TRUE., slow_reservoir, "gather", nbp_glo, index_g)
1372	CALL setvar_p (slow_reservoir, val_exp, 'NO_KEYWORD', zero)
1373
1374	ALLOCATE (stream_reservoir(nbpt,nbasmax), stat=ier)
1375	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for stream_reservoir','','')
1376	var_name = 'streamres'
1377	CALL ioconf_setatt_p('UNITS', 'Kg')
1378	CALL ioconf_setatt_p('LONG_NAME','Water in the stream reservoir')
1379	CALL restget_p (rest_id, var_name, nbp_glo, nbasmax, 1, kjit, .TRUE., stream_reservoir, "gather", nbp_glo, index_g)
1380	CALL setvar_p (stream_reservoir, val_exp, 'NO_KEYWORD', zero)
1381
1382	ALLOCATE (flood_reservoir(nbpt,nbasmax), stat=ier)
1383	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for flood_reservoir','','')
1384	var_name = 'floodres'
1385	CALL ioconf_setatt_p('UNITS', 'Kg')
1386	CALL ioconf_setatt_p('LONG_NAME','Water in the flood reservoir')
1387	CALL restget_p (rest_id, var_name, nbp_glo, nbasmax, 1, kjit, .TRUE., flood_reservoir, "gather", nbp_glo, index_g)
1388	CALL setvar_p (flood_reservoir, val_exp, 'NO_KEYWORD', zero)
1389
1390	ALLOCATE (flood_frac_bas(nbpt,nbasmax), stat=ier)
1391	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for flood_frac_bas','','')
1392	var_name = 'flood_frac_bas'
1393	CALL ioconf_setatt_p('UNITS', '-')
1394	CALL ioconf_setatt_p('LONG_NAME','Flooded fraction per basin')
1395	CALL restget_p (rest_id, var_name, nbp_glo, nbasmax, 1, kjit, .TRUE., flood_frac_bas, "gather", nbp_glo, index_g)
1396	CALL setvar_p (flood_frac_bas, val_exp, 'NO_KEYWORD', zero)
1397
1398	ALLOCATE (flood_height(nbpt), stat=ier)
1399	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for flood_height','','')
1400	var_name = 'floodh'
1401	CALL ioconf_setatt_p('UNITS', '-')
1402	CALL ioconf_setatt_p('LONG_NAME','')
1403	CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., flood_height, "gather", nbp_glo, index_g)
1404	CALL setvar_p (flood_height, val_exp, 'NO_KEYWORD', zero)
1405
1406	ALLOCATE (pond_frac(nbpt), stat=ier)
1407	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for pond_frac','','')
1408	var_name = 'pond_frac'
1409	CALL ioconf_setatt_p('UNITS', '-')
1410	CALL ioconf_setatt_p('LONG_NAME','Pond fraction per grid box')
1411	CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., pond_frac, "gather", nbp_glo, index_g)
1412	CALL setvar_p (pond_frac, val_exp, 'NO_KEYWORD', zero)
1413
1414	var_name = 'flood_frac'
1415	CALL ioconf_setatt_p('UNITS', '-')
1416	CALL ioconf_setatt_p('LONG_NAME','Flooded fraction per grid box')
1417	CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., flood_frac, "gather", nbp_glo, index_g)
1418	CALL setvar_p (flood_frac, val_exp, 'NO_KEYWORD', zero)
1419
1420	var_name = 'flood_res'
1421	CALL ioconf_setatt_p('UNITS','mm')
1422	CALL ioconf_setatt_p('LONG_NAME','Flooded quantity (estimation)')
1423	CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., flood_res, "gather", nbp_glo, index_g)
1424	CALL setvar_p (flood_res, val_exp, 'NO_KEYWORD', zero)
1425	! flood_res = zero
1426
1427	ALLOCATE (lake_reservoir(nbpt), stat=ier)
1428	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for lake_reservoir','','')
1429	var_name = 'lakeres'
1430	CALL ioconf_setatt_p('UNITS', 'Kg')
1431	CALL ioconf_setatt_p('LONG_NAME','Water in the lake reservoir')
1432	CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., lake_reservoir, "gather", nbp_glo, index_g)
1433	CALL setvar_p (lake_reservoir, val_exp, 'NO_KEYWORD', zero)
1434
1435	ALLOCATE (pond_reservoir(nbpt), stat=ier)
1436	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for pond_reservoir','','')
1437	var_name = 'pondres'
1438	CALL ioconf_setatt_p('UNITS', 'Kg')
1439	CALL ioconf_setatt_p('LONG_NAME','Water in the pond reservoir')
1440	CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., pond_reservoir, "gather", nbp_glo, index_g)
1441	CALL setvar_p (pond_reservoir, val_exp, 'NO_KEYWORD', zero)
1442	!
1443	! Map of irrigated areas
1444	!
1445	IF ( do_irrigation ) THEN
1446	ALLOCATE (irrigated(nbpt), stat=ier)
1447	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for irrigated','','')
1448	var_name = 'irrigated'
1449	CALL ioconf_setatt_p('UNITS', 'm^2')
1450	CALL ioconf_setatt_p('LONG_NAME','Surface of irrigated area')
1451	CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., irrigated, "gather", nbp_glo, index_g)
1452	CALL setvar_p (irrigated, val_exp, 'NO_KEYWORD', undef_sechiba)
1453	ENDIF
1454
1455	IF ( do_floodplains ) THEN
1456	ALLOCATE (floodplains(nbpt), stat=ier)
1457	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for floodplains','','')
1458	var_name = 'floodplains'
1459	CALL ioconf_setatt_p('UNITS', 'm^2')
1460	CALL ioconf_setatt_p('LONG_NAME','Surface which can be flooded')
1461	CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., floodplains, "gather", nbp_glo, index_g)
1462	CALL setvar_p (floodplains, val_exp, 'NO_KEYWORD', undef_sechiba)
1463	ENDIF
1464	IF ( doswamps ) THEN
1465	ALLOCATE (swamp(nbpt), stat=ier)
1466	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for swamp','','')
1467	var_name = 'swamp'
1468	CALL ioconf_setatt_p('UNITS', 'm^2')
1469	CALL ioconf_setatt_p('LONG_NAME','Surface which can become swamp')
1470	CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., swamp, "gather", nbp_glo, index_g)
1471	CALL setvar_p (swamp, val_exp, 'NO_KEYWORD', undef_sechiba)
1472	ENDIF
1473	!
1474	! Put into the restart file the fluxes so that they can be regenerated at restart.
1475	!
1476	ALLOCATE (lakeinflow_mean(nbpt), stat=ier)
1477	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for lakeinflow_mean','','')
1478	var_name = 'lakeinflow'
1479	CALL ioconf_setatt_p('UNITS', 'Kg/dt')
1480	CALL ioconf_setatt_p('LONG_NAME','Lake inflow')
1481	CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., lakeinflow_mean, "gather", nbp_glo, index_g)
1482	CALL setvar_p (lakeinflow_mean, val_exp, 'NO_KEYWORD', zero)
1483
1484	ALLOCATE (returnflow_mean(nbpt), stat=ier)
1485	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for returnflow_mean','','')
1486	var_name = 'returnflow'
1487	CALL ioconf_setatt_p('UNITS', 'Kg/m^2/dt')
1488	CALL ioconf_setatt_p('LONG_NAME','Deep return flux')
1489	CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., returnflow_mean, "gather", nbp_glo, index_g)
1490	CALL setvar_p (returnflow_mean, val_exp, 'NO_KEYWORD', zero)
1491	returnflow(:) = returnflow_mean(:)
1492
1493	ALLOCATE (reinfiltration_mean(nbpt), stat=ier)
1494	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for reinfiltration_mean','','')
1495	var_name = 'reinfiltration'
1496	CALL ioconf_setatt_p('UNITS', 'Kg/m^2/dt')
1497	CALL ioconf_setatt_p('LONG_NAME','Top return flux')
1498	CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., reinfiltration_mean, "gather", nbp_glo, index_g)
1499	CALL setvar_p (reinfiltration_mean, val_exp, 'NO_KEYWORD', zero)
1500	reinfiltration(:) = reinfiltration_mean(:)
1501
1502	ALLOCATE (irrigation_mean(nbpt), stat=ier)
1503	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for irrigation_mean','','')
1504	ALLOCATE (irrig_netereq(nbpt), stat=ier)
1505	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for irrig_netereq','','')
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	ELSE
1515	irrigation_mean(:) = zero
1516	ENDIF
1517	irrigation(:) = irrigation_mean(:)
1518
1519	ALLOCATE (riverflow_mean(nbpt), stat=ier)
1520	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for riverflow_mean','','')
1521	var_name = 'riverflow'
1522	CALL ioconf_setatt_p('UNITS', 'Kg/dt')
1523	CALL ioconf_setatt_p('LONG_NAME','River flux into the sea')
1524	CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., riverflow_mean, "gather", nbp_glo, index_g)
1525	CALL setvar_p (riverflow_mean, val_exp, 'NO_KEYWORD', zero)
1526	riverflow(:) = riverflow_mean(:)
1527
1528	ALLOCATE (coastalflow_mean(nbpt), stat=ier)
1529	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for coastalflow_mean','','')
1530	var_name = 'coastalflow'
1531	CALL ioconf_setatt_p('UNITS', 'Kg/dt')
1532	CALL ioconf_setatt_p('LONG_NAME','Diffuse flux into the sea')
1533	CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., coastalflow_mean, "gather", nbp_glo, index_g)
1534	CALL setvar_p (coastalflow_mean, val_exp, 'NO_KEYWORD', zero)
1535	coastalflow(:) = coastalflow_mean(:)
1536
1537	! Locate it at the 2m level
1538	ipn = MINLOC(ABS(diaglev-2))
1539	floodtemp_lev = ipn(1)
1540	ALLOCATE (floodtemp(nbpt), stat=ier)
1541	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for floodtemp','','')
1542	floodtemp(:) = stempdiag(:,floodtemp_lev)
1543
1544	ALLOCATE(hydrographs(nbpt), stat=ier)
1545	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for hydrographs','','')
1546	var_name = 'hydrographs'
1547	CALL ioconf_setatt_p('UNITS', 'kg/dt_sechiba')
1548	CALL ioconf_setatt_p('LONG_NAME','Hydrograph at outlow of grid')
1549	CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., hydrographs, "gather", nbp_glo, index_g)
1550	CALL setvar_p (hydrographs, val_exp, 'NO_KEYWORD', zero)
1551
1552	ALLOCATE(slowflow_diag(nbpt), stat=ier)
1553	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for slowflow_diag','','')
1554	var_name = 'slowflow_diag'
1555	CALL ioconf_setatt_p('UNITS', 'kg/dt_sechiba')
1556	CALL ioconf_setatt_p('LONG_NAME','Slowflow hydrograph at outlow of grid')
1557	CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE.,slowflow_diag, "gather", nbp_glo, index_g)
1558	CALL setvar_p (slowflow_diag, val_exp, 'NO_KEYWORD', zero)
1559
1560	!
1561	! The diagnostic variables, they are initialized from the above restart variables.
1562	!
1563	ALLOCATE(fast_diag(nbpt), slow_diag(nbpt), stream_diag(nbpt), flood_diag(nbpt), &
1564	& pond_diag(nbpt), lake_diag(nbpt), stat=ier)
1565	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for fast_diag,..','','')
1566
1567	fast_diag(:) = zero
1568	slow_diag(:) = zero
1569	stream_diag(:) = zero
1570	flood_diag(:) = zero
1571	pond_diag(:) = zero
1572	lake_diag(:) = zero
1573
1574	DO ig=1,nbpt
1575	totarea = zero
1576	DO ib=1,nbasmax
1577	totarea = totarea + routing_area(ig,ib)
1578	fast_diag(ig) = fast_diag(ig) + fast_reservoir(ig,ib)
1579	slow_diag(ig) = slow_diag(ig) + slow_reservoir(ig,ib)
1580	stream_diag(ig) = stream_diag(ig) + stream_reservoir(ig,ib)
1581	flood_diag(ig) = flood_diag(ig) + flood_reservoir(ig,ib)
1582	ENDDO
1583	!
1584	fast_diag(ig) = fast_diag(ig)/totarea
1585	slow_diag(ig) = slow_diag(ig)/totarea
1586	stream_diag(ig) = stream_diag(ig)/totarea
1587	flood_diag(ig) = flood_diag(ig)/totarea
1588	!
1589	! This is the volume of the lake scaled to the entire grid.
1590	! It would be better to scale it to the size of the lake
1591	! but this information is not yet available.
1592	!
1593	lake_diag(ig) = lake_reservoir(ig)/totarea
1594	!
1595	ENDDO
1596	!
1597	! Get from the restart the fluxes we accumulated.
1598	!
1599	ALLOCATE (floodout_mean(nbpt), stat=ier)
1600	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for floodout_mean','','')
1601	var_name = 'floodout_route'
1602	CALL ioconf_setatt_p('UNITS', 'Kg')
1603	CALL ioconf_setatt_p('LONG_NAME','Accumulated flow out of floodplains for routing')
1604	CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., floodout_mean, "gather", nbp_glo, index_g)
1605	CALL setvar_p (floodout_mean, val_exp, 'NO_KEYWORD', zero)
1606
1607	ALLOCATE (runoff_mean(nbpt), stat=ier)
1608	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for runoff_mean','','')
1609	var_name = 'runoff_route'
1610	CALL ioconf_setatt_p('UNITS', 'Kg')
1611	CALL ioconf_setatt_p('LONG_NAME','Accumulated runoff for routing')
1612	CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., runoff_mean, "gather", nbp_glo, index_g)
1613	CALL setvar_p (runoff_mean, val_exp, 'NO_KEYWORD', zero)
1614
1615	ALLOCATE(drainage_mean(nbpt), stat=ier)
1616	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for drainage_mean','','')
1617	var_name = 'drainage_route'
1618	CALL ioconf_setatt_p('UNITS', 'Kg')
1619	CALL ioconf_setatt_p('LONG_NAME','Accumulated drainage for routing')
1620	CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., drainage_mean, "gather", nbp_glo, index_g)
1621	CALL setvar_p (drainage_mean, val_exp, 'NO_KEYWORD', zero)
1622
1623	ALLOCATE(transpot_mean(nbpt), stat=ier)
1624	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for transpot_mean','','')
1625	var_name = 'transpot_route'
1626	CALL ioconf_setatt_p('UNITS', 'Kg/m^2')
1627	CALL ioconf_setatt_p('LONG_NAME','Accumulated potential transpiration for routing/irrigation')
1628	CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., transpot_mean, "gather", nbp_glo, index_g)
1629	CALL setvar_p (transpot_mean, val_exp, 'NO_KEYWORD', zero)
1630
1631	ALLOCATE(precip_mean(nbpt), stat=ier)
1632	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for precip_mean','','')
1633	var_name = 'precip_route'
1634	CALL ioconf_setatt_p('UNITS', 'Kg/m^2')
1635	CALL ioconf_setatt_p('LONG_NAME','Accumulated rain precipitation for irrigation')
1636	CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., precip_mean, "gather", nbp_glo, index_g)
1637	CALL setvar_p (precip_mean, val_exp, 'NO_KEYWORD', zero)
1638
1639	ALLOCATE(humrel_mean(nbpt), stat=ier)
1640	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for humrel_mean','','')
1641	var_name = 'humrel_route'
1642	CALL ioconf_setatt_p('UNITS', '-')
1643	CALL ioconf_setatt_p('LONG_NAME','Mean humrel for irrigation')
1644	CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., humrel_mean, "gather", nbp_glo, index_g)
1645	CALL setvar_p (humrel_mean, val_exp, 'NO_KEYWORD', un)
1646
1647	ALLOCATE(k_litt_mean(nbpt), stat=ier)
1648	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for k_litt_mean','','')
1649	var_name = 'k_litt_route'
1650	CALL ioconf_setatt_p('UNITS', '-')
1651	CALL ioconf_setatt_p('LONG_NAME','Mean cond. for litter')
1652	CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., k_litt_mean, "gather", nbp_glo, index_g)
1653	CALL setvar_p (k_litt_mean, val_exp, 'NO_KEYWORD', zero)
1654
1655	ALLOCATE(totnobio_mean(nbpt), stat=ier)
1656	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for totnobio_mean','','')
1657	var_name = 'totnobio_route'
1658	CALL ioconf_setatt_p('UNITS', '-')
1659	CALL ioconf_setatt_p('LONG_NAME','Last Total fraction of no bio for irrigation')
1660	CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., totnobio_mean, "gather", nbp_glo, index_g)
1661	CALL setvar_p (totnobio_mean, val_exp, 'NO_KEYWORD', zero)
1662
1663	ALLOCATE(vegtot_mean(nbpt), stat=ier)
1664	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for vegtot_mean','','')
1665	var_name = 'vegtot_route'
1666	CALL ioconf_setatt_p('UNITS', '-')
1667	CALL ioconf_setatt_p('LONG_NAME','Last Total fraction of vegetation')
1668	CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., vegtot_mean, "gather", nbp_glo, index_g)
1669	CALL setvar_p (vegtot_mean, val_exp, 'NO_KEYWORD', un)
1670	!
1671	!
1672	DEALLOCATE(tmp_real_g)
1673	!
1674	! Allocate diagnostic variables
1675	!
1676	ALLOCATE(hydrodiag_loc(nbpt,nbasmax),hydrodiag_glo(nbp_glo,nbasmax),stat=ier)
1677	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for hydrodiag_glo','','')
1678	hydrodiag=>hydrodiag_loc
1679
1680	ALLOCATE(hydroupbasin_loc(nbpt),hydroupbasin_glo(nbp_glo), stat=ier)
1681	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for hydroupbasin_glo','','')
1682	hydroupbasin=>hydroupbasin_loc
1683
1684	END SUBROUTINE routing_init
1685	!
1686	!! ================================================================================================================================
1687	!! SUBROUTINE : routing_clear
1688	!!
1689	!>\BRIEF : This subroutine deallocates the block memory previously allocated.
1690	!! \n
1691	!_ ================================================================================================================================
1692
1693	SUBROUTINE routing_clear()
1694
1695	IF (ALLOCATED(routing_area_loc)) DEALLOCATE(routing_area_loc)
1696	IF (ALLOCATED(route_togrid_loc)) DEALLOCATE(route_togrid_loc)
1697	IF (ALLOCATED(route_tobasin_loc)) DEALLOCATE(route_tobasin_loc)
1698	IF (ALLOCATED(route_nbintobas_loc)) DEALLOCATE(route_nbintobas_loc)
1699	IF (ALLOCATED(global_basinid_loc)) DEALLOCATE(global_basinid_loc)
1700	IF (ALLOCATED(topo_resid_loc)) DEALLOCATE(topo_resid_loc)
1701	IF (ALLOCATED(routing_area_glo)) DEALLOCATE(routing_area_glo)
1702	IF (ALLOCATED(route_togrid_glo)) DEALLOCATE(route_togrid_glo)
1703	IF (ALLOCATED(route_tobasin_glo)) DEALLOCATE(route_tobasin_glo)
1704	IF (ALLOCATED(route_nbintobas_glo)) DEALLOCATE(route_nbintobas_glo)
1705	IF (ALLOCATED(global_basinid_glo)) DEALLOCATE(global_basinid_glo)
1706	IF (ALLOCATED(topo_resid_glo)) DEALLOCATE(topo_resid_glo)
1707	IF (ALLOCATED(fast_reservoir)) DEALLOCATE(fast_reservoir)
1708	IF (ALLOCATED(slow_reservoir)) DEALLOCATE(slow_reservoir)
1709	IF (ALLOCATED(stream_reservoir)) DEALLOCATE(stream_reservoir)
1710	IF (ALLOCATED(flood_reservoir)) DEALLOCATE(flood_reservoir)
1711	IF (ALLOCATED(flood_frac_bas)) DEALLOCATE(flood_frac_bas)
1712	IF (ALLOCATED(flood_height)) DEALLOCATE(flood_height)
1713	IF (ALLOCATED(pond_frac)) DEALLOCATE(pond_frac)
1714	IF (ALLOCATED(lake_reservoir)) DEALLOCATE(lake_reservoir)
1715	IF (ALLOCATED(pond_reservoir)) DEALLOCATE(pond_reservoir)
1716	IF (ALLOCATED(returnflow_mean)) DEALLOCATE(returnflow_mean)
1717	IF (ALLOCATED(reinfiltration_mean)) DEALLOCATE(reinfiltration_mean)
1718	IF (ALLOCATED(riverflow_mean)) DEALLOCATE(riverflow_mean)
1719	IF (ALLOCATED(coastalflow_mean)) DEALLOCATE(coastalflow_mean)
1720	IF (ALLOCATED(lakeinflow_mean)) DEALLOCATE(lakeinflow_mean)
1721	IF (ALLOCATED(runoff_mean)) DEALLOCATE(runoff_mean)
1722	IF (ALLOCATED(floodout_mean)) DEALLOCATE(floodout_mean)
1723	IF (ALLOCATED(drainage_mean)) DEALLOCATE(drainage_mean)
1724	IF (ALLOCATED(transpot_mean)) DEALLOCATE(transpot_mean)
1725	IF (ALLOCATED(precip_mean)) DEALLOCATE(precip_mean)
1726	IF (ALLOCATED(humrel_mean)) DEALLOCATE(humrel_mean)
1727	IF (ALLOCATED(k_litt_mean)) DEALLOCATE(k_litt_mean)
1728	IF (ALLOCATED(totnobio_mean)) DEALLOCATE(totnobio_mean)
1729	IF (ALLOCATED(vegtot_mean)) DEALLOCATE(vegtot_mean)
1730	IF (ALLOCATED(floodtemp)) DEALLOCATE(floodtemp)
1731	IF (ALLOCATED(hydrodiag_loc)) DEALLOCATE(hydrodiag_loc)
1732	IF (ALLOCATED(hydrodiag_glo)) DEALLOCATE(hydrodiag_glo)
1733	IF (ALLOCATED(hydroupbasin_loc)) DEALLOCATE(hydroupbasin_loc)
1734	IF (ALLOCATED(hydroupbasin_glo)) DEALLOCATE(hydroupbasin_glo)
1735	IF (ALLOCATED(hydrographs)) DEALLOCATE(hydrographs)
1736	IF (ALLOCATED(slowflow_diag)) DEALLOCATE(slowflow_diag)
1737	IF (ALLOCATED(irrigation_mean)) DEALLOCATE(irrigation_mean)
1738	IF (ALLOCATED(irrigated)) DEALLOCATE(irrigated)
1739	IF (ALLOCATED(floodplains)) DEALLOCATE(floodplains)
1740	IF (ALLOCATED(swamp)) DEALLOCATE(swamp)
1741	IF (ALLOCATED(fast_diag)) DEALLOCATE(fast_diag)
1742	IF (ALLOCATED(slow_diag)) DEALLOCATE(slow_diag)
1743	IF (ALLOCATED(stream_diag)) DEALLOCATE(stream_diag)
1744	IF (ALLOCATED(flood_diag)) DEALLOCATE(flood_diag)
1745	IF (ALLOCATED(pond_diag)) DEALLOCATE(pond_diag)
1746	IF (ALLOCATED(lake_diag)) DEALLOCATE(lake_diag)
1747
1748	END SUBROUTINE routing_clear
1749	!
1750
1751	!! ================================================================================================================================
1752	!! SUBROUTINE : routing_flow
1753	!!
1754	!>\BRIEF This subroutine computes the transport of water in the various reservoirs
1755	!! (including ponds and floodplains) and the water withdrawals from the reservoirs for irrigation.
1756	!!
1757	!! DESCRIPTION (definitions, functional, design, flags) :
1758	!! This will first compute the amount of water which flows out of each of the 3 reservoirs using the assumption of an
1759	!! exponential decrease of water in the reservoir (see Hagemann S and Dumenil L. (1998)). Then we compute the fluxes
1760	!! for floodplains and ponds. All this will then be used in order to update each of the basins : taking water out of
1761	!! the up-stream basin and adding it to the down-stream one.
1762	!! As this step happens globaly we have to stop the parallel processing in order to exchange the information. Once
1763	!! all reservoirs are updated we deal with irrigation. The final step is to compute diagnostic fluxes. Among them
1764	!! the hydrographs of the largest rivers we have chosen to monitor.
1765	!!
1766	!! RECENT CHANGE(S): None
1767	!!
1768	!! MAIN OUTPUT VARIABLE(S): lakeinflow, returnflow, reinfiltration, irrigation, riverflow, coastalflow, hydrographs, flood_frac, flood_res
1769	!!
1770	!! REFERENCES :
1771	!! - Ngo-Duc, T., K. Laval, G. Ramillien, J. Polcher, and A. Cazenave (2007)
1772	!! Validation of the land water storage simulated by Organising Carbon and Hydrology in Dynamic Ecosystems (ORCHIDEE) with Gravity Recovery and Climate Experiment (GRACE) data.
1773	!! Water Resour. Res., 43, W04427, doi:10.1029/2006WR004941.
1774	!! * Irrigation:
1775	!! - de Rosnay, P., J. Polcher, K. Laval, and M. Sabre (2003)
1776	!! Integrated parameterization of irrigation in the land surface model ORCHIDEE. Validation over Indian Peninsula.
1777	!! Geophys. Res. Lett., 30(19), 1986, doi:10.1029/2003GL018024.
1778	!! - A.C. Vivant (2003)
1779	!! Les plaines d'inondations et l'irrigation dans ORCHIDEE, impacts de leur prise en compte.
1780	!! , , 51pp.
1781	!! - N. Culson (2004)
1782	!! Impact de l'irrigation sur le cycle de l'eau
1783	!! Master thesis, Paris VI University, 55pp.
1784	!! - X.-T. Nguyen-Vinh (2005)
1785	!! Analyse de l'impact de l'irrigation en Amerique du Nord - plaine du Mississippi - sur la climatologie regionale
1786	!! Master thesis, Paris VI University, 33pp.
1787	!! - M. Guimberteau (2006)
1788	!! Analyse et modifications proposees de la modelisation de l'irrigation dans un modele de surface.
1789	!! Master thesis, Paris VI University, 46pp.
1790	!! - Guimberteau M. (2010)
1791	!! Modelisation de l'hydrologie continentale et influences de l'irrigation sur le cycle de l'eau.
1792	!! Ph.D. thesis, Paris VI University, 195pp.
1793	!! - Guimberteau M., Laval K., Perrier A. and Polcher J. (2011).
1794	!! Global effect of irrigation and its impact on the onset of the Indian summer monsoon.
1795	!! In press, Climate Dynamics, doi: 10.1007/s00382-011-1252-5.
1796	!! * Floodplains:
1797	!! - A.C. Vivant (2002)
1798	!! L'ecoulement lateral de l'eau sur les surfaces continentales. Prise en compte des plaines d'inondations dans ORCHIDEE.
1799	!! Master thesis, Paris VI University, 46pp.
1800	!! - A.C. Vivant (2003)
1801	!! Les plaines d'inondations et l'irrigation dans ORCHIDEE, impacts de leur prise en compte.
1802	!! , , 51pp.
1803	!! - T. d'Orgeval (2006)
1804	!! Impact du changement climatique sur le cycle de l'eau en Afrique de l'Ouest: modelisation et incertitudes.
1805	!! Ph.D. thesis, Paris VI University, 188pp.
1806	!! - T. d'Orgeval, J. Polcher, and P. de Rosnay (2008)
1807	!! Sensitivity of the West African hydrological cycle in ORCHIDEE to infiltration processes.
1808	!! Hydrol. Earth Syst. Sci., 12, 1387-1401
1809	!! - M. Guimberteau, G. Drapeau, J. Ronchail, B. Sultan, J. Polcher, J.-M. Martinez, C. Prigent, J.-L. Guyot, G. Cochonneau,
1810	!! J. C. Espinoza, N. Filizola, P. Fraizy, W. Lavado, E. De Oliveira, R. Pombosa, L. Noriega, and P. Vauchel (2011)
1811	!! Discharge simulation in the sub-basins of the Amazon using ORCHIDEE forced by new datasets.
1812	!! Hydrol. Earth Syst. Sci. Discuss., 8, 11171-11232, doi:10.5194/hessd-8-11171-2011
1813	!!
1814	!! FLOWCHART :None
1815	!! \n
1816	!_ ================================================================================================================================
1817
1818	SUBROUTINE routing_flow(nbpt, dt_routing, lalo, floodout, runoff, drainage, &
1819	& vegtot, totnobio, transpot_mean, precip, humrel, k_litt, floodtemp, reinf_slope, &
1820	& lakeinflow, returnflow, reinfiltration, irrigation, riverflow, &
1821	& coastalflow, hydrographs, slowflow_diag, flood_frac, flood_res, &
1822	netflow_stream_diag, netflow_fast_diag, netflow_slow_diag)
1823	!
1824	IMPLICIT NONE
1825	!
1826	!! INPUT VARIABLES
1827	INTEGER(i_std), INTENT(in) :: nbpt !! Domain size (unitless)
1828	REAL(r_std), INTENT (in) :: dt_routing !! Routing time step (s)
1829	REAL(r_std), INTENT(in) :: lalo(nbpt,2) !! Vector of latitude and longitudes
1830	REAL(r_std), INTENT(in) :: runoff(nbpt) !! Grid-point runoff (kg/m^2/dt)
1831	REAL(r_std), INTENT(in) :: floodout(nbpt) !! Grid-point flow out of floodplains (kg/m^2/dt)
1832	REAL(r_std), INTENT(in) :: drainage(nbpt) !! Grid-point drainage (kg/m^2/dt)
1833	REAL(r_std), INTENT(in) :: vegtot(nbpt) !! Potentially vegetated fraction (unitless;0-1)
1834	REAL(r_std), INTENT(in) :: totnobio(nbpt) !! Other areas which can not have vegetation
1835	REAL(r_std), INTENT(in) :: transpot_mean(nbpt) !! Mean potential transpiration of the vegetation (kg/m^2/dt)
1836	REAL(r_std), INTENT(in) :: precip(nbpt) !! Rainfall (kg/m^2/dt)
1837	REAL(r_std), INTENT(in) :: humrel(nbpt) !! Soil moisture stress, root extraction potential (unitless)
1838	REAL(r_std), INTENT(in) :: k_litt(nbpt) !! Averaged conductivity for saturated infiltration in the 'litter' layer (kg/m^2/dt)
1839	REAL(r_std), INTENT(in) :: floodtemp(nbpt) !! Temperature to decide if floodplains work (K)
1840	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)
1841	REAL(r_std), INTENT(out) :: lakeinflow(nbpt) !! Water inflow to the lakes (kg/dt)
1842	!
1843	!! OUTPUT VARIABLES
1844	REAL(r_std), INTENT(out) :: returnflow(nbpt) !! The water flow from lakes and swamps which returns into the grid box.
1845	!! This water will go back into the hydrol or hydrolc module to allow re-evaporation (kg/m^2/dt_routing)
1846	REAL(r_std), INTENT(out) :: reinfiltration(nbpt) !! Water flow from ponds and floodplains which returns to the grid box (kg/m^2/dt)
1847	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)
1848	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)
1849	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)
1850	REAL(r_std), INTENT(out) :: hydrographs(nbpt) !! Hydrographs at the outflow of the grid box for major basins (kg/dt)
1851	REAL(r_std), INTENT(out) :: slowflow_diag(nbpt) !! Hydrographs of slow_flow = routed slow_flow for major basins (kg/dt)
1852	REAL(r_std), INTENT(out) :: flood_frac(nbpt) !! Flooded fraction of the grid box (unitless;0-1)
1853	REAL(r_std), INTENT(out) :: flood_res(nbpt) !! Diagnostic of water amount in the floodplains reservoir (kg)
1854
1855	REAL(r_std), INTENT(out) :: netflow_stream_diag(nbpt) !! Input - Output flow to stream reservoir
1856	REAL(r_std), INTENT(out) :: netflow_fast_diag(nbpt) !! Input - Output flow to fast reservoir
1857	REAL(r_std), INTENT(out) :: netflow_slow_diag(nbpt) !! Input - Output flow to slow reservoir
1858	!
1859	!! LOCAL VARIABLES
1860	REAL(r_std), DIMENSION(nbpt, nbasmax) :: fast_flow !! Outflow from the fast reservoir (kg/dt)
1861	REAL(r_std), DIMENSION(nbpt, nbasmax) :: slow_flow !! Outflow from the slow reservoir (kg/dt)
1862	REAL(r_std), DIMENSION(nbpt, nbasmax) :: stream_flow !! Outflow from the stream reservoir (kg/dt)
1863	REAL(r_std), DIMENSION(nbpt, nbasmax) :: flood_flow !! Outflow from the floodplain reservoir (kg/dt)
1864	REAL(r_std), DIMENSION(nbpt, nbasmax) :: pond_inflow !! Inflow to the pond reservoir (kg/dt)
1865	REAL(r_std), DIMENSION(nbpt, nbasmax) :: pond_drainage !! Drainage from pond (kg/m^2/dt)
1866	REAL(r_std), DIMENSION(nbpt, nbasmax) :: flood_drainage !! Drainage from floodplains (kg/m^2/dt)
1867	REAL(r_std), DIMENSION(nbpt, nbasmax) :: return_swamp !! Inflow to the swamp (kg/dt)
1868	!
1869	! Irrigation per basin
1870	!
1871	REAL(r_std), DIMENSION(nbpt, nbasmax) :: irrig_needs !! Total irrigation requirement (water requirements by the crop for its optimal growth) (kg)
1872	REAL(r_std), DIMENSION(nbpt, nbasmax) :: irrig_actual !! Possible irrigation according to the water availability in the reservoirs (kg)
1873	REAL(r_std), DIMENSION(nbpt, nbasmax) :: irrig_deficit !! Amount of water missing for irrigation (kg)
1874	REAL(r_std), DIMENSION(nbpt, nbasmax) :: irrig_adduct !! Amount of water carried over from other basins for irrigation (kg)
1875	!
1876	REAL(r_std), DIMENSION(nbpt, 0:nbasmax+3) :: transport !! Water transport between basins (kg/dt)
1877	REAL(r_std), DIMENSION(nbp_glo, 0:nbasmax+3) :: transport_glo !! Water transport between basins (kg/dt)
1878	REAL(r_std), DIMENSION(nbpt, nbasmax) :: floods !! Water flow in to the floodplains (kg/dt)
1879	REAL(r_std), DIMENSION(nbpt, nbasmax) :: potflood !! Potential inflow to the swamps (kg/dt)
1880	REAL(r_std), DIMENSION(nbpt) :: tobeflooded !! Maximal surface which can be inundated in each grid box (m^2)
1881	REAL(r_std), DIMENSION(nbpt) :: totarea !! Total area of basin (m^2)
1882	REAL(r_std), DIMENSION(nbpt) :: totflood !! Total amount of water in the floodplains reservoir (kg)
1883	REAL(r_std), DIMENSION(nbasmax) :: pond_excessflow !!
1884	REAL(r_std) :: flow !! Outflow computation for the reservoirs (kg/dt)
1885	REAL(r_std) :: floodindex !! Fraction of grid box area inundated (unitless;0-1)
1886	REAL(r_std) :: pondex !!
1887	REAL(r_std) :: flood_frac_pot !! Total fraction of the grid box which is flooded at optimum repartition (unitless;0-1)
1888	REAL(r_std) :: stream_tot !! Total water amount in the stream reservoirs (kg)
1889	REAL(r_std) :: adduction !! Importation of water from a stream reservoir of a neighboring grid box (kg)
1890	REAL(r_std), DIMENSION(nbp_glo) :: lake_overflow_g !! Removed water from lake reservoir on global grid (kg/gridcell/dt_routing)
1891	REAL(r_std), DIMENSION(nbpt) :: lake_overflow !! Removed water from lake reservoir on local grid (kg/gridcell/dt_routing)
1892	REAL(r_std), DIMENSION(nbpt) :: lake_overflow_coast !! lake_overflow distributed on coast gridcells, only diag(kg/gridcell/dt_routing)
1893	REAL(r_std) :: total_lake_overflow !! Sum of lake_overflow over full grid (kg)
1894	REAL(r_std), DIMENSION(8,nbasmax) :: streams_around !! Stream reservoirs of the neighboring grid boxes (kg)
1895	INTEGER(i_std), DIMENSION(8) :: igrd !!
1896	INTEGER(i_std), DIMENSION(2) :: ff !!
1897	INTEGER(i_std), DIMENSION(1) :: fi !!
1898	INTEGER(i_std) :: ig, ib, ib2, ig2 !! Indices (unitless)
1899	INTEGER(i_std) :: rtg, rtb, in !! Indices (unitless)
1900	INTEGER(i_std) :: ier !! Error handling
1901	REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: fast_flow_g !! Outflow from the fast reservoir (kg/dt)
1902	REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: slow_flow_g !! Outflow from the slow reservoir (kg/dt)
1903	REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: stream_flow_g !! Outflow from the stream reservoir (kg/dt)
1904	REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: irrig_deficit_glo !! Amount of water missing for irrigation (kg)
1905	REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: stream_reservoir_glo !! Water amount in the stream reservoir (kg)
1906	REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: irrig_adduct_glo !! Amount of water carried over from other basins for irrigation (kg)
1907
1908	REAL(r_std), DIMENSION(nbpt, nbasmax) :: netflow_stream !! Input - Output flow to stream reservoir
1909	REAL(r_std), DIMENSION(nbpt, nbasmax) :: netflow_fast !! Input - Output flow to fast reservoir
1910	REAL(r_std), DIMENSION(nbpt, nbasmax) :: netflow_slow !! Input - Output flow to slow reservoir
1911
1912
1913	!! PARAMETERS
1914	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)
1915	!_ ================================================================================================================================
1916	!
1917	transport(:,:) = zero
1918	transport_glo(:,:) = zero
1919	irrig_netereq(:) = zero
1920	irrig_needs(:,:) = zero
1921	irrig_actual(:,:) = zero
1922	irrig_deficit(:,:) = zero
1923	irrig_adduct(:,:) = zero
1924	totarea(:) = zero
1925	totflood(:) = zero
1926	!
1927	! Compute all the fluxes
1928	!
1929	DO ib=1,nbasmax
1930	DO ig=1,nbpt
1931	!
1932	totarea(ig) = totarea(ig) + routing_area(ig,ib)
1933	totflood(ig) = totflood(ig) + flood_reservoir(ig,ib)
1934	ENDDO
1935	ENDDO
1936	!
1937	!> The outflow fluxes from the three reservoirs are computed.
1938	!> The outflow of volume of water Vi into the reservoir i is assumed to be linearly related to its volume.
1939	!> The water travel simulated by the routing scheme is dependent on the water retention index topo_resid
1940	!> given by a 0.5 degree resolution map for each pixel performed from a simplification of Manning's formula
1941	!> (Dingman, 1994; Ducharne et al., 2003).
1942	!> The resulting product of tcst (in day/m) and topo_resid (in m) represents the time constant (day)
1943	!> which is an e-folding time, the time necessary for the water amount
1944	!> in the stream reservoir to decrease by a factor e. Hence, it gives an order of
1945	!> magnitude of the travel time through this reservoir between
1946	!> the sub-basin considered and its downstream neighbor.
1947
1948	DO ib=1,nbasmax
1949	DO ig=1,nbpt
1950	IF ( route_tobasin(ig,ib) .GT. 0 ) THEN
1951	!
1952	! Each of the fluxes is limited by the water in the reservoir and a small margin
1953	! (min_reservoir) to avoid rounding errors.
1954	!
1955	flow = MIN(fast_reservoir(ig,ib)/((topo_resid(ig,ib)/1000.)fast_tcstone_day/dt_routing),&
1956	& fast_reservoir(ig,ib)-min_sechiba)
1957	fast_flow(ig,ib) = MAX(flow, zero)
1958
1959	flow = MIN(slow_reservoir(ig,ib)/((topo_resid(ig,ib)/1000.)slow_tcstone_day/dt_routing),&
1960	& slow_reservoir(ig,ib)-min_sechiba)
1961	slow_flow(ig,ib) = MAX(flow, zero)
1962
1963	flow = MIN(stream_reservoir(ig,ib)/((topo_resid(ig,ib)/1000.)stream_tcst &
1964	& MAX(un-SQRT(flood_frac_bas(ig,ib)),min_sechiba)*one_day/dt_routing),&
1965	& stream_reservoir(ig,ib)-min_sechiba)
1966	stream_flow(ig,ib) = MAX(flow, zero)
1967	!
1968	ELSE
1969	fast_flow(ig,ib) = zero
1970	slow_flow(ig,ib) = zero
1971	stream_flow(ig,ib) = zero
1972	ENDIF
1973	ENDDO
1974	ENDDO
1975	!-
1976	!- Compute the fluxes out of the floodplains and ponds if they exist.
1977	!-
1978	IF (do_floodplains .OR. doponds) THEN
1979	DO ig=1,nbpt
1980	IF (flood_frac(ig) .GT. min_sechiba) THEN
1981	!
1982	flow = MIN(floodout(ig)totarea(ig)pond_frac(ig)/flood_frac(ig), pond_reservoir(ig)+totflood(ig))
1983	pondex = MAX(flow - pond_reservoir(ig), zero)
1984	pond_reservoir(ig) = pond_reservoir(ig) - (flow - pondex)
1985	!
1986	! If demand was over reservoir size, we will take it out from floodplains
1987	!
1988	pond_excessflow(:) = zero
1989	DO ib=1,nbasmax
1990	pond_excessflow(ib) = MIN(pondex*flood_frac_bas(ig,ib)/(flood_frac(ig)-pond_frac(ig)),&
1991	& flood_reservoir(ig,ib))
1992	pondex = pondex - pond_excessflow(ib)
1993	ENDDO
1994	!
1995	IF ( pondex .GT. min_sechiba) THEN
1996	WRITE(numout,*) "Unable to redistribute the excess pond outflow over the water available in the floodplain."
1997	WRITE(numout,*) "Pondex = ", pondex
1998	WRITE(numout,*) "pond_excessflow(:) = ", pond_excessflow(:)
1999	ENDIF
2000	!
2001	DO ib=1,nbasmax
2002	!
2003	flow = floodout(ig)routing_area(ig,ib)flood_frac_bas(ig,ib)/flood_frac(ig) + pond_excessflow(ib)
2004	!
2005	flood_reservoir(ig,ib) = flood_reservoir(ig,ib) - flow
2006	!
2007	!
2008	IF (flood_reservoir(ig,ib) .LT. min_sechiba) THEN
2009	flood_reservoir(ig,ib) = zero
2010	ENDIF
2011	IF (pond_reservoir(ig) .LT. min_sechiba) THEN
2012	pond_reservoir(ig) = zero
2013	ENDIF
2014	ENDDO
2015	ENDIF
2016	ENDDO
2017	ENDIF
2018
2019	!-
2020	!- Computing the drainage and outflow from floodplains
2021	!> Drainage from floodplains is depending on a averaged conductivity (k_litt)
2022	!> for saturated infiltration in the 'litter' layer. Flood_drainage will be
2023	!> a component of the total reinfiltration that leaves the routing scheme.
2024	!-
2025	IF (do_floodplains) THEN
2026	IF (dofloodinfilt) THEN
2027	DO ib=1,nbasmax
2028	DO ig=1,nbpt
2029	flood_drainage(ig,ib) = MAX(zero, MIN(flood_reservoir(ig,ib), &
2030	& flood_frac(ig)routing_area(ig,ib)k_litt(ig)*dt_routing/one_day))
2031	flood_reservoir(ig,ib) = flood_reservoir(ig,ib) - flood_drainage(ig,ib)
2032	ENDDO
2033	ENDDO
2034	ELSE
2035	DO ib=1,nbasmax
2036	DO ig=1,nbpt
2037	flood_drainage(ig,ib) = zero
2038	ENDDO
2039	ENDDO
2040	ENDIF
2041	!> Outflow from floodplains is computed depending a delay. This delay is characterized by a time constant
2042	!> function of the surface of the floodplains and the product of topo_resid and flood_tcst. flood_tcst
2043	!> has been calibrated through observations in the Niger Inner Delta (D'Orgeval, 2006).
2044	!
2045	DO ib=1,nbasmax
2046	DO ig=1,nbpt
2047	IF ( route_tobasin(ig,ib) .GT. 0 ) THEN
2048	IF (flood_frac_bas(ig,ib) .GT. min_sechiba) THEN
2049	flow = MIN(flood_reservoir(ig,ib) &
2050	& /((topo_resid(ig,ib)/1000.)flood_tcst &
2051	& flood_frac_bas(ig,ib)*one_day/dt_routing),&
2052	& flood_reservoir(ig,ib))
2053	ELSE
2054	flow = zero
2055	ENDIF
2056	flood_flow(ig,ib) = flow
2057	ELSE
2058	flood_flow(ig,ib) = zero
2059	ENDIF
2060	ENDDO
2061	ENDDO
2062	ELSE
2063	DO ib=1,nbasmax
2064	DO ig=1,nbpt
2065	flood_drainage(ig,ib) = zero
2066	flood_flow(ig,ib) = zero
2067	flood_reservoir(ig,ib) = zero
2068	ENDDO
2069	ENDDO
2070	ENDIF
2071
2072	!-
2073	!- Computing drainage and inflow for ponds
2074	!> Drainage from ponds is computed in the same way than for floodplains.
2075	!> Reinfiltrated fraction from the runoff (i.e. the outflow from the fast reservoir)
2076	!> is the inflow of the pond reservoir.
2077	!-
2078	IF (doponds) THEN
2079	! If used, the slope coef is not used in hydrol for water2infilt
2080	DO ib=1,nbasmax
2081	DO ig=1,nbpt
2082	pond_inflow(ig,ib) = fast_flow(ig,ib) * reinf_slope(ig)
2083	pond_drainage(ig,ib) = MIN(pond_reservoir(ig)*routing_area(ig,ib)/totarea(ig), &
2084	& pond_frac(ig)routing_area(ig,ib)k_litt(ig)*dt_routing/one_day)
2085	fast_flow(ig,ib) = fast_flow(ig,ib) - pond_inflow(ig,ib)
2086	ENDDO
2087	ENDDO
2088	ELSE
2089	DO ib=1,nbasmax
2090	DO ig=1,nbpt
2091	pond_inflow(ig,ib) = zero
2092	pond_drainage(ig,ib) = zero
2093	pond_reservoir(ig) = zero
2094	ENDDO
2095	ENDDO
2096	ENDIF
2097
2098	!ym cette methode conserve les erreurs d'arrondie
2099	!ym mais n'est pas la plus efficace
2100
2101	!-
2102	!- Compute the transport from one basin to another
2103	!-
2104
2105	IF (is_root_prc) THEN
2106	ALLOCATE( fast_flow_g(nbp_glo, nbasmax), slow_flow_g(nbp_glo, nbasmax), &
2107	stream_flow_g(nbp_glo, nbasmax), stat=ier)
2108	ELSE
2109	ALLOCATE( fast_flow_g(1,1), slow_flow_g(1,1), &
2110	stream_flow_g(1, 1), stat=ier)
2111	ENDIF
2112	IF (ier /= 0) CALL ipslerr_p(3,'routing_flow','Pb in allocate for fast_flow_g','','')
2113
2114	CALL gather(fast_flow,fast_flow_g)
2115	CALL gather(slow_flow,slow_flow_g)
2116	CALL gather(stream_flow,stream_flow_g)
2117
2118	IF (is_root_prc) THEN
2119	DO ib=1,nbasmax
2120	DO ig=1,nbp_glo
2121	!
2122	rtg = route_togrid_glo(ig,ib)
2123	rtb = route_tobasin_glo(ig,ib)
2124	transport_glo(rtg,rtb) = transport_glo(rtg,rtb) + fast_flow_g(ig,ib) + slow_flow_g(ig,ib) + &
2125	& stream_flow_g(ig,ib)
2126	!
2127	ENDDO
2128	ENDDO
2129	ENDIF
2130
2131	DEALLOCATE( fast_flow_g, slow_flow_g, stream_flow_g )
2132
2133	CALL scatter(transport_glo,transport)
2134
2135	!-
2136	!- Do the floodings - First initialize
2137	!-
2138	return_swamp(:,:)=zero
2139	floods(:,:)=zero
2140	!-
2141	!> Over swamp areas, a fraction of water (return_swamp) is withdrawn from the river depending on the
2142	!> parameter swamp_cst.
2143	!> It will be transferred into soil moisture and thus does not return directly to the river.
2144	!
2145	!- 1. Swamps: Take out water from the river to put it to the swamps
2146	!-
2147	!
2148	IF ( doswamps ) THEN
2149	tobeflooded(:) = swamp(:)
2150	DO ib=1,nbasmax
2151	DO ig=1,nbpt
2152	potflood(ig,ib) = transport(ig,ib)
2153	!
2154	IF ( tobeflooded(ig) > 0. .AND. potflood(ig,ib) > 0. .AND. floodtemp(ig) > tp_00 ) THEN
2155	!
2156	IF (routing_area(ig,ib) > tobeflooded(ig)) THEN
2157	floodindex = tobeflooded(ig) / routing_area(ig,ib)
2158	ELSE
2159	floodindex = 1.0
2160	ENDIF
2161	return_swamp(ig,ib) = swamp_cst * potflood(ig,ib) * floodindex
2162	!
2163	tobeflooded(ig) = tobeflooded(ig) - routing_area(ig,ib)
2164	!
2165	ENDIF
2166	ENDDO
2167	ENDDO
2168	ENDIF
2169	!-
2170	!- 2. Floodplains: Update the reservoir with the flux computed above.
2171	!-
2172	IF ( do_floodplains ) THEN
2173	DO ig=1,nbpt
2174	IF (floodplains(ig) .GT. min_sechiba .AND. floodtemp(ig) .GT. tp_00) THEN
2175	DO ib=1,nbasmax
2176	floods(ig,ib) = transport(ig,ib) - return_swamp(ig,ib)
2177	ENDDO
2178	ENDIF
2179	ENDDO
2180	ENDIF
2181	!
2182	! Update all reservoirs
2183	!> The slow and deep reservoir (slow_reservoir) collect the deep drainage whereas the
2184	!> fast_reservoir collects the computed surface runoff. Both discharge into a third reservoir
2185	!> (stream_reservoir) of the next sub-basin downstream.
2186	!> Water from the floodplains reservoir (flood_reservoir) flows also into the stream_reservoir of the next sub-basin downstream.
2187	!> Water that flows into the pond_reservoir is withdrawn from the fast_reservoir.
2188	!
2189	DO ig=1,nbpt
2190	DO ib=1,nbasmax
2191	!
2192	fast_reservoir(ig,ib) = fast_reservoir(ig,ib) + runoff(ig)*routing_area(ig,ib) - &
2193	& fast_flow(ig,ib) - pond_inflow(ig,ib)
2194	!
2195	slow_reservoir(ig,ib) = slow_reservoir(ig,ib) + drainage(ig)*routing_area(ig,ib) - &
2196	& slow_flow(ig,ib)
2197	!
2198	stream_reservoir(ig,ib) = stream_reservoir(ig,ib) + flood_flow(ig,ib) + transport(ig,ib) - &
2199	& stream_flow(ig,ib) - return_swamp(ig,ib) - floods(ig,ib)
2200	!
2201	flood_reservoir(ig,ib) = flood_reservoir(ig,ib) + floods(ig,ib) - &
2202	& flood_flow(ig,ib)
2203	!
2204	pond_reservoir(ig) = pond_reservoir(ig) + pond_inflow(ig,ib) - pond_drainage(ig,ib)
2205	!
2206	IF ( flood_reservoir(ig,ib) .LT. zero ) THEN
2207	IF ( check_reservoir ) THEN
2208	WRITE(numout,*) "WARNING : negative flood reservoir at :", ig, ib, ". Problem is being corrected."
2209	WRITE(numout,*) "flood_reservoir, floods, flood_flow : ", flood_reservoir(ig,ib), floods(ig,ib), &
2210	& flood_flow(ig,ib)
2211	ENDIF
2212	stream_reservoir(ig,ib) = stream_reservoir(ig,ib) + flood_reservoir(ig,ib)
2213	flood_reservoir(ig,ib) = zero
2214	ENDIF
2215	!
2216	IF ( stream_reservoir(ig,ib) .LT. zero ) THEN
2217	IF ( check_reservoir ) THEN
2218	WRITE(numout,*) "WARNING : negative stream reservoir at :", ig, ib, ". Problem is being corrected."
2219	WRITE(numout,*) "stream_reservoir, flood_flow, transport : ", stream_reservoir(ig,ib), flood_flow(ig,ib), &
2220	& transport(ig,ib)
2221	WRITE(numout,*) "stream_flow, return_swamp, floods :", stream_flow(ig,ib), return_swamp(ig,ib), floods(ig,ib)
2222	ENDIF
2223	fast_reservoir(ig,ib) = fast_reservoir(ig,ib) + stream_reservoir(ig,ib)
2224	stream_reservoir(ig,ib) = zero
2225	ENDIF
2226	!
2227	IF ( fast_reservoir(ig,ib) .LT. zero ) THEN
2228	IF ( check_reservoir ) THEN
2229	WRITE(numout,*) "WARNING : negative fast reservoir at :", ig, ib, ". Problem is being corrected."
2230	WRITE(numout,*) "fast_reservoir, runoff, fast_flow, ponf_inflow : ", fast_reservoir(ig,ib), &
2231	&runoff(ig), fast_flow(ig,ib), pond_inflow(ig,ib)
2232	ENDIF
2233	slow_reservoir(ig,ib) = slow_reservoir(ig,ib) + fast_reservoir(ig,ib)
2234	fast_reservoir(ig,ib) = zero
2235	ENDIF
2236
2237	IF ( slow_reservoir(ig,ib) .LT. - min_sechiba ) THEN
2238	WRITE(numout,*) 'WARNING : There is a negative reservoir at :', ig, ib,lalo(ig,:)
2239	WRITE(numout,*) 'WARNING : slowr, slow_flow, drainage', &
2240	& slow_reservoir(ig,ib), slow_flow(ig,ib), drainage(ig)
2241	WRITE(numout,*) 'WARNING : pondr, pond_inflow, pond_drainage', &
2242	& pond_reservoir(ig), pond_inflow(ig,ib), pond_drainage(ig,ib)
2243	CALL ipslerr_p(2, 'routing_flow', 'WARNING negative slow_reservoir.','','')
2244	ENDIF
2245
2246	ENDDO
2247	ENDDO
2248
2249
2250	totflood(:) = zero
2251	DO ig=1,nbpt
2252	DO ib=1,nbasmax
2253	totflood(ig) = totflood(ig) + flood_reservoir(ig,ib)
2254	ENDDO
2255	ENDDO
2256
2257	!-
2258	!- Computes the fraction of floodplains and ponds according to their volume
2259	!-
2260	IF (do_floodplains .OR. doponds) THEN
2261	flood_frac(:) = zero
2262	flood_height(:) = zero
2263	flood_frac_bas(:,:) = zero
2264	DO ig=1, nbpt
2265	IF (totflood(ig) .GT. min_sechiba) THEN
2266	! We first compute the total fraction of the grid box which is flooded at optimum repartition
2267	flood_frac_pot = (totflood(ig) / (totarea(ig)floodcri/(beta+un)))*(beta/(beta+un))
2268	flood_frac(ig) = MIN(floodplains(ig) / totarea(ig), flood_frac_pot)
2269	! Then we diagnose the fraction for each basin with the size of its flood_reservoir
2270	! (flood_frac_bas may be > 1)
2271	DO ib=1,nbasmax
2272	IF (routing_area(ig,ib) .GT. min_sechiba) THEN
2273	flood_frac_bas(ig,ib) = flood_frac(ig) * &
2274	& (flood_reservoir(ig,ib) / totflood(ig)) / (routing_area(ig,ib) / totarea(ig))
2275	ENDIF
2276	ENDDO
2277	! We diagnose the maximum height of floodplain
2278	flood_height(ig) = (beta/(beta+1))floodcri(flood_frac(ig))*(un/beta) + totflood(ig)/(totarea(ig)flood_frac(ig))
2279	! And finally add the pond surface
2280	pond_frac(ig) = MIN(un-flood_frac(ig), ((betap+1)pond_reservoir(ig) / (pondcritotarea(ig)))**(betap/(betap+1)) )
2281	flood_frac(ig) = flood_frac(ig) + pond_frac(ig)
2282	!
2283	ENDIF
2284	ENDDO
2285	ELSE
2286	flood_frac(:) = zero
2287	flood_height(:) = zero
2288	flood_frac_bas(:,:) = zero
2289	ENDIF
2290
2291	!-
2292	!- Compute the total reinfiltration and returnflow to the grid box
2293	!> A term of returnflow is computed including the water from the swamps that does not return directly to the river
2294	!> but will be put into soil moisture (see hydrol module).
2295	!> A term of reinfiltration is computed including the water that reinfiltrated from the ponds and floodplains areas.
2296	!> It will be put into soil moisture (see hydrol module).
2297	!-
2298	IF (do_floodplains .OR. doswamps .OR. doponds) THEN
2299	returnflow(:) = zero
2300	reinfiltration(:) = zero
2301	!
2302	DO ib=1,nbasmax
2303	DO ig=1,nbpt
2304	returnflow(ig) = returnflow(ig) + return_swamp(ig,ib)
2305	reinfiltration(ig) = reinfiltration(ig) + pond_drainage(ig,ib) + flood_drainage(ig,ib)
2306	ENDDO
2307	ENDDO
2308	!
2309	DO ig=1,nbpt
2310	returnflow(ig) = returnflow(ig)/totarea(ig)
2311	reinfiltration(ig) = reinfiltration(ig)/totarea(ig)
2312	ENDDO
2313	ELSE
2314	returnflow(:) = zero
2315	reinfiltration(:) = zero
2316	ENDIF
2317
2318	!
2319	! Compute the net irrigation requirement from Univ of Kassel
2320	!
2321	! This is a very low priority process and thus only applies if
2322	! there is some water left in the reservoirs after all other things.
2323	!
2324	!> The computation of the irrigation is performed here.
2325	!> * First step
2326	!> In a first time, the water requirements (irrig_netereq) by the crops for their optimal growth are calculated
2327	!> over each irrigated fraction (irrigated(ig)/totarea(ig)). It is the difference
2328	!> between the maximal water loss by the crops (transpot_mean) and the net water amount kept by the soil
2329	!> (precipitation and reinfiltration). Transpot_mean is computed in the routines enerbil and diffuco. It
2330	!> is derived from the effective transpiration parametrization under stress-free conditions, called potential transpiration.
2331	!> Crop_coef was used by a previous parametrization of irrigation in the code. Here, its value is equal to one.
2332	!> The crop coefficient was constant in space and time to represent a mean resistance of the vegetation to the potential evaporation.
2333	!> Now, the term crop_coef*Epot is substituted by transpot_mean (see Guimberteau et al., 2011).
2334	!> * Second step
2335	!> We compute irrigation needs in order to supply Irrig_netereq. Water for irrigation (irrig_actual) is withdrawn
2336	!> from the reservoirs. The amount of water is withdrawn in priority from the stream reservoir.
2337	!> If the irrigation requirement is higher than the water availability of the reservoir, water is withdrawn
2338	!> from the fast reservoir or, in the extreme case, from the slow reservoir.
2339	!> * Third step
2340	!> We compute a deficit in water for irrigation. If it is positive, irrigation (depending on water availibility in the reservoirs)
2341	!> has not supplied the crops requirements.
2342	!
2343	IF ( do_irrigation ) THEN
2344	DO ig=1,nbpt
2345	!
2346	IF ((vegtot(ig) .GT. min_sechiba) .AND. (humrel(ig) .LT. un-min_sechiba) .AND. &
2347	& (runoff(ig) .LT. min_sechiba) ) THEN
2348
2349	irrig_netereq(ig) = (irrigated(ig) / totarea(ig) ) * MAX(zero, transpot_mean(ig) - &
2350	& (precip(ig)+reinfiltration(ig)) )
2351
2352	ENDIF
2353	!
2354	DO ib=1,nbasmax
2355	IF ( routing_area(ig,ib) .GT. 0 ) THEN
2356
2357	irrig_needs(ig,ib) = irrig_netereq(ig) * routing_area(ig,ib)
2358
2359	irrig_actual(ig,ib) = MIN(irrig_needs(ig,ib),&
2360	& stream_reservoir(ig,ib) + fast_reservoir(ig,ib) + slow_reservoir(ig,ib) )
2361
2362	slow_reservoir(ig,ib) = MAX(zero, slow_reservoir(ig,ib) + &
2363	& MIN(zero, fast_reservoir(ig,ib) + MIN(zero, stream_reservoir(ig,ib)-irrig_actual(ig,ib))))
2364
2365	fast_reservoir(ig,ib) = MAX( zero, &
2366	& fast_reservoir(ig,ib) + MIN(zero, stream_reservoir(ig,ib)-irrig_actual(ig,ib)))
2367
2368	stream_reservoir(ig,ib) = MAX(zero, stream_reservoir(ig,ib)-irrig_actual(ig,ib) )
2369
2370	irrig_deficit(ig,ib) = irrig_needs(ig,ib)-irrig_actual(ig,ib)
2371
2372	ENDIF
2373	ENDDO
2374	!
2375	! Check if we cannot find the missing water in another basin of the same grid (stream reservoir only).
2376	! If we find that then we create some adduction from that subbasin to the one where we need it for
2377	! irrigation.
2378	!
2379	!> If crops water requirements have not been supplied (irrig_deficit>0), we check if we cannot find the missing water
2380	!> in another basin of the same grid. If there is water in the stream reservoir of this subbasin, we create some adduction
2381	!> from that subbasin to the one where we need it for irrigation.
2382	!>
2383	DO ib=1,nbasmax
2384
2385	stream_tot = SUM(stream_reservoir(ig,:))
2386
2387	DO WHILE ( irrig_deficit(ig,ib) > min_sechiba .AND. stream_tot > min_sechiba)
2388
2389	fi = MAXLOC(stream_reservoir(ig,:))
2390	ib2 = fi(1)
2391
2392	irrig_adduct(ig,ib) = MIN(irrig_deficit(ig,ib), stream_reservoir(ig,ib2))
2393	stream_reservoir(ig,ib2) = stream_reservoir(ig,ib2)-irrig_adduct(ig,ib)
2394	irrig_deficit(ig,ib) = irrig_deficit(ig,ib)-irrig_adduct(ig,ib)
2395
2396	stream_tot = SUM(stream_reservoir(ig,:))
2397
2398	ENDDO
2399
2400	ENDDO
2401	!
2402	ENDDO
2403	!
2404	! If we are at higher resolution we might need to look at neighboring grid boxes to find the streams
2405	! which can feed irrigation
2406	!
2407	!> At higher resolution (grid box smaller than 100x100km), we can import water from neighboring grid boxes
2408	!> to the one where we need it for irrigation.
2409	!
2410	IF (is_root_prc) THEN
2411	ALLOCATE(irrig_deficit_glo(nbp_glo, nbasmax), stream_reservoir_glo(nbp_glo, nbasmax), &
2412	& irrig_adduct_glo(nbp_glo, nbasmax), stat=ier)
2413	ELSE
2414	ALLOCATE(irrig_deficit_glo(0, 0), stream_reservoir_glo(0, 0), &
2415	& irrig_adduct_glo(0, 0), stat=ier)
2416	ENDIF
2417	IF (ier /= 0) CALL ipslerr_p(3,'routing_flow','Pb in allocate for irrig_deficit_glo, stream_reservoir_glo,...','','')
2418
2419	CALL gather(irrig_deficit, irrig_deficit_glo)
2420	CALL gather(stream_reservoir, stream_reservoir_glo)
2421	CALL gather(irrig_adduct, irrig_adduct_glo)
2422
2423	IF (is_root_prc) THEN
2424	!
2425	DO ig=1,nbp_glo
2426	! Only work if the grid box is smaller than 100x100km. Else the piplines we build
2427	! here would be too long to be reasonable.
2428	IF ( resolution_g(ig,1) < 100000. .AND. resolution_g(ig,2) < 100000. ) THEN
2429	DO ib=1,nbasmax
2430	!
2431	IF ( irrig_deficit_glo(ig,ib) > min_sechiba ) THEN
2432	!
2433	streams_around(:,:) = zero
2434	!
2435	DO in=1,NbNeighb
2436	ig2 = routing_nextgrid_g(ig,in)
2437	IF (ig2 .GT. 0 ) THEN
2438	streams_around(in,:) = stream_reservoir_glo(ig2,:)
2439	igrd(in) = ig2
2440	ENDIF
2441	ENDDO
2442	!
2443	IF ( MAXVAL(streams_around) .GT. zero ) THEN
2444	!
2445	ff=MAXLOC(streams_around)
2446	ig2=igrd(ff(1))
2447	ib2=ff(2)
2448	!
2449	IF ( routing_area_glo(ig2,ib2) .GT. 0 .AND. stream_reservoir_glo(ig2,ib2) > zero ) THEN
2450	adduction = MIN(irrig_deficit_glo(ig,ib), stream_reservoir_glo(ig2,ib2))
2451	stream_reservoir_glo(ig2,ib2) = stream_reservoir_glo(ig2,ib2) - adduction
2452	irrig_deficit_glo(ig,ib) = irrig_deficit_glo(ig,ib) - adduction
2453	irrig_adduct_glo(ig,ib) = irrig_adduct_glo(ig,ib) + adduction
2454	ENDIF
2455	!
2456	ENDIF
2457	!
2458	ENDIF
2459	!
2460	ENDDO
2461	ENDIF
2462	ENDDO
2463	!
2464	ENDIF
2465	!
2466
2467	CALL scatter(irrig_deficit_glo, irrig_deficit)
2468	CALL scatter(stream_reservoir_glo, stream_reservoir)
2469	CALL scatter(irrig_adduct_glo, irrig_adduct)
2470
2471	DEALLOCATE(irrig_deficit_glo, stream_reservoir_glo, irrig_adduct_glo)
2472
2473	ENDIF
2474
2475	!! Calculate the net water flow to each routing reservoir (in kg/dt)
2476	!! to further diagnose the corresponding water budget residu
2477	!! in routing_main
2478
2479	netflow_fast_diag(:) = zero
2480	netflow_slow_diag(:) = zero
2481	netflow_stream_diag(:) = zero
2482
2483	DO ib=1,nbasmax
2484	DO ig=1,nbpt
2485	netflow_fast_diag(ig) = netflow_fast_diag(ig) + runoff(ig)*routing_area(ig,ib) &
2486	- fast_flow(ig,ib) - pond_inflow(ig,ib)
2487	netflow_slow_diag(ig) = netflow_slow_diag(ig) + drainage(ig)*routing_area(ig,ib) &
2488	- slow_flow(ig,ib)
2489	netflow_stream_diag(ig) = netflow_stream_diag(ig) + flood_flow(ig,ib) + transport(ig,ib) &
2490	- stream_flow(ig,ib) - return_swamp(ig,ib) - floods(ig,ib)
2491	ENDDO
2492	ENDDO
2493
2494	!! Grid cell averaging
2495	DO ig=1,nbpt
2496	netflow_fast_diag(ig) = netflow_fast_diag(ig)/totarea(ig)
2497	netflow_slow_diag(ig) = netflow_slow_diag(ig)/totarea(ig)
2498	netflow_stream_diag(ig) = netflow_stream_diag(ig)/totarea(ig)
2499	ENDDO
2500
2501	!
2502	!
2503	! Compute the fluxes which leave the routing scheme
2504	!
2505	! Lakeinflow is in Kg/dt
2506	! returnflow is in Kg/m^2/dt
2507	!
2508	hydrographs(:) = zero
2509	slowflow_diag(:) = zero
2510	fast_diag(:) = zero
2511	slow_diag(:) = zero
2512	stream_diag(:) = zero
2513	flood_diag(:) = zero
2514	pond_diag(:) = zero
2515	irrigation(:) = zero
2516	!
2517	!
2518	DO ib=1,nbasmax
2519	!
2520	DO ig=1,nbpt
2521	IF (hydrodiag(ig,ib) > 0 ) THEN
2522	hydrographs(ig) = hydrographs(ig) + fast_flow(ig,ib) + slow_flow(ig,ib) + &
2523	& stream_flow(ig,ib)
2524	slowflow_diag(ig) = slowflow_diag(ig) + slow_flow(ig,ib)
2525	ENDIF
2526	fast_diag(ig) = fast_diag(ig) + fast_reservoir(ig,ib)
2527	slow_diag(ig) = slow_diag(ig) + slow_reservoir(ig,ib)
2528	stream_diag(ig) = stream_diag(ig) + stream_reservoir(ig,ib)
2529	flood_diag(ig) = flood_diag(ig) + flood_reservoir(ig,ib)
2530	irrigation (ig) = irrigation (ig) + irrig_actual(ig,ib) + irrig_adduct(ig,ib)
2531	ENDDO
2532	ENDDO
2533	!
2534	DO ig=1,nbpt
2535	fast_diag(ig) = fast_diag(ig)/totarea(ig)
2536	slow_diag(ig) = slow_diag(ig)/totarea(ig)
2537	stream_diag(ig) = stream_diag(ig)/totarea(ig)
2538	flood_diag(ig) = flood_diag(ig)/totarea(ig)
2539	pond_diag(ig) = pond_reservoir(ig)/totarea(ig)
2540	!
2541	irrigation(ig) = irrigation(ig)/totarea(ig)
2542	!
2543	! The three output types for the routing : endoheric basins,, rivers and
2544	! diffuse coastal flow.
2545	!
2546	lakeinflow(ig) = transport(ig,nbasmax+1)
2547	coastalflow(ig) = transport(ig,nbasmax+2)
2548	riverflow(ig) = transport(ig,nbasmax+3)
2549	!
2550	ENDDO
2551	!
2552	flood_res = flood_diag + pond_diag
2553
2554
2555	!! Remove water from lake reservoir if it exceeds the maximum limit and distribute it
2556	!! uniformly over all possible the coastflow gridcells
2557
2558	! Calculate lake_overflow and remove it from lake_reservoir
2559	DO ig=1,nbpt
2560	lake_overflow(ig) = MAX(0., lake_reservoir(ig) - max_lake_reservoir*totarea(ig))
2561	lake_reservoir(ig) = lake_reservoir(ig) - lake_overflow(ig)
2562	END DO
2563	! Transform lake_overflow from kg/grid-cell/dt_routing into kg/m^2/s
2564	CALL xios_orchidee_send_field("lake_overflow",lake_overflow(:)/totarea(:)/dt_routing)
2565
2566	! Calculate the sum of the lake_overflow and distribute it uniformly over all gridboxes
2567	CALL gather(lake_overflow,lake_overflow_g)
2568	IF (is_root_prc) THEN
2569	total_lake_overflow=SUM(lake_overflow_g)
2570	END IF
2571	CALL bcast(total_lake_overflow)
2572
2573	! Distribute the lake_overflow uniformly over all coastal gridcells
2574	! lake_overflow_coast is only calculated to be used as diagnostics if needed
2575	DO ig=1,nbpt
2576	coastalflow(ig) = coastalflow(ig) + total_lake_overflow/nb_coast_gridcells * mask_coast(ig)
2577	lake_overflow_coast(ig) = total_lake_overflow/nb_coast_gridcells * mask_coast(ig)
2578	END DO
2579	! Transform from kg/grid-cell/dt_routing into m^3/grid-cell/s to match output unit of coastalflow
2580	CALL xios_orchidee_send_field("lake_overflow_coast",lake_overflow_coast/mille/dt_routing)
2581
2582
2583	END SUBROUTINE routing_flow
2584	!
2585	!! ================================================================================================================================
2586	!! SUBROUTINE : routing_lake
2587	!!
2588	!>\BRIEF : This subroutine stores water in lakes so that it does not cycle through the runoff.
2589	!! For the moment it only works for endoheric lakes but I can be extended in the future.
2590	!!
2591	!! DESCRIPTION (definitions, functional, design, flags): The return flow to the soil moisture reservoir
2592	!! is based on a maximum lake evaporation rate (maxevap_lake). \n
2593	!!
2594	!! RECENT CHANGE(S): None
2595	!!
2596	!! MAIN OUTPUT VARIABLE(S):
2597	!!
2598	!! REFERENCES : None
2599	!!
2600	!! FLOWCHART :None
2601	!! \n
2602	!_ ================================================================================================================================
2603
2604	SUBROUTINE routing_lake(nbpt, dt_routing, lakeinflow, humrel, return_lakes)
2605	!
2606	IMPLICIT NONE
2607	!
2608	!! INPUT VARIABLES
2609	INTEGER(i_std), INTENT(in) :: nbpt !! Domain size (unitless)
2610	REAL(r_std), INTENT (in) :: dt_routing !! Routing time step (s)
2611	REAL(r_std), INTENT(out) :: lakeinflow(nbpt) !! Water inflow to the lakes (kg/dt)
2612	REAL(r_std), INTENT(in) :: humrel(nbpt) !! Soil moisture stress, root extraction potential (unitless)
2613	!
2614	!! OUTPUT VARIABLES
2615	REAL(r_std), INTENT(out) :: return_lakes(nbpt) !! Water from lakes flowing back into soil moisture (kg/m^2/dt)
2616	!
2617	!! LOCAL VARIABLES
2618	INTEGER(i_std) :: ig !! Indices (unitless)
2619	REAL(r_std) :: refill !!
2620	REAL(r_std) :: total_area !! Sum of all the surfaces of the basins (m^2)
2621
2622	!_ ================================================================================================================================
2623	!
2624	!
2625	DO ig=1,nbpt
2626	!
2627	total_area = SUM(routing_area(ig,:))
2628	!
2629	lake_reservoir(ig) = lake_reservoir(ig) + lakeinflow(ig)
2630
2631	IF ( doswamps ) THEN
2632	! Calculate a return flow that will be extracted from the lake reservoir and reinserted in the soil in hydrol
2633	! Uptake in Kg/dt
2634	refill = MAX(zero, maxevap_lake * (un - humrel(ig)) * dt_routing * total_area)
2635	return_lakes(ig) = MIN(refill, lake_reservoir(ig))
2636	lake_reservoir(ig) = lake_reservoir(ig) - return_lakes(ig)
2637	! Return in Kg/m^2/dt
2638	return_lakes(ig) = return_lakes(ig)/total_area
2639	ELSE
2640	return_lakes(ig) = zero
2641	ENDIF
2642
2643	! This is the volume of the lake scaled to the entire grid.
2644	! It would be better to scale it to the size of the lake
2645	! but this information is not yet available.
2646	lake_diag(ig) = lake_reservoir(ig)/total_area
2647
2648	lakeinflow(ig) = lakeinflow(ig)/total_area
2649
2650	ENDDO
2651	!
2652	END SUBROUTINE routing_lake
2653	!
2654
2655	!! ================================================================================================================================
2656	!! SUBROUTINE : routing_diagnostic_p
2657	!!
2658	!>\BRIEF This parallelized subroutine gives a diagnostic of the basins used
2659	!!
2660	!! DESCRIPTION (definitions, functional, design, flags) : None
2661	!!
2662	!! RECENT CHANGE(S): None
2663	!!
2664	!! MAIN OUTPUT VARIABLE(S):
2665	!!
2666	!! REFERENCES : None
2667	!!
2668	!! FLOWCHART : None
2669	!! \n
2670	!_ ================================================================================================================================
2671
2672	SUBROUTINE routing_diagnostic_p(nbpt, index, lalo, resolution, contfrac, hist_id, hist2_id)
2673	!
2674	IMPLICIT NONE
2675
2676	!! INPUT VARIABLES
2677	INTEGER(i_std), INTENT(in) :: nbpt !! Domain size (unitless)
2678	INTEGER(i_std), INTENT(in) :: index(nbpt) !! Indices of the points on the map (unitless)
2679	REAL(r_std), INTENT(in) :: lalo(nbpt,2) !! Vector of latitude and longitudes (beware of the order !)
2680	REAL(r_std), INTENT(in) :: resolution(nbpt,2) !! The size of each grid box in X and Y (m)
2681	REAL(r_std), INTENT(in) :: contfrac(nbpt) !! Fraction of land in each grid box (unitless;0-1)
2682	INTEGER(i_std),INTENT (in) :: hist_id !! Access to history file (unitless)
2683	INTEGER(i_std),INTENT (in) :: hist2_id !! Access to history file 2 (unitless)
2684	!
2685	!! LOCAL VARIABLES
2686	REAL(r_std), DIMENSION(nbpt) :: nbrivers !! Number of rivers in the grid (unitless)
2687	REAL(r_std), DIMENSION(nbpt) :: basinmap !! Map of basins (unitless)
2688	REAL(r_std), DIMENSION(nbp_glo) :: nbrivers_g !! Number of rivers in the grid (unitless)
2689	REAL(r_std), DIMENSION(nbp_glo) :: basinmap_g !! Map of basins (unitless)
2690
2691	!_ ================================================================================================================================
2692	routing_area => routing_area_glo
2693	topo_resid => topo_resid_glo
2694	route_togrid => route_togrid_glo
2695	route_tobasin => route_tobasin_glo
2696	route_nbintobas => route_nbintobas_glo
2697	global_basinid => global_basinid_glo
2698	hydrodiag=>hydrodiag_glo
2699	hydroupbasin=>hydroupbasin_glo
2700
2701	IF (is_root_prc) CALL routing_diagnostic(nbp_glo, index_g, lalo_g, resolution_g, contfrac_g, nbrivers_g,basinmap_g)
2702
2703	routing_area => routing_area_loc
2704	topo_resid => topo_resid_loc
2705	route_togrid => route_togrid_loc
2706	route_tobasin => route_tobasin_loc
2707	route_nbintobas => route_nbintobas_loc
2708	global_basinid => global_basinid_loc
2709	hydrodiag=>hydrodiag_loc
2710	hydroupbasin=>hydroupbasin_loc
2711
2712	CALL scatter(nbrivers_g,nbrivers)
2713	CALL scatter(basinmap_g,basinmap)
2714	CALL scatter(hydrodiag_glo,hydrodiag_loc)
2715	CALL scatter(hydroupbasin_glo,hydroupbasin_loc)
2716
2717	CALL xios_orchidee_send_field("basinmap",basinmap)
2718	CALL xios_orchidee_send_field("nbrivers",nbrivers)
2719
2720	IF ( .NOT. almaoutput ) THEN
2721	CALL histwrite_p(hist_id, 'basinmap', 1, basinmap, nbpt, index)
2722	CALL histwrite_p(hist_id, 'nbrivers', 1, nbrivers, nbpt, index)
2723	ELSE
2724	ENDIF
2725	IF ( hist2_id > 0 ) THEN
2726	IF ( .NOT. almaoutput ) THEN
2727	CALL histwrite_p(hist2_id, 'basinmap', 1, basinmap, nbpt, index)
2728	CALL histwrite_p(hist2_id, 'nbrivers', 1, nbrivers, nbpt, index)
2729	ELSE
2730	ENDIF
2731	ENDIF
2732
2733
2734	END SUBROUTINE routing_diagnostic_p
2735
2736	!! ================================================================================================================================
2737	!! SUBROUTINE : routing_diagnostic
2738	!!
2739	!>\BRIEF This non-parallelized subroutine gives a diagnostic of the basins used. This produces some information
2740	!! on the rivers which are being diagnosed.
2741	!!
2742	!! DESCRIPTION (definitions, functional, design, flags) : As not all rivers can be monitored in the model, we will only
2743	!! archive num_largest rivers. In this routine we will diagnose the num_largest largest rivers and print to the standard
2744	!! 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
2745	!! routine routing_names. As this standard output is not sufficient, we will also write it to a netCDF file with the routine
2746	!! routing_diagncfile. It is important to keep for diagnostic the fraction of the largest basins in each grid box and keep information
2747	!! how they are linked one to the other.
2748	!!
2749	!! RECENT CHANGE(S): None
2750	!!
2751	!! MAIN OUTPUT VARIABLE(S): No output variables.
2752	!!
2753	!! REFERENCES : None
2754	!!
2755	!! FLOWCHART :None
2756	!! \n
2757	!_ ================================================================================================================================
2758
2759	SUBROUTINE routing_diagnostic(nbpt, l_index, lalo, resolution, contfrac, nbrivers, basinmap)
2760	!
2761	IMPLICIT NONE
2762	!
2763	!! INPUT VARIABLES
2764	INTEGER(i_std), INTENT(in) :: nbpt !! Domain size (unitless)
2765	INTEGER(i_std), INTENT(in) :: l_index(nbpt) !! Indices of the points on the map (unitless)
2766	REAL(r_std), INTENT(in) :: lalo(nbpt,2) !! Vector of latitude and longitudes (beware of the order !)
2767	REAL(r_std), INTENT(in) :: resolution(nbpt,2) !! The size of each grid box in X and Y (m)
2768	REAL(r_std), INTENT(in) :: contfrac(nbpt) !! Fraction of land in each grid box (unitless;0-1)
2769	!
2770	!! OUTPUT VARIABLES
2771	REAL(r_std), DIMENSION(nbpt), INTENT(out) :: nbrivers !! Number of rivers in the grid (unitless)
2772	REAL(r_std), DIMENSION(nbpt), INTENT(out) :: basinmap !! Map of basins (unitless)
2773	!
2774	!! LOCAL VARIABLES
2775	INTEGER(i_std), DIMENSION(nbpt,nbasmax) :: outids !! IDs of river to which this basin contributes (unitless)
2776	INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:) :: pts !! List the points belonging to the basin (unitless)
2777	INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:) :: ptbas !! List the basin number for this point (unitless)
2778	INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:) :: outpt !! Outflow point for each basin (unitless)
2779	INTEGER(i_std), ALLOCATABLE, DIMENSION(:) :: nb_pts !! Number of points in the basin (unitless)
2780	REAL(r_std), ALLOCATABLE, DIMENSION(:) :: totarea !! Total area of basin (m^2)
2781	REAL(r_std), ALLOCATABLE, DIMENSION(:) :: tmparea !!
2782	INTEGER(i_std), ALLOCATABLE, DIMENSION(:) :: topids !! The IDs of the first num_largest basins (unitless)
2783	CHARACTER(LEN=25), ALLOCATABLE, DIMENSION(:) :: basin_names !! Names of the rivers (unitless)
2784	CHARACTER(LEN=25) :: name_str !!
2785	!
2786	LOGICAL :: river_file !! Choose to write a description of the rivers (true/false)
2787	CHARACTER(LEN=80) :: river_file_name !! Filename in which we write the description of the rivers (unitless)
2788	!
2789	CHARACTER(LEN=25), ALLOCATABLE, DIMENSION(:) :: sorted_names !!
2790	INTEGER(i_std), ALLOCATABLE, DIMENSION(:) :: streams_nb !! Number of streams in basin (unitless)
2791	INTEGER(i_std), ALLOCATABLE, DIMENSION(:) :: streams_avehops !! Average number of hops in streams (unitless)
2792	INTEGER(i_std), ALLOCATABLE, DIMENSION(:) :: streams_minhops !! Minimum number of hops in streams (unitless)
2793	INTEGER(i_std), ALLOCATABLE, DIMENSION(:) :: streams_maxhops !! Minimum number of hops in streams (unitless)
2794	REAL(r_std), ALLOCATABLE, DIMENSION(:) :: streams_resid !! Average residence time
2795	!
2796	REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: lbasin_area !!
2797	REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: lbasin_uparea !!
2798	INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:) :: lrivercode !!
2799	!
2800	INTEGER(i_std) :: ig, ib, og, ob, ign, ibn, ff(1), ic, icc, nb_small, idbas, slen, ii !! Indices (unitless)
2801	INTEGER(i_std) :: ier !! Error handling
2802	CHARACTER(LEN=1) :: nn !!
2803	INTEGER(i_std) :: name_found !!
2804	!
2805	REAL(r_std) :: averesid !!
2806	REAL(r_std), DIMENSION(nbasmax) :: tmpbas !!
2807	REAL(r_std), DIMENSION(nbpt,nbasmax) :: areaupbasin !!
2808	INTEGER(i_std), ALLOCATABLE, DIMENSION(:) :: sortedrivs !!
2809	!
2810	! Variables for the river coding
2811	!
2812	INTEGER(i_std) :: longest_river !!
2813	INTEGER(i_std) :: nbmax !!
2814	INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:) :: allstreams !!
2815	REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: upstreamchange !!
2816	INTEGER(i_std), ALLOCATABLE, DIMENSION(:) :: tstreams, tslen, tpts, tptbas, tcode !!
2817	REAL(r_std), ALLOCATABLE, DIMENSION(:) :: tuparea !!
2818	REAL(r_std), ALLOCATABLE, DIMENSION(:) :: tupstreamchange !!
2819	!
2820	LOGICAL :: err_nbpt_grid_basin !! (true/false)
2821	LOGICAL :: err_basin_number !! (true/false)
2822
2823	!_ ================================================================================================================================
2824	!
2825	!
2826	ALLOCATE(pts(num_largest, nbpt), stat=ier)
2827	IF (ier /= 0) CALL ipslerr_p(3,'routing_diagnostic','Pb in allocate for pts','','')
2828
2829	ALLOCATE(ptbas(num_largest, nbpt), stat=ier)
2830	IF (ier /= 0) CALL ipslerr_p(3,'routing_diagnostic','Pb in allocate for ptbas','','')
2831
2832	ALLOCATE(outpt(num_largest, 2), stat=ier)
2833	IF (ier /= 0) CALL ipslerr_p(3,'routing_diagnostic','Pb in allocate for outpt','','')
2834
2835	ALLOCATE(nb_pts(num_largest), stat=ier)
2836	IF (ier /= 0) CALL ipslerr_p(3,'routing_diagnostic','Pb in allocate for nb_pts','','')
2837
2838	ALLOCATE(totarea(num_largest), tmparea(num_largest), stat=ier)
2839	IF (ier /= 0) CALL ipslerr_p(3,'routing_diagnostic','Pb in allocate for totarea','','')
2840
2841	ALLOCATE(topids(num_largest), stat=ier)
2842	IF (ier /= 0) CALL ipslerr_p(3,'routing_diagnostic','Pb in allocate for topids','','')
2843
2844	ALLOCATE(sortedrivs(num_largest), stat=ier)
2845	IF (ier /= 0) CALL ipslerr_p(3,'routing_diagnostic','Pb in allocate for sortedrivs','','')
2846
2847	ALLOCATE(sorted_names(num_largest), stat=ier)
2848	IF (ier /= 0) CALL ipslerr_p(3,'routing_diagnostic','Pb in allocate for sorted_names','','')
2849
2850	ALLOCATE(streams_nb(num_largest), streams_avehops(num_largest), streams_minhops(num_largest), stat=ier)
2851	IF (ier /= 0) CALL ipslerr_p(3,'routing_diagnostic','Pb in allocate for streams_nb','','')
2852
2853	ALLOCATE(streams_maxhops(num_largest), stat=ier)
2854	IF (ier /= 0) CALL ipslerr_p(3,'routing_diagnostic','Pb in allocate for streams_maxhops','','')
2855
2856	ALLOCATE(streams_resid(num_largest), stat=ier)
2857	IF (ier /= 0) CALL ipslerr_p(3,'routing_diagnostic','Pb in allocate for streams_resid','','')
2858
2859	ALLOCATE(lbasin_area(num_largest,nbpt), lbasin_uparea(num_largest,nbpt), lrivercode(num_largest,nbpt), stat=ier)
2860	IF (ier /= 0) CALL ipslerr_p(3,'routing_diagnostic','Pb in allocate for lbasin_area','','')
2861
2862	IF ( .NOT. is_root_prc) THEN
2863	WRITE(numout,*) "routing_diagnostic is not suitable for running in parallel"
2864	WRITE(numout,*) "We are here on a non root processor. is_root_prc = ", is_root_prc
2865	WRITE(numout,*) "STOP from routing_diagnostic"
2866	CALL ipslerr_p(3,'routing_diagnostic','This routine is not suitable for running in parallel','','')
2867	ENDIF
2868
2869
2870	!Config Key = RIVER_DESC
2871	!Config Desc = Writes out a description of the rivers
2872	!Config If = RIVER_ROUTING
2873	!Config Def = n
2874	!Config Help = This flag allows to write out a file containing the list of
2875	!Config rivers which are beeing simulated. It provides location of outflow
2876	!Config drainage area, name and ID.
2877	!Config Units = [FLAG]
2878	!
2879	river_file=.FALSE.
2880	CALL getin('RIVER_DESC', river_file)
2881	!
2882	!Config Key = RIVER_DESC_FILE
2883	!Config Desc = Filename in which we write the description of the rivers. If suffix is ".nc" a netCDF file is created
2884	!Config If = RIVER_DESC
2885	!Config Def = river_desc.nc
2886	!Config Help = File name where we will write the information. If the suffix is ".nc" a netCDF file is generated. Else
2887	!Config a simple text file will contain some information. The netCDF file is valuable for post-processing the
2888	! data as it will contain the fraction of the large basins in each grid box.
2889	!Config Units = [FILE]
2890	!
2891	river_file_name="river_desc.nc"
2892	CALL getin('RIVER_DESC_FILE', river_file_name)
2893	!
2894	!
2895	! First we get the list of all river outflow points
2896	! We work under the assumption that we only have num_largest basins finishing with
2897	! nbasmax+3. This is checked in routing_truncate.
2898	!
2899	nb_small = 1
2900	outpt(:,:) = -1
2901	ic = 0
2902	DO ig=1,nbpt
2903	DO ib=1,nbasmax
2904	ign = route_togrid(ig, ib)
2905	ibn = route_tobasin(ig, ib)
2906	IF ( ibn .EQ. nbasmax+3) THEN
2907	ic = ic + 1
2908	outpt(ic,1) = ig
2909	outpt(ic,2) = ib
2910	!
2911	! Get the largest id of the basins we call a river. This is
2912	! to extract the names of all rivers.
2913	!
2914	IF ( global_basinid(ig,ib) > nb_small ) THEN
2915	nb_small = global_basinid(ig,ib)
2916	ENDIF
2917	ENDIF
2918	ENDDO
2919	ENDDO
2920
2921	nb_small = MIN(nb_small, 349)
2922
2923	ALLOCATE(basin_names(nb_small), stat=ier)
2924	IF (ier /= 0) CALL ipslerr_p(3,'routing_diagnostic','Pb in allocate for basins_names','','')
2925
2926	CALL routing_names(nb_small, basin_names)
2927	!
2928	! Go through all points and basins to see if they outflow as a river and store the
2929	! information needed in the various arrays.
2930	!
2931	nb_pts(:) = 0
2932	totarea(:) = zero
2933	hydrodiag(:,:) = 0
2934	areaupbasin(:,:) = zero
2935	outids(:,:) = -1
2936	ob = -1
2937	og = -1
2938	lbasin_area(:,:) = zero
2939	lbasin_uparea(:,:) = zero
2940	longest_river = 0
2941	!
2942	err_nbpt_grid_basin = .FALSE.
2943	loopgridbasin : DO ig=1,nbpt
2944	!
2945	DO ib=1,nbasmax
2946	IF ( routing_area(ig,ib) .GT. zero ) THEN
2947	ic = 0
2948	ign = ig
2949	ibn = ib
2950	! Locate outflow point
2951	DO WHILE (ibn .GT. 0 .AND. ibn .LE. nbasmax .AND. ic .LT. nbasmax*nbpt)
2952	ic = ic + 1
2953	og = ign
2954	ob = ibn
2955	ign = route_togrid(og, ob)
2956	ibn = route_tobasin(og, ob)
2957	areaupbasin(og, ob) = areaupbasin(og, ob) + routing_area(ig,ib)
2958	ENDDO
2959	!
2960	longest_river = MAX(longest_river, ic)
2961	!
2962	! Now that we have an outflow check if it is one of the num_largest rivers.
2963	! In this case we keeps the location so we diagnose it.
2964	!
2965	IF ( ibn .EQ. nbasmax + 3) THEN
2966	DO icc = 1,num_largest
2967	IF ( outpt(icc,1) .EQ. og .AND. outpt(icc,2) .EQ. ob ) THEN
2968	!
2969	! We only keep this point for our map if it is large enough.
2970	!
2971	nb_pts(icc) = nb_pts(icc) + 1
2972	!
2973	!
2974	IF ( nb_pts(icc) > nbpt ) THEN
2975	err_nbpt_grid_basin = .TRUE.
2976	EXIT loopgridbasin
2977	ENDIF
2978	!
2979	pts(icc, nb_pts(icc)) = ig
2980	ptbas(icc, nb_pts(icc)) = ib
2981	totarea(icc) = totarea(icc) + routing_area(ig,ib)
2982	!
2983	lbasin_area(icc,nb_pts(icc)) = routing_area(ig,ib)
2984	!
2985	! ID of the river is taken from the last point before the outflow.
2986	topids(icc) = global_basinid(og,ob)
2987	outids(ig,ib) = global_basinid(og,ob)
2988	!
2989	! On this gridbox and basin we will diagnose the hydrograph
2990	!
2991	hydrodiag(ig, ib) = 1
2992	!
2993	ENDIF
2994	ENDDO
2995	ENDIF
2996	ENDIF
2997	!
2998	ENDDO
2999	!
3000	ENDDO loopgridbasin
3001	!
3002	IF ( err_nbpt_grid_basin ) THEN
3003	WRITE(numout, *) "routing_diagnostic : The number of grid points in basin ", icc
3004	WRITE(numout, *) "routing_diagnostic : is larger than anticiped. "
3005	CALL ipslerr_p(3, 'routing_diagnostic', 'We are heading for a out of bounds in arrays pts, ptsbas and lbasin_area.',&
3006	& 'Increase the last dimension of these arrays.','')
3007	ENDIF
3008	!
3009	! Now we decide which points we will keep from the largest basins
3010	!
3011	! Temporary fix
3012	route_nbintobas(:,:) = 0
3013	!
3014	basinmap(:) = zero
3015	DO ig=1,nbpt
3016	!
3017	! Look for the dominant basin in this grid. This information only affects some
3018	! diagnostics : hydrographs and saved area upstream.
3019	!
3020	icc = 0
3021	idbas = -1
3022	!
3023	DO ib=1,nbasmax
3024	IF ( outids(ig,ib) > 0 ) THEN
3025	IF ( COUNT(outids(ig,:) == outids(ig,ib)) > icc ) THEN
3026	icc = COUNT(outids(ig,:) == outids(ig,ib))
3027	idbas = outids(ig,ib)
3028	ENDIF
3029	ENDIF
3030	ENDDO
3031	!
3032	! If we have found a point from the large basins and decided which one
3033	! takes over this grid then we note it on the map.
3034	! Clean-up a little the hydrodiag array
3035	!
3036	IF ( idbas > 0 ) THEN
3037	basinmap(ig) = REAL(idbas, r_std)
3038	ENDIF
3039	!
3040	! Now place the hydrograph diagnostic on the point closest to the
3041	! ocean.
3042	!
3043	tmpbas(:) = zero
3044	DO ib=1,nbasmax
3045	IF ( outids(ig,ib) .EQ. idbas) THEN
3046	tmpbas(ib) = areaupbasin(ig,ib)
3047	ENDIF
3048	ENDDO
3049	hydrodiag(ig,:) = 0
3050	ff=MAXLOC(tmpbas)
3051	hydrodiag(ig,ff(1)) = 1
3052	hydroupbasin(ig) = areaupbasin(ig,ff(1))
3053	!
3054	ENDDO
3055	!
3056	!
3057	!
3058	tmparea(:) = totarea(:)
3059	DO icc = 1, num_largest
3060	ff = MAXLOC(tmparea)
3061	sortedrivs(icc) = ff(1)
3062	tmparea(ff(1)) = 0.0
3063	ENDDO
3064	!
3065	! Diagnose the complexity of the basins obtained and determine their code in the Pfafstetter system
3066	!
3067	nbmax=MAXVAL(nb_pts)
3068	ALLOCATE(allstreams(nbmax, longest_river), upstreamchange(nbmax, longest_river), stat=ier)
3069	IF (ier /= 0) CALL ipslerr_p(3,'routing_diagnostic','Pb in allocate for allstreams','','')
3070
3071	ALLOCATE(tstreams(longest_river), tupstreamchange(longest_river), stat=ier)
3072	IF (ier /= 0) CALL ipslerr_p(3,'routing_diagnostic','Pb in allocate for tstreams','','')
3073
3074	ALLOCATE(tslen(nbmax), tpts(nbmax), tptbas(nbmax), tuparea(nbmax), stat=ier)
3075	IF (ier /= 0) CALL ipslerr_p(3,'routing_diagnostic','Pb in allocate for tslen','','')
3076
3077	ALLOCATE(tcode(nbmax), stat=ier)
3078	IF (ier /= 0) CALL ipslerr_p(3,'routing_diagnostic','Pb in allocate for tcode','','')
3079
3080	DO icc = 1, num_largest
3081	!
3082	! Work through the largest basins
3083	!
3084	idbas = sortedrivs(icc)
3085	!
3086	streams_nb(idbas) = 0
3087	streams_avehops(idbas) = 0
3088	streams_minhops(idbas) = undef_int
3089	streams_maxhops(idbas) = 0
3090	streams_resid(idbas) = zero
3091	tslen(:) = 0
3092	!
3093	allstreams(:,:) = 0
3094	upstreamchange(:,:) = zero
3095	!
3096	DO ii=1,nb_pts(idbas)
3097	!
3098	ig = pts(idbas, ii)
3099	ib = ptbas(idbas, ii)
3100	!
3101	lbasin_uparea(idbas,ii) = areaupbasin(ig,ib)
3102	!
3103	slen = 0
3104	ign = ig
3105	ibn = ib
3106	og = ig
3107	ob = ib
3108	!
3109	averesid = zero
3110	tupstreamchange(:) = zero
3111	! go to outflow point to count the number of hops
3112	DO WHILE (ibn .GT. 0 .AND. ibn .LE. nbasmax)
3113	! Store data
3114	slen = slen + 1
3115	tstreams(slen) = ign
3116	tupstreamchange(slen) = areaupbasin(ign,ibn)-areaupbasin(og,ob)
3117	! Move to next point
3118	og = ign
3119	ob = ibn
3120	ign = route_togrid(og, ob)
3121	ibn = route_tobasin(og, ob)
3122	averesid = averesid + topo_resid(og, ob)**2
3123	ENDDO
3124	!
3125	allstreams(ii,1:slen) = tstreams(slen:1:-1)
3126	upstreamchange(ii,1:slen) = tupstreamchange(slen:1:-1)
3127	tslen(ii) = slen
3128	!
3129	! Save diagnostics
3130	!
3131	streams_nb(idbas) = streams_nb(idbas) + 1
3132	streams_avehops(idbas) = streams_avehops(idbas) + slen
3133	streams_resid(idbas) = streams_resid(idbas) + SQRT(averesid)
3134	IF ( slen < streams_minhops(idbas) ) THEN
3135	streams_minhops(idbas) = slen
3136	ENDIF
3137	IF ( slen > streams_maxhops(idbas) ) THEN
3138	streams_maxhops(idbas) = slen
3139	ENDIF
3140	!
3141	ENDDO
3142	! build the average
3143	IF ( streams_nb(idbas) > 0 ) THEN
3144	streams_avehops(idbas) = streams_avehops(idbas)/streams_nb(idbas)
3145	streams_resid(idbas) = streams_resid(idbas)/REAL(streams_nb(idbas), r_std)
3146	ELSE
3147	! River without streams ... very rare but happens
3148	streams_avehops(idbas) = zero
3149	streams_resid(idbas) = zero
3150	streams_maxhops(idbas) = zero
3151	streams_minhops(idbas) = zero
3152	ENDIF
3153	!
3154	!
3155	ii=nb_pts(idbas)
3156	tpts(:) = 0
3157	tpts(1:ii) = pts(idbas,1:ii)
3158	tptbas(:) = 0
3159	tptbas(1:ii) = ptbas(idbas,1:ii)
3160	tuparea(:) = 0
3161	tuparea(1:ii) = lbasin_uparea(idbas,1:ii)
3162	!
3163	CALL routing_diagcode(ii, tpts, tptbas, tuparea, tslen, MAXVAL(tslen), allstreams, upstreamchange, tcode)
3164	!
3165	lrivercode(idbas,:) = 0
3166	lrivercode(idbas,1:ii) = tcode(1:ii)
3167	!
3168	ENDDO
3169	!
3170	! Create the sorted list of names
3171	!
3172	err_basin_number = .FALSE.
3173	DO icc = 1, num_largest
3174	!
3175	ib=sortedrivs(icc)
3176	!
3177	IF ( topids(ib) .GT. nb_small ) THEN
3178	IF (topids(ib) <= 99 ) THEN
3179	WRITE(sorted_names(icc), '("Nb_",I2.2)') topids(ib)
3180	ELSE IF (topids(ib) <= 999 ) THEN
3181	WRITE(sorted_names(icc), '("Nb_",I3.3)') topids(ib)
3182	ELSE IF (topids(ib) <= 9999 ) THEN
3183	WRITE(sorted_names(icc), '("Nb_",I4.4)') topids(ib)
3184	ELSE IF (topids(ib) <= 99999 ) THEN
3185	WRITE(sorted_names(icc), '("Nb_",I5.5)') topids(ib)
3186	ELSE IF (topids(ib) <= 999999 ) THEN
3187	WRITE(sorted_names(icc), '("Nb_",I6.6)') topids(ib)
3188	ELSE
3189	err_basin_number = .TRUE.
3190	EXIT
3191	ENDIF
3192
3193	ELSE
3194	sorted_names(icc) = basin_names(topids(ib))
3195	ENDIF
3196	!
3197	ENDDO
3198	!
3199	IF ( err_basin_number ) THEN
3200	CALL ipslerr_p(3, 'routing_diagnostic', 'We found a basin number larger than 999999.',&
3201	& 'This is impossible. Please verify your configuration.','')
3202	ENDIF
3203	!
3204	! Check for doubles and rename if needed
3205	!
3206	DO icc = 1, num_largest
3207	name_found=0
3208	DO ic=1, num_largest
3209	IF ( TRIM(sorted_names(icc)) == TRIM(sorted_names(ic)) ) THEN
3210	name_found = name_found + 1
3211	ENDIF
3212	ENDDO
3213	!
3214	IF ( name_found > 1 ) THEN
3215	DO ic=num_largest,1,-1
3216	IF ( TRIM(sorted_names(icc)) == TRIM(sorted_names(ic)) ) THEN
3217	IF ( name_found > 1 ) THEN
3218	WRITE(nn,'(I1)') name_found
3219	sorted_names(ic) = TRIM(sorted_names(ic))//nn
3220	name_found = name_found - 1
3221	ENDIF
3222	ENDIF
3223	ENDDO
3224	ENDIF
3225	!
3226	ENDDO
3227	!
3228	! Print to stdout on ROOT_PROC the diagnostics for the largest basins we have found.
3229	!
3230	DO icc = 1, num_largest
3231	!
3232	IF ( nb_pts(sortedrivs(icc)) .GT. 2 ) THEN
3233	name_str = sorted_names(icc)
3234	WRITE(numout,'("Basin ID ", I5," ", A15, " Area [km^2] : ", F13.4, " Nb points : ", I4)')&
3235	& topids(sortedrivs(icc)), name_str(1:15), totarea(sortedrivs(icc))/1.e6, nb_pts(sortedrivs(icc))
3236	ENDIF
3237	!
3238	ENDDO
3239	!
3240	! Save some of the basin information into files.
3241	!
3242	IF ( river_file ) THEN
3243
3244	IF ( INDEX(river_file_name,".nc") > 1 ) THEN
3245
3246	CALL routing_diagncfile(river_file_name, nbpt, lalo, nb_pts, topids, sorted_names, sortedrivs, &
3247	& pts, lbasin_area, lbasin_uparea, lrivercode, outpt, streams_nb, streams_avehops, &
3248	& streams_minhops, streams_maxhops, streams_resid)
3249
3250	ELSE
3251
3252	OPEN(diagunit, FILE=river_file_name)
3253	WRITE(diagunit,'(A)') "Basin ID, Area [km^2], Nb points, Lon and Lat of outflow"
3254	WRITE(diagunit,'(A)') "Nb streams, total number of hops, min, ave and max number of hops per stream"
3255	!
3256	DO icc = 1, num_largest
3257	!
3258	IF ( nb_pts(sortedrivs(icc)) .GT. 2 ) THEN
3259	!
3260	name_str = sorted_names(icc)
3261	!
3262	WRITE(diagunit,'(I5,A25,F14.5,I5,2F9.2)') topids(sortedrivs(icc)), name_str(1:15), totarea(sortedrivs(icc))/1.e6, &
3263	& nb_pts(sortedrivs(icc)), lalo(outpt(sortedrivs(icc),1),2), lalo(outpt(sortedrivs(icc),1),1)
3264	WRITE(diagunit,'(5I9,F16.4)') streams_nb(sortedrivs(icc)), &
3265	& streams_avehops(sortedrivs(icc))*streams_nb(sortedrivs(icc)), &
3266	& streams_minhops(sortedrivs(icc)), &
3267	& streams_avehops(sortedrivs(icc)), &
3268	& streams_maxhops(sortedrivs(icc)), streams_resid(sortedrivs(icc))
3269	!
3270	ENDIF
3271	!
3272	ENDDO
3273	!
3274	CLOSE(diagunit)
3275	!
3276	ENDIF
3277	!
3278	ENDIF
3279	!
3280	!
3281	nbrivers(:) = zero
3282	DO ig=1,nbpt
3283	nbrivers(ig) = COUNT(route_tobasin(ig,1:nbasmax) == nbasmax+3)
3284	ENDDO
3285	DO ig=1,nbpt
3286	IF ( nbrivers(ig) > 1 ) THEN
3287	WRITE(numout,*) 'Grid box ', ig, ' has ', NINT(nbrivers(ig)), ' outflow points.'
3288	WRITE(numout,*) 'The rivers which flow into the ocean at this point are :'
3289	DO icc=1,nbasmax
3290	IF ( route_tobasin(ig,icc) == nbasmax+3) THEN
3291	IF ( global_basinid(ig,icc) <= nb_small ) THEN
3292	WRITE(numout,*) 'ID = ',global_basinid(ig,icc), ' Name = ', basin_names(global_basinid(ig,icc))
3293	ELSE
3294	WRITE(numout,*) 'ID = ',global_basinid(ig,icc), ' Problem ===== ID is larger than possible'
3295	ENDIF
3296	ENDIF
3297	ENDDO
3298	ENDIF
3299	ENDDO
3300	!
3301	WRITE(numout,*) 'Maximum topographic index :', MAXVAL(topo_resid)
3302	ic = COUNT(topo_resid .GT. 0.)
3303	WRITE(numout,*) 'Mean topographic index :', SUM(topo_resid, MASK=topo_resid .GT. zero)/ic
3304	WRITE(numout,*) 'Minimum topographic index :', MINVAL(topo_resid, MASK=topo_resid .GT. zero)
3305	!
3306	DEALLOCATE(pts)
3307	DEALLOCATE(outpt)
3308	DEALLOCATE(nb_pts)
3309	DEALLOCATE(totarea, tmparea)
3310	DEALLOCATE(streams_nb, streams_avehops, streams_minhops, streams_maxhops)
3311	!
3312	DEALLOCATE(lbasin_area, lbasin_uparea, lrivercode)
3313	!
3314	DEALLOCATE(allstreams)
3315	DEALLOCATE(tstreams)
3316	DEALLOCATE(tslen, tpts, tptbas, tuparea)
3317	DEALLOCATE(tcode)
3318	!
3319	WRITE(numout,*) 'Maximum topographic index :', MAXVAL(topo_resid)
3320	ic = COUNT(topo_resid .GT. 0.)
3321	WRITE(numout,*) 'Mean topographic index :', SUM(topo_resid, MASK=topo_resid .GT. 0.)/ic
3322	WRITE(numout,*) 'Minimum topographic index :', MINVAL(topo_resid, MASK=topo_resid .GT. 0.)
3323	!
3324	!
3325	END SUBROUTINE routing_diagnostic
3326	!
3327	!! ================================================================================================================================
3328	!! SUBROUTINE : routing_diagcode
3329	!!
3330	!>\BRIEF This subroutine determines the code in the Pfafstetter system for all points
3331	!! within the given catchment.
3332	!!
3333	!! DESCRIPTION (definitions, functional, design, flags) : None
3334	!!
3335	!! RECENT CHANGE(S): None
3336	!!
3337	!! MAIN OUTPUT VARIABLE(S): streamcode
3338	!!
3339	!! REFERENCES : None
3340	!!
3341	!! FLOWCHART :None
3342	!! \n
3343	!_ ================================================================================================================================
3344
3345	SUBROUTINE routing_diagcode(ip, tpts, tpbas, tuparea, tslen, ls, allstreams, upstreamchange, streamcode)
3346	!
3347	IMPLICIT NONE
3348	!
3349	!! INPUT VARIABLES
3350	INTEGER(i_std), INTENT(in) :: ip !!
3351	INTEGER(i_std), INTENT(in) :: ls !!
3352	INTEGER(i_std), DIMENSION(ip), INTENT(in) :: tpts !!
3353	INTEGER(i_std), DIMENSION(ip), INTENT(in) :: tpbas !!
3354	REAL(r_std), DIMENSION(ip), INTENT(in) :: tuparea !!
3355	INTEGER(i_std), DIMENSION(ip), INTENT(in) :: tslen !!
3356	INTEGER(i_std), DIMENSION(ip,ls), INTENT(in) :: allstreams !!
3357	REAL(r_std), DIMENSION(ip,ls), INTENT(in) :: upstreamchange !!
3358	!
3359	!! OUTPUT VARIABLES
3360	INTEGER(i_std), DIMENSION(ip), INTENT(out) :: streamcode !!
3361	!
3362	!! LOCAL VARIABLES
3363	INTEGER(i_std) :: ilev, cntsubbas, ib, ic, i, it, ilevmax, imaxlen, nbzero !!
3364	INTEGER(i_std) :: tstreamcode(ip)!!
3365	INTEGER(i_std) :: indsubbas(ip) !!
3366	INTEGER(i_std) :: iw(ip) !!
3367	INTEGER(i_std) :: tdiff(ip) !!
3368	INTEGER(i_std) :: tmpjunc(4) !!
3369	INTEGER(i_std) :: junction(4) !!
3370	INTEGER(i_std) :: ff(1) !!
3371	INTEGER(i_std) :: ll !!
3372	REAL(r_std) :: chguparea(ip) !!
3373	REAL(r_std) :: largest !!
3374
3375	!_ ================================================================================================================================
3376	!
3377	streamcode(:) = 0
3378	!
3379	! If we accept 4 grid boxes per coded basin then per level we need at least
3380	! 4*9=36 boxes.
3381	!
3382	ilevmax = 0
3383	it = ip
3384	DO WHILE (it >= 36)
3385	ilevmax = ilevmax+1
3386	it = it/9
3387	ENDDO
3388	!
3389	DO ilev=1,ilevmax
3390	!
3391	! Count number of sub-basins we already have
3392	!
3393	cntsubbas=0
3394	tstreamcode(:) = streamcode(:)
3395	DO WHILE ( COUNT(tstreamcode(:) >= 0) > 0 )
3396	cntsubbas=cntsubbas+1
3397	indsubbas(cntsubbas) = MAXVAL(tstreamcode(:))
3398	WHERE ( tstreamcode(:) == indsubbas(cntsubbas) ) tstreamcode = -1
3399	ENDDO
3400	!
3401	! Go through all these basins in order to find the next Pfafstetter numbers
3402	!
3403	DO ib=1,cntsubbas
3404	!
3405	! Get all the streams which have the current Pfadstetter number
3406	!
3407	it=0
3408	DO ic=1,ip
3409	IF ( streamcode(ic) == indsubbas(ib) ) THEN
3410	it =it+1
3411	iw(it)=ic
3412	ENDIF
3413	ENDDO
3414	!
3415	! Which is the longest stream in this basin ?
3416	!
3417	ff=MAXLOC(tslen(iw(1:it)))
3418	imaxlen=iw(ff(1))
3419	chguparea(:) = zero
3420	chguparea(1:tslen(imaxlen)) = upstreamchange(imaxlen, 1:tslen(imaxlen))
3421	!
3422	IF ( COUNT(chguparea(1:tslen(imaxlen)) > 0) < 4 ) THEN
3423	!
3424	! If this subbasin is too small we just set all points to zero
3425	!
3426	DO i=1,it
3427	streamcode(iw(i)) = streamcode(iw(i))*10
3428	ENDDO
3429	ELSE
3430	!
3431	! Else do the Pfafstetter numbering
3432	!
3433	!
3434	! Where do we have the 4 largest change in upstream area on this stream.
3435	! This must be the confluence of 2 rivers and thus a junction point.
3436	!
3437	largest=piR_EarthR_Earth
3438	DO i=1,4
3439	ff = MAXLOC(chguparea(1:tslen(imaxlen)), MASK = chguparea(1:tslen(imaxlen)) < largest)
3440	tmpjunc(i) = ff(1)
3441	largest=chguparea(tmpjunc(i))
3442	ENDDO
3443	! sort junctions to go from the outflow up-stream
3444	ff(1)=0
3445	DO i=1,4
3446	junction(i) = MINVAL(tmpjunc, MASK=tmpjunc > ff(1))
3447	ff(1) = junction(i)
3448	ENDDO
3449	!
3450	! Find all streams which are identical up to that junction and increase their code accordingly
3451	!
3452	DO i=1,it
3453	ll=MIN(tslen(imaxlen),tslen(iw(i)))
3454	tdiff(1:ll) = allstreams(imaxlen,1:ll)-allstreams(iw(i),1:ll)
3455	nbzero = COUNT(tdiff(1:ll) == 0)
3456	IF (nbzero < junction(1) ) THEN
3457	! Before first of the 4 largest basins
3458	streamcode(iw(i)) = streamcode(iw(i))*10+1
3459	ELSE IF (nbzero == junction(1) ) THEN
3460	! Stream part of the first largest basin
3461	streamcode(iw(i)) = streamcode(iw(i))*10+2
3462	ELSE IF (nbzero < junction(2) ) THEN
3463	! Between first and second stream
3464	streamcode(iw(i)) = streamcode(iw(i))*10+3
3465	ELSE IF (nbzero == junction(2) ) THEN
3466	! Stream part of the second basin
3467	streamcode(iw(i)) = streamcode(iw(i))*10+4
3468	ELSE IF (nbzero < junction(3) ) THEN
3469	! In between stream 2 and 3
3470	streamcode(iw(i)) = streamcode(iw(i))*10+5
3471	ELSE IF (nbzero == junction(3) ) THEN
3472	! Part of 3rd basin
3473	streamcode(iw(i)) = streamcode(iw(i))*10+6
3474	ELSE IF (nbzero < junction(4) ) THEN
3475	! In between 3 and 4th basins
3476	streamcode(iw(i)) = streamcode(iw(i))*10+7
3477	ELSE IF (nbzero == junction(4) ) THEN
3478	! Final of the 4 largest basins
3479	streamcode(iw(i)) = streamcode(iw(i))*10+8
3480	ELSE
3481	! The rest of the points and also the basin of the longest stream
3482	streamcode(iw(i)) = streamcode(iw(i))*10+9
3483	ENDIF
3484	ENDDO
3485	ENDIF
3486	ENDDO
3487	!
3488	ENDDO
3489	!
3490	!
3491	END SUBROUTINE routing_diagcode
3492	!
3493	!! ================================================================================================================================
3494	!! SUBROUTINE : routing_diagncfile
3495	!!
3496	!>\BRIEF This subroutine creates a netCDF file containing all the informations
3497	!! on the largest rivers which can be used for a refined analysis.
3498	!!
3499	!! DESCRIPTION (definitions, functional, design, flags) : None
3500	!!
3501	!! RECENT CHANGE(S): None
3502	!!
3503	!! MAIN OUTPUT VARIABLE(S): None
3504	!!
3505	!! REFERENCES : None
3506	!!
3507	!! FLOWCHART : None
3508	!! \n
3509	!_ ================================================================================================================================
3510
3511	SUBROUTINE routing_diagncfile(river_file_name, nbpt, lalo, nb_pts, topids, sorted_names, sortedrivs, &
3512	& lbasin_index, lbasin_area, lbasin_uparea, lrivercode, outpt, streams_nb, streams_avehops, &
3513	& streams_minhops, streams_maxhops, streams_resid)
3514	!
3515	USE netcdf
3516	!
3517	IMPLICIT NONE
3518	!
3519	!
3520	!! INPUT VARIABLES
3521	REAL(r_std), INTENT(in) :: lalo(nbpt,2) !! Vector of latitude and longitudes (beware of the order !)
3522
3523	!! LOCAL VARIABLES
3524	CHARACTER(LEN=80) :: river_file_name !! Filename in which we write the description of the rivers (1)
3525	INTEGER(i_std) :: nbpt !! Domain size (unitless)
3526	INTEGER(i_std), DIMENSION(num_largest) :: nb_pts !! Number of points in the basin (unitless)
3527	INTEGER(i_std), DIMENSION(num_largest) :: topids !! The IDs of the first num_largest basins (unitless)
3528	CHARACTER(LEN=25), DIMENSION(num_largest) :: sorted_names !! Names of the basins to be put into the file (unitless)
3529	INTEGER(i_std), DIMENSION(num_largest) :: sortedrivs !!
3530	INTEGER(i_std), DIMENSION(num_largest,nbpt) :: lbasin_index !!
3531	REAL(r_std), DIMENSION(num_largest,nbpt) :: lbasin_area !!
3532	REAL(r_std), DIMENSION(num_largest,nbpt) :: lbasin_uparea !!
3533	INTEGER(i_std), DIMENSION(num_largest,nbpt) :: lrivercode !!
3534	!
3535	INTEGER(i_std), DIMENSION(num_largest,2) :: outpt !! Outflow point for each basin (unitless)
3536	INTEGER(i_std), DIMENSION(num_largest) :: streams_nb !! Number of streams in basin (unitless)
3537	INTEGER(i_std), DIMENSION(num_largest) :: streams_avehops !! Average number of hops in streams (unitless)
3538	INTEGER(i_std), DIMENSION(num_largest) :: streams_minhops !! Minimum number of hops in streams (unitless)
3539	INTEGER(i_std), DIMENSION(num_largest) :: streams_maxhops !! Minimum number of hops in streams (unitless)
3540	REAL(r_std), DIMENSION(num_largest) :: streams_resid !! Average residence time
3541	!
3542	INTEGER(i_std) :: icc, fid, iret, ierr_tot, ib, ij, ik, i, j, lcc !! Indices (unitless)
3543	INTEGER(i_std) :: nlonid, nlatid, varid, varid2, varid3
3544	INTEGER(i_std) :: dims(2) !!
3545	REAL(r_std) :: lon_min, lon_max, lat_min, lat_max
3546	CHARACTER(LEN=80) :: lon_name, lat_name, var_name, long_name, nc_name, att_str !!
3547	!
3548	REAL(r_std) :: basinfrac(iim_g,jjm_g) !!
3549	REAL(r_std) :: basinuparea(iim_g,jjm_g) !!
3550	INTEGER(i_std) :: basincode(iim_g,jjm_g) !!
3551	!
3552	LOGICAL :: check=.FALSE. !! (true/false)
3553	!
3554	!! PARAMETERS
3555	INTEGER(i_std),PARAMETER :: kind_r_diag=NF90_REAL8 !!
3556	INTEGER(i_std),PARAMETER :: kind_i_diag=NF90_INT !!
3557
3558	!_ ================================================================================================================================
3559	!
3560	!
3561	! 1.0 Create the NETCDF file and store the coordinates.
3562	!
3563	!
3564	iret = NF90_CREATE(TRIM(river_file_name), NF90_CLOBBER, fid)
3565	IF (iret /= NF90_NOERR) THEN
3566	CALL ipslerr_p (3,'routing_diagncfile', 'Could not create file :', &
3567	& TRIM(river_file_name), '(Problem with disk place or filename ?)')
3568	ENDIF
3569	!
3570	! 1.1 Define dimensions
3571	!
3572	IF ( INDEX(GridType, "RegLonLat") == 1 ) THEN
3573	!
3574	! 1.1.1 regular grid
3575	!
3576	iret = NF90_DEF_DIM(fid, 'lon', iim_g, dims(1))
3577	IF (iret /= NF90_NOERR) THEN
3578	CALL ipslerr_p (3,'routing_diagncfile', 'Dimension "x" can not be defined for the file : ', &
3579	& TRIM(river_file_name),'(Solution ?)')
3580	ENDIF
3581	iret = NF90_DEF_DIM(fid, 'lat', jjm_g, dims(2))
3582	IF (iret /= NF90_NOERR) THEN
3583	CALL ipslerr_p (3,'routing_diagncfile', 'Dimension "y" can not be defined for the file : ', &
3584	& TRIM(river_file_name),'(Solution ?)')
3585	ENDIF
3586	ELSE IF ( INDEX(GridType, "RegXY") == 1 ) THEN
3587	!
3588	! 1.1.2 irregular grid
3589	!
3590	iret = NF90_DEF_DIM(fid, 'x', iim_g, dims(1))
3591	IF (iret /= NF90_NOERR) THEN
3592	CALL ipslerr_p (3,'routing_diagncfile', 'Dimension "x" can not be defined for the file : ', &
3593	& TRIM(river_file_name),'(Solution ?)')
3594	ENDIF
3595
3596	iret = NF90_DEF_DIM(fid, 'y', jjm_g, dims(2))
3597	IF (iret /= NF90_NOERR) THEN
3598	CALL ipslerr_p (3,'routing_diagncfile', 'Dimension "y" can not be defined for the file : ', &
3599	& TRIM(river_file_name),'(Solution ?)')
3600	ENDIF
3601	ELSE
3602	WRITE(numout,*) "Gridtype =", GridType, "not implemented yet"
3603	CALL ipslerr_p (3,'routing_diagncfile', 'Cannot deal with this grid type yet.', &
3604	& '', '')
3605	ENDIF
3606	!
3607	!
3608	! 1.2 Define variables and attributes
3609	!
3610	IF ( INDEX(GridType, "RegLonLat") == 1 ) THEN
3611	!
3612	! 1.2.1 regular grid
3613	!
3614	lon_name = 'lon'
3615	!
3616	iret = NF90_DEF_VAR(fid, lon_name, kind_r_diag, dims(1), nlonid)
3617	IF (iret /= NF90_NOERR) THEN
3618	CALL ipslerr_p (3,'routing_diagncfile', 'Variable '//lon_name//' can not be defined for the file : ', &
3619	& TRIM(river_file_name),'(Solution ?)')
3620	ENDIF
3621	!
3622	lat_name = 'lat'
3623	iret = NF90_DEF_VAR(fid, lat_name, kind_r_diag, dims(2), nlatid)
3624	IF (iret /= NF90_NOERR) THEN
3625	CALL ipslerr_p (3,'routing_diagncfile', 'Variable '//lat_name//' can not be defined for the file : ', &
3626	& TRIM(river_file_name),'(Solution ?)')
3627	ENDIF
3628	!
3629	ELSE IF ( INDEX(GridType, "RegXY") == 1 ) THEN
3630	!
3631	! 1.2.2 irregular grid
3632	!
3633	lon_name = 'nav_lon'
3634	!
3635	iret = NF90_DEF_VAR(fid, lon_name, kind_r_diag, dims, nlonid)
3636	IF (iret /= NF90_NOERR) THEN
3637	CALL ipslerr_p (3,'routing_diagncfile', 'Variable '//lon_name//' can not be defined for the file : ', &
3638	& TRIM(river_file_name),'(Solution ?)')
3639	ENDIF
3640	!
3641	lat_name = 'nav_lat'
3642	iret = NF90_DEF_VAR(fid, lat_name, kind_r_diag, dims, nlatid)
3643	IF (iret /= NF90_NOERR) THEN
3644	CALL ipslerr_p (3,'routing_diagncfile', 'Variable '//lat_name//' can not be defined for the file : ', &
3645	& TRIM(river_file_name),'(Solution ?)')
3646	ENDIF
3647	!
3648	ELSE
3649	WRITE(numout,*) "Gridtype = ", GridType, " not implemented yet."
3650	CALL ipslerr_p (3,'routing_diagncfile', 'Cannot deal with this grid type yet.', &
3651	& '', '')
3652	ENDIF
3653	!
3654	! 1.3 Add attributes to the coordinate variables
3655	!
3656	iret = NF90_PUT_ATT(fid, nlonid, 'units', "degrees_east")
3657	IF (iret /= NF90_NOERR) THEN
3658	CALL ipslerr_p (3,'routing_diagncfile', 'Could not add attribut to variable '//lon_name//' for the file :', &
3659	& TRIM(river_file_name),'(Solution ?)')
3660	ENDIF
3661	!
3662	lon_min = -180.
3663	lon_max = 180.
3664	!
3665	iret = NF90_PUT_ATT(fid, nlonid, 'valid_min', lon_min)
3666	IF (iret /= NF90_NOERR) THEN
3667	CALL ipslerr_p (3,'routing_diagncfile', 'Could not add attribut to variable '//lon_name//' for the file :', &
3668	& TRIM(river_file_name),'(Solution ?)')
3669	ENDIF
3670	iret = NF90_PUT_ATT(fid, nlonid, 'valid_max', lon_max)
3671	IF (iret /= NF90_NOERR) THEN
3672	CALL ipslerr_p (3,'routing_diagncfile', 'Could not add attribut to variable '//lon_name//' for the file :', &
3673	& TRIM(river_file_name),'(Solution ?)')
3674	ENDIF
3675	!
3676	iret = NF90_PUT_ATT(fid, nlonid, 'long_name', "Longitude")
3677	IF (iret /= NF90_NOERR) THEN
3678	CALL ipslerr_p (3,'routing_diagncfile', 'Could not add attribut to variable '//lon_name//' for the file :', &
3679	& TRIM(river_file_name),'(Solution ?)')
3680	ENDIF
3681	iret = NF90_PUT_ATT(fid, nlatid, 'units', "degrees_north")
3682	IF (iret /= NF90_NOERR) THEN
3683	CALL ipslerr_p (3,'routing_diagncfile', 'Could not add attribut to variable '//lat_name//' for the file :', &
3684	& TRIM(river_file_name),'(Solution ?)')
3685	ENDIF
3686	!
3687	lat_max = 90.
3688	lat_min = -90.
3689	!
3690	iret = NF90_PUT_ATT(fid, nlatid, 'valid_min', lat_min)
3691	IF (iret /= NF90_NOERR) THEN
3692	CALL ipslerr_p (3,'routing_diagncfile', 'Could not add attribut to variable '//lat_name//' for the file :', &
3693	& TRIM(river_file_name),'(Solution ?)')
3694	ENDIF
3695	iret = NF90_PUT_ATT(fid, nlatid, 'valid_max', lat_max)
3696	IF (iret /= NF90_NOERR) THEN
3697	CALL ipslerr_p (3,'routing_diagncfile', 'Could not add attribut to variable '//lat_name//' for the file :', &
3698	& TRIM(river_file_name),'(Solution ?)')
3699	ENDIF
3700	iret = NF90_PUT_ATT(fid, nlatid, 'long_name', "Latitude")
3701	IF (iret /= NF90_NOERR) THEN
3702	CALL ipslerr_p (3,'routing_diagncfile', 'Could not add attribut to variable '//lat_name//' for the file :', &
3703	& TRIM(river_file_name),'(Solution ?)')
3704	ENDIF
3705	!
3706	iret = NF90_ENDDEF(fid)
3707	IF (iret /= NF90_NOERR) THEN
3708	CALL ipslerr_p (3,'routing_diagncfile', 'Could not end definitions in the file : ', &
3709	& TRIM(river_file_name),'(Solution ?)')
3710	ENDIF
3711	!
3712	! 1.4 Write coordinates
3713	!
3714	IF ( INDEX(GridType, "RegLonLat") == 1 ) THEN
3715	!
3716	! 1.4.1 regular grid
3717	!
3718	iret = NF90_PUT_VAR(fid, nlonid, lon_g(1:iim_g,1))
3719	IF (iret /= NF90_NOERR) THEN
3720	CALL ipslerr_p (3,'routing_diagncfile', 'Could not put variable nav_lon in the file : ', &
3721	& TRIM(river_file_name),'(Solution ?)')
3722	ENDIF
3723	!
3724	iret = NF90_PUT_VAR(fid, nlatid, lat_g(1,1:jjm_g))
3725	IF (iret /= NF90_NOERR) THEN
3726	CALL ipslerr_p (3,'routing_diagncfile', 'Could not put variable nav_lat in the file : ', &
3727	& TRIM(river_file_name),'(Solution ?)')
3728	ENDIF
3729	ELSE IF ( INDEX(GridType, "RegXY") == 1 ) THEN
3730	!
3731	! 1.4.2 irregular grid
3732	!
3733	iret = NF90_PUT_VAR(fid, nlonid, lon_g)
3734	IF (iret /= NF90_NOERR) THEN
3735	CALL ipslerr_p (3,'routing_diagncfile', 'Could not put variable nav_lon in the file : ', &
3736	& TRIM(river_file_name),'(Solution ?)')
3737	ENDIF
3738	!
3739	iret = NF90_PUT_VAR(fid, nlatid, lat_g)
3740	IF (iret /= NF90_NOERR) THEN
3741	CALL ipslerr_p (3,'routing_diagncfile', 'Could not put variable nav_lat in the file : ', &
3742	& TRIM(river_file_name),'(Solution ?)')
3743	ENDIF
3744	ELSE
3745	!
3746	! This case was already caught before !
3747	!
3748	ENDIF
3749	!
3750	! 2.0 Go through all basins and wirte the information into the netCDF file.
3751	!
3752	DO icc = 1, num_largest
3753	!
3754	! 2.1 Compute the fields to be saved in the file
3755	!
3756	ib=sortedrivs(icc)
3757	!
3758	!
3759	IF ( nb_pts(ib) > 2 ) THEN
3760	!
3761	basinfrac(:,:) = zero
3762	basinuparea(:,:) = zero
3763	basincode(:,:) = zero
3764	!
3765	DO ij=1, nb_pts(ib)
3766
3767	ik=lbasin_index(ib,ij)
3768
3769	j = ((index_g(ik)-1)/iim_g) + 1
3770	i = (index_g(ik)-(j-1)*iim_g)
3771
3772	basinfrac(i,j) = basinfrac(i,j) + lbasin_area(ib,ij)/(resolution_g(ik,1)*resolution_g(ik,2))
3773	basinuparea(i,j) = MAX(basinuparea(i,j), lbasin_uparea(ib,ij))
3774	basincode(i,j) = lrivercode(ib,ij)
3775
3776	ENDDO
3777	!
3778	DO i=1,iim_g
3779	DO j=1,jjm_g
3780	IF ( basinfrac(i,j) <= EPSILON(zero) ) THEN
3781	basinfrac(i,j) = undef_sechiba
3782	basinuparea(i,j) = undef_sechiba
3783	basincode(i,j) = undef_int
3784	ELSE
3785	basinfrac(i,j) = MIN(basinfrac(i,j), un)
3786	ENDIF
3787	ENDDO
3788	ENDDO
3789	!
3790	!
3791	! 2.2 Define the variables in the netCDF file
3792	!
3793	iret = NF90_REDEF(fid)
3794	IF (iret /= NF90_NOERR) THEN
3795	CALL ipslerr_p (3,'routing_diagncfile', &
3796	& 'Could not restart definitions in the file : ', &
3797	& TRIM(river_file_name),'(Solution ?)')
3798	ENDIF
3799	!
3800	! Create a name more suitable for a variable in a netCDF file
3801	!
3802	nc_name = TRIM(sorted_names(icc))
3803	! Take out all character which could cause problems
3804	lcc=LEN_TRIM(nc_name)
3805	DO ij=1,lcc
3806	IF ( nc_name(ij:ij) == " " ) nc_name(ij:ij) = "_"
3807	IF ( nc_name(ij:ij) == "(" ) nc_name(ij:ij) = "_"
3808	IF ( nc_name(ij:ij) == ")" ) nc_name(ij:ij) = "_"
3809	ENDDO
3810	! reduce redundant "__"
3811	DO ij=1,lcc
3812	IF ( nc_name(ij:ij+1) == "__" ) nc_name(ij+1:)=nc_name(ij+2:lcc)
3813	ENDDO
3814	lcc=LEN_TRIM(nc_name)
3815	IF ( nc_name(lcc:lcc) == "_" ) nc_name(lcc:lcc) = " "
3816	!
3817	!
3818	! 2.3 Fraction variable
3819	!
3820	IF (check) WRITE(numout,*) "Define Fraction variable and add attributes"
3821	!
3822	var_name = TRIM(nc_name)//"_frac"
3823	!
3824	iret = NF90_DEF_VAR(fid, TRIM(var_name), kind_r_diag, dims, varid)
3825	IF (iret /= NF90_NOERR) THEN
3826	CALL ipslerr_p (3,'routing_diagncfile', 'Variable '//TRIM(var_name)//' can not be defined for the file : ', &
3827	& TRIM(river_file_name),'(Solution ?)')
3828	ENDIF
3829	!
3830	ierr_tot = 0
3831	! Units
3832	iret = NF90_PUT_ATT(fid, varid, 'units', "-")
3833	IF (iret /= NF90_NOERR) THEN
3834	WRITE(numout,*) 'Units', iret
3835	WRITE(numout,*) TRIM(NF90_STRERROR(iret))
3836	ierr_tot = ierr_tot + 1
3837	ENDIF
3838	! Long name
3839	long_name = "Fraction of basin "//TRIM(sorted_names(icc))//" per grid box"
3840	iret = NF90_PUT_ATT(fid, varid, 'long_name', long_name)
3841	IF (iret /= NF90_NOERR) THEN
3842	WRITE(numout,*) 'Long_Name', long_name, iret
3843	WRITE(numout,*) TRIM(NF90_STRERROR(iret))
3844	ierr_tot = ierr_tot + 1
3845	ENDIF
3846	! Missing value
3847	iret = NF90_PUT_ATT(fid, varid, 'missing_value', undef_sechiba)
3848	IF (iret /= NF90_NOERR) THEN
3849	WRITE(numout,*) 'Missing value', undef_sechiba, iret
3850	WRITE(numout,*) TRIM(NF90_STRERROR(iret))
3851	ierr_tot = ierr_tot + 1
3852	ENDIF
3853	!
3854	ib=sortedrivs(icc)
3855	IF ( check ) WRITE(numout,*) "Doing basin ", icc," corrsdponding to index = ", ib, "num_largest : ", num_largest
3856	!
3857	! Nb of grid points in basin
3858	att_str='Nb_of_grid_points_in_basin'
3859	iret = NF90_PUT_ATT(fid, varid, att_str, nb_pts(ib))
3860	IF (iret /= NF90_NOERR) THEN
3861	WRITE(numout,*) 'Nb of grid points in basin', nb_pts(ib), iret
3862	WRITE(numout,*) TRIM(NF90_STRERROR(iret))
3863	ierr_tot = ierr_tot + 1
3864	ENDIF
3865	!
3866	! Longitude of outflow point
3867	att_str='Longitude_of_outflow_point'
3868	iret = NF90_PUT_ATT(fid, varid, att_str, lalo(outpt(ib,1),2))
3869	IF (iret /= NF90_NOERR) THEN
3870	WRITE(numout,*) 'Longitude of outflow point', lalo(outpt(ib,1),2), iret
3871	WRITE(numout,*) TRIM(NF90_STRERROR(iret))
3872	ierr_tot = ierr_tot + 1
3873	ENDIF
3874	!
3875	! Latitide of outflow point
3876	att_str='Latitude_of_outflow_point'
3877	iret = NF90_PUT_ATT(fid, varid, att_str, lalo(outpt(ib,1),1))
3878	IF (iret /= NF90_NOERR) THEN
3879	WRITE(numout,*) 'Latitude of outflow point', lalo(outpt(ib,1),1), iret
3880	WRITE(numout,*) TRIM(NF90_STRERROR(iret))
3881	ierr_tot = ierr_tot + 1
3882	ENDIF
3883	!
3884	! Number of streams
3885	att_str= 'Number_of_streams'
3886	iret = NF90_PUT_ATT(fid, varid, att_str, streams_nb(ib))
3887	IF (iret /= NF90_NOERR) THEN
3888	WRITE(numout,*) 'Number of streams', streams_nb(ib), iret
3889	WRITE(numout,*) TRIM(NF90_STRERROR(iret))
3890	ierr_tot = ierr_tot + 1
3891	ENDIF
3892	!
3893	! Total number of hops to go to the oceans
3894	att_str='Total_number_of_hops_to_ocean'
3895	iret = NF90_PUT_ATT(fid, varid, att_str, streams_avehops(ib)*streams_nb(ib))
3896	IF (iret /= NF90_NOERR) THEN
3897	WRITE(numout,) 'Total number of hops to go to the oceans ', streams_avehops(ib)streams_nb(ib), iret
3898	ierr_tot = ierr_tot + 1
3899	ENDIF
3900	!
3901	! Minimum number of hops to go to the ocean for any stream
3902	att_str='Minimum_number_of_hops_to_ocean_for_any_stream'
3903	iret = NF90_PUT_ATT(fid, varid, att_str, streams_minhops(ib))
3904	IF (iret /= NF90_NOERR) THEN
3905	WRITE(numout,*) 'Minimum number of hops to go tp the ocean for any stream', streams_minhops(ib), iret
3906	ierr_tot = ierr_tot + 1
3907	ENDIF
3908	!
3909	! Average number of hops to go to the ocean for any stream
3910	att_str='Average_number_of_hops_to_ocean_for_any_stream'
3911	iret = NF90_PUT_ATT(fid, varid, att_str, streams_avehops(ib))
3912	IF (iret /= NF90_NOERR) THEN
3913	WRITE(numout,*) 'Average number of hops to go tp the ocean for any stream', streams_avehops(ib), iret
3914	ierr_tot = ierr_tot + 1
3915	ENDIF
3916	!
3917	! Maximum number of hops to go to the ocean for any stream
3918	att_str='Maximum_number_of_hops_to_ocean_for_any_stream'
3919	iret = NF90_PUT_ATT(fid, varid, att_str, streams_maxhops(ib))
3920	IF (iret /= NF90_NOERR) THEN
3921	WRITE(numout,*) 'Maximum number of hops to go tp the ocean for any stream', streams_maxhops(ib), iret
3922	ierr_tot = ierr_tot + 1
3923	ENDIF
3924	!
3925	! Average residence time in the basin
3926	att_str='Average_residence_time_in_basin'
3927	iret = NF90_PUT_ATT(fid, varid, att_str, streams_resid(ib))
3928	IF (iret /= NF90_NOERR) THEN
3929	WRITE(numout,*) 'Average residence time in the basin', streams_resid(ib), iret
3930	ierr_tot = ierr_tot + 1
3931	ENDIF
3932	!
3933	IF (ierr_tot > 0 ) THEN
3934	CALL ipslerr_p (3,'routing_diagncfile', 'Could not add some attributes to variable '//var_name//' for the file :', &
3935	& TRIM(river_file_name),'(Solution ?)')
3936	ENDIF
3937	!
3938	! 2.4 Upstream area variable variable
3939	!
3940	IF (check) WRITE(numout,*) "Define Upstream variable and add attributes"
3941	!
3942	! Create a name more suitable for a variable in a netCDF file
3943	!
3944	var_name = TRIM(nc_name)//"_upstream"
3945	DO ij=1,LEN_TRIM(var_name)
3946	IF ( var_name(ij:ij) == " " ) var_name(ij:ij) = "_"
3947	ENDDO
3948	!
3949	iret = NF90_DEF_VAR(fid, TRIM(var_name), kind_r_diag, dims, varid2)
3950	IF (iret /= NF90_NOERR) THEN
3951	CALL ipslerr_p (3,'routing_diagncfile', 'Variable '//TRIM(var_name)//' can not be defined for the file : ', &
3952	& TRIM(river_file_name),'(Solution ?)')
3953	ENDIF
3954	!
3955	ierr_tot = 0
3956	! Units
3957	iret = NF90_PUT_ATT(fid, varid2, 'units', "m^2")
3958	IF (iret /= NF90_NOERR) ierr_tot = ierr_tot + 1
3959	! Long name
3960	long_name = "Upstream area of basin "//TRIM(sorted_names(icc))//" in the grid box"
3961	iret = NF90_PUT_ATT(fid, varid2, 'long_name', long_name)
3962	IF (iret /= NF90_NOERR) ierr_tot = ierr_tot + 1
3963	! Missing value
3964	iret = NF90_PUT_ATT(fid, varid2, 'missing_value', undef_sechiba)
3965	IF (iret /= NF90_NOERR) ierr_tot = ierr_tot + 1
3966	!
3967	IF (ierr_tot > 0 ) THEN
3968	CALL ipslerr_p (3,'routing_diagncfile', 'Could not add some attributes to variable '//var_name//' for the file :', &
3969	& TRIM(river_file_name),'(Solution ?)')
3970	ENDIF
3971	!
3972	! 2.5 Pfafstetter codes for basins
3973	!
3974	IF (check) WRITE(numout,*) "Define Pfafstetter codes variable and add attributes"
3975	!
3976	var_name = TRIM(nc_name)//"_coding"
3977	DO ij=1,LEN_TRIM(var_name)
3978	IF ( var_name(ij:ij) == " " ) var_name(ij:ij) = "_"
3979	ENDDO
3980	!
3981	iret = NF90_DEF_VAR(fid, TRIM(var_name), kind_i_diag, dims, varid3)
3982	IF (iret /= NF90_NOERR) THEN
3983	CALL ipslerr_p (3,'routing_diagncfile', 'Variable '//TRIM(var_name)//' can not be defined for the file : ', &
3984	& TRIM(river_file_name),'(Solution ?)')
3985	ENDIF
3986	!
3987	ierr_tot = 0
3988	! Units
3989	iret = NF90_PUT_ATT(fid, varid3, 'units', "-")
3990	IF (iret /= NF90_NOERR) ierr_tot = ierr_tot + 1
3991	! Long name
3992	long_name = "Pfafstetter codes of grid boxes in basin "//TRIM(sorted_names(icc))
3993	iret = NF90_PUT_ATT(fid, varid3, 'long_name', long_name)
3994	IF (iret /= NF90_NOERR) ierr_tot = ierr_tot + 1
3995	! Missing value
3996	iret = NF90_PUT_ATT(fid, varid3, 'missing_value', undef_int)
3997	IF (iret /= NF90_NOERR) ierr_tot = ierr_tot + 1
3998	!
3999	IF (ierr_tot > 0 ) THEN
4000	CALL ipslerr_p (3,'routing_diagncfile', 'Could not add some attributes to variable '//var_name//' for the file :', &
4001	& TRIM(river_file_name),'(Solution ?)')
4002	ENDIF
4003	!
4004	! 2.6 ENDDEF of netCDF file
4005	!
4006	IF (check) WRITE(numout,*) "END define"
4007	!
4008	iret = NF90_ENDDEF(fid)
4009	IF (iret /= NF90_NOERR) THEN
4010	CALL ipslerr_p (3,'routing_diagncfile', &
4011	& 'Could not end definitions in the file : ', &
4012	& TRIM(river_file_name),'(Solution ?)')
4013	ENDIF
4014	!
4015	! 2.7 Write the data to the file
4016	!
4017	IF (check) WRITE(numout,*) "Put basinfrac"
4018	iret = NF90_PUT_VAR(fid, varid, basinfrac)
4019	IF (iret /= NF90_NOERR) THEN
4020	CALL ipslerr_p (3,'routing_diagncfile', 'Could not put variable basinfrac in the file : ', &
4021	& TRIM(river_file_name),'(Solution ?)')
4022	ENDIF
4023
4024	IF (check) WRITE(numout,*) "Put basinuparea"
4025	iret = NF90_PUT_VAR(fid, varid2, basinuparea)
4026	IF (iret /= NF90_NOERR) THEN
4027	CALL ipslerr_p (3,'routing_diagncfile', 'Could not put variable basinuparea in the file : ', &
4028	& TRIM(river_file_name),'(Solution ?)')
4029	ENDIF
4030
4031	IF (check) WRITE(numout,*) "Put basincode"
4032	iret = NF90_PUT_VAR(fid, varid3, basincode)
4033	IF (iret /= NF90_NOERR) THEN
4034	CALL ipslerr_p (3,'routing_diagfile', 'Could not put variable basincode in the file : ', &
4035	& TRIM(river_file_name),'(Solution ?)')
4036	ENDIF
4037	!
4038	ENDIF
4039	!
4040	ENDDO
4041	!
4042	IF (check) WRITE(numout,*) "Close file"
4043	!
4044	! Close netCDF file and do some memory management.
4045	!
4046	iret = NF90_CLOSE(fid)
4047	IF (iret /= NF90_NOERR) THEN
4048	CALL ipslerr_p (3,'routing_diagncfile', &
4049	& 'Could not end definitions in the file : ', &
4050	& TRIM(river_file_name),'(Solution ?)')
4051	ENDIF
4052	!
4053	!
4054	END SUBROUTINE routing_diagncfile
4055	!
4056	!! ================================================================================================================================
4057	!! SUBROUTINE : routing_basins_p
4058	!!
4059	!>\BRIEF This parallelized subroutine computes the routing map if needed.
4060	!!
4061	!! DESCRIPTION (definitions, functional, design, flags) : None
4062	!!
4063	!! RECENT CHANGE(S): None
4064	!!
4065	!! MAIN OUTPUT VARIABLE(S):
4066	!!
4067	!! REFERENCES : None
4068	!!
4069	!! FLOWCHART : None
4070	!! \n
4071	!_ ================================================================================================================================
4072
4073	SUBROUTINE routing_basins_p(nbpt, lalo, neighbours, resolution, contfrac)
4074	!
4075	IMPLICIT NONE
4076	!
4077	!! INPUT VARIABLES
4078	INTEGER(i_std), INTENT(in) :: nbpt !! Domain size (unitless)
4079	REAL(r_std), INTENT(in) :: lalo(nbpt,2) !! Vector of latitude and longitudes (beware of the order !)
4080	INTEGER(i_std), INTENT(in) :: neighbours(nbpt,NbNeighb) !! Vector of neighbours for each grid point (1=North and then clockwise) (unitless)
4081	REAL(r_std), INTENT(in) :: resolution(nbpt,2) !! The size of each grid box in X and Y (m)
4082	REAL(r_std), INTENT(in) :: contfrac(nbpt) !! Fraction of land in each grid box (unitless;0-1)
4083
4084	!_ ================================================================================================================================
4085
4086	routing_area => routing_area_glo
4087	topo_resid => topo_resid_glo
4088	route_togrid => route_togrid_glo
4089	route_tobasin => route_tobasin_glo
4090	route_nbintobas => route_nbintobas_glo
4091	global_basinid => global_basinid_glo
4092
4093	IF (is_root_prc) CALL routing_basins(nbp_glo,lalo_g, neighbours_g, resolution_g, contfrac_g)
4094
4095	routing_area => routing_area_loc
4096	topo_resid => topo_resid_loc
4097	route_togrid => route_togrid_loc
4098	route_tobasin => route_tobasin_loc
4099	route_nbintobas => route_nbintobas_loc
4100	global_basinid => global_basinid_loc
4101
4102	CALL scatter(routing_area_glo,routing_area_loc)
4103	CALL scatter(topo_resid_glo,topo_resid_loc)
4104	CALL scatter(route_togrid_glo,route_togrid_loc)
4105	CALL scatter(route_tobasin_glo,route_tobasin_loc)
4106	CALL scatter(route_nbintobas_glo,route_nbintobas_loc)
4107	CALL scatter(global_basinid_glo,global_basinid_loc)
4108
4109	END SUBROUTINE routing_basins_p
4110	!
4111
4112	!! ================================================================================================================================
4113	!! SUBROUTINE : routing_basins
4114	!!
4115	!>\BRIEF This non-parallelized subroutine reads in the map of basins and flow direction to construct
4116	!! the catchments of each grid box.
4117	!!
4118	!! DESCRIPTION (definitions, functional, design, flags) :
4119	!! The work is done in a number of steps which are performed locally on the
4120	!! GCM grid:
4121	!! 1) First we find the grid-points of the high resolution routing grid which are
4122	!! within the coarser grid of the GCM.
4123	!! 2) When we have these grid points we decompose them into basins in the routine
4124	!! routing_findbasins. A number of simplifications are done if needed.
4125	!! 3) In the routine routing_globalize we put the basin information of this grid
4126	!! into the global fields.
4127	!! Then we work on the global grid to perform the following tasks :
4128	!! 1) We link up the basins of the various grid points and check the global consistency.
4129	!! 2) The area of each outflow point is computed.
4130	!! 3) The final step is to reduce the number of basins in order to fit into the truncation.\n
4131	!!
4132	!! RECENT CHANGE(S): None
4133	!!
4134	!! MAIN OUTPUT VARIABLE(S): None, as the routine puts information into the global variables of the module.
4135	!!
4136	!! REFERENCES : None
4137	!!
4138	!! FLOWCHART : None
4139	!! \n
4140	!_ ================================================================================================================================
4141
4142	SUBROUTINE routing_basins(nbpt, lalo, neighbours, resolution, contfrac)
4143	!
4144	IMPLICIT NONE
4145	!
4146	!! INPUT VARIABLES
4147	INTEGER(i_std), INTENT(in) :: nbpt !! Domain size (unitless)
4148	REAL(r_std), INTENT(in) :: lalo(nbpt,2) !! Vector of latitude and longitudes (beware of the order !)
4149	INTEGER(i_std), INTENT(in) :: neighbours(nbpt,NbNeighb)!! Vector of neighbours for each grid point
4150	!! (1=North and then cloxkwise)
4151	REAL(r_std), INTENT(in) :: resolution(nbpt,2) !! The size of each grid box in X and Y (m)
4152	REAL(r_std), INTENT(in) :: contfrac(nbpt) !! Fraction of land in each grid box (unitless;0-1)
4153	!
4154	!! LOCAL VARIABLES
4155	CHARACTER(LEN=80) :: filename !! Name of the netcdf file (unitless)
4156	INTEGER(i_std) :: iml, jml, lml, tml, fid, ib, ip, jp, fopt !! Indices (unitless)
4157	REAL(r_std) :: lev(1), date, dt, coslat
4158	INTEGER(i_std) :: itau(1) !!
4159	REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: trip !! The trip field (unitless)
4160	REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: basins !! The basin field (unitless)
4161	REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: topoindex !! Topographic index of the residence time (m)
4162	REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: hierarchy !!
4163	REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: lat_rel !!
4164	REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: lon_rel !!
4165	!
4166	INTEGER(i_std) :: nbi, nbj !! Number of point in x and y within the grid (unitless)
4167	REAL(r_std) :: min_topoind !! The current minimum of topographic index (m)
4168	REAL(r_std) :: max_basins !!
4169	REAL(r_std) :: invented_basins !!
4170	!
4171	REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: area_bx !! Area of each small box in the grid box (m^2)
4172	REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: hierarchy_bx !! Level in the basin of the point
4173	REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: lon_bx !!
4174	REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: lat_bx !!
4175	REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: lshead_bx !! Large scale heading of the flow out of the grid box.
4176	REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: topoind_bx !! Topographic index of the residence time for each of the smaller boxes (m)
4177	INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:) :: trip_bx !! The trip field for each of the smaller boxes (unitless)
4178	INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:) :: basin_bx !!
4179	INTEGER(i_std), ALLOCATABLE, DIMENSION(:) :: coast_pts !! The coastal flow points (unitless)
4180	!
4181	INTEGER(i_std), ALLOCATABLE, DIMENSION(:) :: basin_count !!
4182	INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:) :: basin_id !!
4183	REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: basin_area !!
4184	REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: basin_hierarchy !!
4185	REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: basin_topoind !! Topographic index of the residence time for a basin (m)
4186	REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: fetch_basin !!
4187	INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:) :: basin_flowdir !! Water flow directions in the basin (unitless)
4188	REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: basin_lshead !! Large scale heading for basin flowing out of the grid
4189	!! (degrees from North).
4190	INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:) :: outflow_grid !! Type of outflow on the grid box (unitless)
4191	INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:) :: outflow_basin !!
4192	INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:) :: inflow_number !!
4193	INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:,:) :: inflow_basin !!
4194	INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:,:) :: inflow_grid !!
4195	INTEGER(i_std), ALLOCATABLE, DIMENSION(:) :: nbcoastal !!
4196	INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:) :: coastal_basin !!
4197	!
4198	! Interpolation help variables
4199	!
4200	INTEGER(i_std) :: nix, njx !!
4201	CHARACTER(LEN=30) :: callsign !!
4202	REAL(r_std), ALLOCATABLE, DIMENSION(:,:,:) :: resol_lu !! Resolution
4203	INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:) :: mask !! Mask to exclude some points (unitless)
4204	REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: sub_area !! Area on the fine grid (m^2)
4205	INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:,:) :: sub_index !! Indices of the points we need on the fine grid (unitless)
4206	INTEGER(i_std), ALLOCATABLE, DIMENSION(:) :: sub_pts !! Number of high resolution points on this grid (unitless)
4207	INTEGER :: ALLOC_ERR !!
4208	LOGICAL :: ok_interpol = .FALSE. !! Flag for interpolation (true/false)
4209	!
4210	INTEGER(i_std) :: nb_basin !! Number of sub-basins (unitless)
4211	INTEGER(i_std) :: nwbas, ii !!
4212	INTEGER(i_std), ALLOCATABLE, DIMENSION(:) :: basin_inbxid !!
4213	INTEGER(i_std), ALLOCATABLE, DIMENSION(:) :: basin_sz !!
4214	INTEGER(i_std), ALLOCATABLE, DIMENSION(:) :: basin_bxout !!
4215	INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:,:) :: basin_pts !!
4216	REAL(r_std), ALLOCATABLE, DIMENSION(:) :: lshead !! Temporary array for large scale flow out.
4217	CHARACTER(LEN=7) :: fmt !!
4218	LOGICAL :: debug = .FALSE. !! (true/false)
4219	!
4220	REAL(r_std), DIMENSION(1,2) :: diaglalo !! Point (in Lat/Lon) where diagnostics will be printed.
4221	!
4222	!_ ================================================================================================================================
4223	!
4224	! The points on which diagnostics are to be printed in case debug=.TRUE.
4225	! WARNING : The order of the coordinates is Latitude, Longitude !
4226	!
4227	diaglalo(1,:) = (/ -8.875, 14.875 /)
4228	!!$ diaglalo(2,:) = (/ 39.6446, 26.9151 /)
4229	!!$ diaglalo(3,:) = (/ 39.4648, 26.8760 /)
4230	!
4231	IF ( .NOT. is_root_prc) THEN
4232	WRITE(numout,*) "is_root_prc = ", is_root_prc
4233	CALL ipslerr_p (3,'routing_basins', &
4234	& 'routing_basins is not suitable for running in parallel', &
4235	& 'We are here on a non root processor. ','(STOP from routing_basins)')
4236	ENDIF
4237	!
4238	!
4239	! Needs to be a configurable variable
4240	!
4241	!
4242	!Config Key = ROUTING_FILE
4243	!Config Desc = Name of file which contains the routing information
4244	!Config If = RIVER_ROUTING
4245	!Config Def = routing.nc
4246	!Config Help = The file provided here should alow the routing module to
4247	!Config read the high resolution grid of basins and the flow direction
4248	!Config from one mesh to the other.
4249	!Config Units = [FILE]
4250	!
4251	filename = 'routing.nc'
4252	CALL getin('ROUTING_FILE',filename)
4253	!
4254	CALL flininfo(filename,iml, jml, lml, tml, fid)
4255	CALL flinclo(fid)
4256	!
4257	! soils_param.nc file is 1Â° soit texture file.
4258	!
4259	ALLOCATE(lat_rel(iml,jml), STAT=ALLOC_ERR)
4260	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for lat_rel','','')
4261
4262	ALLOCATE(lon_rel(iml,jml), STAT=ALLOC_ERR)
4263	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for lon_rel','','')
4264
4265	ALLOCATE (trip(iml,jml), STAT=ALLOC_ERR)
4266	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for trip','','')
4267
4268	ALLOCATE (basins(iml,jml), STAT=ALLOC_ERR)
4269	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for basins','','')
4270
4271	ALLOCATE (topoindex(iml,jml), STAT=ALLOC_ERR)
4272	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for topoindex','','')
4273
4274	ALLOCATE (hierarchy(iml,jml), STAT=ALLOC_ERR)
4275	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for hierarchy','','')
4276
4277	!
4278	CALL flinopen(filename, .FALSE., iml, jml, lml, lon_rel, lat_rel, lev, tml, itau, date, dt, fid)
4279	!!
4280	!! From the basin description data we will read the following variables :
4281	!!
4282	!! Trip : Provides the flow direction following the convention :
4283	!! trip = 1 : flow = N
4284	!! trip = 2 : flow = NE
4285	!! trip = 3 : flow = E
4286	!! trip = 4 : flow = SE
4287	!! trip = 5 : flow = S
4288	!! trip = 6 : flow = SW
4289	!! trip = 7 : flow = W
4290	!! trip = 8 : flow = NW
4291	!! trip = 97 : return flow into the ground
4292	!! trip = 98 : coastal flow (diffuse flow into the oceans)
4293	!! trip = 99 : river flow into the oceans
4294	!!
4295	!! Basins : Provides a uniqe ID for each basin. These IDs are also used to get
4296	!! the name of the basin from the table in routine routing_names.
4297	!!
4298	!! Topoind : is the topographic index for the retention time of the water in the
4299	!! grid box. It has been computed with the following formula : 1000 x sqrt(d^3/Dz)
4300	!! where d is the distance of the river from the current grid box to the next one
4301	!! as indicated by the variable trip.
4302	!! Dz the hight difference between between the two grid boxes.
4303	!! All these variables are in meters.
4304	!! Furthermore we have to limit the height difference to 5m in order to avoid any unpleasant
4305	!! surprises. If dz < 5m then dz=5.
4306	!!
4307	!
4308	CALL flinget(fid, 'trip', iml, jml, lml, tml, 1, 1, trip)
4309	!
4310	CALL flinget(fid, 'basins', iml, jml, lml, tml, 1, 1, basins)
4311	!
4312	CALL flinget(fid, 'topoind', iml, jml, lml, tml, 1, 1, topoindex)
4313	!
4314	CALL flinclo(fid)
4315	!
4316	min_topoind = MINVAL(topoindex, MASK=topoindex .LT. undef_sechiba-un)
4317	!
4318	DO ip=1,iml
4319	DO jp=1,jml
4320	IF ( trip(ip,jp) < 1.e10 .AND. topoindex(ip,jp) > 1.e10) THEN
4321	WRITE(numout,*) 'trip exists but not topoind :'
4322	WRITE(numout,*) 'ip, jp :', ip, jp
4323	WRITE(numout,*) 'trip, topoind : ', trip(ip,jp), topoindex(ip,jp)
4324	CALL ipslerr_p(3,'routing_basins','trip exists but not topoind','','')
4325	ENDIF
4326	ENDDO
4327	ENDDO
4328
4329	ALLOCATE(resol_lu(iml,jml,2), STAT=ALLOC_ERR)
4330	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for resol_lu','','')
4331
4332	ALLOCATE(mask(iml,jml), STAT=ALLOC_ERR)
4333	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for mask','','')
4334	!
4335	! Consider all points a priori
4336	!
4337	mask(:,:) = 0
4338	!
4339	DO ip=1,iml
4340	DO jp=1,jml
4341	!
4342	! Determine the land mask of the basin map read from the file ROUTING_FILE
4343	!
4344	IF ( trip(ip,jp) < 1.e10 ) THEN
4345	mask(ip,jp) = 1
4346	ENDIF
4347	!
4348	! Resolution in longitude
4349	!
4350	coslat = MAX( COS( lat_rel(ip,jp) * pi/180. ), mincos )
4351	IF ( ip .EQ. 1 ) THEN
4352	resol_lu(ip,jp,1) = ABS( lon_rel(ip+1,jp) - lon_rel(ip,jp) ) * pi/180. * R_Earth * coslat
4353	ELSEIF ( ip .EQ. iml ) THEN
4354	resol_lu(ip,jp,1) = ABS( lon_rel(ip,jp) - lon_rel(ip-1,jp) ) * pi/180. * R_Earth * coslat
4355	ELSE
4356	resol_lu(ip,jp,1) = ABS( lon_rel(ip+1,jp) - lon_rel(ip-1,jp) )/2. * pi/180. * R_Earth * coslat
4357	ENDIF
4358	!
4359	! Resolution in latitude
4360	!
4361	IF ( jp .EQ. 1 ) THEN
4362	resol_lu(ip,jp,2) = ABS( lat_rel(ip,jp) - lat_rel(ip,jp+1) ) * pi/180. * R_Earth
4363	ELSEIF ( jp .EQ. jml ) THEN
4364	resol_lu(ip,jp,2) = ABS( lat_rel(ip,jp-1) - lat_rel(ip,jp) ) * pi/180. * R_Earth
4365	ELSE
4366	resol_lu(ip,jp,2) = ABS( lat_rel(ip,jp-1) - lat_rel(ip,jp+1) )/2. * pi/180. * R_Earth
4367	ENDIF
4368	!
4369	ENDDO
4370	ENDDO
4371	!
4372	! The maximum number of points of the source map (basin description here) which can fit into
4373	! any grid point of the ORCHIDEE grid is stimated here.
4374	! Some margin is taken.
4375	!
4376	callsign = "routing_basins"
4377	ok_interpol = .FALSE.
4378	!
4379	nix=INT(MAXVAL(resolution_g(:,1))/MAXVAL(resol_lu(:,:,1)))+2
4380	njx=INT(MAXVAL(resolution_g(:,2))/MAXVAL(resol_lu(:,:,2)))+2
4381	nbvmax = nixnjx2
4382	!
4383	! We are on the root processor here as this routine is not in parallel. So no need to broadcast.
4384	!
4385	WRITE(numout,*) "Projection arrays for ",callsign," : "
4386	WRITE(numout,*) "Routing : nbvmax = ", nbvmax
4387
4388
4389	ALLOCATE (sub_area(nbpt,nbvmax), STAT=ALLOC_ERR)
4390	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for sub_area','','')
4391	sub_area(:,:)=zero
4392
4393	ALLOCATE (sub_index(nbpt,nbvmax,2), STAT=ALLOC_ERR)
4394	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for sub_index','','')
4395	sub_index(:,:,:)=0
4396
4397	ALLOCATE (sub_pts(nbpt), STAT=ALLOC_ERR)
4398	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for sub_pts','','')
4399	sub_pts(:)=0
4400	!
4401	! routine aggregate will for each point of the ORCHIDEE grid determine which points
4402	! of the source grid (basin definitions here) fit in there and which fraction of
4403	! of the ORCHIDEE grid it represents.
4404	!
4405	CALL aggregate(nbpt, lalo, neighbours, resolution, contfrac, &
4406	& iml, jml, lon_rel, lat_rel, mask, callsign, &
4407	& nbvmax, sub_index, sub_area, ok_interpol)
4408	!
4409	WHERE (sub_area < 0) sub_area=zero
4410	!
4411	! Some verifications
4412	!
4413	DO ib=1,nbpt
4414	sub_pts(ib) = COUNT(sub_area(ib,:) > zero)
4415	DO fopt=1,sub_pts(ib)
4416	IF (sub_area(ib, fopt) == 0 ) THEN
4417	WRITE(numout,*) "Zero Area - Sub_area > 0 : ", ib, fopt
4418	WRITE(numout,*) "Zero Area - lon : ",lalo(ib,2)
4419	WRITE(numout,*) "Zero Area - lon_rel : ", lon_rel(sub_index(ib, fopt, 1),sub_index(ib, fopt, 2))
4420	WRITE(numout,*) "Zero Area - lat : ",lalo(ib,1)
4421	WRITE(numout,*) "Zero Area - lat_rel : ", lat_rel(sub_index(ib, fopt, 1),sub_index(ib, fopt, 2))
4422	ENDIF
4423	ENDDO
4424	ENDDO
4425	!
4426	! Do some memory management.
4427	!
4428	nwbas = MAX(MAXVAL(sub_pts), NbNeighb+1)
4429	nwbas = MAX(nwbas, nbvmax)
4430	WRITE(numout,*) "Routing : nwbas = ", nwbas
4431	!
4432	ALLOCATE (area_bx(nbvmax,nbvmax), stat=ALLOC_ERR)
4433	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for area_bx','','')
4434	ALLOCATE (hierarchy_bx(nbvmax,nbvmax), stat=ALLOC_ERR)
4435	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for hierarchy_bx','','')
4436	ALLOCATE (lon_bx(nbvmax,nbvmax), stat=ALLOC_ERR)
4437	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for lon_bx','','')
4438	ALLOCATE (lat_bx(nbvmax,nbvmax), stat=ALLOC_ERR)
4439	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for lat_bx','','')
4440	ALLOCATE (topoind_bx(nbvmax,nbvmax), stat=ALLOC_ERR)
4441	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for topoind_bx','','')
4442	ALLOCATE (lshead_bx(nbvmax,nbvmax), stat=ALLOC_ERR)
4443	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for lshead_bx','','')
4444	ALLOCATE (trip_bx(nbvmax,nbvmax), stat=ALLOC_ERR)
4445	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for trip_bx','','')
4446	ALLOCATE (basin_bx(nbvmax,nbvmax), stat=ALLOC_ERR)
4447	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for basin_bx','','')
4448	ALLOCATE (coast_pts(nbvmax), stat=ALLOC_ERR)
4449	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for coast_pts','','')
4450	ALLOCATE (basin_inbxid(nbvmax), stat=ALLOC_ERR)
4451	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for basin_inbxid','','')
4452	ALLOCATE (basin_sz(nbvmax), stat=ALLOC_ERR)
4453	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for basin_sz','','')
4454	ALLOCATE (basin_pts(nbvmax,nbvmax,2), stat=ALLOC_ERR)
4455	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for basin_pts','','')
4456	ALLOCATE (lshead(nbvmax), stat=ALLOC_ERR)
4457	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for lshead','','')
4458	ALLOCATE (basin_bxout(nbvmax), stat=ALLOC_ERR)
4459	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for basin_bxout','','')
4460	ALLOCATE (basin_count(nbpt), stat=ALLOC_ERR)
4461	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for basin_count','','')
4462	ALLOCATE (basin_area(nbpt,nwbas), basin_hierarchy(nbpt,nwbas), basin_topoind(nbpt,nwbas), stat=ALLOC_ERR)
4463	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for basin_area','','')
4464	ALLOCATE (fetch_basin(nbpt,nwbas), stat=ALLOC_ERR)
4465	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for fetch_basin','','')
4466	ALLOCATE (basin_id(nbpt,nwbas), basin_flowdir(nbpt,nwbas), stat=ALLOC_ERR)
4467	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for basin_id','','')
4468	ALLOCATE (basin_lshead(nbp_glo,nwbas), stat=ALLOC_ERR)
4469	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for basin_lshead','','')
4470	ALLOCATE (outflow_grid(nbpt,nwbas),outflow_basin(nbpt,nwbas), stat=ALLOC_ERR)
4471	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for outflow_grid','','')
4472	ALLOCATE (inflow_number(nbpt,nwbas), stat=ALLOC_ERR)
4473	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for inflow_number','','')
4474	ALLOCATE (inflow_basin(nbpt,nwbas,nwbas), inflow_grid(nbpt,nwbas,nwbas), stat=ALLOC_ERR)
4475	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for inflow_basin','','')
4476	ALLOCATE (nbcoastal(nbpt), coastal_basin(nbpt,nwbas), stat=ALLOC_ERR)
4477	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for nbcoastal','','')
4478
4479	! Order all sub points in each grid_box and find the sub basins
4480	!
4481	! before we start we set the maps to empty
4482	!
4483	basin_id(:,:) = undef_int
4484	basin_count(:) = 0
4485	hierarchy(:,:) = undef_sechiba
4486	max_basins = MAXVAL(basins, MASK=basins .LT. 1.e10)
4487	invented_basins = max_basins
4488	nbcoastal(:) = 0
4489	outflow_basin(:,:) = undef_int
4490	!
4491	!! Finds,in each grid box, the distance to the outflow point ... this defines the order in which
4492	!! the water will go through the sub-basins and grid boxes.
4493	!
4494	CALL routing_hierarchy(iml, jml, trip, topoindex, hierarchy)
4495	!
4496	!
4497	DO ib =1, nbpt
4498	!
4499	!
4500	! extract the information for this grid box
4501	!
4502	!! Extracts from the global high resolution fields the data for the current grid box.
4503	!
4504	CALL routing_getgrid(nbpt, iml, jml, ib, sub_pts, sub_index, sub_area, max_basins, min_topoind, &
4505	& lon_rel, lat_rel, lalo, resolution, contfrac, trip, basins, topoindex, hierarchy, &
4506	& nbi, nbj, area_bx, trip_bx, basin_bx, topoind_bx, hierarchy_bx, lon_bx, lat_bx, lshead_bx)
4507	!
4508	!! Finds the basins: returns the list of all points which are within the same basin of the grid box.
4509	!
4510	CALL routing_findbasins(nbi, nbj, trip_bx, basin_bx, hierarchy_bx, topoind_bx, lshead_bx, &
4511	& diaglalo, nb_basin, basin_inbxid, basin_sz, basin_bxout, basin_pts, lshead, coast_pts)
4512	!
4513	! Deal with the case where nb_basin=0 for this grid box. In this case all goes into coastal flow.
4514	!
4515	IF ( debug .AND. routing_diagbox_g(ib,diaglalo)) THEN
4516	WRITE(numout,*) '===================== IB = :', ib
4517	WRITE(numout,*) "sub_pts(ib) :", sub_pts(ib), "sub_area(ib,:) :",sub_area(ib,1:2)
4518	WRITE(numout,*) 'LON LAT of GCM :', lalo(ib,2), lalo(ib,1)
4519	DO ii=1,NbNeighb
4520	WRITE(numout,*) 'Neighbor options :', ii, routing_nextgrid_g(ib,ii)
4521	ENDDO
4522	WRITE(numout,*) 'Resolution :', resolution(ib,1:2)
4523	WRITE(fmt,"('(',I3,'I6)')") nbi
4524	WRITE(numout,*) '-------------> trip ', trip_bx(1,1)
4525	DO jp=1,nbj
4526	WRITE(numout,fmt) trip_bx(1:nbi,jp)
4527	ENDDO
4528	WRITE(numout,*) '-------------> lshead '
4529	DO jp=1,nbj
4530	WRITE(numout,fmt) NINT(lshead_bx(1:nbi,jp))
4531	ENDDO
4532	WRITE(numout,*) '-------------> basin ',basin_bx(1,1)
4533	DO jp=1,nbj
4534	WRITE(numout,fmt) basin_bx(1:nbi,jp)
4535	ENDDO
4536	WRITE(numout,*) '-------------> hierarchy ',hierarchy_bx(1,1)
4537	DO jp=1,nbj
4538	WRITE(numout,fmt) INT(hierarchy_bx(1:nbi,jp)/1000.)
4539	ENDDO
4540	WRITE(numout,*) '-------------> topoindex ',topoind_bx(1,1)
4541	DO jp=1,nbj
4542	WRITE(numout,fmt) INT(topoind_bx(1:nbi,jp)/1000.)
4543	ENDDO
4544	!
4545	WRITE(numout,*) '------------> The basins we retain'
4546	DO jp=1,nb_basin
4547	WRITE(numout,*) 'index, size, bxout, coast :', basin_inbxid(jp), basin_sz(jp),&
4548	& basin_bxout(jp), coast_pts(jp)
4549	ENDDO
4550	!
4551	ENDIF
4552	!
4553	!! Puts the basins found for the current grid box in the context of the global map.
4554	!
4555	CALL routing_globalize(nbpt, ib, neighbours, area_bx, trip_bx, hierarchy_bx, topoind_bx, min_topoind,&
4556	& nb_basin, basin_inbxid, basin_sz, basin_pts, basin_bxout, lshead, coast_pts, nwbas, basin_count,&
4557	& basin_area, basin_hierarchy, basin_topoind, basin_id, basin_flowdir, basin_lshead, outflow_grid,&
4558	& nbcoastal, coastal_basin)
4559	!
4560	!
4561	IF ( debug .AND. routing_diagbox_g(ib,diaglalo) ) THEN
4562	WRITE(numout,*) 'GLOBAL information after routing_globalize for grid ', ib
4563	DO jp=1,basin_count(ib)
4564	WRITE(numout,*) 'Basin ID : ', basin_id(ib, jp)
4565	WRITE(numout,*) 'Basin flowdir :', basin_flowdir(ib, jp)
4566	WRITE(numout,*) 'Basin hierarchy :', basin_hierarchy(ib, jp)
4567	WRITE(numout,*) 'Basin topoindex :', basin_topoind(ib, jp)
4568	WRITE(numout,*) 'Basin outflow grid :', outflow_grid(ib,jp)
4569	ENDDO
4570	ENDIF
4571	!
4572	ENDDO
4573	!
4574	!! Makes the connections between the bains and ensures global coherence.
4575	!
4576	CALL routing_linkup(nbpt, neighbours, nwbas, basin_count, basin_area, basin_id, basin_flowdir, &
4577	& basin_lshead, basin_hierarchy, diaglalo, outflow_grid, outflow_basin, inflow_number, inflow_grid, &
4578	& inflow_basin, nbcoastal, coastal_basin, invented_basins)
4579	!
4580	!
4581	WRITE(numout,*) 'The maximum number of basins in any grid :', MAXVAL(basin_count)
4582	!
4583	!! Computes the fetch of each basin, upstream area in known.
4584	!
4585	CALL routing_fetch(nbpt, resolution, contfrac, nwbas, basin_count, basin_area, basin_id, basin_hierarchy, outflow_grid, &
4586	& outflow_basin, fetch_basin)
4587	!
4588	!
4589	WRITE(numout,*) "Start reducing the number of basins per grid to meet the required truncation."
4590	!
4591	!! Reduces the number of basins per grid to the value chosen by the user.
4592	!
4593	CALL routing_truncate(nbpt, resolution, contfrac, nwbas, basin_count, basin_area, basin_topoind,&
4594	& fetch_basin, basin_id, basin_flowdir, outflow_grid, outflow_basin, inflow_number,&
4595	& inflow_grid, inflow_basin)
4596	!
4597	DEALLOCATE (lat_rel)
4598	DEALLOCATE (lon_rel)
4599	!
4600	DEALLOCATE (trip)
4601	DEALLOCATE (basins)
4602	DEALLOCATE (topoindex)
4603	DEALLOCATE (hierarchy)
4604	!
4605	DEALLOCATE (sub_area)
4606	DEALLOCATE (sub_index)
4607	DEALLOCATE (sub_pts)
4608	!
4609	DEALLOCATE (mask)
4610	DEALLOCATE (resol_lu)
4611	!
4612	DEALLOCATE (basin_count)
4613	DEALLOCATE (basin_area, basin_hierarchy, basin_topoind, fetch_basin)
4614	DEALLOCATE (basin_id, basin_flowdir)
4615	DEALLOCATE (outflow_grid,outflow_basin)
4616	DEALLOCATE (inflow_number)
4617	DEALLOCATE (inflow_basin, inflow_grid)
4618	DEALLOCATE (nbcoastal, coastal_basin)
4619
4620	END SUBROUTINE routing_basins
4621
4622
4623	!! ================================================================================================================================
4624	!! SUBROUTINE : routing_getgrid
4625	!!
4626	!>\BRIEF This subroutine extracts from the global high resolution fields
4627	!! the data for the current grid box we are dealing with.
4628	!!
4629	!! DESCRIPTION (definitions, functional, design, flags) :
4630	!! Convention for trip on the input :
4631	!! The trip field follows the following convention for the flow of the water :
4632	!! trip = 1 : flow = N
4633	!! trip = 2 : flow = NE
4634	!! trip = 3 : flow = E
4635	!! trip = 4 : flow = SE
4636	!! trip = 5 : flow = S
4637	!! trip = 6 : flow = SW
4638	!! trip = 7 : flow = W
4639	!! trip = 8 : flow = NW
4640	!! trip = 97 : return flow into the ground
4641	!! trip = 98 : coastal flow (diffuse flow into the oceans) These values are created here
4642	!! trip = 99 : river flow into the oceans
4643	!!
4644	!! On output, the grid boxes of the basin map which flow out of the GCM grid are identified
4645	!! by numbers larger than 100 :
4646	!! trip = 101 : flow = N out of the coarse grid
4647	!! trip = 102 : flow = NE out of the coarse grid
4648	!! trip = 103 : flow = E out of the coarse grid
4649	!! trip = 104 : flow = SE out of the coarse grid
4650	!! trip = 105 : flow = S out of the coarse grid
4651	!! trip = 106 : flow = SW out of the coarse grid
4652	!! trip = 107 : flow = W out of the coarse grid
4653	!! trip = 108 : flow = NW out of the coarse grid
4654	!! Inside the grid the convention remains the same as above (ie between 1 and 99).:\n
4655	!!
4656	!! RECENT CHANGE(S): None
4657	!!
4658	!! MAIN OUTPUT VARIABLE(S):
4659	!!
4660	!! REFERENCES : None
4661	!!
4662	!! FLOWCHART : None
4663	!! \n
4664	!_ ================================================================================================================================
4665
4666	SUBROUTINE routing_getgrid(nbpt, iml, jml, ib, sub_pts, sub_index, sub_area, max_basins, min_topoind, &
4667	& lon_rel, lat_rel, lalo, resolution, contfrac, trip, basins, topoindex, hierarchy, &
4668	& nbi, nbj, area_bx, trip_bx, basin_bx, topoind_bx, hierarchy_bx, lon_bx, lat_bx, lshead_bx)
4669	!
4670	IMPLICIT NONE
4671	!
4672	!! INPUT VARIABLES
4673	INTEGER(i_std), INTENT(in) :: nbpt !! Domain size (unitless)
4674	INTEGER(i_std), INTENT(in) :: iml !! X resolution of the high resolution grid
4675	INTEGER(i_std), INTENT(in) :: jml !! Y resolution of the high resolution grid
4676	INTEGER(i_std), INTENT(in) :: ib !! Current basin (unitless)
4677	INTEGER(i_std), INTENT(in) :: sub_pts(nbpt) !! Number of high resolution points on this grid (unitless)
4678	INTEGER(i_std), INTENT(in) :: sub_index(nbpt,nbvmax,2) !! Indices of the points we need on the fine grid (unitless)
4679	REAL(r_std), INTENT(inout) :: max_basins !! The current maximum of basins
4680	REAL(r_std), INTENT(in) :: min_topoind !! The current minimum of topographic index (m)
4681	REAL(r_std), INTENT(in) :: sub_area(nbpt,nbvmax) !! Area on the fine grid (m^2)
4682	REAL(r_std), INTENT(in) :: lon_rel(iml,jml) !!
4683	REAL(r_std), INTENT(in) :: lat_rel(iml,jml) !! coordinates of the fine grid
4684	REAL(r_std), INTENT(in) :: lalo(nbpt,2) !! Vector of latitude and longitudes (beware of the order !)
4685	REAL(r_std), INTENT(in) :: resolution(nbpt,2) !! The size of each grid box in X and Y (m)
4686	REAL(r_std), INTENT(in) :: contfrac(nbpt) !! Fraction of land in each grid box (unitless;0-1)
4687	REAL(r_std), INTENT(inout) :: trip(iml,jml) !! The trip field (unitless)
4688	REAL(r_std), INTENT(inout) :: basins(iml,jml) !! data on the fine grid
4689	REAL(r_std), INTENT(inout) :: topoindex(iml,jml) !! Topographic index of the residence time (m)
4690	REAL(r_std), INTENT(inout) :: hierarchy(iml, jml) !! data on the fine grid
4691	!
4692	!! OUTPUT VARIABLES
4693	INTEGER(i_std), INTENT(out) :: nbi, nbj !! Number of point in x and y within the grid (unitless)
4694	REAL(r_std), INTENT(out) :: area_bx(nbvmax,nbvmax) !! Area of each small box in the grid box (m^2)
4695	REAL(r_std), INTENT(out) :: hierarchy_bx(nbvmax,nbvmax) !! Level in the basin of the point
4696	REAL(r_std), INTENT(out) :: lon_bx(nbvmax,nbvmax) !!
4697	REAL(r_std), INTENT(out) :: lat_bx(nbvmax,nbvmax) !!
4698	REAL(r_std), INTENT(out) :: topoind_bx(nbvmax,nbvmax) !! Topographic index of the residence time for each of the smaller boxes (m)
4699	INTEGER(i_std), INTENT(out) :: trip_bx(nbvmax,nbvmax) !! The trip field for each of the smaller boxes (unitless)
4700	INTEGER(i_std), INTENT(out) :: basin_bx(nbvmax,nbvmax) !!
4701	REAL(r_std), INTENT(out) :: lshead_bx(nbvmax,nbvmax) !! Large scale heading for outflow points.
4702	!
4703	!! LOCAL VARIABLES
4704	INTEGER(i_std) :: ip, jp, ll(1), iloc, jloc !! Indices (unitless)
4705	INTEGER(i_std) :: ipp, jpp
4706	INTEGER(i_std), DIMENSION(8,2) :: inc
4707	REAL(r_std) :: cenlon, cenlat, dlon, dlat, deslon, deslat, facti, factj
4708	!
4709	REAL(r_std) :: lonstr(nbvmax*nbvmax) !!
4710	REAL(r_std) :: latstr(nbvmax*nbvmax) !!
4711
4712	!_ ================================================================================================================================
4713	!
4714	! The routing code (i=1, j=2)
4715	!
4716	inc(1,1) = 0
4717	inc(1,2) = -1
4718	inc(2,1) = 1
4719	inc(2,2) = -1
4720	inc(3,1) = 1
4721	inc(3,2) = 0
4722	inc(4,1) = 1
4723	inc(4,2) = 1
4724	inc(5,1) = 0
4725	inc(5,2) = 1
4726	inc(6,1) = -1
4727	inc(6,2) = 1
4728	inc(7,1) = -1
4729	inc(7,2) = 0
4730	inc(8,1) = -1
4731	inc(8,2) = -1
4732	!
4733	! Set everything to undef to locate easily empty points
4734	!
4735	trip_bx(:,:) = undef_int
4736	basin_bx(:,:) = undef_int
4737	topoind_bx(:,:) = undef_sechiba
4738	area_bx(:,:) = undef_sechiba
4739	hierarchy_bx(:,:) = undef_sechiba
4740	lon_bx(:,:) = undef_sechiba
4741	lat_bx(:,:) = undef_sechiba
4742	!
4743	IF ( sub_pts(ib) > 0 ) THEN
4744	!
4745	DO ip=1,sub_pts(ib)
4746	IF ( ip >nbvmax*nbvmax ) THEN
4747	CALL ipslerr_p(3,'routing_getgrid','nbvmax too small when filling lonstr',&
4748	& 'Please change method to estimate nbvmax','')
4749	ENDIF
4750	lonstr(ip) = lon_rel(sub_index(ib, ip, 1), sub_index(ib, ip, 2))
4751	latstr(ip) = lat_rel(sub_index(ib, ip, 1), sub_index(ib, ip, 2))
4752	ENDDO
4753	!
4754	! Get the size of the area and order the coordinates to go from North to South and West to East
4755	!
4756	CALL routing_sortcoord(sub_pts(ib), lonstr, 'WE', nbi)
4757	CALL routing_sortcoord(sub_pts(ib), latstr, 'NS', nbj)
4758	!
4759	! Verify dimension and allocated space
4760	!
4761	IF ( nbi > nbvmax .OR. nbj > nbvmax ) THEN
4762	WRITE(numout,*) "size of area : nbi=",nbi,"nbj=",nbj, "nbvmax=", nbvmax
4763	CALL ipslerr_p(3,'routing_getgrid','nbvmax too small','Please change method to estimate nbvmax','')
4764	ENDIF
4765	!
4766	! Transfer the data in such a way that (1,1) is the North Western corner and
4767	! (nbi, nbj) the South Eastern.
4768	!
4769	DO ip=1,sub_pts(ib)
4770	ll = MINLOC(ABS(lonstr(1:nbi) - lon_rel(sub_index(ib, ip, 1), sub_index(ib, ip, 2))))
4771	iloc = ll(1)
4772	ll = MINLOC(ABS(latstr(1:nbj) - lat_rel(sub_index(ib, ip, 1), sub_index(ib, ip, 2))))
4773	jloc = ll(1)
4774	!
4775	trip_bx(iloc, jloc) = NINT(trip(sub_index(ib, ip, 1), sub_index(ib, ip, 2)))
4776	basin_bx(iloc, jloc) = NINT(basins(sub_index(ib, ip, 1), sub_index(ib, ip, 2)))
4777	area_bx(iloc, jloc) = sub_area(ib, ip)
4778	topoind_bx(iloc, jloc) = topoindex(sub_index(ib, ip, 1), sub_index(ib, ip, 2))
4779	hierarchy_bx(iloc, jloc) = hierarchy(sub_index(ib, ip, 1), sub_index(ib, ip, 2))
4780	lon_bx(iloc, jloc) = lon_rel(sub_index(ib, ip, 1), sub_index(ib, ip, 2))
4781	lat_bx(iloc, jloc) = lat_rel(sub_index(ib, ip, 1), sub_index(ib, ip, 2))
4782	ENDDO
4783	ELSE
4784	!
4785	! This is the case where the model invented a continental point
4786	!
4787	nbi = 1
4788	nbj = 1
4789	iloc = 1
4790	jloc = 1
4791	trip_bx(iloc, jloc) = 98
4792	basin_bx(iloc, jloc) = NINT(max_basins + 1)
4793	max_basins = max_basins + 1
4794	area_bx(iloc, jloc) = resolution(ib,1)resolution(ib,2)contfrac(ib)
4795	topoind_bx(iloc, jloc) = min_topoind
4796	hierarchy_bx(iloc, jloc) = min_topoind
4797	lon_bx(iloc, jloc) = lalo(ib,2)
4798	lat_bx(iloc, jloc) = lalo(ib,1)
4799	!
4800	ENDIF
4801	!
4802	! Tag in trip all the outflow conditions. The table is thus :
4803	! trip = 100+n : Outflow into another grid box
4804	! trip = 99 : River outflow into the ocean
4805	! trip = 98 : This will be coastal flow (not organized as a basin)
4806	! trip = 97 : return flow into the soil (local)
4807	!
4808	DO jp=1,nbj
4809	DO ip=1,nbi
4810	!
4811	! Compute the destination of the flow on the high resolution grid (if possible !) to see if it still within the points
4812	! belonging to the grid we are working on.
4813	!
4814	IF ( trip_bx(ip,jp) < 97 ) THEN
4815	!
4816	ipp = ip+inc(trip_bx(ip,jp),1)
4817	jpp = jp+inc(trip_bx(ip,jp),2)
4818	!
4819	! Check if the indices are outside of the box, then we have a border points
4820	!
4821	IF ( ipp < 1 .OR. ipp > nbi .OR. jpp < 1 .OR. jpp > nbj ) THEN
4822	IF (routing_nextgrid_g(ib,trip_bx(ip,jp)) < -1 ) THEN
4823	trip_bx(ip,jp) = 98
4824	ELSE
4825	trip_bx(ip,jp) = trip_bx(ip,jp) + 100
4826	ENDIF
4827	ELSE
4828	!
4829	! It can also be a border point if the neighbour is not defined
4830	!
4831	IF ( basin_bx(ipp,jpp) > undef_int-1 ) THEN
4832	IF (routing_nextgrid_g(ib,trip_bx(ip,jp)) < -1 ) THEN
4833	trip_bx(ip,jp) = 98
4834	ELSE
4835	trip_bx(ip,jp) = trip_bx(ip,jp) + 100
4836	ENDIF
4837	ENDIF
4838	ENDIF
4839	ELSE IF ( trip_bx(ip,jp) > 100 .AND. trip_bx(ip,jp) < 109 ) THEN
4840	WRITE(numout,*) 'WARNING : Point flows our of routing.nc file '
4841	WRITE(numout,*) 'WARNING : Point : basin = ', basin_bx(ip,jp)
4842	WRITE(numout,*) 'WARNING : Point : coord = ', lon_bx(ip, jp), lat_bx(ip, jp)
4843	WRITE(numout,*) 'WARNING : Please consider using a larger domaine for the routing.nc file'
4844	trip_bx(ip,jp) = 98
4845	ENDIF
4846	!
4847	ENDDO
4848	ENDDO
4849	!
4850	! Compute the large scale flow direction for each outflow point (trip_bx > 100). This
4851	! is done by walking into the direction indicated by the small scale trip. The distance of this walk
4852	! will depend how far we are from the corner of the polygon. If we are in
4853	! the middle of a segment we walk less far than when we are on either corner.
4854	!
4855	dlon=ABS(corners_g(ib,NbSegments,1)-corners_g(ib,1,1))
4856	dlat=ABS(corners_g(ib,NbSegments,2)-corners_g(ib,1,2))
4857	DO ip=1,NbSegments-1
4858	dlon = MAX(dlon,ABS(corners_g(ib,ip+1,1)-corners_g(ib,ip,1)))
4859	dlat = MAX(dlat,ABS(corners_g(ib,ip+1,2)-corners_g(ib,ip,2)))
4860	ENDDO
4861	!
4862	DO jp=1,nbj
4863	DO ip=1,nbi
4864	!
4865	IF ( trip_bx(ip,jp) < undef_int ) THEN
4866	lshead_bx(ip,jp) = zero
4867	IF ( trip_bx(ip,jp) > 100 ) THEN
4868	IF ( nbi > 1 ) THEN
4869	facti = REAL(ABS((nbi-1)/2.0-(ip-1)), r_std)/((nbi-1)/2.0)
4870	ELSE
4871	facti = un
4872	ENDIF
4873	deslon = lon_bx(ip,jp) + inc(trip_bx(ip,jp)-100,1)dlon/2.0facti
4874	IF ( nbj > 1 ) THEN
4875	factj = REAL(ABS((nbj-1)/2.0-(jp-1)), r_std)/((nbj-1)/2.0)
4876	ELSE
4877	factj = un
4878	ENDIF
4879	deslat = lat_bx(ip,jp) - inc(trip_bx(ip,jp)-100,2)dlat/2.0factj
4880	lshead_bx(ip,jp) = MOD(haversine_heading(deslon, deslat, cenlon, cenlat)+180.0, 360.0)
4881	ENDIF
4882	ENDIF
4883	ENDDO
4884	ENDDO
4885	!
4886	END SUBROUTINE routing_getgrid
4887	!
4888	!! ================================================================================================================================
4889	!! SUBROUTINE : routing_findbasins
4890	!!
4891	!>\BRIEF This subroutine finds the basins and does some clean up.
4892	!! The aim is to return the list off all points which are within the
4893	!! same basin of the grid box.
4894	!!
4895	!! DESCRIPTION (definitions, functional, design, flags) :
4896	!! We will also collect all points which directly flow into the ocean in one basin
4897	!! Make sure that we do not have a basin with two outflows and other exceptions.
4898	!! At this stage no effort is made to come down to the truncation of the model.
4899	!!
4900	!! Convention for trip \n
4901	!! ------------------- \n
4902	!! Inside of the box : \n
4903	!! trip = 1 : flow = N \n
4904	!! trip = 2 : flow = NE \n
4905	!! trip = 3 : flow = E \n
4906	!! trip = 4 : flow = SE \n
4907	!! trip = 5 : flow = S \n
4908	!! trip = 6 : flow = SW \n
4909	!! trip = 7 : flow = W \n
4910	!! trip = 8 : flow = NW \n
4911	!! trip = 97 : return flow into the ground \n
4912	!! trip = 98 : coastal flow (diffuse flow into the oceans) These values are created here \n
4913	!! trip = 99 : river flow into the oceans \n
4914	!!
4915	!! Out flow from the grid : \n
4916	!! trip = 101 : flow = N out of the coarse grid \n
4917	!! trip = 102 : flow = NE out of the coarse grid \n
4918	!! trip = 103 : flow = E out of the coarse grid \n
4919	!! trip = 104 : flow = SE out of the coarse grid \n
4920	!! trip = 105 : flow = S out of the coarse grid \n
4921	!! trip = 106 : flow = SW out of the coarse grid \n
4922	!! trip = 107 : flow = W out of the coarse grid \n
4923	!! trip = 108 : flow = NW out of the coarse grid! \n
4924	!! RECENT CHANGE(S): None
4925	!!
4926	!! MAIN OUTPUT VARIABLE(S):
4927	!!
4928	!! REFERENCES : None
4929	!!
4930	!! FLOWCHART : None
4931	!! \n
4932	!_ ================================================================================================================================
4933
4934	SUBROUTINE routing_findbasins(nbi, nbj, trip, basin, hierarchy, topoind, lshead, diaglalo, &
4935	& nb_basin, basin_inbxid, basin_sz, basin_bxout, basin_pts, basin_lshead, coast_pts)
4936	!
4937	IMPLICIT NONE
4938	!
4939	!! INPUT VARIABLES
4940	INTEGER(i_std), INTENT(in) :: nbi !! Number of point in x within the grid (unitless)
4941	INTEGER(i_std), INTENT(in) :: nbj !! Number of point in y within the grid (unitless)
4942	REAL(r_std), INTENT(in) :: hierarchy(:,:) !!
4943	REAL(r_std), INTENT(in) :: topoind(:,:) !! Topographic index of the residence time (m)
4944	REAL(r_std), INTENT(in) :: lshead(:,:) !!
4945	REAL(r_std), DIMENSION(:,:), INTENT(in) :: diaglalo !! Point (in Lat/Lon) where diagnostics will be printed.
4946	!
4947	! Modified
4948	INTEGER(i_std), INTENT(inout) :: trip(:,:) !! The trip field (unitless)
4949	INTEGER(i_std), INTENT(inout) :: basin(:,:) !!
4950	!
4951	!! OUTPUT VARIABLES
4952	INTEGER(i_std), INTENT(out) :: nb_basin !! Number of sub-basins (unitless)
4953	INTEGER(i_std), INTENT(out) :: basin_inbxid(nbvmax) !!
4954	INTEGER(i_std), INTENT(out) :: basin_sz(nbvmax) !!
4955	INTEGER(i_std), INTENT(out) :: basin_bxout(nbvmax) !!
4956	INTEGER(i_std), INTENT(out) :: basin_pts(nbvmax, nbvmax, 2) !!
4957	REAL(r_std), INTENT(out) :: basin_lshead(nbvmax) !!
4958	INTEGER(i_std), INTENT(out) :: coast_pts(nbvmax) !! The coastal flow points (unitless)
4959	!
4960	!! LOCAL VARIABLES
4961	INTEGER(i_std) :: ibas, ilf, nbb, nb_in !!
4962	INTEGER(i_std) :: bname(nbvmax) !!
4963	INTEGER(i_std) :: sz(nbvmax) !!
4964	INTEGER(i_std) :: pts(nbvmax,nbvmax,2) !!
4965	INTEGER(i_std) :: nbout(nbvmax) !!
4966	INTEGER(i_std) :: new_nb !!
4967	INTEGER(i_std) :: new_bname(nbvmax) !!
4968	INTEGER(i_std) :: new_sz(nbvmax) !!
4969	INTEGER(i_std) :: new_pts(nbvmax,nbvmax,2) !!
4970	INTEGER(i_std) :: itrans !!
4971	INTEGER(i_std) :: trans(nbvmax) !!
4972	INTEGER(i_std) :: outdir(nbvmax) !!
4973	REAL(r_std) :: tmphead(nbvmax) !!
4974	INTEGER(i_std) :: tmpsz(nbvmax) !!
4975	INTEGER(i_std) :: ip, jp, jpp(1), ipb !!
4976	INTEGER(i_std) :: sortind(nbvmax) !!
4977	CHARACTER(LEN=7) :: fmt !!
4978
4979	!_ ================================================================================================================================
4980	!
4981	nbb = 0
4982	ibas = -1
4983	bname(:) = undef_int
4984	sz(:) = 0
4985	nbout(:) = 0
4986	new_pts(:,:,:) = 0
4987	!
4988	! 1.0 Find all basins within this grid box
4989	! Sort the variables per basin so that we can more easily
4990	! access data from the same basin (The variables are :
4991	! bname, sz, pts, nbout)
4992	!
4993	DO ip=1,nbi
4994	DO jp=1,nbj
4995	IF ( basin(ip,jp) .LT. undef_int) THEN
4996	IF ( COUNT(basin(ip,jp) .EQ. bname(:)) .EQ. 0 ) THEN
4997	nbb = nbb + 1
4998	IF ( nbb .GT. nbvmax ) CALL ipslerr_p(3,'routing_findbasins','nbvmax too small','first section','')
4999	bname(nbb) = basin(ip,jp)
5000	sz(nbb) = 0
5001	ENDIF
5002	!
5003	DO ilf=1,nbb
5004	IF ( basin(ip,jp) .EQ. bname(ilf) ) THEN
5005	ibas = ilf
5006	ENDIF
5007	ENDDO
5008	!
5009	sz(ibas) = sz(ibas) + 1
5010	IF ( sz(ibas) .GT. nbvmax ) CALL ipslerr_p(3,'routing_findbasins','nbvmax too small','second section','')
5011	pts(ibas, sz(ibas), 1) = ip
5012	pts(ibas, sz(ibas), 2) = jp
5013	! We deal only with outflow and leave flow back into the grid box for later.
5014	IF ( trip(ip,jp) .GE. 97 ) THEN
5015	nbout(ibas) = nbout(ibas) + 1
5016	ENDIF
5017	!
5018	ENDIF
5019	!
5020	ENDDO
5021	ENDDO
5022	!
5023	! 2.0 All basins which have size 1 and flow to the ocean are put together.
5024	!
5025	itrans = 0
5026	coast_pts(:) = undef_int
5027	! Get all the points we can collect
5028	DO ip=1,nbb
5029	IF ( sz(ip) .EQ. 1 .AND. trip(pts(ip,1,1),pts(ip,1,2)) .EQ. 99) THEN
5030	itrans = itrans + 1
5031	trans(itrans) = ip
5032	trip(pts(ip,1,1),pts(ip,1,2)) = 98
5033	ENDIF
5034	ENDDO
5035	! put everything in the first basin
5036	IF ( itrans .GT. 1) THEN
5037	ipb = trans(1)
5038	coast_pts(sz(ipb)) = bname(ipb)
5039	bname(ipb) = -1
5040	DO ip=2,itrans
5041	sz(ipb) = sz(ipb) + 1
5042	coast_pts(sz(ipb)) = bname(trans(ip))
5043	sz(trans(ip)) = 0
5044	pts(ipb, sz(ipb), 1) = pts(trans(ip), 1, 1)
5045	pts(ipb, sz(ipb), 2) = pts(trans(ip), 1, 2)
5046	ENDDO
5047	ENDIF
5048	!
5049	! 3.0 Make sure that we have only one outflow point in each basin
5050	!
5051	! nbb is the number of basins on this grid box.
5052	new_nb = 0
5053	DO ip=1,nbb
5054	! We only do this for grid-points which have more than one outflow
5055	IF ( sz(ip) .GT. 1 .AND. nbout(ip) .GT. 1) THEN
5056	!
5057	! Pick up all points needed and store them in trans
5058	!
5059	itrans = 0
5060	DO jp=1,sz(ip)
5061	IF ( trip(pts(ip,jp,1),pts(ip,jp,2)) .GE. 97) THEN
5062	itrans = itrans + 1
5063	trans(itrans) = trip(pts(ip,jp,1),pts(ip,jp,2))
5064	ENDIF
5065	ENDDO
5066	!
5067	! First issue : We have more than one point of the basin which flows into
5068	! the ocean. In this case we put everything into coastal flow. It will go into
5069	! a separate basin in the routing_globalize routine.
5070	!
5071	IF ( (COUNT(trans(1:itrans) .EQ. 99) + COUNT(trans(1:itrans) .EQ. 98)) .GT. 1) THEN
5072	DO jp=1,sz(ip)
5073	IF ( trip(pts(ip,jp,1),pts(ip,jp,2)) .EQ. 99 ) THEN
5074	trip(pts(ip,jp,1),pts(ip,jp,2)) = 98
5075	trans(itrans) = trip(pts(ip,jp,1),pts(ip,jp,2))
5076	ENDIF
5077	ENDDO
5078	ENDIF
5079	!
5080	! Second issue : We have redundant outflows at the boundaries. That is two small grid
5081	! boxes flowing into the same GCM grid box.
5082	!
5083	IF ( COUNT(trans(1:itrans) .GT. 100) .GE. 1) THEN
5084	CALL routing_simplify(nbi, nbj, trip, basin, hierarchy, bname(ip))
5085	itrans = 0
5086	DO jp=1,sz(ip)
5087	IF ( trip(pts(ip,jp,1),pts(ip,jp,2)) .GE. 9) THEN
5088	itrans = itrans + 1
5089	trans(itrans) = trip(pts(ip,jp,1),pts(ip,jp,2))
5090	ENDIF
5091	ENDDO
5092	ENDIF
5093	!
5094	! Third issue : we have more than one outflow from the boxes. This could be
5095	! - flow into 2 or more neighboring GCM grids
5096	! - flow into a neighboring GCM grids and into the ocean or be a return flow (=97. =98, =99)
5097	! - flow into a neighboring GCM grids or ocean and back into the same GCM grid box
5098	! The only solution is to cut the basin up in as many parts.
5099	!
5100	IF ( COUNT(trans(1:itrans) .GE. 97) .GT. 1) THEN
5101	!
5102	nb_in = new_nb
5103	CALL routing_cutbasin(nbi, nbj, nbb, trip, basin, bname(ip), new_nb, new_bname, new_sz, new_pts)
5104	!
5105	! If we have split the basin then we need to cancel the old one
5106	!
5107	IF ( nb_in .NE. new_nb) THEN
5108	sz(ip) = 0
5109	ENDIF
5110	!
5111	ENDIF
5112	!
5113	ENDIF
5114	ENDDO
5115	!
5116	! Add the new basins to the end of the list
5117	!
5118	If ( nbb+new_nb .LE. nbvmax) THEN
5119	DO ip=1,new_nb
5120	bname(nbb+ip) = new_bname(ip)
5121	sz(nbb+ip) = new_sz(ip)
5122	pts(nbb+ip,:,:) = new_pts(ip,:,:)
5123	ENDDO
5124	nbb = nbb+new_nb
5125	ELSE
5126	WRITE(numout,*) 'Increase nbvmax. It is too small to contain all the basins (routing_findbasins)'
5127	CALL ipslerr_p(3,'routing_findbasins','Increase nbvmax.','It is too small to contain all the basins','')
5128	ENDIF
5129	!
5130	! Keep the output direction
5131	!
5132	tmphead(:) = undef_sechiba
5133	!
5134	DO ip=1,nbb
5135	IF ( sz(ip) .GT. 0 ) THEN
5136	trans(:) = 0
5137	DO jp=1,sz(ip)
5138	trans(jp) = trip(pts(ip,jp,1),pts(ip,jp,2))
5139	IF ( trans(jp) .GE. 97 ) THEN
5140	tmphead(ip) = lshead(pts(ip,jp,1),pts(ip,jp,2))
5141	ENDIF
5142	ENDDO
5143	outdir(ip) = MAXVAL(trans(1:sz(ip)))
5144	IF ( outdir(ip) .GE. 97 ) THEN
5145	outdir(ip) = outdir(ip) - 100
5146	ELSE
5147	WRITE(numout,*) 'Why are we here and can not find a trip larger than 96'
5148	WRITE(numout,*) 'Does this mean that the basin does not have any outflow ', ip, bname(ip)
5149	WRITE(fmt,"('(',I3,'I9)')") nbi
5150	WRITE(numout,*) '-----------------------> trip'
5151	DO jp=1,nbj
5152	WRITE(numout,fmt) trip(1:nbi,jp)
5153	ENDDO
5154	WRITE(numout,*) '-----------------------> basin'
5155	DO jp=1,nbj
5156	WRITE(numout,fmt) basin(1:nbi,jp)
5157	ENDDO
5158	CALL ipslerr_p(3,'routing_findbasins','Probleme finding trip','','')
5159	ENDIF
5160	ENDIF
5161	ENDDO
5162	!
5163	!
5164	! Sort the output by size of the various basins.
5165	!
5166	nb_basin = COUNT(sz(1:nbb) .GT. 0)
5167	tmpsz(:) = -1
5168	tmpsz(1:nbb) = sz(1:nbb)
5169	DO ip=1,nbb
5170	jpp = MAXLOC(tmpsz(:))
5171	IF ( sz(jpp(1)) .GT. 0) THEN
5172	sortind(ip) = jpp(1)
5173	tmpsz(jpp(1)) = -1
5174	ENDIF
5175	ENDDO
5176	basin_inbxid(1:nb_basin) = bname(sortind(1:nb_basin))
5177	basin_sz(1:nb_basin) = sz(sortind(1:nb_basin))
5178	basin_pts(1:nb_basin,:,:) = pts(sortind(1:nb_basin),:,:)
5179	basin_bxout(1:nb_basin) = outdir(sortind(1:nb_basin))
5180	basin_lshead(1:nb_basin) = tmphead(sortind(1:nb_basin))
5181	!
5182	! We can only check if we have at least as many outflows as basins
5183	!
5184	ip = COUNT(trip(1:nbi,1:nbj) .GE. 97 .AND. trip(1:nbi,1:nbj) .LT. undef_int)
5185	!! ip = ip + COUNT(trip(1:nbi,1:nbj) .EQ. 97)
5186	!! IF ( COUNT(trip(1:nbi,1:nbj) .EQ. 98) .GT. 0) ip = ip + 1
5187	IF ( ip .LT. nb_basin ) THEN
5188	WRITE(numout,*) 'We have less outflow points than basins :', ip
5189	WRITE(fmt,"('(',I3,'I9)')") nbi
5190	WRITE(numout,*) '-----------------------> trip'
5191	DO jp=1,nbj
5192	WRITE(numout,fmt) trip(1:nbi,jp)
5193	ENDDO
5194	WRITE(numout,*) '-----------------------> basin'
5195	DO jp=1,nbj
5196	WRITE(numout,fmt) basin(1:nbi,jp)
5197	ENDDO
5198	WRITE(numout,*) 'nb_basin :', nb_basin
5199	WRITE(numout,*) 'Basin sized :', basin_sz(1:nb_basin)
5200	CALL ipslerr_p(3,'routing_findbasins','Probleme less outflow points than basins','','')
5201	ENDIF
5202
5203	END SUBROUTINE routing_findbasins
5204	!
5205	!! ================================================================================================================================
5206	!! SUBROUTINE : routing_simplify
5207	!!
5208	!>\BRIEF This subroutine symplifies the routing out of each basin by taking
5209	!! out redundancies at the borders of the GCM box.
5210	!! The aim is to have only one outflow point per basin and grid box.
5211	!! But here we will not change the direction of the outflow.
5212	!!
5213	!! DESCRIPTION (definitions, functional, design, flags) : None
5214	!!
5215	!! RECENT CHANGE(S): None
5216	!!
5217	!! MAIN OUTPUT VARIABLE(S):
5218	!!
5219	!! REFERENCES : None
5220	!!
5221	!! FLOWCHART : None
5222	!! \n
5223	!_ ================================================================================================================================
5224
5225	SUBROUTINE routing_simplify(nbi, nbj, trip, basin, hierarchy, basin_inbxid)
5226	!
5227	IMPLICIT NONE
5228	!
5229	!! LOCAL VARIABLES
5230	INTEGER(i_std) :: nbi !! Number of point in x within the grid (unitless)
5231	INTEGER(i_std) :: nbj !! Number of point in y within the grid (unitless)
5232	INTEGER(i_std) :: trip(:,:) !! The trip field (unitless)
5233	INTEGER(i_std) :: basin(:,:) !!
5234	REAL(r_std) :: hierarchy(:,:) !!
5235	INTEGER(i_std) :: basin_inbxid !!
5236	!
5237	INTEGER(i_std) :: ip, jp, nbout, basin_sz, iborder !!
5238	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)
5239	INTEGER(i_std), DIMENSION(nbvmax,nbvmax,2) :: trip_flow !!
5240	INTEGER(i_std), DIMENSION(nbvmax,2) :: outflow !!
5241	INTEGER(i_std), DIMENSION(nbvmax) :: outsz !!
5242	CHARACTER(LEN=7) :: fmt !!
5243	!
5244	INTEGER(i_std), DIMENSION(8,2) :: inc !!
5245	INTEGER(i_std) :: itodo, ill(1), icc, ismall, ibas, iip, jjp, ib, id !! Indices (unitless)
5246	INTEGER(i_std), DIMENSION(nbvmax) :: todopt !!
5247	!!$, todosz
5248	REAL(r_std), DIMENSION(nbvmax) :: todohi !!
5249	LOGICAL :: not_found, debug = .FALSE. !! (true/false)
5250
5251	!_ ================================================================================================================================
5252	!
5253	!
5254	! The routing code (i=1, j=2)
5255	!
5256	inc(1,1) = 0
5257	inc(1,2) = -1
5258	inc(2,1) = 1
5259	inc(2,2) = -1
5260	inc(3,1) = 1
5261	inc(3,2) = 0
5262	inc(4,1) = 1
5263	inc(4,2) = 1
5264	inc(5,1) = 0
5265	inc(5,2) = 1
5266	inc(6,1) = -1
5267	inc(6,2) = 1
5268	inc(7,1) = -1
5269	inc(7,2) = 0
5270	inc(8,1) = -1
5271	inc(8,2) = -1
5272	!
5273	!
5274	! Symplify the outflow conditions first. We are only interested in the
5275	! outflows which go to different GCM grid boxes.
5276	!
5277	IF ( debug ) THEN
5278	WRITE(numout,*) '+++++++++++++++++++ BEFORE ANYTHING ++++++++++++++++++++'
5279	WRITE(fmt,"('(',I3,'I6)')") nbi
5280	DO jp=1,nbj
5281	WRITE(numout,fmt) trip_tmp(1:nbi,jp)
5282	ENDDO
5283	ENDIF
5284	!
5285	! transfer the trips into an array which only contains the basin we are interested in
5286	!
5287	trip_tmp(:,:) = -1
5288	basin_sz = 0
5289	DO ip=1,nbi
5290	DO jp=1,nbj
5291	IF ( basin(ip,jp) .EQ. basin_inbxid) THEN
5292	trip_tmp(ip,jp) = trip(ip,jp)
5293	basin_sz = basin_sz + 1
5294	ENDIF
5295	ENDDO
5296	ENDDO
5297	!
5298	! Determine for each point where it flows to
5299	!
5300	CALL routing_findrout(nbi, nbj, trip_tmp, basin_sz, basin_inbxid, nbout, outflow, trip_flow, outsz)
5301	!
5302	!
5303	!
5304	!
5305	! Over the width of a GCM grid box we can have many outflows but we are interested
5306	! in only one for each basin. Thus we wish to collect them all to form only one outflow
5307	! to the neighboring grid box.
5308	!
5309	DO iborder = 101,107,2
5310	!
5311	! If we have more than one of these outflows then we need to merge the sub-basins
5312	!
5313	icc = COUNT(trip_tmp .EQ. iborder)-1
5314	DO WHILE ( icc .GT. 0)
5315	! Pick out all the points we will have to do
5316	itodo = 0
5317	DO ip=1,nbout
5318	IF (trip_tmp(outflow(ip,1),outflow(ip,2)) .EQ. iborder) THEN
5319	itodo = itodo + 1
5320	todopt(itodo) = ip
5321	!!$ todosz(itodo) = outsz(ip)
5322	! We take the hierarchy of the outflow point as we will try to
5323	! minimize if for the outflow of the entire basin.
5324	todohi(itodo) = hierarchy(outflow(ip,1),outflow(ip,2))
5325	ENDIF
5326	ENDDO
5327	!
5328	! We change the direction of the smallest basin.
5329	!
5330	ill=MAXLOC(todohi(1:itodo))
5331	ismall = todopt(ill(1))
5332	!
5333	DO ip=1,nbi
5334	DO jp=1,nbj
5335	IF ( trip_flow(ip,jp,1) .EQ. outflow(ismall,1) .AND.&
5336	& trip_flow(ip,jp,2) .EQ. outflow(ismall,2) ) THEN
5337	! Now that we have found a point of the smallest sub-basin we
5338	! look around for another sub-basin
5339	ib = 1
5340	not_found = .TRUE.
5341	DO WHILE ( not_found .AND. ib .LE. itodo )
5342	IF ( ib .NE. ill(1) ) THEN
5343	ibas = todopt(ib)
5344	DO id=1,8
5345	iip = ip + inc(id,1)
5346	jjp = jp + inc(id,2)
5347	! Can we look at this points or is there any need to ?
5348	IF ( iip .GE. 1 .AND. iip .LE. nbi .AND. &
5349	& jjp .GE. 1 .AND. jjp .LE. nbj .AND. not_found) THEN
5350	! Is this point the one we look for ?
5351	IF ( trip_flow(iip,jjp,1) .EQ. outflow(ibas,1) .AND. &
5352	& trip_flow(iip,jjp,2) .EQ. outflow(ibas,2)) THEN
5353	trip_flow(ip,jp,1) = outflow(ibas,1)
5354	trip_flow(ip,jp,2) = outflow(ibas,2)
5355	trip_tmp(ip,jp) = id
5356	! This last line ensures that we do not come back to this point
5357	! and that in the end the outer while will stop
5358	not_found = .FALSE.
5359	ENDIF
5360	ENDIF
5361	ENDDO
5362	ENDIF
5363	ib = ib + 1
5364	ENDDO
5365	ENDIF
5366	ENDDO
5367	ENDDO
5368	!
5369	icc = icc - 1
5370	ENDDO
5371	!
5372	!
5373	ENDDO
5374	!
5375	IF ( debug ) THEN
5376	WRITE(numout,*) '+++++++++++++++++++ AFTER +++++++++++++++++++++++++++++'
5377	WRITE(fmt,"('(',I3,'I6)')") nbi
5378	DO jp=1,nbj
5379	WRITE(numout,fmt) trip_tmp(1:nbi,jp)
5380	ENDDO
5381	ENDIF
5382	!
5383	! Put trip_tmp back into trip
5384	!
5385	DO ip=1,nbi
5386	DO jp=1,nbj
5387	IF ( trip_tmp(ip,jp) .GT. 0) THEN
5388	trip(ip,jp) = trip_tmp(ip,jp)
5389	ENDIF
5390	ENDDO
5391	ENDDO
5392	!
5393	END SUBROUTINE routing_simplify
5394	!
5395	!! ================================================================================================================================
5396	!! SUBROUTINE : routing_cutbasin
5397	!!
5398	!>\BRIEF This subroutine cuts the original basin which has more than one outflow
5399	!! into as many subbasins as outflow directions.
5400	!!
5401	!! DESCRIPTION (definitions, functional, design, flags) : None
5402	!!
5403	!! RECENT CHANGE(S): None
5404	!!
5405	!! MAIN OUTPUT VARIABLE(S):
5406	!!
5407	!! REFERENCES : None
5408	!!
5409	!! FLOWCHART : None
5410	!! \n
5411	!_ ================================================================================================================================
5412
5413	SUBROUTINE routing_cutbasin (nbi, nbj, nbbasins, trip, basin, basin_inbxid, nb, bname, sz, pts)
5414	!
5415	IMPLICIT NONE
5416	!
5417	!! INPUT VARIABLES
5418	INTEGER(i_std), INTENT(in) :: nbi, nbj !! Number of point in x and y within the grid (unitless)
5419	INTEGER(i_std), INTENT(in) :: nbbasins !!
5420	INTEGER(i_std), INTENT(in) :: basin_inbxid !!
5421	!
5422	! Modified
5423	INTEGER(i_std), INTENT(inout) :: trip(:,:) !! The trip field (unitless)
5424	INTEGER(i_std), INTENT(inout) :: basin(:,:) !!
5425	!
5426	!! OUTPUT VARIABLES
5427	INTEGER(i_std), INTENT(out) :: nb !!
5428	INTEGER(i_std), INTENT(out) :: bname(nbvmax) !!
5429	INTEGER(i_std), INTENT(out) :: sz(nbvmax) !!
5430	INTEGER(i_std), INTENT(out) :: pts(nbvmax,nbvmax,2) !!
5431	!
5432	!! LOCAL VARIABLES
5433	INTEGER(i_std) :: ip, jp, iip, jjp, ib, ibb, id, nbout !! Indices (unitless)
5434	INTEGER(i_std) :: basin_sz !!
5435	INTEGER(i_std) :: nb_in !!
5436	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)
5437	INTEGER(i_std), DIMENSION(nbvmax,nbvmax,2) :: trip_flow !!
5438	INTEGER(i_std), DIMENSION(nbvmax,2) :: outflow !!
5439	INTEGER(i_std), DIMENSION(nbvmax) :: outsz !!
5440	CHARACTER(LEN=7) :: fmt !!
5441	LOGICAL :: not_found !! (true/false)
5442	LOGICAL :: debug=.FALSE. !! (true/false)
5443	!
5444	INTEGER(i_std), DIMENSION(8,2) :: inc !!
5445
5446	!_ ================================================================================================================================
5447	!
5448	!
5449	! The routing code (i=1, j=2)
5450	!
5451	inc(1,1) = 0
5452	inc(1,2) = -1
5453	inc(2,1) = 1
5454	inc(2,2) = -1
5455	inc(3,1) = 1
5456	inc(3,2) = 0
5457	inc(4,1) = 1
5458	inc(4,2) = 1
5459	inc(5,1) = 0
5460	inc(5,2) = 1
5461	inc(6,1) = -1
5462	inc(6,2) = 1
5463	inc(7,1) = -1
5464	inc(7,2) = 0
5465	inc(8,1) = -1
5466	inc(8,2) = -1
5467	!
5468	! Set up a temporary trip field which only contains the values
5469	! for the basin on which we currently work.
5470	!
5471	trip_tmp(:,:) = -1
5472	basin_sz = 0
5473	DO ip=1,nbi
5474	DO jp=1,nbj
5475	IF ( basin(ip,jp) .EQ. basin_inbxid) THEN
5476	trip_tmp(ip,jp) = trip(ip,jp)
5477	basin_sz = basin_sz + 1
5478	ENDIF
5479	ENDDO
5480	ENDDO
5481	!
5482	CALL routing_findrout(nbi, nbj, trip_tmp, basin_sz, basin_inbxid, nbout, outflow, trip_flow, outsz)
5483	!
5484	! IF ( debug ) THEN
5485	! DO ib = nb_in+1,nb
5486	! DO ip=1,sz(ib)
5487	! trip_tmp(pts(ib, ip, 1),pts(ib, ip, 2)) = ib*(-1)-900
5488	! ENDDO
5489	! ENDDO
5490	! WRITE(fmt,"('(',I3,'I6)')") nbi
5491	! WRITE(numout,*) 'BEFORE ------------> New basins '
5492	! WRITE(numout,*) nb, ' sz :', sz(1:nb)
5493	! DO jp=1,nbj
5494	! WRITE(numout,fmt) trip_tmp(1:nbi,jp)
5495	! ENDDO
5496	! ENDIF
5497	!
5498	! Take out the small sub-basins. That is those which have only one grid box
5499	! This is only done if we need to save space in the number of basins. Else we
5500	! can take it easy and keep diverging sub-basins for the moment.
5501	!
5502	IF ( nbbasins .GE. nbasmax ) THEN
5503	DO ib=1,nbout
5504	! If the sub-basin is of size one and its larger neighbor is flowing into another
5505	! direction then we put them together.
5506	IF ( outsz(ib) .EQ. 1 .AND. trip(outflow(ib,1), outflow(ib,2)) .GT. 99 ) THEN
5507	!
5508	not_found = .TRUE.
5509	DO id=1,8
5510	ip = outflow(ib,1)
5511	jp = outflow(ib,2)
5512	iip = ip + inc(id,1)
5513	jjp = jp + inc(id,2)
5514	! Can we look at this points ?
5515	IF ( iip .GE. 1 .AND. iip .LE. nbi .AND. &
5516	& jjp .GE. 1 .AND. jjp .LE. nbj .AND. not_found) THEN
5517	! Did we find a direct neighbor which is an outflow point ?
5518	IF ( trip_tmp(iip,jjp) .GT. 100 ) THEN
5519	! IF so direct the flow towards it and update the tables.
5520	not_found = .FALSE.
5521	trip(ip,jp) = id
5522	trip_tmp(ip,jp) = id
5523	outsz(ib) = 0
5524	! update the table of this basin
5525	DO ibb=1,nbout
5526	IF ( iip .EQ. outflow(ibb,1) .AND. jjp .EQ. outflow(ibb,2) ) THEN
5527	outsz(ibb) = outsz(ibb)+1
5528	trip_flow(ip,jp,1) = outflow(ibb,1)
5529	trip_flow(ip,jp,2) = outflow(ibb,2)
5530	ENDIF
5531	ENDDO
5532	ENDIF
5533	ENDIF
5534	ENDDO
5535	ENDIF
5536	ENDDO
5537	ENDIF
5538	!
5539	!
5540	! Cut the basin if we have more than 1 left.
5541	!
5542	!
5543	IF ( COUNT(outsz(1:nbout) .GT. 0) .GT. 1 ) THEN
5544	!
5545	nb_in = nb
5546	!
5547	DO ib = 1,nbout
5548	IF ( outsz(ib) .GT. 0) THEN
5549	nb = nb+1
5550	IF ( nb .GT. nbvmax) THEN
5551	WRITE(numout,*) 'nbvmax too small, increase it (routing_cutbasin)'
5552	ENDIF
5553	bname(nb) = basin_inbxid
5554	sz(nb) = 0
5555	DO ip=1,nbi
5556	DO jp=1,nbj
5557	IF ( (trip_flow(ip,jp,1) + trip_flow(ip,jp,1)) .GT. 0 .AND. &
5558	& trip_flow(ip,jp,1) .EQ. outflow(ib,1) .AND. &
5559	& trip_flow(ip,jp,2) .EQ. outflow(ib,2) ) THEN
5560	sz(nb) = sz(nb) + 1
5561	pts(nb, sz(nb), 1) = ip
5562	pts(nb, sz(nb), 2) = jp
5563	ENDIF
5564	ENDDO
5565	ENDDO
5566	ENDIF
5567	ENDDO
5568	! A short verification
5569	IF ( SUM(sz(nb_in+1:nb)) .NE. basin_sz) THEN
5570	WRITE(numout,*) 'Lost some points while spliting the basin'
5571	WRITE(numout,*) 'nbout :', nbout
5572	DO ib = nb_in+1,nb
5573	WRITE(numout,*) 'ib, SZ :', ib, sz(ib)
5574	ENDDO
5575	WRITE(fmt,"('(',I3,'I6)')") nbi
5576	WRITE(numout,*) '-------------> trip '
5577	DO jp=1,nbj
5578	WRITE(numout,fmt) trip_tmp(1:nbi,jp)
5579	ENDDO
5580	CALL ipslerr_p(3,'routing_cutbasin','Lost some points while spliting the basin','','')
5581	ENDIF
5582
5583	IF ( debug ) THEN
5584	DO ib = nb_in+1,nb
5585	DO ip=1,sz(ib)
5586	trip_tmp(pts(ib, ip, 1),pts(ib, ip, 2)) = ib*(-1)-900
5587	ENDDO
5588	ENDDO
5589	WRITE(fmt,"('(',I3,'I6)')") nbi
5590	WRITE(numout,*) 'AFTER-------------> New basins '
5591	WRITE(numout,*) nb, ' sz :', sz(1:nb)
5592	DO jp=1,nbj
5593	WRITE(numout,fmt) trip_tmp(1:nbi,jp)
5594	ENDDO
5595	IF ( MAXVAl(trip_tmp(1:nbi,1:nbj)) .GT. 0) THEN
5596	CALL ipslerr_p(3,'routing_cutbasin','Error in debug checking','','')
5597	ENDIF
5598	ENDIF
5599	ENDIF
5600	!
5601	END SUBROUTINE routing_cutbasin
5602	!
5603	!! ================================================================================================================================
5604	!! SUBROUTINE : routing_hierarchy
5605	!!
5606	!>\BRIEF This subroutine finds, for each point, the distance to the outflow
5607	!! point along the flowlines of the basin.
5608	!!
5609	!! DESCRIPTION (definitions, functional, design, flags) : None
5610	!!
5611	!! RECENT CHANGE(S): None
5612	!!
5613	!! MAIN OUTPUT VARIABLE(S):
5614	!!
5615	!! REFERENCES : None
5616	!!
5617	!! FLOWCHART : None
5618	!! \n
5619	!_ ================================================================================================================================
5620
5621	SUBROUTINE routing_hierarchy(iml, jml, trip, topoindex, hierarchy)
5622	!
5623	IMPLICIT NONE
5624	!
5625	!! LOCAL VARIABLES
5626	INTEGER(i_std) :: iml !! X resolution of the high resolution grid
5627	INTEGER(i_std) :: jml !! Y resolution of the high resolution grid
5628	REAL(r_std), DIMENSION(iml,jml) :: trip !! The trip field (unitless)
5629	REAL(r_std), DIMENSION(iml,jml) :: hierarchy !!
5630	REAL(r_std), DIMENSION(iml,jml) :: topoindex !! Topographic index of the residence time (m)
5631	!
5632	INTEGER(i_std), DIMENSION(8,2) :: inc !!
5633	INTEGER(i_std) :: ip, jp, ib, ntripi, ntripj, cnt, trp !!
5634	REAL(r_std) :: topohier !! The new value of topographically weighted hierarchy (m)
5635	REAL(r_std) :: topohier_old !! The old value of topographically weighted hierarchy (m)
5636	CHARACTER(LEN=7) :: fmt !!
5637
5638	!_ ================================================================================================================================
5639	!
5640	! The routing code (i=1, j=2)
5641	!
5642	inc(1,1) = 0
5643	inc(1,2) = -1
5644	inc(2,1) = 1
5645	inc(2,2) = -1
5646	inc(3,1) = 1
5647	inc(3,2) = 0
5648	inc(4,1) = 1
5649	inc(4,2) = 1
5650	inc(5,1) = 0
5651	inc(5,2) = 1
5652	inc(6,1) = -1
5653	inc(6,2) = 1
5654	inc(7,1) = -1
5655	inc(7,2) = 0
5656	inc(8,1) = -1
5657	inc(8,2) = -1
5658	!
5659	DO ip=1,iml
5660	DO jp=1,jml
5661	IF ( trip(ip,jp) .LT. undef_sechiba ) THEN
5662	ntripi = ip
5663	ntripj = jp
5664	trp = NINT(trip(ip,jp))
5665	cnt = 1
5666	! Warn for extreme numbers
5667	IF ( topoindex(ip,jp) .GT. 1.e10 ) THEN
5668	WRITE(numout,*) 'We have a very large topographic index for point ', ip, jp
5669	WRITE(numout,*) 'This can not be right :', topoindex(ip,jp)
5670	CALL ipslerr_p(3,'routing_hierarchy','Too large topographic index','','')
5671	ELSE
5672	topohier = topoindex(ip,jp)
5673	ENDIF
5674	!
5675	DO WHILE ( trp .GT. 0 .AND. trp .LT. 9 .AND. cnt .LT. iml*jml)
5676	cnt = cnt + 1
5677	ntripi = ntripi + inc(trp,1)
5678	IF ( ntripi .LT. 1) ntripi = iml
5679	IF ( ntripi .GT. iml) ntripi = 1
5680	ntripj = ntripj + inc(trp,2)
5681	topohier_old = topohier
5682	topohier = topohier + topoindex(ntripi, ntripj)
5683	IF ( topohier_old .GT. topohier) THEN
5684	WRITE(numout,*) 'Big Problem, how comes we climb up a hill ?'
5685	WRITE(numout,*) 'The old value of topographicaly weighted hierarchy was : ', topohier_old
5686	WRITE(numout,*) 'The new one is :', topohier
5687	CALL ipslerr_p(3,'routing_hierarchy','Big Problem, how comes we climb up a hill ?','','')
5688	ENDIF
5689	trp = NINT(trip(ntripi, ntripj))
5690	ENDDO
5691
5692	IF ( cnt .EQ. iml*jml) THEN
5693	WRITE(numout,*) 'We could not route point (routing_findrout) :', ip, jp
5694	WRITE(numout,*) '-------------> trip '
5695	WRITE(fmt,"('(',I3,'I6)')") iml
5696	DO ib=1,jml
5697	WRITE(numout,fmt) trip(1:iml,ib)
5698	ENDDO
5699	CALL ipslerr_p(3,'routing_hierarchy','We could not route point','','')
5700	ENDIF
5701
5702	hierarchy(ip,jp) = topohier
5703
5704	ENDIF
5705	ENDDO
5706	ENDDO
5707	!
5708	!
5709	END SUBROUTINE routing_hierarchy
5710	!
5711	!! ================================================================================================================================
5712	!! SUBROUTINE : routing_findrout
5713	!!
5714	!>\BRIEF This subroutine simply computes the route to each outflow point
5715	!! and returns the outflow point for each point in the basin.
5716	!!
5717	!! DESCRIPTION (definitions, functional, design, flags) : None
5718	!!
5719	!! RECENT CHANGE(S): None
5720	!!
5721	!! MAIN OUTPUT VARIABLE(S):
5722	!!
5723	!! REFERENCES : None
5724	!!
5725	!! FLOWCHART : None
5726	!! \n
5727	!_ ================================================================================================================================
5728
5729	SUBROUTINE routing_findrout(nbi, nbj, trip, basin_sz, basinid, nbout, outflow, trip_flow, outsz)
5730	!
5731	IMPLICIT NONE
5732	!
5733	!! INPUT VARIABLES
5734	INTEGER(i_std) :: nbi !! Number of point in x within the grid (unitless)
5735	INTEGER(i_std) :: nbj !! Number of point in y within the grid (unitless)
5736	INTEGER(i_std), DIMENSION(nbvmax,nbvmax) :: trip !! The trip field (unitless)
5737	INTEGER(i_std) :: basin_sz !!
5738	INTEGER(i_std) :: basinid !!
5739	!
5740	!! OUTPUT VARIABLES
5741	INTEGER(i_std), DIMENSION(nbvmax,2), INTENT(out) :: outflow !!
5742	INTEGER(i_std), DIMENSION(nbvmax,nbvmax,2), INTENT(out) :: trip_flow !!
5743	INTEGER(i_std), INTENT(out) :: nbout !!
5744	INTEGER(i_std), DIMENSION(nbvmax), INTENT(out) :: outsz !!
5745	!
5746	!! LOCAL VARIABLES
5747	INTEGER(i_std), DIMENSION(8,2) :: inc !!
5748	INTEGER(i_std) :: ip, jp, ib, cnt, trp, totsz !! Indices (unitless)
5749	CHARACTER(LEN=7) :: fmt !!
5750
5751	!_ ================================================================================================================================
5752	!
5753	!
5754	! The routing code (i=1, j=2)
5755	!
5756	inc(1,1) = 0
5757	inc(1,2) = -1
5758	inc(2,1) = 1
5759	inc(2,2) = -1
5760	inc(3,1) = 1
5761	inc(3,2) = 0
5762	inc(4,1) = 1
5763	inc(4,2) = 1
5764	inc(5,1) = 0
5765	inc(5,2) = 1
5766	inc(6,1) = -1
5767	inc(6,2) = 1
5768	inc(7,1) = -1
5769	inc(7,2) = 0
5770	inc(8,1) = -1
5771	inc(8,2) = -1
5772	!
5773	!
5774	! Get the outflows and determine for each point to which outflow point it belong
5775	!
5776	nbout = 0
5777	trip_flow(:,:,:) = 0
5778	DO ip=1,nbi
5779	DO jp=1,nbj
5780	IF ( trip(ip,jp) .GT. 9) THEN
5781	nbout = nbout + 1
5782	outflow(nbout,1) = ip
5783	outflow(nbout,2) = jp
5784	ENDIF
5785	IF ( trip(ip,jp) .GT. 0) THEN
5786	trip_flow(ip,jp,1) = ip
5787	trip_flow(ip,jp,2) = jp
5788	ENDIF
5789	ENDDO
5790	ENDDO
5791	!
5792	! Follow the flow of the water
5793	!
5794	DO ip=1,nbi
5795	DO jp=1,nbj
5796	IF ( (trip_flow(ip,jp,1) + trip_flow(ip,jp,2)) .GT. 0) THEN
5797	trp = trip(trip_flow(ip,jp,1), trip_flow(ip,jp,2))
5798	cnt = 0
5799	DO WHILE ( trp .GT. 0 .AND. trp .LT. 9 .AND. cnt .LT. nbi*nbj)
5800	cnt = cnt + 1
5801	trip_flow(ip,jp,1) = trip_flow(ip,jp,1) + inc(trp,1)
5802	trip_flow(ip,jp,2) = trip_flow(ip,jp,2) + inc(trp,2)
5803	trp = trip(trip_flow(ip,jp,1), trip_flow(ip,jp,2))
5804	ENDDO
5805	IF ( cnt .EQ. nbi*nbj) THEN
5806	WRITE(numout,*) 'We could not route point (routing_findrout) :', ip, jp
5807	WRITE(numout,*) '-------------> trip '
5808	WRITE(fmt,"('(',I3,'I6)')") nbi
5809	DO ib=1,nbj
5810	WRITE(numout,fmt) trip(1:nbi,ib)
5811	ENDDO
5812	CALL ipslerr_p(3,'routing_findrout','We could not route point','','')
5813	ENDIF
5814	ENDIF
5815	ENDDO
5816	ENDDO
5817	!
5818	! What is the size of the region behind each outflow point ?
5819	!
5820	totsz = 0
5821	DO ip=1,nbout
5822	outsz(ip) = COUNT(trip_flow(:,:,1) .EQ. outflow(ip,1) .AND. trip_flow(:,:,2) .EQ. outflow(ip,2))
5823	totsz = totsz + outsz(ip)
5824	ENDDO
5825	IF ( basin_sz .NE. totsz) THEN
5826	WRITE(numout,*) 'Water got lost while I tried to follow it '
5827	WRITE(numout,*) basin_sz, totsz
5828	WRITE(numout,*) 'Basin id :', basinid
5829	DO ip=1,nbout
5830	WRITE(numout,*) 'ip :', ip, ' outsz :', outsz(ip), ' outflow :', outflow(ip,1), outflow(ip,2)
5831	ENDDO
5832	WRITE(numout,*) '-------------> trip '
5833	WRITE(fmt,"('(',I3,'I6)')") nbi
5834	DO jp=1,nbj
5835	WRITE(numout,fmt) trip(1:nbi,jp)
5836	ENDDO
5837	CALL ipslerr_p(3,'routing_findrout','Water got lost while I tried to follow it','','')
5838	ENDIF
5839	!
5840	END SUBROUTINE routing_findrout
5841	!
5842	!! ================================================================================================================================
5843	!! SUBROUTINE : routing_globalize
5844	!!
5845	!>\BRIEF This subroutine puts the basins found for grid box in the global map.
5846	!! Connection can only be made later when all information is together.
5847	!!
5848	!! DESCRIPTION (definitions, functional, design, flags) : None
5849	!!
5850	!! RECENT CHANGE(S): None
5851	!!
5852	!! MAIN OUTPUT VARIABLE(S):
5853	!! One of the outputs is basin_flowdir. Its convention is 1-8 for the directions from North to North
5854	!! West going through South. The negative values will be -3 for return flow, -2 for coastal flow
5855	!!
5856	!! REFERENCES : None
5857	!!
5858	!! FLOWCHART : None
5859	!! \n
5860	!_ ================================================================================================================================
5861
5862	SUBROUTINE routing_globalize(nbpt, ib, neighbours, area_bx, trip_bx, hierarchy_bx, topoind_bx, min_topoind,&
5863	& nb_basin, basin_inbxid, basin_sz, basin_pts, basin_bxout, lshead, coast_pts, nwbas, basin_count,&
5864	& basin_area, basin_hierarchy, basin_topoind, basin_id, basin_flowdir, basin_lshead, outflow_grid,&
5865	& nbcoastal, coastal_basin)
5866	!
5867	IMPLICIT NONE
5868	!
5869	!! INPUT VARIABLES
5870	INTEGER(i_std), INTENT (in) :: nbpt !! Domain size (unitless)
5871	INTEGER(i_std), INTENT (in) :: ib !! Current basin (unitless)
5872	INTEGER(i_std), INTENT(in) :: neighbours(nbpt,NbNeighb)!! Vector of neighbours for each grid point
5873	!! (1=North and then clockwise)
5874	!! LOCAL VARIABLES
5875	REAL(r_std), DIMENSION(nbvmax,nbvmax) :: area_bx !! Area of each small box in the grid box (m^2)
5876	INTEGER(i_std), DIMENSION(nbvmax,nbvmax) :: trip_bx !! The trip field for each of the smaller boxes (unitless)
5877	REAL(r_std), DIMENSION(nbvmax,nbvmax) :: hierarchy_bx !! Level in the basin of the point
5878	REAL(r_std), DIMENSION(nbvmax,nbvmax) :: topoind_bx !! Topographic index of the residence time for each of the smaller boxes (m)
5879	REAL(r_std) :: min_topoind !! The current minimum of topographic index (m)
5880	INTEGER(i_std) :: nb_basin !! Number of sub-basins (unitless)
5881	INTEGER(i_std), DIMENSION(nbvmax) :: basin_inbxid, basin_sz !! ID of basin, number of points in the basin
5882	INTEGER(i_std), DIMENSION(nbvmax,nbvmax,2) :: basin_pts !! Points in each basin
5883	INTEGER(i_std), DIMENSION(nbvmax) :: basin_bxout !! outflow direction
5884	REAL(r_std), DIMENSION(nbvmax) :: lshead !! Large scale heading of outflow.
5885	INTEGER(i_std) :: coast_pts(nbvmax) !! The coastal flow points (unitless)
5886	! global maps
5887	INTEGER(i_std) :: nwbas !!
5888	INTEGER(i_std), DIMENSION(nbpt) :: basin_count !!
5889	INTEGER(i_std), DIMENSION(nbpt,nwbas) :: basin_id !!
5890	INTEGER(i_std), DIMENSION(nbpt,nwbas) :: basin_flowdir !! Water flow directions in the basin (unitless)
5891	REAL(r_std), DIMENSION(nbpt,nwbas) :: basin_area !!
5892	REAL(r_std), DIMENSION(nbpt,nwbas) :: basin_hierarchy !!
5893	REAL(r_std), DIMENSION(nbpt,nwbas) :: basin_topoind !! Topographic index of the residence time for a basin (m)
5894	REAL(r_std), DIMENSION(nbpt,nwbas) :: basin_lshead !! Large scale heading out of the grid box.
5895	INTEGER(i_std), DIMENSION(nbpt,nwbas) :: outflow_grid !! Type of outflow on the grid box (unitless)
5896	INTEGER(i_std), DIMENSION(nbpt) :: nbcoastal !!
5897	INTEGER(i_std), DIMENSION(nbpt,nwbas) :: coastal_basin !!
5898	!
5899	INTEGER(i_std) :: ij, iz !! Indices (unitless)
5900	CHARACTER(LEN=4) :: hierar_method = 'OUTP' !!
5901	!
5902	!_ ================================================================================================================================
5903	!
5904	!
5905	DO ij=1, nb_basin
5906	!
5907	! Count the basins and keep their ID
5908	!
5909	basin_count(ib) = basin_count(ib)+1
5910	if (basin_count(ib) > nwbas) then
5911	WRITE(numout,*) 'ib=',ib
5912	call ipslerr_p(3,'routing_globalize', &
5913	& 'Problem with basin_count : ', &
5914	& 'It is greater than number of allocated basin nwbas.', &
5915	& '(stop to count basins)')
5916	endif
5917	basin_id(ib,basin_count(ib)) = basin_inbxid(ij)
5918	!
5919	! Transfer the list of basins which flow into the ocean as coastal flow.
5920	!
5921	IF ( basin_id(ib,basin_count(ib)) .LT. 0) THEN
5922	nbcoastal(ib) = basin_sz(ij)
5923	coastal_basin(ib,1:nbcoastal(ib)) = coast_pts(1:nbcoastal(ib))
5924	ENDIF
5925	!
5926	!
5927	! Compute the area of the basin
5928	!
5929	basin_area(ib,ij) = zero
5930	basin_hierarchy(ib,ij) = zero
5931	!
5932	SELECT CASE (hierar_method)
5933	!
5934	CASE("MINI")
5935	basin_hierarchy(ib,ij) = undef_sechiba
5936	!
5937	END SELECT
5938	basin_topoind(ib,ij) = zero
5939	!
5940	DO iz=1,basin_sz(ij)
5941	!
5942	basin_area(ib,ij) = basin_area(ib,ij) + area_bx(basin_pts(ij,iz,1),basin_pts(ij,iz,2))
5943	basin_topoind(ib,ij) = basin_topoind(ib,ij) + topoind_bx(basin_pts(ij,iz,1),basin_pts(ij,iz,2))
5944	!
5945	! There are a number of ways to determine the hierarchy of the entire basin.
5946	! We allow for three here :
5947	! - Take the mean value
5948	! - Take the minimum value within the basin
5949	! - Take the value at the outflow point
5950	! Probably taking the value of the outflow point is the best solution.
5951	!
5952	SELECT CASE (hierar_method)
5953	!
5954	CASE("MEAN")
5955	! Mean hierarchy of the basin
5956	basin_hierarchy(ib,ij) = basin_hierarchy(ib,ij) + &
5957	& hierarchy_bx(basin_pts(ij,iz,1),basin_pts(ij,iz,2))
5958	CASE("MINI")
5959	! The smallest value of the basin
5960	IF ( hierarchy_bx(basin_pts(ij,iz,1),basin_pts(ij,iz,2)) .LT. basin_hierarchy(ib,ij)) THEN
5961	basin_hierarchy(ib,ij) = hierarchy_bx(basin_pts(ij,iz,1),basin_pts(ij,iz,2))
5962	ENDIF
5963	CASE("OUTP")
5964	! Value at the outflow point
5965	IF ( trip_bx(basin_pts(ij,iz,1),basin_pts(ij,iz,2)) .GT. 100 ) THEN
5966	basin_hierarchy(ib,ij) = hierarchy_bx(basin_pts(ij,iz,1),basin_pts(ij,iz,2))
5967	ENDIF
5968	CASE DEFAULT
5969	WRITE(numout,*) 'Unknown method for computing the hierarchy of the basin'
5970	CALL ipslerr_p(3,'routing_globalize','Unknown method for computing the hierarchy of the basin','','')
5971	END SELECT
5972	!
5973	ENDDO
5974	!
5975	basin_topoind(ib,ij) = basin_topoind(ib,ij)/REAL(basin_sz(ij),r_std)
5976	!
5977	SELECT CASE (hierar_method)
5978	!
5979	CASE("MEAN")
5980	basin_hierarchy(ib,ij) = basin_hierarchy(ib,ij)/REAL(basin_sz(ij),r_std)
5981	!
5982	END SELECT
5983	!
5984	! To make sure that it has the lowest number if this is an outflow point we reset basin_hierarchy
5985	!
5986	IF (basin_bxout(ij) .LT. 0) THEN
5987	basin_hierarchy(ib,ij) = min_topoind
5988	basin_topoind(ib,ij) = min_topoind
5989	ENDIF
5990	!
5991	!
5992	! Keep the outflow boxes and basin
5993	!
5994	basin_flowdir(ib,ij) = basin_bxout(ij)
5995	IF (basin_bxout(ij) .GT. 0) THEN
5996	basin_lshead(ib,ij) = lshead(ij)
5997	outflow_grid(ib,ij) = routing_nextgrid_g(ib,basin_bxout(ij))
5998	ELSE
5999	basin_lshead(ib,ij) = undef_sechiba
6000	outflow_grid(ib,ij) = basin_bxout(ij)
6001	ENDIF
6002	!
6003	!
6004	ENDDO
6005	!
6006	END SUBROUTINE routing_globalize
6007	!
6008	!! ================================================================================================================================
6009	!! SUBROUTINE : routing_linkup
6010	!!
6011	!>\BRIEF This subroutine makes the connections between the basins and ensure global coherence.
6012	!!
6013	!! DESCRIPTION (definitions, functional, design, flags) :
6014	!! The convention for outflow_grid is :
6015	!! outflow_grid > : The grid bow in which the basin is supposed to flow.
6016	!! outflow_grid = -1 : River flow
6017	!! outflow_grid = -2 : Coastal flow
6018	!! outflow_grid = -3 : Return flow
6019	!! outflow_grid = -4 : Flows into a basin in the same grid
6020	!! For outflow_basin we have the following conventions :
6021	!! outflow_basin = basin id in the case of the basin not flowing out of the current grid (i.e. outflow_grid=-4).
6022	!! Else outflow_basin = undef_int and the objective of this routine is to find what that basin is. This work
6023	!! essentially occurs in the routine routing_bestsubbasin. But for that we need to find the grid box where
6024	!! we will look for the right basin. This operation is performed here in 5 successive steps. The order correspond
6025	!! to the solution we would prefer.
6026	!! 1.0 : We will look in the grid provided by outflow_grid for the right basin. This neighbour has been obtained
6027	!! from the small scale flow direction given in routing.nc.
6028	!! 2.0 : Try the grid box given by the large scale flow direction.
6029	!! 3.0 : Have another attempt at the outflow_grid by looking at the neighbour just to the right and the left.
6030	!! 4.0 : Here we look at half of the neighbouring grid boxes around the large scale flow direction.
6031	!! 5.0 : If all the above failed then we look within the current grid box if we find a suitable outflow basin.
6032	!!
6033	!! RECENT CHANGE(S): None
6034	!!
6035	!! MAIN OUTPUT VARIABLE(S):
6036	!!
6037	!! REFERENCES : None
6038	!!
6039	!! FLOWCHART : None
6040	!! \n
6041	!_ ================================================================================================================================
6042
6043	SUBROUTINE routing_linkup(nbpt, neighbours, nwbas, basin_count, basin_area, basin_id, basin_flowdir, &
6044	& basin_lshead, basin_hierarchy, diaglalo, outflow_grid, outflow_basin, inflow_number, inflow_grid, &
6045	& inflow_basin, nbcoastal, coastal_basin, invented_basins)
6046	!
6047	IMPLICIT NONE
6048	!
6049	!! INPUT VARIABLES
6050	INTEGER(i_std), INTENT (in) :: nbpt !! Domain size (unitless)
6051	INTEGER(i_std), DIMENSION(nbpt,NbNeighb), INTENT (in) :: neighbours !!
6052	REAL(r_std), INTENT(in) :: invented_basins !!
6053	!
6054	INTEGER(i_std) :: nwbas !!
6055	INTEGER(i_std), DIMENSION(nbpt) :: basin_count !!
6056	INTEGER(i_std), DIMENSION(nbpt,nwbas) :: basin_id !!
6057	INTEGER(i_std), DIMENSION(nbpt,nwbas) :: basin_flowdir !! Water flow directions in the basin (unitless)
6058	REAL(r_std), DIMENSION(nbpt,nwbas) :: basin_lshead !! Large scale flow direction out of the basin.
6059	REAL(r_std), DIMENSION(nbpt,nwbas) :: basin_area !!
6060	REAL(r_std), DIMENSION(nbpt,nwbas) :: basin_hierarchy !!
6061	REAL(r_std), DIMENSION(:,:), INTENT(in) :: diaglalo !! Point (in Lat/Lon) where diagnostics will be printed.
6062	INTEGER(i_std), DIMENSION(nbpt,nwbas) :: outflow_grid !! Type of outflow on the grid box (unitless)
6063	INTEGER(i_std), DIMENSION(nbpt,nwbas) :: outflow_basin !!
6064	!
6065	INTEGER(i_std), DIMENSION(nbpt,nwbas) :: inflow_number !!
6066	INTEGER(i_std), DIMENSION(nbpt,nwbas,nwbas) :: inflow_basin !!
6067	INTEGER(i_std), DIMENSION(nbpt,nwbas,nwbas) :: inflow_grid !!
6068	!
6069	INTEGER(i_std), DIMENSION(nbpt) :: nbcoastal !!
6070	INTEGER(i_std), DIMENSION(nbpt,nwbas) :: coastal_basin !!
6071	!
6072	!! LOCAL VARIABLES
6073	INTEGER(i_std) :: sp, sb, sbl, inp, outdm1, outdp1 !! Indices (unitless)
6074	INTEGER(i_std) :: spa, sba, sbint
6075	INTEGER(i_std) :: i, nbocean, it
6076	REAL(r_std) :: wocean
6077	INTEGER(i_std) :: dp1, dm1, dm1i, dls, bp1, bm1, bls !! Indices (unitless)
6078	INTEGER(i_std) :: dop, bop, nbtotest !!
6079	INTEGER(i_std) :: fbas(nwbas), nbfbas !!
6080	REAL(r_std) :: ang, angp1, angm1, bopqual, blsqual, bp1qual, bm1qual, crit
6081	REAL(r_std) :: fbas_hierarchy(nwbas) !!
6082	INTEGER(i_std) :: ff(1) !!
6083	INTEGER(i_std), DIMENSION(NbNeighb) :: gridstotest, gridbasin
6084	REAL(r_std), DIMENSION(NbNeighb) :: diffangle, gridangle
6085	INTEGER(i_std), DIMENSION(nbpt,5) :: solved
6086	INTEGER(i_std) :: unsolved, testbasinid
6087	REAL(r_std), ALLOCATABLE, DIMENSION(:) :: hatoutflow
6088	INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:) :: minhloc
6089	!
6090	!
6091	!! PARAMETERS
6092	LOGICAL, PARAMETER :: debug = .FALSE. !! (true/false)
6093	!
6094	!_ ================================================================================================================================
6095	!
6096	!
6097	testbasinid = -93063
6098	!
6099	IF ( debug ) WRITE (numout,*) 'SIZE inflow_grid:',SIZE(inflow_grid,1),SIZE(inflow_grid,2),SIZE(inflow_grid,3)
6100	IF ( debug ) WRITE (numout,*) 'SIZE inflow_basin:',SIZE(inflow_basin,1),SIZE(inflow_basin,2),SIZE(inflow_basin,3)
6101	CALL FLUSH(numout)
6102	!
6103	inflow_number(:,:) = 0
6104
6105	!
6106	! Variable to keep track of how many points were solved at each stage
6107	!
6108	solved(:,:) = 0
6109	!
6110	! Some preparatory work. We need the minimum hierarchy for each basin and its location.
6111	! This comes from the fact that for coastal basins it is often difficult to decide if they
6112	! first flow into another grid or directly into the ocean. So this information will be
6113	! useful.
6114	!
6115	ALLOCATE(hatoutflow(INT(invented_basins)))
6116	ALLOCATE(minhloc(INT(invented_basins),2))
6117	hatoutflow(:) = undef_sechiba
6118	DO sp=1,nbpt
6119	DO sb=1,basin_count(sp)
6120	IF ( basin_id(sp,sb) < INT(invented_basins) .AND. basin_id(sp,sb) > 0 ) THEN
6121	IF ( hatoutflow(basin_id(sp,sb)) > basin_hierarchy(sp,sb) ) THEN
6122	hatoutflow(basin_id(sp,sb)) = basin_hierarchy(sp,sb)
6123	minhloc(basin_id(sp,sb),1) = sp
6124	minhloc(basin_id(sp,sb),2) = sb
6125	ENDIF
6126	ENDIF
6127	ENDDO
6128	ENDDO
6129	!
6130	! 1.0 Follow the flow direction as given by the high resolution basin description. This case also treats the
6131	! basins which remain in the current grid box, rivers, coastal and return flows.
6132	!
6133	DO sp=1,nbpt
6134	!
6135	DO sb=1,basin_count(sp)
6136	!
6137	!
6138	! We only work on this point if it does not flow into the ocean
6139	! or flow to another sub-basin in the same grid box.
6140	! At this point any of the outflows is designated by a negative values in
6141	! outflow_grid
6142	!
6143	IF ( outflow_grid(sp,sb) < 0 ) THEN
6144	IF ( outflow_grid(sp,sb) .EQ. -4 ) THEN
6145	! Flow into a basin of the same grid
6146	bop = outflow_basin(sp,sb)
6147	CALL routing_updateflow(sp, sb, sp, bop, nbpt, nwbas, nwbas, outflow_grid, outflow_basin, &
6148	& inflow_number, inflow_grid, inflow_basin)
6149	IF ( outflow_basin(sp,sb) == bop ) THEN
6150	solved(sp,1) = solved(sp,1) + 1
6151	ENDIF
6152	!
6153	ELSE IF ( outflow_grid(sp,sb) .EQ. -3 ) THEN
6154	! Return flow
6155	! Nothing to do but just remember it is done.
6156	solved(sp,1) = solved(sp,1) + 1
6157	ELSE IF ( outflow_grid(sp,sb) .EQ. -2 ) THEN
6158	! Coastal flow
6159	! Nothing to do but just remember it is done.
6160	solved(sp,1) = solved(sp,1) + 1
6161	ELSE IF ( outflow_grid(sp,sb) .EQ. -1 ) THEN
6162	! River flow
6163	! Nothing to do but just remember it is done.
6164	solved(sp,1) = solved(sp,1) + 1
6165	ENDIF
6166	ELSE IF ( outflow_grid(sp,sb) .GT. 0 ) THEN
6167	!
6168	inp = outflow_grid(sp,sb)
6169	!
6170	CALL routing_bestsubbasin(sp, basin_id(sp,sb), basin_hierarchy(sp,sb), basin_flowdir(sp,sb), invented_basins, &
6171	& nbpt, nwbas, inp, basin_count, basin_id, basin_hierarchy, &
6172	& basin_flowdir, nbcoastal, coastal_basin, bop, bopqual)
6173	!
6174	IF ( sp == 21 ) THEN
6175	WRITE(numout,*) "AFTER bestsubbasin : bop, bopqual =", bop, bopqual
6176	ENDIF
6177	ang = routing_anglediff_g(sp, inp, basin_flowdir(sp,sb))
6178	!
6179	! If the basin is suitable (bop < undef_int) then take it
6180	!
6181	IF ( bop .LT. undef_int ) THEN
6182	!
6183	CALL routing_updateflow(sp, sb, inp, bop, nbpt, nwbas, nwbas, outflow_grid, outflow_basin, &
6184	& inflow_number, inflow_grid, inflow_basin)
6185	!
6186	IF ( outflow_basin(sp,sb) == bop ) THEN
6187	solved(sp,1) = solved(sp,1) + 1
6188	ENDIF
6189	!
6190	ENDIF
6191	!
6192	ENDIF
6193	!
6194	IF ( debug .AND. routing_diagbox_g(sp,diaglalo) ) THEN
6195	WRITE(numout,*) "Linkup 1.0 - In routing_linkup working on sp & sb:",sp, sb
6196	WRITE(numout,*) "Linkup 1.0 - Coords : ", lalo_g(sp,2), lalo_g(sp,1)
6197	WRITE(numout,*) "Linkup 1.0 - outflow_flowdir = ", basin_flowdir(sp,sb)
6198	WRITE(numout,*) "Linkup 1.0 - Large scale heading =", basin_lshead(sp,sb)
6199	WRITE(numout,*) "Linkup 1.0 - Hierarchy =", basin_hierarchy(sp,sb)
6200	WRITE(numout,) "Linkup 1.0 - Basin % of grid =", basin_area(sp,sb)/area_g(sp)100
6201	WRITE(numout,*) "Linkup 1.0 - outflow_grid =", outflow_grid(sp,sb)
6202	IF ( outflow_grid(sp,sb) > 0 ) THEN
6203	WRITE(numout,*) "Linkup 1.0 - Coords outflow: ", lalo_g(outflow_grid(sp,sb),2), lalo_g(outflow_grid(sp,sb),1)
6204	ENDIF
6205	WRITE(numout,*) "Linkup 1.0 - outflow_basin = ", outflow_basin(sp,sb)
6206	IF ( outflow_grid(sp,sb) > 0 .AND. outflow_basin(sp,sb) < undef_int ) THEN
6207	WRITE(numout,*) "Linkup 1.0 - Outflow Hierarchy =", basin_hierarchy(outflow_grid(sp,sb),outflow_basin(sp,sb))
6208	ENDIF
6209	ENDIF
6210	ENDDO
6211	ENDDO
6212	!
6213	! 2.0 : Do we have a valid outflow basin ? If not we need to test other options.
6214	! The reason for not finding the outflow basin could be that the outflow_grid correspons to a
6215	! small scale feature not corresponding to the orientation of the grid. So we use the large
6216	! scale heading of the flow out of the grid in order to test another neighbour.
6217	!
6218	DO sp=1,nbpt
6219	!
6220	DO sb=1,basin_count(sp)
6221	!
6222	IF ( outflow_basin(sp,sb) .EQ. undef_int .AND. &
6223	& outflow_grid(sp,sb) > 0 .AND. basin_flowdir(sp,sb) > 0) THEN
6224	!
6225	DO i=1,NbNeighb
6226	diffangle(i) = ABS(haversine_diffangle(headings_g(sp,i), basin_lshead(sp,sb)))
6227	ENDDO
6228	ff = MINLOC(diffangle)
6229	dls = neighbours_g(sp,ff(1))
6230	!
6231	IF ( dls .LE. -1 ) THEN
6232	! This flows out of the domain so put the basin into coastal flow
6233	outflow_grid(sp,sb) = -2
6234	outflow_basin(sp,sb) = undef_int
6235	solved(sp,2) = solved(sp,2)+1
6236	IF ( debug .AND. routing_diagbox_g(sp,diaglalo) ) THEN
6237	WRITE(numout,*) "Linkup 2.0 - ", sp, sb, "becomes a coastal flow basin."
6238	ENDIF
6239	ELSE
6240	IF ( dls > 0 ) THEN
6241	CALL routing_bestsubbasin(sp, basin_id(sp,sb), basin_hierarchy(sp,sb), basin_flowdir(sp,sb), invented_basins, &
6242	& nbpt, nwbas, dls, basin_count, basin_id, basin_hierarchy, &
6243	& basin_flowdir, nbcoastal, coastal_basin, bls, blsqual)
6244	ELSE
6245	bls = undef_int
6246	blsqual = 0
6247	ENDIF
6248	ENDIF
6249	!
6250	IF ( dls > 0 .AND. bls < undef_int ) THEN
6251	!
6252	CALL routing_updateflow(sp, sb, dls, bls, nbpt, nwbas, nwbas, outflow_grid, outflow_basin, &
6253	& inflow_number, inflow_grid, inflow_basin)
6254	!
6255	ENDIF
6256	!
6257	IF ( debug .AND. routing_diagbox_g(sp,diaglalo) ) THEN
6258	WRITE(numout,*) "Linkup 2.0 - sp, sb = ", sp, sb
6259	WRITE(numout,*) "Linkup 2.0 - Large scale heading =", basin_lshead(sp,sb)
6260	WRITE(numout,*) "Linkup 2.0 - Large scale test =", dls, bls
6261	WRITE(numout,*) "Linkup 2.0 - outflow_grid =", outflow_grid(sp,sb)
6262	WRITE(numout,*) "Linkup 2.0 - outflow_basin = ", outflow_basin(sp,sb)
6263	ENDIF
6264	!
6265	IF ( outflow_basin(sp,sb) < undef_int ) solved(sp,2) = solved(sp,2)+1
6266	!
6267	ENDIF
6268	!
6269	ENDDO
6270	ENDDO
6271	!
6272	!
6273	! 3.0 Look within the general direction of the indicated flow to see if we find a matching basin.
6274	!
6275	! In case we did not find the correct basin we start to look
6276	! around. We find two options for the outflow direction (dp1 & dm1) and the corresponding
6277	! basin index (bp1 & bm1).
6278	! These options are only acceptable if the angle to the original direction is less or equal
6279	! to 45 degrees.
6280	!
6281	DO sp=1,nbpt
6282	!
6283	DO sb=1,basin_count(sp)
6284	!
6285	nbocean = 0
6286	!
6287	IF ( outflow_basin(sp,sb) .EQ. undef_int .AND. &
6288	& outflow_grid(sp,sb) > 0 .AND. basin_flowdir(sp,sb) > 0) THEN
6289	!
6290	! Try to neighboring directions on the model grid.
6291	!
6292	dp1 = routing_nextgrid_g(sp, basin_flowdir(sp,sb), +1)
6293	dm1 = routing_nextgrid_g(sp, basin_flowdir(sp,sb), -1)
6294	!
6295	! How many are ocean points ?
6296	!
6297	IF ( dp1 .LE. -1 ) nbocean = nbocean + 1
6298	IF ( dm1 .LE. -1 ) nbocean = nbocean + 1
6299	!
6300	! Compute bp1 and bm1
6301	!
6302	IF ( dp1 .GT. 0 ) THEN
6303	angp1 = routing_anglediff_g(sp, dp1, basin_flowdir(sp,sb))
6304	IF ( angp1 <= 45.0 ) THEN
6305	CALL routing_bestsubbasin(sp, basin_id(sp,sb), basin_hierarchy(sp,sb), basin_flowdir(sp,sb), invented_basins, &
6306	& nbpt, nwbas, dp1, basin_count, basin_id, basin_hierarchy, &
6307	& basin_flowdir, nbcoastal, coastal_basin, bp1, bp1qual)
6308	ELSE
6309	bp1 = undef_int
6310	bp1qual = 0
6311	ENDIF
6312	ELSE
6313	bp1 = undef_int
6314	bp1qual = 0
6315	ENDIF
6316	IF ( dm1 .GT. 0 ) THEN
6317	angm1 = routing_anglediff_g(sp, dm1, basin_flowdir(sp,sb))
6318	IF ( angm1 <= 45.0 ) THEN
6319	CALL routing_bestsubbasin(sp, basin_id(sp,sb), basin_hierarchy(sp,sb), basin_flowdir(sp,sb), invented_basins, &
6320	& nbpt, nwbas, dm1, basin_count, basin_id, basin_hierarchy, &
6321	& basin_flowdir, nbcoastal, coastal_basin, bm1, bm1qual)
6322	ELSE
6323	bm1 = undef_int
6324	bm1qual = 0
6325	ENDIF
6326	ELSE
6327	bm1 = undef_int
6328	bm1qual = 0
6329	ENDIF
6330	!
6331	! Decide between dp1 and dm1 which is the better solution !
6332	!
6333	dop = undef_int
6334	IF ( bp1 < undef_int .OR. bm1 < undef_int ) THEN
6335	IF ( bp1 < undef_int ) THEN
6336	dop = dp1
6337	bop = bp1
6338	ELSE IF ( bm1 < undef_int ) THEN
6339	dop = dm1
6340	bop = bm1
6341	ELSE
6342	IF ( bp1qual > bm1qual ) THEN
6343	dop = dp1
6344	bop = bp1
6345	ELSE IF ( bp1qual > bm1qual ) THEN
6346	dop = dm1
6347	bop = bm1
6348	ELSE
6349	IF ( angm1 < angp1 ) THEN
6350	dop = dm1
6351	bop = bm1
6352	ELSE
6353	dop = dp1
6354	bop = bp1
6355	ENDIF
6356	ENDIF
6357	ENDIF
6358	ENDIF
6359	!
6360	! Now that we know where we want the water to flow to we write the
6361	! the information in the right fields.
6362	!
6363	IF ( dop > 0 .AND. dop < undef_int .AND. bop < undef_int ) THEN
6364	!
6365	CALL routing_updateflow(sp, sb, dop, bop, nbpt, nwbas, nwbas, outflow_grid, outflow_basin, &
6366	& inflow_number, inflow_grid, inflow_basin)
6367	!
6368	ENDIF
6369	!
6370	! If one of the outflow options is an ocean point then we should use it.
6371	! We are a little more stringent with the angle.
6372	!
6373	IF ( outflow_basin(sp,sb) .EQ. undef_int .AND. &
6374	& outflow_grid(sp,sb) > 0 .AND. basin_flowdir(sp,sb) > 0) THEN
6375	IF ( nbocean >= 1 ) THEN
6376	IF ( (dp1 .LE. -1 .AND. angp1 < 45.0 ) .OR. &
6377	& (dm1 .LE. -1 .AND. angm1 < 45.0 ) ) THEN
6378	outflow_grid(sp,sb) = -2
6379	outflow_basin(sp,sb) = undef_int
6380	solved(sp,3) = solved(sp,3)+1
6381	IF ( debug .AND. routing_diagbox_g(sp,diaglalo) ) THEN
6382	WRITE(numout,*) "Linkup 3.0 - ", sp, sb, "becomes a coastal flow basin."
6383	ENDIF
6384	ENDIF
6385	ENDIF
6386	ENDIF
6387	!
6388	IF ( debug .AND. routing_diagbox_g(sp,diaglalo) ) THEN
6389	WRITE(numout,*) "Linkup 3.0 - In routing_linkup working on sp & sb:", sp, sb
6390	WRITE(numout,*) "Linkup 3.0 - outflow_flowdir = ", basin_flowdir(sp,sb)
6391	WRITE(numout,*) "Linkup 3.0 - Tested dp1 & dm1 : ", dp1, dm1
6392	WRITE(numout,*) "Linkup 3.0 - Angles : ",angp1, angm1
6393	WRITE(numout,*) "Linkup 3.0 - Test output bp1 & bm1 = ", bp1, bm1
6394	WRITE(numout,*) "Linkup 3.0 - Selected bop & dop = ", bop, dop
6395	WRITE(numout,*) "Linkup 3.0 - outflow_grid =", outflow_grid(sp,sb)
6396	WRITE(numout,*) "Linkup 3.0 - outflow_basin = ", outflow_basin(sp,sb)
6397	ENDIF
6398	!
6399	IF ( outflow_basin(sp,sb) < undef_int ) solved(sp,3) = solved(sp,3)+1
6400	!
6401	ENDIF
6402	!
6403	ENDDO
6404	ENDDO
6405	!
6406	! 4.0 If we still have not found the correct basin so we look into other directions
6407	! East and West of the large scale flow direction we have. We work this with the
6408	! the smallest angle to the large scale flow direction first. Remember the grid
6409	! in the large scale flow direction was already tested (in 2.0).
6410	!
6411	nbtotest = INT(NbNeighb/2.0)
6412	!
6413	DO sp=1,nbpt
6414	!
6415	DO sb=1,basin_count(sp)
6416	!
6417	nbocean = 0
6418	wocean = zero
6419	!
6420	IF ( outflow_basin(sp,sb) .EQ. undef_int .AND. &
6421	& outflow_grid(sp,sb) > 0 .AND. basin_flowdir(sp,sb) > 0) THEN
6422	!
6423	! Try to neighboring directions on the model grid.
6424	!
6425	DO i=1,NbNeighb
6426	diffangle(i) = ABS(haversine_diffangle(headings_g(sp,i), basin_lshead(sp,sb)))
6427	ENDDO
6428	!
6429	! The minimum was already done above. So we delete from the list
6430	!
6431	ff = MINLOC(diffangle)
6432	dls = neighbours_g(sp,ff(1))
6433	IF ( dls .LE. -1 ) THEN
6434	nbocean = nbocean + 1
6435	wocean = wocean + diffangle(ff(1))
6436	ENDIF
6437	diffangle(ff(1)) = undef_sechiba
6438	!
6439	DO it=1,nbtotest
6440	ff = MINLOC(diffangle)
6441	gridstotest(it) = neighbours_g(sp,ff(1))
6442	gridangle(it) = diffangle(ff(1))
6443	!
6444	! neighbours outside of the domain are considered as ocean points.
6445	!
6446	IF ( gridstotest(it) .LE. -1 ) THEN
6447	nbocean = nbocean + 1
6448	wocean = wocean + diffangle(ff(1))
6449	ENDIF
6450	diffangle(ff(1)) = undef_sechiba
6451	ENDDO
6452	!
6453	! Now work through our list of points
6454	!
6455	DO it=1,nbtotest
6456	IF ( outflow_basin(sp,sb) .EQ. undef_int ) THEN
6457	dls = gridstotest(it)
6458	!
6459	IF ( dls .GT. 0 ) THEN
6460	dop = dls
6461	CALL routing_bestsubbasin(sp, basin_id(sp,sb), basin_hierarchy(sp,sb), basin_flowdir(sp,sb), &
6462	& invented_basins, nbpt, nwbas, dls, basin_count, basin_id, &
6463	& basin_hierarchy, basin_flowdir, nbcoastal, coastal_basin, bop, bopqual)
6464	ELSE
6465	bop = undef_int
6466	bopqual = 0
6467	ENDIF
6468	gridbasin(it) = bop
6469	!
6470	! Now that we know where we want the water to flow to we write the
6471	! the information into the right fields.
6472	!
6473	IF ( dls > 0 .AND. dls < undef_int .AND. bop < undef_int ) THEN
6474	!
6475	CALL routing_updateflow(sp, sb, dls, bop, nbpt, nwbas, nwbas, outflow_grid, outflow_basin, &
6476	& inflow_number, inflow_grid, inflow_basin)
6477	!
6478	ENDIF
6479	ENDIF
6480	ENDDO
6481	!
6482	IF ( debug .AND. routing_diagbox_g(sp,diaglalo) ) THEN
6483	WRITE(numout,*) "Linkup 4.0 - In routing_linkup working on sp & sb:", sp, sb
6484	WRITE(numout,*) "Linkup 4.0 - Large scale heading =", basin_lshead(sp,sb)
6485	WRITE(numout,*) "Linkup 4.0 - Tested gridstotest : ", gridstotest(1:nbtotest)
6486	WRITE(numout,*) "Linkup 4.0 - Angles of tested : ", gridangle(1:nbtotest)
6487	WRITE(numout,*) "Linkup 4.0 - Tested outflow basin = ", gridbasin(1:nbtotest)
6488	WRITE(numout,*) "Linkup 4.0 - outflow_grid =", outflow_grid(sp,sb)
6489	WRITE(numout,*) "Linkup 4.0 - outflow_basin = ", outflow_basin(sp,sb)
6490	WRITE(numout,*) "Linkup 4.0 - Number of ocean options : ", nbocean
6491	IF (nbocean > 0 ) WRITE(numout,*) "Linkup 4.0 - ocean direction = ", wocean/nbocean
6492	IF ( basin_id(sp,sb) < invented_basins ) THEN
6493	WRITE(numout,*) "Linkup 4.0 - Hmin for basin :", hatoutflow(basin_id(sp,sb))
6494	WRITE(numout,*) "Linkup 4.0 - Hmin location :", minhloc(basin_id(sp,sb),1), minhloc(basin_id(sp,sb),2)
6495	ENDIF
6496	ENDIF
6497	!
6498	IF ( outflow_basin(sp,sb) < undef_int ) solved(sp,4) = solved(sp,4)+1
6499	!
6500	ENDIF
6501	!
6502	! If we have not found anything, but we have an ocean point as neighbour, then go for it.
6503	! This would be coastal flow then.
6504	!
6505	IF ( outflow_basin(sp,sb) .EQ. undef_int .AND. &
6506	& outflow_grid(sp,sb) > 0 .AND. basin_flowdir(sp,sb) > 0) THEN
6507	!
6508	IF ( basin_id(sp,sb) < invented_basins ) THEN
6509	crit = (basin_hierarchy(sp,sb)-hatoutflow(basin_id(sp,sb)))/(basin_hierarchy(sp,sb)+1)
6510	ELSE
6511	crit = zero
6512	ENDIF
6513	!
6514	! If we have at least 2 ocean points within the examined points then ouflow points
6515	! we put this basin into the ocean. If hierarchy is lower than the
6516	! average at other outflow points, then we relax this condition.
6517	!
6518	IF ( crit > 0.1 ) THEN
6519	IF ( nbocean >= nbtotest/2.0 ) THEN
6520	!
6521	! These ocean points should not be too far away from the large scale direction.
6522	! In this phase we should also consider the size of the basin. If it small then we can
6523	! neglect its and put it into the ocean.
6524	!
6525	IF ( wocean/nbocean < 90.0 .OR. (basin_area(sp,sb)/area_g(sp)*100< 0.5) ) THEN
6526	outflow_grid(sp,sb) = -2
6527	outflow_basin(sp,sb) = undef_int
6528	solved(sp,4) = solved(sp,4)+1
6529	IF ( debug .AND. routing_diagbox_g(sp,diaglalo) ) THEN
6530	WRITE(numout,*) "Linkup 4.0 - ", sp, sb, "becomes a coastal flow basin."
6531	ENDIF
6532	ENDIF
6533	ENDIF
6534	ELSE
6535	!
6536	! Here we are with a basin that has a hierarchy close to that of the outflow point. So
6537	! we can be more relaxed about the criteria.
6538	!
6539	IF ( nbocean >= 1 ) THEN
6540	!
6541	! These ocean points should not be too far away from the large scale direction.
6542	!
6543	IF ( wocean/nbocean < 90.0 .OR. (basin_area(sp,sb)/area_g(sp)*100< 0.5) ) THEN
6544	outflow_grid(sp,sb) = -2
6545	outflow_basin(sp,sb) = undef_int
6546	solved(sp,4) = solved(sp,4)+1
6547	IF ( debug .AND. routing_diagbox_g(sp,diaglalo) ) THEN
6548	WRITE(numout,*) "Linkup 4.0 - ", sp, sb, "becomes a coastal flow basin. Relaxed condition"
6549	ENDIF
6550	ENDIF
6551	ENDIF
6552	ENDIF
6553	!
6554	ENDIF
6555	!
6556	!
6557	ENDDO
6558	ENDDO
6559	!
6560	! 5.0
6561	!
6562	! We probably have not yet solved all points. So we go through all points and basins again
6563	! to see if we cannot find some local solution as a last resort.
6564	!
6565	!
6566	DO sp=1,nbpt
6567	!
6568	DO sb=1,basin_count(sp)
6569	!
6570	IF ( outflow_basin(sp,sb) .EQ. undef_int .AND. &
6571	& outflow_grid(sp,sb) > 0 .AND. basin_flowdir(sp,sb) > 0) THEN
6572	!
6573	! Last resort, we look if a larger basin (i.e. we already have solved !) within this grid has
6574	! a lower or the same hierarchy (within 1%).
6575	!
6576	sbint = undef_int
6577	!
6578	DO sba=1,basin_count(sp)
6579	IF ( sba .NE. sb ) THEN
6580	IF ( basin_id(sp,sb) == basin_id(sp,sba) ) THEN
6581	!
6582	! Only look for suitable hierrachy if we have a solution for the sub-basin : it has an outflow grid
6583	! and basin or flows into the ocean.
6584	!
6585	IF ( (outflow_grid(sp,sba) > 0 .AND. outflow_basin(sp,sba) < undef_int) .OR. &
6586	& outflow_grid(sp,sba) .EQ. -1 .OR. outflow_grid(sp,sba) .EQ. -2 ) THEN
6587	!
6588	! calculation of the criterion for considering that the hierarchy are close enough.
6589	! Watch out hierarchy can be zero. 1 is considered the
6590	! minimum here.
6591	crit = (basin_hierarchy(sp,sb)-basin_hierarchy(sp,sba))/(basin_hierarchy(sp,sb)+1)
6592	IF ( crit < 0.1 ) THEN
6593	sbint = sba
6594	ENDIF
6595	ENDIF
6596	ENDIF
6597	ENDIF
6598	ENDDO
6599	!
6600	! If this grid contains the lowest hierarchy of this basin ID, we can also merge without second thought.
6601	!
6602	IF ( basin_id(sp,sb) < invented_basins ) THEN
6603	IF ( sp == minhloc(basin_id(sp,sb),1) ) THEN
6604	sbint = minhloc(basin_id(sp,sb),2)
6605	ENDIF
6606	ENDIF
6607	!
6608	IF ( sbint < undef_int ) THEN
6609	basin_hierarchy(sp,sb) = basin_hierarchy(sp,sbint)
6610	CALL routing_updateflow(sp, sb, sp, sbint, nbpt, nwbas, nwbas, outflow_grid, outflow_basin, &
6611	& inflow_number, inflow_grid, inflow_basin)
6612	ENDIF
6613	!
6614	! See if we could find the same basin in this grid with a lower hierarchy
6615	!
6616	IF ( debug .AND. routing_diagbox_g(sp,diaglalo) ) THEN
6617	IF ( basin_id(sp,sb) == basin_id(sp,sba) ) THEN
6618	WRITE(numout,*) "Linkup 5.0 - In routing_linkup working on sp & sb :", sp,sb
6619	WRITE(numout,*) "Linkup 5.0 - Do we have an internal solution here :", outflow_basin(sp,sb)
6620	WRITE(numout,*) "Linkup 5.0 - ID = ", basin_id(sp,sb), basin_id(sp,sba)
6621	WRITE(numout,*) "Linkup 5.0 - H = ", basin_hierarchy(sp,sb), basin_hierarchy(sp,sba)
6622	WRITE(numout,*) "Linkup 5.0 - Area = ", basin_area(sp,sb), basin_area(sp,sba)
6623	WRITE(numout,*) "Linkup 5.0 - outflow_grid =", outflow_grid(sp,sb)
6624	WRITE(numout,*) "Linkup 5.0 - outflow_basin = ", outflow_basin(sp,sb)
6625	ENDIF
6626	ENDIF
6627	!
6628	IF ( outflow_basin(sp,sb) < undef_int ) solved(sp,5) = solved(sp,5)+1
6629	!
6630	ENDIF
6631	!
6632	ENDDO
6633	ENDDO
6634	!
6635	IF ( debug .AND. testbasinid > 0 ) THEN
6636	DO sp=1,nbpt
6637	DO sb=1,basin_count(sp)
6638	IF ( basin_id(sp,sb) == testbasinid ) THEN
6639	WRITE(numout,*) "Linkup TEST : ", basin_id(sp,sb), "@", sp, sb
6640	WRITE(numout,*) "Linkup TEST H= ", basin_hierarchy(sp,sb)
6641	WRITE(numout,*) "Linkup TEST outflow_grid ", outflow_grid(sp,sb)
6642	WRITE(numout,*) "Linkup TEST outflow_basin ", outflow_basin(sp,sb)
6643	WRITE(numout,*) "Linkup TEST basin_lshead ", basin_lshead(sp,sb)
6644	WRITE(numout,*) "Linkup TEST basin_flowdir ", basin_flowdir(sp,sb)
6645	ENDIF
6646	ENDDO
6647	ENDDO
6648	ENDIF
6649	!
6650	! 4.0 We hopefully have solved all the points but here we check it and print sole diagnostics.
6651	!
6652	WRITE(numout,*) "Linkup : Out of ", SUM(basin_count), " basins ", SUM(solved), "were resolved."
6653	DO sb=1,5
6654	WRITE(numout,) "Linkup : ",NINT(REAL(SUM(solved(:,sb)), r_std)/SUM(basin_count)100.0), &
6655	& " % of basins solved by case", sb,".0."
6656	ENDDO
6657	!
6658	DO sp=1,nbpt
6659	!
6660	DO sb=1,basin_count(sp)
6661	!
6662	! OK this is it, we give up :-)
6663	!
6664	IF ( outflow_basin(sp,sb) .EQ. undef_int .AND. &
6665	& outflow_grid(sp,sb) > 0 .AND. basin_flowdir(sp,sb) > 0 ) THEN
6666	WRITE(numout,*) 'We could not find the basin into which we need to flow, Linkup FAILED'
6667	WRITE(numout,*) 'Linkup FAILED : Grid point ', sp, ' and basin ', sb
6668	WRITE(numout,*) 'Linkup FAILED : Coordinates : ', lalo_g(sp,2), lalo_g(sp,1)
6669	WRITE(numout,*) 'Linkup FAILED : Outflow direction :', basin_flowdir(sp,sb)
6670	WRITE(numout,*) 'Linkup FAILED : Large scale outflow direction :',basin_lshead(sp,sb)
6671	WRITE(numout,*) 'Linkup FAILED : Outlfow grid :', outflow_grid(sp,sb)
6672	WRITE(numout,*) 'Linkup FAILED : Outlfow basin :',outflow_basin(sp,sb)
6673	WRITE(numout,*) 'Linkup FAILED : basin ID:',basin_id(sp,sb)
6674	WRITE(numout,*) 'Linkup FAILED : Hierarchy :', basin_hierarchy(sp,sb)
6675	CALL ipslerr_p(3,'routing_linkup', &
6676	"We could not find the basin into which we need to flow",'Try with debug=.TRUE.','stop routing_linkup')
6677	ENDIF
6678	!
6679	ENDDO
6680	!
6681	ENDDO
6682	!
6683	! Check for each outflow basin that it exists
6684	!
6685	DO sp=1,nbpt
6686	DO sb=1,basin_count(sp)
6687	!
6688	inp = outflow_grid(sp,sb)
6689	sbl = outflow_basin(sp,sb)
6690	IF ( inp .GE. 0 .AND. sbl .LE. 0 ) THEN
6691	WRITE(numout,*) 'Point :', sp, ' Basin :', sb
6692	WRITE(numout,*) 'Flows into point :', inp, ' basin :', sbl
6693	WRITE(numout,*) 'Coordinates : ', lalo_g(sp,2), lalo_g(sp,1)
6694	WRITE(numout,*) 'Why is sbl zero or less ????'
6695	CALL ipslerr_p(3,'routing_linkup','Problem with outflow','','')
6696	ENDIF
6697	!
6698	IF ( inp .GE. 0 ) THEN
6699	IF ( basin_count(inp) .LT. sbl ) THEN
6700	WRITE(numout,*) 'Point :', sp, ' Basin :', sb
6701	WRITE(numout,*) 'Flows into point :', inp, ' basin :', sbl
6702	WRITE(numout,*) 'But it flows into now here as basin count = ', basin_count(inp)
6703	!
6704	WRITE(numout,*) 'Input sub-basin :'
6705	WRITE(numout,*) 'Outflow direction :', basin_flowdir(sp,sb)
6706	WRITE(numout,*) 'Outlfow grid :', outflow_grid(sp,sb)
6707	WRITE(numout,*) 'Outlfow basin :',outflow_basin(sp,sb)
6708	WRITE(numout,*) 'Basin ID:',basin_id(sp,sb)
6709	WRITE(numout,*) 'Hierarchy :', basin_hierarchy(sp,sb)
6710	WRITE(numout,*) 'Output grid box:'
6711	WRITE(numout,*) 'Basin ID:',basin_id(inp,basin_count(inp))
6712	WRITE(numout,*) 'Hierarchy :', basin_hierarchy(inp,basin_count(inp))
6713	!
6714	CALL ipslerr_p(3,'routing_linkup','Problem with outflow','','')
6715	ENDIF
6716	ENDIF
6717	ENDDO
6718	ENDDO
6719	!
6720	END SUBROUTINE routing_linkup
6721	!
6722	!! ================================================================================================================================
6723	!! SUBROUTINE : routing_fetch
6724	!!
6725	!>\BRIEF This subroutine computes the fetch of each basin. This means that for each basin we
6726	!! will know how much area is upstream. It will help decide how to procede with the
6727	!! the truncation later and allow to set correctly in outflow_grid the distinction
6728	!! between coastal and river flow.
6729	!!
6730	!! DESCRIPTION (definitions, functional, design, flags) : None
6731	!!
6732	!! RECENT CHANGE(S): None
6733	!!
6734	!! MAIN OUTPUT VARIABLE(S):
6735	!!
6736	!! REFERENCES : None
6737	!!
6738	!! FLOWCHART : None
6739	!! \n
6740	!_ ================================================================================================================================
6741
6742	SUBROUTINE routing_fetch(nbpt, resolution, contfrac, nwbas, basin_count, basin_area, basin_id, basin_hierarchy, &
6743	& outflow_grid, outflow_basin, fetch_basin)
6744	!
6745	IMPLICIT NONE
6746	!
6747	!! INPUT VARIABLES
6748	INTEGER(i_std), INTENT(in) :: nbpt !! Domain size (unitless)
6749	!
6750	REAL(r_std), DIMENSION(nbpt,2), INTENT(in) :: resolution !! The size of each grid box in X and Y (m)
6751	REAL(r_std), DIMENSION(nbpt), INTENT(in) :: contfrac !! Fraction of land in each grid box (unitless;0-1)
6752	!
6753	INTEGER(i_std) :: nwbas !!
6754	INTEGER(i_std), DIMENSION(nbpt), INTENT(in) :: basin_count !!
6755	REAL(r_std), DIMENSION(nbpt,nwbas), INTENT(inout) :: basin_area !!
6756	INTEGER(i_std), DIMENSION(nbpt,nwbas), INTENT(in) :: basin_id !!
6757	REAL(r_std), DIMENSION(nbpt,nwbas), INTENT(in) :: basin_hierarchy
6758	INTEGER(i_std), DIMENSION(nbpt,nwbas), INTENT(inout) :: outflow_grid !! Type of outflow on the grid box (unitless)
6759	INTEGER(i_std), DIMENSION(nbpt,nwbas), INTENT(in) :: outflow_basin !!
6760	!
6761	!! OUTPUT VARIABLES
6762	REAL(r_std), DIMENSION(nbpt,nwbas), INTENT(out) :: fetch_basin !!
6763	!
6764	!! LOCAL VARIABLES
6765	INTEGER(i_std) :: ib, ij, ff(1), it, itt, igrif, ibasf, nboutflow !! Indices (unitless)
6766	REAL(r_std) :: contarea !!
6767	REAL(r_std) :: totbasins !!
6768	REAL(r_std), DIMENSION(nbpt*nbvmax) :: tmp_area !!
6769	INTEGER(i_std), DIMENSION(nbpt*nbvmax,2) :: tmpindex !!
6770
6771	!_ ================================================================================================================================
6772	!
6773	!
6774	! Normalize the area of all basins
6775	!
6776	DO ib=1,nbpt
6777	!
6778	totbasins = SUM(basin_area(ib,1:basin_count(ib)))
6779	contarea = resolution(ib,1)resolution(ib,2)contfrac(ib)
6780	!
6781	DO ij=1,basin_count(ib)
6782	basin_area(ib,ij) = basin_area(ib,ij)/totbasins*contarea
6783	ENDDO
6784	!
6785	ENDDO
6786	WRITE(numout,*) 'Normalization done'
6787	!
6788	! Compute the area upstream of each basin
6789	!
6790	fetch_basin(:,:) = zero
6791	!
6792	!
6793	DO ib=1,nbpt
6794	!
6795	DO ij=1,basin_count(ib)
6796	!
6797	fetch_basin(ib, ij) = fetch_basin(ib, ij) + basin_area(ib,ij)
6798	!
6799	igrif = outflow_grid(ib,ij)
6800	ibasf = outflow_basin(ib,ij)
6801	!
6802	itt = 0
6803	DO WHILE (igrif .GT. 0)
6804	fetch_basin(igrif,ibasf) = fetch_basin(igrif,ibasf) + basin_area(ib, ij)
6805	it = outflow_grid(igrif, ibasf)
6806	ibasf = outflow_basin(igrif, ibasf)
6807	igrif = it
6808	itt = itt + 1
6809	IF ( itt .GT. 500) THEN
6810	WRITE(numout,&
6811	"('Grid ',I5, ' and basin ',I5, 'did not converge after iteration ',I5)") ib, ij, itt
6812	WRITE(numout, "('==> We flow through grid ',I5,' and basin ',I5)") igrif, ibasf
6813	WRITE(numout,*) '==> Basin ID :', basin_id(igrif,ibasf), "Hierarchy :", basin_hierarchy(igrif,ibasf)
6814	WRITE(numout,*) "==> Coordinates : ", lalo_g(igrif,2), lalo_g(igrif,1)
6815	IF ( itt .GT. 510) THEN
6816	CALL ipslerr_p(3,'routing_fetch','Problem...','','')
6817	ENDIF
6818	ENDIF
6819	ENDDO
6820	!
6821	ENDDO
6822	!
6823	ENDDO
6824	!
6825	WRITE(numout,*) 'The smallest FETCH :', MINVAL(fetch_basin)
6826	WRITE(numout,*) 'The largest FETCH :', MAXVAL(fetch_basin)
6827	!
6828	! Now we set for the 'num_largest' largest basins the outflow condition as stream flow
6829	! (i.e. outflow_grid = -1) and all other outflow basins are set to coastal flow
6830	! (i.e. outflow_grid = -2). The return flow is not touched.
6831	!
6832	nboutflow = 0
6833	!
6834	DO ib=1,nbpt
6835	!
6836	DO ij=1,basin_count(ib)
6837	!
6838	! We do not need any more the river flow flag as we are going to reset it.
6839	!
6840	IF ( outflow_grid(ib,ij) .EQ. -1) THEN
6841	outflow_grid(ib,ij) = -2
6842	ENDIF
6843	!
6844	IF ( outflow_grid(ib,ij) .EQ. -2) THEN
6845	!
6846	nboutflow = nboutflow + 1
6847	tmp_area(nboutflow) = fetch_basin(ib,ij)
6848	tmpindex(nboutflow,1) = ib
6849	tmpindex(nboutflow,2) = ij
6850	!
6851	ENDIF
6852	!
6853	ENDDO
6854	ENDDO
6855	!
6856	DO ib=1, num_largest
6857	ff = MAXLOC(tmp_area(1:nboutflow))
6858	outflow_grid(tmpindex(ff(1),1), tmpindex(ff(1),2)) = -1
6859	tmp_area(ff(1)) = zero
6860	ENDDO
6861	!
6862	END SUBROUTINE routing_fetch
6863	!
6864	!! ================================================================================================================================
6865	!! SUBROUTINE : routing_truncate
6866	!!
6867	!>\BRIEF This subroutine reduces the number of basins per grid to the value chosen by the user.
6868	!! It also computes the final field which will be used to route the water at the
6869	!! requested truncation.
6870	!!
6871	!! DESCRIPTION (definitions, functional, design, flags) :
6872	!! Truncate if needed and find the path closest to the high resolution data.
6873	!!
6874	!! The algorithm :
6875	!!
6876	!! We only go through this procedure only as many times as there are basins to take out at most.
6877	!! This is important as it allows the simplifications to spread from one grid to the other.
6878	!! The for each step of the iteration and at each grid point we check the following options for
6879	!! simplifying the pathways of water :
6880	!! 1) If the basin of a grid flows into another basin of the same grid. Kill the one which only
6881	!! served as a transition
6882	!! 2) If in one grid box we have a number of basins which flow into the ocean as coastal flow.
6883	!! We kill the smallest one and put into the largest basin. There is no need to manage many
6884	!! basins going into the ocean as coastal flows.
6885	!! 3) If we have streams run in parallel from one gird box to the others (that is these are
6886	!! different basins) we will put the smaller one in the larger one. This may hapen at any
6887	!! level of the flow but in theory it should propagate downstream.
6888	!! 4) If we have two basins with the same ID but flow into different grid boxes we sacrifice
6889	!! the smallest one and route it through the largest.
6890	!!
6891	!! Obviously if any of the options find something then we skip the rest and take out the basin.:\n
6892	!!
6893	!! RECENT CHANGE(S): None
6894	!!
6895	!! MAIN OUTPUT VARIABLE(S):
6896	!!
6897	!! REFERENCES : None
6898	!!
6899	!! FLOWCHART : None
6900	!! \n
6901	!_ ================================================================================================================================
6902
6903	SUBROUTINE routing_truncate(nbpt, resolution, contfrac, nwbas, basin_count, basin_area, basin_topoind,&
6904	& fetch_basin, basin_id, basin_flowdir, outflow_grid, outflow_basin, inflow_number,&
6905	& inflow_grid, inflow_basin)
6906	!
6907	IMPLICIT NONE
6908	!
6909	!! PARAMETERS
6910	INTEGER(i_std), PARAMETER :: pickmax = 200 !!
6911
6912	!! INPUT VARIABLES
6913	INTEGER(i_std) :: nbpt !! Domain size (unitless)
6914	!
6915	REAL(r_std), DIMENSION(nbpt,2) :: resolution !! The size of each grid box in X and Y (m)
6916	REAL(r_std), DIMENSION(nbpt), INTENT(in) :: contfrac !! Fraction of land in each grid box (unitless;0-1)
6917	!
6918	INTEGER(i_std) :: nwbas !!
6919	INTEGER(i_std), DIMENSION(nbpt) :: basin_count !!
6920	INTEGER(i_std), DIMENSION(nbpt,nwbas) :: basin_id !!
6921	INTEGER(i_std), DIMENSION(nbpt,nwbas) :: basin_flowdir !! Water flow directions in the basin (unitless)
6922	REAL(r_std), DIMENSION(nbpt,nwbas) :: basin_area !!
6923	REAL(r_std), DIMENSION(nbpt,nwbas) :: basin_topoind !! Topographic index of the residence time for a basin (m)
6924	REAL(r_std), DIMENSION(nbpt,nwbas) :: fetch_basin !!
6925	INTEGER(i_std), DIMENSION(nbpt,nwbas) :: outflow_grid !! Type of outflow on the grid box (unitless)
6926	INTEGER(i_std), DIMENSION(nbpt,nwbas) :: outflow_basin !!
6927	INTEGER(i_std), DIMENSION(nbpt,nwbas) :: inflow_number !!
6928	INTEGER(i_std), DIMENSION(nbpt,nwbas,nwbas) :: inflow_basin !!
6929	INTEGER(i_std), DIMENSION(nbpt,nwbas,nwbas) :: inflow_grid !!
6930	!
6931	!! LOCAL VARIABLES
6932	INTEGER(i_std) :: ib, ij, ibf, ijf, igrif, ibasf, cnt, pold, bold, ff(2) !! Indices (unitless)
6933	INTEGER(i_std) :: ii, kbas, sbas, ik, iter, ibt, obj !! Indices (unitless)
6934	REAL(r_std), DIMENSION(nbpt,nbasmax) :: floflo !!
6935	REAL(r_std), DIMENSION(nbpt) :: gridarea !!
6936	REAL(r_std), DIMENSION(nbpt) :: gridbasinarea !!
6937	REAL(r_std) :: ratio !!
6938	INTEGER(i_std), DIMENSION(pickmax,2) :: largest_basins !!
6939	INTEGER(i_std), DIMENSION(pickmax) :: tmp_ids !!
6940	INTEGER(i_std) :: multbas !!
6941	INTEGER(i_std) :: iml(1) !! X resolution of the high resolution grid
6942	INTEGER(i_std), DIMENSION(pickmax) :: multbas_sz !!
6943	REAL(r_std), DIMENSION(pickmax) :: tmp_area !!
6944	INTEGER(i_std), DIMENSION(pickmax,pickmax) :: multbas_list !!
6945	!
6946	INTEGER(i_std) :: nbtruncate !!
6947	INTEGER(i_std), SAVE, ALLOCATABLE, DIMENSION(:) :: indextrunc !!
6948	!$OMP THREADPRIVATE(indextrunc)
6949
6950	!_ ================================================================================================================================
6951	!
6952	!
6953	IF ( .NOT. ALLOCATED(indextrunc)) THEN
6954	ALLOCATE(indextrunc(nbpt))
6955	ENDIF
6956	!
6957	! We have to go through the grid as least as often as we have to reduce the number of basins
6958	! For good measure we add 3 more passages.
6959	!
6960	!
6961	DO iter = 1, MAXVAL(basin_count) - nbasmax +3
6962	!
6963	! Get the points over which we wish to truncate
6964	!
6965	nbtruncate = 0
6966	DO ib = 1, nbpt
6967	IF ( basin_count(ib) .GT. nbasmax ) THEN
6968	nbtruncate = nbtruncate + 1
6969	indextrunc(nbtruncate) = ib
6970	ENDIF
6971	ENDDO
6972	!
6973	! Go through the basins which need to be truncated.
6974	!
6975	DO ibt=1,nbtruncate
6976	!
6977	ib = indextrunc(ibt)
6978	!
6979	! Check if we have basin which flows into a basin in the same grid
6980	! kbas = basin we will have to kill
6981	! sbas = basin which takes over kbas
6982	!
6983	kbas = 0
6984	sbas = 0
6985	!
6986	! 1) Can we find a basin which flows into a basin of the same grid ?
6987	!
6988	DO ij=1,basin_count(ib)
6989	DO ii=1,basin_count(ib)
6990	IF ( outflow_grid(ib,ii) .EQ. ib .AND. outflow_basin(ib, ii) .EQ. ij .AND. kbas*sbas .NE. 0) THEN
6991	kbas = ii
6992	sbas = ij
6993	ENDIF
6994	ENDDO
6995	ENDDO
6996	!
6997	! 2) Merge two basins which flow into the ocean as coastal or return flow
6998	! (outflow_grid = -2 or -3). Well obviously only if we have more than 1 and
6999	! have not found anything yet!
7000	!
7001	IF ( (COUNT(outflow_grid(ib,1:basin_count(ib)) .EQ. -2) .GT. 1 .OR.&
7002	& COUNT(outflow_grid(ib,1:basin_count(ib)) .EQ. -3) .GT. 1) .AND.&
7003	& kbas*sbas .EQ. 0) THEN
7004	!
7005	multbas = 0
7006	multbas_sz(:) = 0
7007	!
7008	IF ( COUNT(outflow_grid(ib,1:basin_count(ib)) .EQ. -2) .GT. 1 ) THEN
7009	obj = -2
7010	ELSE
7011	obj = -3
7012	ENDIF
7013	!
7014	! First we get the list of all basins which go out as coastal or return flow (obj)
7015	!
7016	DO ij=1,basin_count(ib)
7017	IF ( outflow_grid(ib,ij) .EQ. obj ) THEN
7018	multbas = multbas + 1
7019	multbas_sz(multbas) = ij
7020	tmp_area(multbas) = fetch_basin(ib,ij)
7021	ENDIF
7022	ENDDO
7023	!
7024	! Now the take the smallest to be transfered to the largest
7025	!
7026	iml = MAXLOC(tmp_area(1:multbas), MASK = tmp_area(1:multbas) .GT. zero)
7027	sbas = multbas_sz(iml(1))
7028	iml = MINLOC(tmp_area(1:multbas), MASK = tmp_area(1:multbas) .GT. zero)
7029	kbas = multbas_sz(iml(1))
7030	!
7031	ENDIF
7032	!
7033	! 3) If we have basins flowing into the same grid but different basins then we put them
7034	! together. Obviously we first work with the grid which has most streams running into it
7035	! and putting the smallest in the largests catchments.
7036	!
7037	IF ( kbas*sbas .EQ. 0) THEN
7038	!
7039	tmp_ids(1:basin_count(ib)) = outflow_grid(ib,1:basin_count(ib))
7040	multbas = 0
7041	multbas_sz(:) = 0
7042	!
7043	! First obtain the list of basins which flow into the same basin
7044	!
7045	DO ij=1,basin_count(ib)
7046	IF ( outflow_grid(ib,ij) .GT. 0 .AND.&
7047	& COUNT(tmp_ids(1:basin_count(ib)) .EQ. outflow_grid(ib,ij)) .GT. 1) THEN
7048	multbas = multbas + 1
7049	DO ii=1,basin_count(ib)
7050	IF ( tmp_ids(ii) .EQ. outflow_grid(ib,ij)) THEN
7051	multbas_sz(multbas) = multbas_sz(multbas) + 1
7052	multbas_list(multbas,multbas_sz(multbas)) = ii
7053	tmp_ids(ii) = -99
7054	ENDIF
7055	ENDDO
7056	ELSE
7057	tmp_ids(ij) = -99
7058	ENDIF
7059	ENDDO
7060	!
7061	! Did we come up with any basins to deal with this way ?
7062	!
7063	IF ( multbas .GT. 0 ) THEN
7064	!
7065	iml = MAXLOC(multbas_sz(1:multbas))
7066	ik = iml(1)
7067	!
7068	! Take the smallest and largest of these basins !
7069	!
7070	DO ii=1,multbas_sz(ik)
7071	tmp_area(ii) = fetch_basin(ib, multbas_list(ik,ii))
7072	ENDDO
7073	!
7074	iml = MAXLOC(tmp_area(1:multbas_sz(ik)), MASK = tmp_area(1:multbas_sz(ik)) .GT. zero)
7075	sbas = multbas_list(ik,iml(1))
7076	iml = MINLOC(tmp_area(1:multbas_sz(ik)), MASK = tmp_area(1:multbas_sz(ik)) .GT. zero)
7077	kbas = multbas_list(ik,iml(1))
7078	!
7079	ENDIF
7080	!
7081	ENDIF
7082	!
7083	! 4) If we have twice the same basin we put them together even if they flow into different
7084	! directions. If one of them goes to the ocean it takes the advantage.
7085	!
7086	IF ( kbas*sbas .EQ. 0) THEN
7087	!
7088	tmp_ids(1:basin_count(ib)) = basin_id(ib,1:basin_count(ib))
7089	multbas = 0
7090	multbas_sz(:) = 0
7091	!
7092	! First obtain the list of basins which have sub-basins in this grid box.
7093	! (these are identified by their IDs)
7094	!
7095	DO ij=1,basin_count(ib)
7096	IF ( COUNT(tmp_ids(1:basin_count(ib)) .EQ. basin_id(ib,ij)) .GT. 1) THEN
7097	multbas = multbas + 1
7098	DO ii=1,basin_count(ib)
7099	IF ( tmp_ids(ii) .EQ. basin_id(ib,ij)) THEN
7100	multbas_sz(multbas) = multbas_sz(multbas) + 1
7101	multbas_list(multbas,multbas_sz(multbas)) = ii
7102	tmp_ids(ii) = -99
7103	ENDIF
7104	ENDDO
7105	ELSE
7106	tmp_ids(ij) = -99
7107	ENDIF
7108	ENDDO
7109	!
7110	! We are going to work on the basin with the largest number of sub-basins.
7111	! (IF we have a basin which has subbasins !)
7112	!
7113	IF ( multbas .GT. 0 ) THEN
7114	!
7115	iml = MAXLOC(multbas_sz(1:multbas))
7116	ik = iml(1)
7117	!
7118	! If one of the basins goes to the ocean then it is going to have the priority
7119	!
7120	tmp_area(:) = zero
7121	IF ( COUNT(outflow_grid(ib,multbas_list(ik,1:multbas_sz(ik))) .LT. 0) .GT. 0) THEN
7122	DO ii=1,multbas_sz(ik)
7123	IF ( outflow_grid(ib,multbas_list(ik,ii)) .LT. 0 .AND. sbas .EQ. 0 ) THEN
7124	sbas = multbas_list(ik,ii)
7125	ELSE
7126	tmp_area(ii) = fetch_basin(ib, multbas_list(ik,ii))
7127	ENDIF
7128	ENDDO
7129	! take the smallest of the subbasins
7130	iml = MINLOC(tmp_area(1:multbas_sz(ik)), MASK = tmp_area(1:multbas_sz(ik)) .GT. zero)
7131	kbas = multbas_list(ik,iml(1))
7132	ELSE
7133	!
7134	! Else we take simply the largest and smallest
7135	!
7136	DO ii=1,multbas_sz(ik)
7137	tmp_area(ii) = fetch_basin(ib, multbas_list(ik,ii))
7138	ENDDO
7139	iml = MAXLOC(tmp_area(1:multbas_sz(ik)), MASK = tmp_area(1:multbas_sz(ik)) .GT. zero)
7140	sbas = multbas_list(ik,iml(1))
7141	iml = MINLOC(tmp_area(1:multbas_sz(ik)), MASK = tmp_area(1:multbas_sz(ik)) .GT. zero)
7142	kbas = multbas_list(ik,iml(1))
7143	!
7144	ENDIF
7145	!
7146	!
7147	ENDIF
7148	ENDIF
7149	!
7150	!
7151	!
7152	! Then we call routing_killbas to clean up the basins in this grid
7153	!
7154	IF ( kbas .GT. 0 .AND. sbas .GT. 0 ) THEN
7155	CALL routing_killbas(nbpt, ib, kbas, sbas, nwbas, basin_count, basin_area, basin_topoind,&
7156	& fetch_basin, basin_id, basin_flowdir, outflow_grid, outflow_basin, inflow_number,&
7157	& inflow_grid, inflow_basin)
7158	ENDIF
7159	!
7160	ENDDO
7161	!
7162	!
7163	ENDDO
7164	!
7165	! If there are any grids left with too many basins we need to take out the big hammer !
7166	! We will only do it if this represents less than 5% of all points.
7167	!
7168	IF ( COUNT(basin_count .GT. nbasmax) .GT. 0 ) THEN
7169	!
7170	!
7171	IF ( COUNT(basin_count .GT. nbasmax)/nbpt*100 .GT. 5 ) THEN
7172	WRITE(numout,) 'We have ', COUNT(basin_count .GT. nbasmax)/nbpt100, '% of all points which do not yet'
7173	WRITE(numout,*) 'have the right trunctaction. That is too much to apply a brutal method'
7174	DO ib = 1, nbpt
7175	IF ( basin_count(ib) .GT. nbasmax ) THEN
7176	!
7177	WRITE(numout,*) 'We did not find a basin which could be supressed. We will'
7178	WRITE(numout,*) 'not be able to reduce the truncation in grid ', ib
7179	DO ij=1,basin_count(ib)
7180	WRITE(numout,*) 'grid, basin nb and id :', ib, ij, basin_id(ib,ij)
7181	WRITE(numout,*) 'Outflow grid and basin ->', outflow_grid(ib,ij), outflow_basin(ib, ij)
7182	ENDDO
7183	ENDIF
7184	ENDDO
7185	CALL ipslerr_p(3,'routing_truncate','No basin found which could be supressed.','','')
7186	ELSE
7187	!
7188	!
7189	DO ib = 1,nbpt
7190	DO WHILE ( basin_count(ib) .GT. nbasmax )
7191	!
7192	WRITE(numout,*) 'HAMMER, ib, basin_count :', ib, basin_count(ib)
7193	!
7194	! Here we simply put the smallest basins into the largest ones. It is really a brute force
7195	! method but it will only be applied if everything has failed.
7196	!
7197	DO ii = 1,basin_count(ib)
7198	tmp_area(ii) = fetch_basin(ib, ii)
7199	ENDDO
7200	!
7201	iml = MAXLOC(tmp_area(1:basin_count(ib)), MASK = tmp_area(1:basin_count(ib)) .GT. 0.)
7202	sbas =iml(1)
7203	iml = MINLOC(tmp_area(1:basin_count(ib)), MASK = tmp_area(1:basin_count(ib)) .GT. 0.)
7204	kbas = iml(1)
7205	!
7206	IF ( kbas .GT. 0 .AND. sbas .GT. 0 ) THEN
7207	CALL routing_killbas(nbpt, ib, kbas, sbas, nwbas, basin_count, basin_area, basin_topoind,&
7208	& fetch_basin, basin_id, basin_flowdir, outflow_grid, outflow_basin, inflow_number,&
7209	& inflow_grid, inflow_basin)
7210	ENDIF
7211	ENDDO
7212	ENDDO
7213	!
7214	ENDIF
7215	!
7216	!
7217	ENDIF
7218	!
7219	! Now that we have reached the right truncation (resolution) we will start
7220	! to produce the variables we will use to route the water.
7221	!
7222	DO ib=1,nbpt
7223	!
7224	! For non existing basins the route_tobasin variable is put to zero. This will allow us
7225	! to pick up the number of basin afterwards.
7226	!
7227	route_togrid(ib,:) = ib
7228	route_tobasin(ib,:) = 0
7229	routing_area(ib,:) = zero
7230	!
7231	ENDDO
7232	!
7233	! Transfer the info into the definitive variables
7234	!
7235	DO ib=1,nbpt
7236	DO ij=1,basin_count(ib)
7237	routing_area(ib,ij) = basin_area(ib,ij)
7238	topo_resid(ib,ij) = basin_topoind(ib,ij)
7239	global_basinid(ib,ij) = basin_id(ib,ij)
7240	route_togrid(ib,ij) = outflow_grid(ib,ij)
7241	route_tobasin(ib,ij) = outflow_basin(ib,ij)
7242	ENDDO
7243	ENDDO
7244	!
7245	!
7246	! Set the new convention for the outflow conditions
7247	! Now it is based in the outflow basin and the outflow grid will
7248	! be the same as the current.
7249	! returnflow to the grid : nbasmax + 1
7250	! coastal flow : nbasmax + 2
7251	! river outflow : nbasmax + 3
7252	!
7253	! Here we put everything here in coastal flow. It is later where we will
7254	! put the largest basins into river outflow.
7255	!
7256	DO ib=1,nbpt
7257	DO ij=1,basin_count(ib)
7258	! River flows
7259	IF ( route_togrid(ib,ij) .EQ. -1 ) THEN
7260	route_tobasin(ib,ij) = nbasmax + 2
7261	route_togrid(ib,ij) = ib
7262	! Coastal flows
7263	ELSE IF ( route_togrid(ib,ij) .EQ. -2 ) THEN
7264	route_tobasin(ib,ij) = nbasmax + 2
7265	route_togrid(ib,ij) = ib
7266	! Return flow
7267	ELSE IF ( route_togrid(ib,ij) .EQ. -3 ) THEN
7268	route_tobasin(ib,ij) = nbasmax + 1
7269	route_togrid(ib,ij) = ib
7270	ENDIF
7271	ENDDO
7272	ENDDO
7273	!
7274	! A second check on the data. Just make sure that each basin flows somewhere.
7275	!
7276	DO ib=1,nbpt
7277	DO ij=1,basin_count(ib)
7278	ibf = route_togrid(ib,ij)
7279	ijf = route_tobasin(ib,ij)
7280	IF ( ijf .GT. basin_count(ibf) .AND. ijf .LE. nbasmax) THEN
7281	WRITE(numout,*) 'Second check'
7282	WRITE(numout,*) 'point :', ib, ' basin :', ij
7283	WRITE(numout,*) 'Flows into point :', ibf, ' basin :', ijf
7284	WRITE(numout,*) 'But it flows into now here as basin count = ', basin_count(ibf)
7285	CALL ipslerr_p(3,'routing_truncate','Problem with routing..','','')
7286	ENDIF
7287	ENDDO
7288	ENDDO
7289	!
7290	! Verify areas of the continents
7291	!
7292	floflo(:,:) = zero
7293	gridarea(:) = contfrac(:)resolution(:,1)resolution(:,2)
7294	DO ib=1,nbpt
7295	gridbasinarea(ib) = SUM(routing_area(ib,:))
7296	ENDDO
7297	!
7298	DO ib=1,nbpt
7299	DO ij=1,basin_count(ib)
7300	cnt = 0
7301	igrif = ib
7302	ibasf = ij
7303	DO WHILE (ibasf .LE. nbasmax .AND. cnt .LT. nbasmax*nbpt)
7304	cnt = cnt + 1
7305	pold = igrif
7306	bold = ibasf
7307	igrif = route_togrid(pold, bold)
7308	ibasf = route_tobasin(pold, bold)
7309	IF ( ibasf .GT. basin_count(igrif) .AND. ibasf .LE. nbasmax) THEN
7310	WRITE(numout,*) 'We should not be here as the basin flows into the pampa'
7311	WRITE(numout,*) 'Last correct point :', pold, bold
7312	WRITE(numout,*) 'It pointed to in the new variables :', route_togrid(pold, bold),route_tobasin(pold, bold)
7313	WRITE(numout,*) 'The old variables gave :', outflow_grid(pold, bold), outflow_basin(pold, bold)
7314	WRITE(numout,*) 'Where we ended up :', igrif,ibasf
7315	CALL ipslerr_p(3,'routing_truncate','Problem with routing..','','')
7316	ENDIF
7317	ENDDO
7318	!
7319	IF ( ibasf .GT. nbasmax ) THEN
7320	floflo(igrif,bold) = floflo(igrif,bold) + routing_area(ib,ij)
7321	ELSE
7322	WRITE(numout,*) 'The flow did not end up in the ocean or in the grid cell.'
7323	WRITE(numout,*) 'For grid ', ib, ' and basin ', ij
7324	WRITE(numout,*) 'The last grid was ', igrif, ' and basin ', ibasf
7325	CALL ipslerr_p(3,'routing_truncate','Problem with routing..','','')
7326	ENDIF
7327	ENDDO
7328	ENDDO
7329	!
7330	DO ib=1,nbpt
7331	IF ( gridbasinarea(ib) > zero ) THEN
7332	ratio = gridarea(ib)/gridbasinarea(ib)
7333	routing_area(ib,:) = routing_area(ib,:)*ratio
7334	ELSE
7335	WRITE(numout,*) 'gridbasinarea(ib) <= zero. We should stop here :', ib
7336	ENDIF
7337	ENDDO
7338	!
7339	WRITE(numout,*) 'Sum of area of all outflow areas :',SUM(routing_area)
7340	WRITE(numout,*) 'Surface of all continents :', SUM(gridarea)
7341	!
7342	! Redo the the distinction between river outflow and coastal flow. We can not
7343	! take into account the return flow points.
7344	!
7345	ibf = 0
7346	DO ib=1, pickmax
7347	ff = MAXLOC(floflo)
7348	! tdo - To take into account rivers that do not flow to the oceans
7349	IF ( route_tobasin(ff(1), ff(2)) .GT. nbasmax ) THEN
7350	! IF ( route_tobasin(ff(1), ff(2)) .EQ. nbasmax + 2) THEN
7351	ibf = ibf + 1
7352	largest_basins(ibf,:) = ff(:)
7353	ENDIF
7354	floflo(ff(1), ff(2)) = zero
7355	ENDDO
7356	!
7357	! Put the largest basins into river flows.
7358	!
7359	IF ( ibf .LT. num_largest) THEN
7360	WRITE(numout,*) 'Not enough basins to choose the ', num_largest, 'largest'
7361	CALL ipslerr_p(3,'routing_truncate','Not enough basins','','')
7362	ENDIF
7363	!
7364	!
7365	!
7366	DO ib=1, num_largest
7367	route_tobasin(largest_basins(ib,1),largest_basins(ib,2)) = nbasmax + 3
7368	ENDDO
7369	!
7370	WRITE(numout,*) 'NUMBER OF RIVERS :', COUNT(route_tobasin .GE. nbasmax + 3)
7371	!
7372	END SUBROUTINE routing_truncate
7373	!
7374	!! ================================================================================================================================
7375	!! SUBROUTINE : routing_killbas
7376	!!
7377	!>\BRIEF The aim of this subroutine is to kill a basin (that is put into another larger one).
7378	!! When we do this we need to be careful and change all associated variables.
7379	!!
7380	!! DESCRIPTION (definitions, functional, design, flags) : None
7381	!!
7382	!! RECENT CHANGE(S): None
7383	!!
7384	!! MAIN OUTPUT VARIABLE(S):
7385	!!
7386	!! REFERENCES : None
7387	!!
7388	!! FLOWCHART : None
7389	!! \n
7390	!_ ================================================================================================================================
7391
7392	SUBROUTINE routing_killbas(nbpt, ib, tokill, totakeover, nwbas, basin_count, basin_area, basin_topoind,&
7393	& fetch_basin, basin_id, basin_flowdir, outflow_grid, outflow_basin, inflow_number,&
7394	& inflow_grid, inflow_basin)
7395	!
7396	!
7397	IMPLICIT NONE
7398	!
7399	INTEGER(i_std) :: tokill !!
7400	INTEGER(i_std) :: totakeover !!
7401	INTEGER(i_std) :: nbpt !! Domain size (unitless)
7402	INTEGER(i_std) :: ib !! Current basin (unitless)
7403	!
7404	INTEGER(i_std) :: nwbas !!
7405	INTEGER(i_std), DIMENSION(nbpt) :: basin_count !!
7406	INTEGER(i_std), DIMENSION(nbpt,nwbas) :: basin_id !!
7407	INTEGER(i_std), DIMENSION(nbpt,nwbas) :: basin_flowdir !! Water flow directions in the basin (unitless)
7408	REAL(r_std), DIMENSION(nbpt,nwbas) :: basin_area !!
7409	REAL(r_std), DIMENSION(nbpt,nwbas) :: basin_topoind !! Topographic index of the residence time for a basin (m)
7410	REAL(r_std), DIMENSION(nbpt,nwbas) :: fetch_basin !!
7411	INTEGER(i_std), DIMENSION(nbpt,nwbas) :: outflow_grid !! Type of outflow on the grid box (unitless)
7412	INTEGER(i_std), DIMENSION(nbpt,nwbas) :: outflow_basin !!
7413	INTEGER(i_std), DIMENSION(nbpt,nwbas) :: inflow_number !!
7414	INTEGER(i_std), DIMENSION(nbpt,nwbas,nwbas) :: inflow_basin !!
7415	INTEGER(i_std), DIMENSION(nbpt,nwbas,nwbas) :: inflow_grid !!
7416	!
7417	!! LOCAL VARIABLES
7418	INTEGER(i_std) :: inf, ibs, ing, inb, ibasf, igrif, it !! Indices (unitless)
7419	LOGICAL :: doshift !! (true/false)
7420
7421	!_ ================================================================================================================================
7422	!
7423	! Update the information needed in the basin "totakeover"
7424	! For the moment only area
7425	!
7426	WRITE(numout,*) 'KILL BASIN :', ib, tokill, totakeover, basin_id(ib,tokill), basin_id(ib,totakeover)
7427	!
7428	!
7429	basin_area(ib, totakeover) = basin_area(ib, totakeover) + basin_area(ib, tokill)
7430	basin_topoind(ib, totakeover) = (basin_topoind(ib, totakeover) + basin_topoind(ib, tokill))/2.0
7431	!
7432	! Add the fetch of the basin will kill to the one which gets the water
7433	!
7434	fetch_basin(ib, totakeover) = fetch_basin(ib, totakeover) + fetch_basin(ib, tokill)
7435	igrif = outflow_grid(ib,totakeover)
7436	ibasf = outflow_basin(ib,totakeover)
7437	!
7438	inf = 0
7439	DO WHILE (igrif .GT. 0)
7440	fetch_basin(igrif,ibasf) = fetch_basin(igrif,ibasf) + fetch_basin(ib, tokill)
7441	it = outflow_grid(igrif, ibasf)
7442	ibasf = outflow_basin(igrif, ibasf)
7443	igrif = it
7444	inf = inf + 1
7445	ENDDO
7446	!
7447	! Take out the basin we have just rerouted from the fetch of the basins in which it used to flow.
7448	!
7449	igrif = outflow_grid(ib,tokill)
7450	ibasf = outflow_basin(ib,tokill)
7451	!
7452	DO WHILE (igrif .GT. 0)
7453	fetch_basin(igrif,ibasf) = fetch_basin(igrif,ibasf) - fetch_basin(ib, tokill)
7454	it = outflow_grid(igrif, ibasf)
7455	ibasf = outflow_basin(igrif, ibasf)
7456	igrif = it
7457	ENDDO
7458	!
7459	! Redirect the flows which went into the basin to be killed before we change everything
7460	!
7461	DO inf = 1, inflow_number(ib, tokill)
7462	outflow_basin(inflow_grid(ib, tokill, inf), inflow_basin(ib, tokill, inf)) = totakeover
7463	inflow_number(ib, totakeover) = inflow_number(ib, totakeover) + 1
7464	inflow_grid(ib, totakeover, inflow_number(ib, totakeover)) = inflow_grid(ib, tokill, inf)
7465	inflow_basin(ib, totakeover, inflow_number(ib, totakeover)) = inflow_basin(ib, tokill, inf)
7466	ENDDO
7467	!
7468	! Take out the basin to be killed from the list of inflow basins of the downstream basin
7469	! (In case the basin does not flow into an ocean or lake)
7470	!
7471	IF ( outflow_grid(ib,tokill) .GT. 0) THEN
7472	!
7473	ing = outflow_grid(ib, tokill)
7474	inb = outflow_basin(ib, tokill)
7475	doshift = .FALSE.
7476	!
7477	DO inf = 1, inflow_number(ing, inb)
7478	IF ( doshift ) THEN
7479	inflow_grid(ing, inb, inf-1) = inflow_grid(ing, inb, inf)
7480	inflow_basin(ing, inb, inf-1) = inflow_basin(ing, inb, inf)
7481	ENDIF
7482	IF ( inflow_grid(ing, inb, inf) .EQ. ib .AND. inflow_basin(ing, inb, inf) .EQ. tokill) THEN
7483	doshift = .TRUE.
7484	ENDIF
7485	ENDDO
7486	!
7487	! This is only to allow for the last check
7488	!
7489	inf = inflow_number(ing, inb)
7490	IF ( inflow_grid(ing, inb, inf) .EQ. ib .AND. inflow_basin(ing, inb, inf) .EQ. tokill) THEN
7491	doshift = .TRUE.
7492	ENDIF
7493	!
7494	IF ( .NOT. doshift ) THEN
7495	WRITE(numout,*) 'Strange we did not find the basin to kill in the downstream basin'
7496	CALL ipslerr_p(3,'routing_killbas','Basin not found','','')
7497	ENDIF
7498	inflow_number(ing, inb) = inflow_number(ing, inb) - 1
7499
7500	ENDIF
7501	!
7502	! Now remove from the arrays the information of basin "tokill"
7503	!
7504	basin_id(ib, tokill:basin_count(ib)-1) = basin_id(ib, tokill+1:basin_count(ib))
7505	basin_flowdir(ib, tokill:basin_count(ib)-1) = basin_flowdir(ib, tokill+1:basin_count(ib))
7506	basin_area(ib, tokill:basin_count(ib)-1) = basin_area(ib, tokill+1:basin_count(ib))
7507	basin_area(ib, basin_count(ib):nwbas) = zero
7508	basin_topoind(ib, tokill:basin_count(ib)-1) = basin_topoind(ib, tokill+1:basin_count(ib))
7509	basin_topoind(ib, basin_count(ib):nwbas) = zero
7510	fetch_basin(ib, tokill:basin_count(ib)-1) = fetch_basin(ib, tokill+1:basin_count(ib))
7511	fetch_basin(ib, basin_count(ib):nwbas) = zero
7512	!
7513	! Before we remove the information from the outflow fields we have to correct the corresponding inflow fields
7514	! of the grids into which the flow goes
7515	!
7516	DO ibs = tokill+1,basin_count(ib)
7517	ing = outflow_grid(ib, ibs)
7518	inb = outflow_basin(ib, ibs)
7519	IF ( ing .GT. 0 ) THEN
7520	DO inf = 1, inflow_number(ing, inb)
7521	IF ( inflow_grid(ing,inb,inf) .EQ. ib .AND. inflow_basin(ing,inb,inf) .EQ. ibs) THEN
7522	inflow_basin(ing,inb,inf) = ibs - 1
7523	ENDIF
7524	ENDDO
7525	ENDIF
7526	ENDDO
7527	outflow_grid(ib, tokill:basin_count(ib)-1) = outflow_grid(ib, tokill+1:basin_count(ib))
7528	outflow_basin(ib, tokill:basin_count(ib)-1) = outflow_basin(ib, tokill+1:basin_count(ib))
7529	!
7530	! Basins which moved down also need to redirect their incoming flows.
7531	!
7532	DO ibs=tokill+1, basin_count(ib)
7533	DO inf = 1, inflow_number(ib, ibs)
7534	outflow_basin(inflow_grid(ib, ibs, inf), inflow_basin(ib, ibs, inf)) = ibs-1
7535	ENDDO
7536	ENDDO
7537	!
7538	! Shift the inflow basins
7539	!
7540	DO it = tokill+1,basin_count(ib)
7541	inflow_grid(ib, it-1, 1:inflow_number(ib,it)) = inflow_grid(ib, it, 1:inflow_number(ib,it))
7542	inflow_basin(ib, it-1, 1:inflow_number(ib,it)) = inflow_basin(ib, it, 1:inflow_number(ib,it))
7543	inflow_number(ib,it-1) = inflow_number(ib,it)
7544	ENDDO
7545	!
7546	basin_count(ib) = basin_count(ib) - 1
7547	!
7548	END SUBROUTINE routing_killbas
7549	!
7550	!! ================================================================================================================================
7551	!! SUBROUTINE : routing_names
7552	!!
7553	!>\BRIEF This subroutine lists the name of the largest basins which are explicitly listed in the basin
7554	!! description file used by ORCHIDEE.
7555	!!
7556	!! DESCRIPTION (definitions, functional, design, flags) : None
7557	!!
7558	!! RECENT CHANGE(S): None
7559	!!
7560	!! MAIN OUTPUT VARIABLE(S):
7561	!!
7562	!! REFERENCES : None
7563	!!
7564	!! FLOWCHART : None
7565	!! \n
7566	!_ ================================================================================================================================
7567
7568	SUBROUTINE routing_names(numlar, basin_names)
7569	!
7570	IMPLICIT NONE
7571	!
7572	! Arguments
7573	!
7574	INTEGER(i_std), INTENT(in) :: numlar !!
7575	CHARACTER(LEN=*), INTENT(inout) :: basin_names(numlar) !! Name of the basins (unitless)
7576	!! PARAMETERS
7577	INTEGER(i_std), PARAMETER :: listleng=349 !!
7578	!
7579	!! LOCAL VARIABLES
7580	INTEGER(i_std) :: lenstr, i !!
7581	CHARACTER(LEN=60), DIMENSION(listleng) :: list_names !!
7582	CHARACTER(LEN=60) :: tmp_str !!
7583
7584	!_ ================================================================================================================================
7585	!
7586
7587	lenstr = LEN(basin_names(1))
7588	!
7589	list_names(1) = "Amazon"
7590	list_names(2) = "Nile"
7591	list_names(3) = "Zaire"
7592	list_names(4) = "Mississippi"
7593	list_names(5) = "Amur"
7594	list_names(6) = "Parana"
7595	list_names(7) = "Yenisei"
7596	list_names(8) = "Ob"
7597	list_names(9) = "Lena"
7598	list_names(10) = "Niger"
7599	list_names(11) = "Zambezi"
7600	list_names(12) = "Erg Iguidi (Sahara)"
7601	list_names(13) = "Chang Jiang (Yangtze)"
7602	list_names(14) = "Mackenzie"
7603	list_names(15) = "Ganges"
7604	list_names(16) = "Chari"
7605	list_names(17) = "Volga"
7606	list_names(18) = "St. Lawrence"
7607	list_names(19) = "Indus"
7608	list_names(20) = "Syr-Darya"
7609	list_names(21) = "Nelson"
7610	list_names(22) = "Orinoco"
7611	list_names(23) = "Murray"
7612	list_names(24) = "Great Artesian Basin"
7613	list_names(25) = "Shatt el Arab"
7614	list_names(26) = "Orange"
7615	list_names(27) = "Huang He"
7616	list_names(28) = "Yukon"
7617	list_names(29) = "Senegal"
7618	list_names(30) = "Chott Jerid"
7619	list_names(31) = "Jubba"
7620	list_names(32) = "Colorado (Ari)"
7621	list_names(33) = "Rio Grande (US)"
7622	list_names(34) = "Danube"
7623	list_names(35) = "Mekong"
7624	list_names(36) = "Tocantins"
7625	list_names(37) = "Wadi al Farigh"
7626	list_names(38) = "Tarim"
7627	list_names(39) = "Columbia"
7628	list_names(40) = "Komadugu Yobe (Tchad)"
7629	list_names(41) = "Kolyma"
7630	list_names(42) = "Sao Francisco"
7631	list_names(43) = "Amu-Darya"
7632	list_names(44) = "GHAASBasin51"
7633	list_names(45) = "Dnepr"
7634	list_names(46) = "GHAASBasin61"
7635	list_names(47) = "Don"
7636	list_names(48) = "Colorado (Arg)"
7637	list_names(49) = "Limpopo"
7638	list_names(50) = "GHAASBasin50"
7639	list_names(51) = "Zhujiang"
7640	list_names(52) = "Irrawaddy"
7641	list_names(53) = "Volta"
7642	list_names(54) = "GHAASBasin54"
7643	list_names(55) = "Farah"
7644	list_names(56) = "Khatanga"
7645	list_names(57) = "Dvina"
7646	list_names(58) = "Urugay"
7647	list_names(59) = "Qarqan"
7648	list_names(60) = "GHAASBasin75"
7649	list_names(61) = "Parnaiba"
7650	list_names(62) = "GHAASBasin73"
7651	list_names(63) = "Indigirka"
7652	list_names(64) = "Churchill (Hud)"
7653	list_names(65) = "Godavari"
7654	list_names(66) = "Pur - Taz"
7655	list_names(67) = "Pechora"
7656	list_names(68) = "Baker"
7657	list_names(69) = "Ural"
7658	list_names(70) = "Neva"
7659	list_names(71) = "Liao"
7660	list_names(72) = "Salween"
7661	list_names(73) = "GHAASBasin73"
7662	list_names(74) = "Jordan"
7663	list_names(75) = "GHAASBasin78"
7664	list_names(76) = "Magdalena"
7665	list_names(77) = "Krishna"
7666	list_names(78) = "Salado"
7667	list_names(79) = "Fraser"
7668	list_names(80) = "Hai Ho"
7669	list_names(81) = "Huai"
7670	list_names(82) = "Yana"
7671	list_names(83) = "GHAASBasin95"
7672	list_names(84) = "GHAASBasin105"
7673	list_names(85) = "Kura"
7674	list_names(86) = "Olenek"
7675	list_names(87) = "Ogooue"
7676	list_names(88) = "Taymyr"
7677	list_names(89) = "Negro Arg"
7678	list_names(90) = "Chubut"
7679	list_names(91) = "GHAASBasin91"
7680	list_names(92) = "GHAASBasin122"
7681	list_names(93) = "GHAASBasin120"
7682	list_names(94) = "Sacramento"
7683	list_names(95) = "Fitzroy West"
7684	list_names(96) = "Grande de Santiago"
7685	list_names(97) = "Rufiji"
7686	list_names(98) = "Wisla"
7687	list_names(99) = "GHAASBasin47"
7688	list_names(100) = "GHAASBasin127"
7689	list_names(101) = "Hong"
7690	list_names(102) = "GHAASBasin97"
7691	list_names(103) = "Swan-Avon"
7692	list_names(104) = "Rhine"
7693	list_names(105) = "Cuanza"
7694	list_names(106) = "GHAASBasin106"
7695	list_names(107) = "GHAASBasin142"
7696	list_names(108) = "Roviuna"
7697	list_names(109) = "Essequibo"
7698	list_names(110) = "Elbe"
7699	list_names(111) = "Koksoak"
7700	list_names(112) = "Chao Phraya"
7701	list_names(113) = "Brahmani"
7702	list_names(114) = "GHAASBasin165"
7703	list_names(115) = "Pyasina"
7704	list_names(116) = "Fitzroy East"
7705	list_names(117) = "GHAASBasin173"
7706	list_names(118) = "Albany"
7707	list_names(119) = "Sanaga"
7708	list_names(120) = "GHAASBasin120"
7709	list_names(121) = "GHAASBasin178"
7710	list_names(122) = "GHAASBasin148"
7711	list_names(123) = "Brazos (Tex)"
7712	list_names(124) = "GHAASBasin124"
7713	list_names(125) = "Alabama"
7714	list_names(126) = "GHAASBasin174"
7715	list_names(127) = "GHAASBasin179"
7716	list_names(128) = "Balsas"
7717	list_names(129) = "GHAASBasin172"
7718	list_names(130) = "Burdekin"
7719	list_names(131) = "Colorado (Texas)"
7720	list_names(132) = "GHAASBasin150"
7721	list_names(133) = "Odra"
7722	list_names(134) = "Loire"
7723	list_names(135) = "GHAASBasin98"
7724	list_names(136) = "Galana"
7725	list_names(137) = "Kuskowin"
7726	list_names(138) = "Moose"
7727	list_names(139) = "Narmada"
7728	list_names(140) = "GHAASBasin140"
7729	list_names(141) = "GHAASBasin141"
7730	list_names(142) = "Flinders"
7731	list_names(143) = "Kizil Irmak"
7732	list_names(144) = "GHAASBasin144"
7733	list_names(145) = "Save"
7734	list_names(146) = "Roper"
7735	list_names(147) = "Churchill (Atlantic)"
7736	list_names(148) = "GHAASBasin148"
7737	list_names(149) = "Victoria"
7738	list_names(150) = "Back"
7739	list_names(151) = "Bandama"
7740	list_names(152) = "Severn (Can)"
7741	list_names(153) = "Po"
7742	list_names(154) = "GHAASBasin154"
7743	list_names(155) = "GHAASBasin155"
7744	list_names(156) = "GHAASBasin156"
7745	list_names(157) = "Rhone"
7746	list_names(158) = "Tana (Ken)"
7747	list_names(159) = "La Grande"
7748	list_names(160) = "GHAASBasin160"
7749	list_names(161) = "Cunene"
7750	list_names(162) = "Douro"
7751	list_names(163) = "GHAASBasin163"
7752	list_names(164) = "Nemanus"
7753	list_names(165) = "GHAASBasin165"
7754	list_names(166) = "Anabar"
7755	list_names(167) = "Hayes"
7756	list_names(168) = "Mearim"
7757	list_names(169) = "GHAASBasin169"
7758	list_names(170) = "Panuco"
7759	list_names(171) = "GHAASBasin171"
7760	list_names(172) = "Doce"
7761	list_names(173) = "Gasgoyne"
7762	list_names(174) = "GHAASBasin174"
7763	list_names(175) = "GHAASBasin175"
7764	list_names(176) = "Ashburton"
7765	list_names(177) = "GHAASBasin177"
7766	list_names(178) = "Peel"
7767	list_names(179) = "Daugava"
7768	list_names(180) = "GHAASBasin180"
7769	list_names(181) = "Ebro"
7770	list_names(182) = "Comoe"
7771	list_names(183) = "Jacui"
7772	list_names(184) = "GHAASBasin184"
7773	list_names(185) = "Kapuas"
7774	list_names(186) = "GHAASBasin186"
7775	list_names(187) = "Penzhina"
7776	list_names(188) = "Cauweri"
7777	list_names(189) = "GHAASBasin189"
7778	list_names(190) = "Mamberamo"
7779	list_names(191) = "Sepik"
7780	list_names(192) = "GHAASBasin192"
7781	list_names(193) = "Sassandra"
7782	list_names(194) = "GHAASBasin194"
7783	list_names(195) = "GHAASBasin195"
7784	list_names(196) = "Nottaway"
7785	list_names(197) = "Barito"
7786	list_names(198) = "GHAASBasin198"
7787	list_names(199) = "Seine"
7788	list_names(200) = "Tejo"
7789	list_names(201) = "GHAASBasin201"
7790	list_names(202) = "Gambia"
7791	list_names(203) = "Susquehanna"
7792	list_names(204) = "Dnestr"
7793	list_names(205) = "Murchinson"
7794	list_names(206) = "Deseado"
7795	list_names(207) = "Mitchell"
7796	list_names(208) = "Mahakam"
7797	list_names(209) = "GHAASBasin209"
7798	list_names(210) = "Pangani"
7799	list_names(211) = "GHAASBasin211"
7800	list_names(212) = "GHAASBasin212"
7801	list_names(213) = "GHAASBasin213"
7802	list_names(214) = "GHAASBasin214"
7803	list_names(215) = "GHAASBasin215"
7804	list_names(216) = "Bug"
7805	list_names(217) = "GHAASBasin217"
7806	list_names(218) = "Usumacinta"
7807	list_names(219) = "Jequitinhonha"
7808	list_names(220) = "GHAASBasin220"
7809	list_names(221) = "Corantijn"
7810	list_names(222) = "Fuchun Jiang"
7811	list_names(223) = "Copper"
7812	list_names(224) = "Tapti"
7813	list_names(225) = "Menjiang"
7814	list_names(226) = "Karun"
7815	list_names(227) = "Mezen"
7816	list_names(228) = "Guadiana"
7817	list_names(229) = "Maroni"
7818	list_names(230) = "GHAASBasin230"
7819	list_names(231) = "Uda"
7820	list_names(232) = "GHAASBasin232"
7821	list_names(233) = "Kuban"
7822	list_names(234) = "Colville"
7823	list_names(235) = "Thaane"
7824	list_names(236) = "Alazeya"
7825	list_names(237) = "Paraiba do Sul"
7826	list_names(238) = "GHAASBasin238"
7827	list_names(239) = "Fortesque"
7828	list_names(240) = "GHAASBasin240"
7829	list_names(241) = "GHAASBasin241"
7830	list_names(242) = "Winisk"
7831	list_names(243) = "GHAASBasin243"
7832	list_names(244) = "GHAASBasin244"
7833	list_names(245) = "Ikopa"
7834	list_names(246) = "Gilbert"
7835	list_names(247) = "Kouilou"
7836	list_names(248) = "Fly"
7837	list_names(249) = "GHAASBasin249"
7838	list_names(250) = "GHAASBasin250"
7839	list_names(251) = "GHAASBasin251"
7840	list_names(252) = "Mangoky"
7841	list_names(253) = "Damodar"
7842	list_names(254) = "Onega"
7843	list_names(255) = "Moulouya"
7844	list_names(256) = "GHAASBasin256"
7845	list_names(257) = "Ord"
7846	list_names(258) = "GHAASBasin258"
7847	list_names(259) = "GHAASBasin259"
7848	list_names(260) = "GHAASBasin260"
7849	list_names(261) = "GHAASBasin261"
7850	list_names(262) = "Narva"
7851	list_names(263) = "GHAASBasin263"
7852	list_names(264) = "Seal"
7853	list_names(265) = "Cheliff"
7854	list_names(266) = "Garonne"
7855	list_names(267) = "Rupert"
7856	list_names(268) = "GHAASBasin268"
7857	list_names(269) = "Brahmani"
7858	list_names(270) = "Sakarya"
7859	list_names(271) = "Gourits"
7860	list_names(272) = "Sittang"
7861	list_names(273) = "Rajang"
7862	list_names(274) = "Evros"
7863	list_names(275) = "Appalachicola"
7864	list_names(276) = "Attawapiskat"
7865	list_names(277) = "Lurio"
7866	list_names(278) = "Daly"
7867	list_names(279) = "Penner"
7868	list_names(280) = "GHAASBasin280"
7869	list_names(281) = "GHAASBasin281"
7870	list_names(282) = "Guadalquivir"
7871	list_names(283) = "Nadym"
7872	list_names(284) = "GHAASBasin284"
7873	list_names(285) = "Saint John"
7874	list_names(286) = "GHAASBasin286"
7875	list_names(287) = "Cross"
7876	list_names(288) = "Omoloy"
7877	list_names(289) = "Oueme"
7878	list_names(290) = "GHAASBasin290"
7879	list_names(291) = "Gota"
7880	list_names(292) = "Nueces"
7881	list_names(293) = "Stikine"
7882	list_names(294) = "Yalu"
7883	list_names(295) = "Arnaud"
7884	list_names(296) = "GHAASBasin296"
7885	list_names(297) = "Jequitinhonha"
7886	list_names(298) = "Kamchatka"
7887	list_names(299) = "GHAASBasin299"
7888	list_names(300) = "Grijalva"
7889	list_names(301) = "GHAASBasin301"
7890	list_names(302) = "Kemijoki"
7891	list_names(303) = "Olifants"
7892	list_names(304) = "GHAASBasin304"
7893	list_names(305) = "Tsiribihina"
7894	list_names(306) = "Coppermine"
7895	list_names(307) = "GHAASBasin307"
7896	list_names(308) = "GHAASBasin308"
7897	list_names(309) = "Kovda"
7898	list_names(310) = "Trinity"
7899	list_names(311) = "Glama"
7900	list_names(312) = "GHAASBasin312"
7901	list_names(313) = "Luan"
7902	list_names(314) = "Leichhardt"
7903	list_names(315) = "GHAASBasin315"
7904	list_names(316) = "Gurupi"
7905	list_names(317) = "GR Baleine"
7906	list_names(318) = "Aux Feuilles"
7907	list_names(319) = "GHAASBasin319"
7908	list_names(320) = "Weser"
7909	list_names(321) = "GHAASBasin321"
7910	list_names(322) = "GHAASBasin322"
7911	list_names(323) = "Yesil"
7912	list_names(324) = "Incomati"
7913	list_names(325) = "GHAASBasin325"
7914	list_names(326) = "GHAASBasin326"
7915	list_names(327) = "Pungoe"
7916	list_names(328) = "GHAASBasin328"
7917	list_names(329) = "Meuse"
7918	list_names(330) = "Eastmain"
7919	list_names(331) = "Araguari"
7920	list_names(332) = "Hudson"
7921	list_names(333) = "GHAASBasin333"
7922	list_names(334) = "GHAASBasin334"
7923	list_names(335) = "GHAASBasin335"
7924	list_names(336) = "GHAASBasin336"
7925	list_names(337) = "Kobuk"
7926	list_names(338) = "Altamaha"
7927	list_names(339) = "GHAASBasin339"
7928	list_names(340) = "Mand"
7929	list_names(341) = "Santee"
7930	list_names(342) = "GHAASBasin342"
7931	list_names(343) = "GHAASBasin343"
7932	list_names(344) = "GHAASBasin344"
7933	list_names(345) = "Hari"
7934	list_names(346) = "GHAASBasin346"
7935	list_names(347) = "Wami"
7936	list_names(348) = "GHAASBasin348"
7937	list_names(349) = "GHAASBasin349"
7938	!
7939	basin_names(:) = ' '
7940	!
7941	DO i=1,numlar
7942	tmp_str = list_names(i)
7943	basin_names(i) = tmp_str(1:MIN(lenstr,LEN_TRIM(tmp_str)))
7944	ENDDO
7945	!
7946	END SUBROUTINE routing_names
7947	!
7948	!! ================================================================================================================================
7949	!! SUBROUTINE : routing_irrigmap
7950	!!
7951	!>\BRIEF This subroutine interpolates the 0.5x0.5 degree based map of irrigated areas to the resolution of the model.
7952	!!
7953	!! DESCRIPTION (definitions, functional, design, flags) : None
7954	!!
7955	!! RECENT CHANGE(S): None
7956	!!
7957	!! MAIN OUTPUT VARIABLE(S):
7958	!!
7959	!! REFERENCES : None
7960	!!
7961	!! FLOWCHART : None
7962	!! \n
7963	!_ ================================================================================================================================
7964
7965	SUBROUTINE routing_irrigmap (nbpt, index, lalo, neighbours, resolution, contfrac, &
7966	& init_irrig, irrigated, init_flood, floodplains, init_swamp, swamp, hist_id, hist2_id)
7967	!
7968	IMPLICIT NONE
7969	!
7970	!! PARAMETERS
7971	INTEGER(i_std), PARAMETER :: ilake = 1 !! Number of type of lakes area (unitless)
7972	INTEGER(i_std), PARAMETER :: idam = 2 !! Number of type of dams area (unitless)
7973	INTEGER(i_std), PARAMETER :: iflood = 3 !! Number of type of floodplains area (unitless)
7974	INTEGER(i_std), PARAMETER :: iswamp = 4 !! Number of type of swamps area (unitless)
7975	INTEGER(i_std), PARAMETER :: isal = 5 !! Number of type of salines area (unitless)
7976	INTEGER(i_std), PARAMETER :: ipond = 6 !! Number of type of ponds area (unitless)
7977	INTEGER(i_std), PARAMETER :: ntype = 6 !! Number of types of flooded surfaces (unitless)
7978
7979	!! INPUT VARIABLES
7980	INTEGER(i_std), INTENT(in) :: nbpt !! Domain size (unitless)
7981	INTEGER(i_std), INTENT(in) :: index(nbpt) !! Index on the global map.
7982	REAL(r_std), INTENT(in) :: lalo(nbpt,2) !! Vector of latitude and longitudes (beware of the order !)
7983	INTEGER(i_std), INTENT(in) :: neighbours(nbpt,NbNeighb)!! Vector of neighbours for each grid point
7984	REAL(r_std), INTENT(in) :: resolution(nbpt,2) !! The size of each grid box in X and Y (m)
7985	REAL(r_std), INTENT(in) :: contfrac(nbpt) !! Fraction of land in each grid box (unitless;0-1)
7986	INTEGER(i_std), INTENT(in) :: hist_id !! Access to history file (unitless)
7987	INTEGER(i_std), INTENT(in) :: hist2_id !! Access to history file 2 (unitless)
7988	LOGICAL, INTENT(in) :: init_irrig !! Logical to initialize the irrigation (true/false)
7989	LOGICAL, INTENT(in) :: init_flood !! Logical to initialize the floodplains (true/false)
7990	LOGICAL, INTENT(in) :: init_swamp !! Logical to initialize the swamps (true/false)
7991	!
7992	!! OUTPUT VARIABLES
7993	REAL(r_std), INTENT(out) :: irrigated(:) !! Irrigated surface in each grid box (m^2)
7994	REAL(r_std), INTENT(out) :: floodplains(:) !! Surface which can be inundated in each grid box (m^2)
7995	REAL(r_std), INTENT(out) :: swamp(:) !! Surface which can be swamp in each grid box (m^2)
7996	!
7997	!! LOCAL VARIABLES
7998	! Interpolation variables
7999	!
8000	INTEGER(i_std) :: nbpmax, nix, njx, fopt !!
8001	CHARACTER(LEN=30) :: callsign !!
8002	REAL(r_std), ALLOCATABLE, DIMENSION(:,:,:) :: resol_lu !! Resolution read on the map
8003	INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:) :: mask !! Mask to exclude some points (unitless)
8004	REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: irrsub_area !! Area on the fine grid (m^2)
8005	INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:,:) :: irrsub_index !! Indices of the points we need on the fine grid (unitless)
8006	INTEGER :: ALLOC_ERR !!
8007	LOGICAL :: ok_interpol = .FALSE. !! Flag for interpolation (true/false)
8008	!
8009	CHARACTER(LEN=80) :: filename !! Name of the netcdf file (unitless)
8010	INTEGER(i_std) :: iml, jml, lml, tml, fid, ib, ip, jp, itype !! Indices (unitless)
8011	REAL(r_std) :: lev(1), date, dt, coslat !!
8012	INTEGER(i_std) :: itau(1) !!
8013	REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: latrel !! Latitude
8014	REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: lonrel !! Longitude
8015	REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: irrigated_frac !! Irrigated fraction of the grid box (unitless;0-1)
8016	REAL(r_std), ALLOCATABLE, DIMENSION(:,:,:) :: flood_fracmax !! Maximal flooded fraction of the grid box (unitless;0-1)
8017	REAL(r_std) :: area_irrig !! Irrigated surface in the grid box (m^2)
8018	REAL(r_std) :: area_flood(ntype) !! Flooded surface in the grid box (m^2)
8019	!!$ REAL(r_std) :: irrigmap(nbpt)
8020	!!$ REAL(r_std) :: floodmap(nbpt)
8021	!!$ REAL(r_std) :: swampmap(nbpt)
8022
8023	!_ ================================================================================================================================
8024
8025	!
8026	!Config Key = IRRIGATION_FILE
8027	!Config Desc = Name of file which contains the map of irrigated areas
8028	!Config Def = floodplains.nc
8029	!Config If = DO_IRRIGATION OR DO_FLOODPLAINS
8030	!Config Help = The name of the file to be opened to read the field
8031	!Config with the area in m^2 of the area irrigated within each
8032	!Config 0.5 0.5 deg grid box. The map currently used is the one
8033	!Config developed by the Center for Environmental Systems Research
8034	!Config in Kassel (1995).
8035	!Config Units = [FILE]
8036	!
8037	filename = 'floodplains.nc'
8038	CALL getin_p('IRRIGATION_FILE',filename)
8039	!
8040	IF (is_root_prc) THEN
8041	CALL flininfo(filename,iml, jml, lml, tml, fid)
8042	CALL flinclo(fid)
8043	ELSE
8044	iml = 0
8045	jml = 0
8046	lml = 0
8047	tml = 0
8048	ENDIF
8049	!
8050	CALL bcast(iml)
8051	CALL bcast(jml)
8052	CALL bcast(lml)
8053	CALL bcast(tml)
8054	!
8055	!
8056	!
8057	ALLOCATE (latrel(iml,jml), STAT=ALLOC_ERR)
8058	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_irrigmap','Pb in allocate for latrel','','')
8059
8060	ALLOCATE (lonrel(iml,jml), STAT=ALLOC_ERR)
8061	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_irrigmap','Pb in allocate for lonrel','','')
8062
8063	ALLOCATE (irrigated_frac(iml,jml), STAT=ALLOC_ERR)
8064	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_irrigmap','Pb in allocate for irrigated_frac','','')
8065
8066	ALLOCATE (flood_fracmax(iml,jml,ntype), STAT=ALLOC_ERR)
8067	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_irrigmap','Pb in allocate for flood_fracmax','','')
8068
8069	IF (is_root_prc) CALL flinopen(filename, .FALSE., iml, jml, lml, lonrel, latrel, lev, tml, itau, date, dt, fid)
8070
8071	CALL bcast(lonrel)
8072	CALL bcast(latrel)
8073	!
8074	IF (is_root_prc) CALL flinget(fid, 'irrig', iml, jml, lml, tml, 1, 1, irrigated_frac)
8075	CALL bcast(irrigated_frac)
8076	IF (is_root_prc) CALL flinget(fid, 'lake', iml, jml, lml, tml, 1, 1, flood_fracmax(:,:,ilake))
8077	IF (is_root_prc) CALL flinget(fid, 'dam', iml, jml, lml, tml, 1, 1, flood_fracmax(:,:,idam))
8078	IF (is_root_prc) CALL flinget(fid, 'flood', iml, jml, lml, tml, 1, 1, flood_fracmax(:,:,iflood))
8079	IF (is_root_prc) CALL flinget(fid, 'swamp', iml, jml, lml, tml, 1, 1, flood_fracmax(:,:,iswamp))
8080	IF (is_root_prc) CALL flinget(fid, 'saline', iml, jml, lml, tml, 1, 1, flood_fracmax(:,:,isal))
8081	CALL bcast(flood_fracmax)
8082	!
8083	IF (is_root_prc) CALL flinclo(fid)
8084	!
8085	! Set to zero all fraction which are less than 0.5%
8086	!
8087	DO ip=1,iml
8088	DO jp=1,jml
8089	!
8090	IF ( irrigated_frac(ip,jp) .LT. undef_sechiba-un) THEN
8091	irrigated_frac(ip,jp) = irrigated_frac(ip,jp)/100.
8092	IF ( irrigated_frac(ip,jp) < 0.005 ) irrigated_frac(ip,jp) = zero
8093	ENDIF
8094	!
8095	DO itype=1,ntype
8096	IF ( flood_fracmax(ip,jp,itype) .LT. undef_sechiba-1.) THEN
8097	flood_fracmax(ip,jp,itype) = flood_fracmax(ip,jp,itype)/100
8098	IF ( flood_fracmax(ip,jp,itype) < 0.005 ) flood_fracmax(ip,jp,itype) = zero
8099	ENDIF
8100	ENDDO
8101	!
8102	ENDDO
8103	ENDDO
8104	!
8105	WRITE(numout,*) 'lonrel : ', MAXVAL(lonrel), MINVAL(lonrel)
8106	WRITE(numout,*) 'latrel : ', MAXVAL(latrel), MINVAL(latrel)
8107	WRITE(numout,*) 'irrigated_frac : ', MINVAL(irrigated_frac, MASK=irrigated_frac .GT. 0), &
8108	& MAXVAL(irrigated_frac, MASK=irrigated_frac .LT. undef_sechiba)
8109	WRITE(numout,*) 'flood_fracmax : ', MINVAL(flood_fracmax, MASK=flood_fracmax .GT. 0), &
8110	& MAXVAL(flood_fracmax, MASK=flood_fracmax .LT. undef_sechiba)
8111	!
8112	! Consider all points a priori
8113	!
8114	ALLOCATE(resol_lu(iml,jml,2), STAT=ALLOC_ERR)
8115	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_irrigmap','Pb in allocate for resol_lu','','')
8116
8117	ALLOCATE(mask(iml,jml), STAT=ALLOC_ERR)
8118	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_irrigmap','Pb in allocate for mask','','')
8119	mask(:,:) = 0
8120
8121	DO ip=1,iml
8122	DO jp=1,jml
8123	!
8124	! Exclude the points where we are close to the missing value.
8125	!
8126	!MG This condition cannot be applied in floodplains/swamps configuration because
8127	! the same mask would be used for the interpolation of irrigation, floodplains and swamps maps.
8128	! IF ( irrigated_frac(ip,jp) < undef_sechiba ) THEN
8129	mask(ip,jp) = 1
8130	! ENDIF
8131	!
8132	! Resolution in longitude
8133	!
8134	coslat = MAX( COS( latrel(ip,jp) * pi/180. ), mincos )
8135	IF ( ip .EQ. 1 ) THEN
8136	resol_lu(ip,jp,1) = ABS( lonrel(ip+1,jp) - lonrel(ip,jp) ) * pi/180. * R_Earth * coslat
8137	ELSEIF ( ip .EQ. iml ) THEN
8138	resol_lu(ip,jp,1) = ABS( lonrel(ip,jp) - lonrel(ip-1,jp) ) * pi/180. * R_Earth * coslat
8139	ELSE
8140	resol_lu(ip,jp,1) = ABS( lonrel(ip+1,jp) - lonrel(ip-1,jp) )/2. * pi/180. * R_Earth * coslat
8141	ENDIF
8142	!
8143	! Resolution in latitude
8144	!
8145	IF ( jp .EQ. 1 ) THEN
8146	resol_lu(ip,jp,2) = ABS( latrel(ip,jp) - latrel(ip,jp+1) ) * pi/180. * R_Earth
8147	ELSEIF ( jp .EQ. jml ) THEN
8148	resol_lu(ip,jp,2) = ABS( latrel(ip,jp-1) - latrel(ip,jp) ) * pi/180. * R_Earth
8149	ELSE
8150	resol_lu(ip,jp,2) = ABS( latrel(ip,jp-1) - latrel(ip,jp+1) )/2. * pi/180. * R_Earth
8151	ENDIF
8152	!
8153	ENDDO
8154	ENDDO
8155	!
8156	! The number of maximum vegetation map points in the GCM grid is estimated.
8157	! Some lmargin is taken.
8158	!
8159	callsign = 'Irrigation map'
8160	ok_interpol = .FALSE.
8161	IF (is_root_prc) THEN
8162	nix=INT(MAXVAL(resolution_g(:,1))/MAXVAL(resol_lu(:,:,1)))+2
8163	njx=INT(MAXVAL(resolution_g(:,2))/MAXVAL(resol_lu(:,:,2)))+2
8164	nbpmax = nixnjx2
8165	WRITE(numout,*) "Projection arrays for ",callsign," : "
8166	WRITE(numout,*) "nbpmax = ",nbpmax, nix, njx
8167	ENDIF
8168	CALL bcast(nbpmax)
8169
8170	ALLOCATE(irrsub_index(nbpt, nbpmax, 2), STAT=ALLOC_ERR)
8171	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_irrigmap','Pb in allocate for irrsub_index','','')
8172	irrsub_index(:,:,:)=0
8173
8174	ALLOCATE(irrsub_area(nbpt, nbpmax), STAT=ALLOC_ERR)
8175	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_irrigmap','Pb in allocate for irrsub_area','','')
8176	irrsub_area(:,:)=zero
8177
8178	CALL aggregate_p(nbpt, lalo, neighbours, resolution, contfrac, &
8179	& iml, jml, lonrel, latrel, mask, callsign, &
8180	& nbpmax, irrsub_index, irrsub_area, ok_interpol)
8181	!
8182	!
8183	WHERE (irrsub_area < 0) irrsub_area=zero
8184	!
8185	! Test here if not all sub_area are larger than 0 if so, then we need to increase nbpmax
8186	!
8187	DO ib=1,nbpt
8188	!
8189	area_irrig = 0.0
8190	area_flood = 0.0
8191	!
8192	DO fopt=1,COUNT(irrsub_area(ib,:) > zero)
8193	!
8194	ip = irrsub_index(ib, fopt, 1)
8195	jp = irrsub_index(ib, fopt, 2)
8196	!
8197	IF (irrigated_frac(ip,jp) .LT. undef_sechiba-1.) THEN
8198	area_irrig = area_irrig + irrsub_area(ib,fopt)*irrigated_frac(ip,jp)
8199	ENDIF
8200	!
8201	DO itype=1,ntype
8202	IF (flood_fracmax(ip,jp,itype) .LT. undef_sechiba-1.) THEN
8203	area_flood(itype) = area_flood(itype) + irrsub_area(ib,fopt)*flood_fracmax(ip,jp,itype)
8204	ENDIF
8205	ENDDO
8206	ENDDO
8207	!
8208	! Put the total irrigated and flooded areas in the output variables
8209	!
8210	IF ( init_irrig ) THEN
8211	irrigated(ib) = MIN(area_irrig, resolution(ib,1)resolution(ib,2)contfrac(ib))
8212	IF ( irrigated(ib) < 0 ) THEN
8213	WRITE(numout,*) 'We have a problem here : ', irrigated(ib)
8214	WRITE(numout,*) 'resolution :', resolution(ib,1), resolution(ib,2)
8215	WRITE(numout,*) area_irrig
8216	CALL ipslerr_p(3,'routing_irrigmap','Problem with irrigated...','','')
8217	ENDIF
8218	!!$ ! Compute a diagnostic of the map.
8219	!!$ IF(contfrac(ib).GT.zero) THEN
8220	!!$ irrigmap (ib) = irrigated(ib) / ( resolution(ib,1)resolution(ib,2)contfrac(ib) )
8221	!!$ ELSE
8222	!!$ irrigmap (ib) = zero
8223	!!$ ENDIF
8224	!
8225	ENDIF
8226	!
8227	IF ( init_flood ) THEN
8228	floodplains(ib) = MIN(area_flood(iflood)+area_flood(idam)+area_flood(isal), &
8229	& resolution(ib,1)resolution(ib,2)contfrac(ib))
8230	IF ( floodplains(ib) < 0 ) THEN
8231	WRITE(numout,*) 'We have a problem here : ', floodplains(ib)
8232	WRITE(numout,*) 'resolution :', resolution(ib,1), resolution(ib,2)
8233	WRITE(numout,*) area_flood
8234	CALL ipslerr_p(3,'routing_irrigmap','Problem with floodplains..','','')
8235	ENDIF
8236	!!$ ! Compute a diagnostic of the map.
8237	!!$ IF(contfrac(ib).GT.zero) THEN
8238	!!$ floodmap(ib) = floodplains(ib) / ( resolution(ib,1)resolution(ib,2)contfrac(ib) )
8239	!!$ ELSE
8240	!!$ floodmap(ib) = 0.0
8241	!!$ ENDIF
8242	ENDIF
8243	!
8244	IF ( init_swamp ) THEN
8245	swamp(ib) = MIN(area_flood(iswamp), resolution(ib,1)resolution(ib,2)contfrac(ib))
8246	IF ( swamp(ib) < 0 ) THEN
8247	WRITE(numout,*) 'We have a problem here : ', swamp(ib)
8248	WRITE(numout,*) 'resolution :', resolution(ib,1), resolution(ib,2)
8249	WRITE(numout,*) area_flood
8250	CALL ipslerr_p(3,'routing_irrigmap','Problem with swamp...','','')
8251	ENDIF
8252	!!$ ! Compute a diagnostic of the map.
8253	!!$ IF(contfrac(ib).GT.zero) THEN
8254	!!$ swampmap(ib) = swamp(ib) / ( resolution(ib,1)resolution(ib,2)contfrac(ib) )
8255	!!$ ELSE
8256	!!$ swampmap(ib) = zero
8257	!!$ ENDIF
8258	ENDIF
8259	!
8260	!
8261	ENDDO
8262	!
8263	!
8264
8265	IF ( init_irrig ) WRITE(numout,*) "Diagnostics irrigated :", MINVAL(irrigated), MAXVAL(irrigated)
8266	IF ( init_flood ) WRITE(numout,*) "Diagnostics floodplains :", MINVAL(floodplains), MAXVAL(floodplains)
8267	IF ( init_swamp ) WRITE(numout,*) "Diagnostics swamp :", MINVAL(swamp), MAXVAL(swamp)
8268	!
8269	! No compensation is done for overlapping floodplains, swamp and irrig. At least overlapping will not
8270	! happen between floodplains and swamp alone
8271	! IF ( init_irrig .AND. init_flood ) THEN
8272	! DO ib = 1, nbpt
8273	! surp = (floodplains(ib)+swamp(ib)+irrigated(ib)) / (resolution(ib,1)resolution(ib,2)contfrac(ib))
8274	! IF ( surp .GT. un ) THEN
8275	! floodplains(ib) = floodplains(ib) / surp
8276	! swamp(ib) = swamp(ib) / surp
8277	! irrigated(ib) = irrigated(ib) / surp
8278	! ENDIF
8279	! ENDDO
8280	! ENDIF
8281	!
8282	DEALLOCATE (irrsub_area)
8283	DEALLOCATE (irrsub_index)
8284	!
8285	DEALLOCATE (mask)
8286	DEALLOCATE (resol_lu)
8287	!
8288	DEALLOCATE (lonrel)
8289	DEALLOCATE (latrel)
8290	!
8291	END SUBROUTINE routing_irrigmap
8292	!
8293	!! ================================================================================================================================
8294	!! SUBROUTINE : routing_waterbal
8295	!!
8296	!>\BRIEF This subroutine checks the water balance in the routing module.
8297	!!
8298	!! DESCRIPTION (definitions, functional, design, flags) : None
8299	!!
8300	!! RECENT CHANGE(S): None
8301	!!
8302	!! MAIN OUTPUT VARIABLE(S):
8303	!!
8304	!! REFERENCES : None
8305	!!
8306	!! FLOWCHART : None
8307	!! \n
8308	!_ ================================================================================================================================
8309
8310	SUBROUTINE routing_waterbal(nbpt, reinit, floodout, runoff, drainage, returnflow, &
8311	& reinfiltration, irrigation, riverflow, coastalflow)
8312	!
8313	IMPLICIT NONE
8314	!
8315	!! INPUT VARIABLES
8316	INTEGER(i_std), INTENT(in) :: nbpt !! Domain size (unitless)
8317	LOGICAL, INTENT(in) :: reinit !! Controls behaviour (true/false)
8318	REAL(r_std), INTENT(in) :: floodout(nbpt) !! Grid-point flow out of floodplains (kg/m^2/dt)
8319	REAL(r_std), INTENT(in) :: runoff(nbpt) !! Grid-point runoff (kg/m^2/dt)
8320	REAL(r_std), INTENT(in) :: drainage(nbpt) !! Grid-point drainage (kg/m^2/dt)
8321	REAL(r_std), INTENT(in) :: returnflow(nbpt) !! The water flow from lakes and swamps which returns to the grid box.
8322	!! This water will go back into the hydrol or hydrolc module to allow re-evaporation (kg/m^2/dt)
8323	REAL(r_std), INTENT(in) :: reinfiltration(nbpt) !! Water flow from ponds and floodplains which returns to the grid box (kg/m^2/dt)
8324	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)
8325	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)
8326	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)
8327	!
8328	! We sum-up all the water we have in the warious reservoirs
8329	!
8330	REAL(r_std), SAVE :: totw_flood !! Sum of all the water amount in the floodplains reservoirs (kg)
8331	!$OMP THREADPRIVATE(totw_flood)
8332	REAL(r_std), SAVE :: totw_stream !! Sum of all the water amount in the stream reservoirs (kg)
8333	!$OMP THREADPRIVATE(totw_stream)
8334	REAL(r_std), SAVE :: totw_fast !! Sum of all the water amount in the fast reservoirs (kg)
8335	!$OMP THREADPRIVATE(totw_fast)
8336	REAL(r_std), SAVE :: totw_slow !! Sum of all the water amount in the slow reservoirs (kg)
8337	!$OMP THREADPRIVATE(totw_slow)
8338	REAL(r_std), SAVE :: totw_lake !! Sum of all the water amount in the lake reservoirs (kg)
8339	!$OMP THREADPRIVATE(totw_lake)
8340	REAL(r_std), SAVE :: totw_pond !! Sum of all the water amount in the pond reservoirs (kg)
8341	!$OMP THREADPRIVATE(totw_pond)
8342	REAL(r_std), SAVE :: totw_in !! Sum of the water flow in to the routing scheme
8343	!$OMP THREADPRIVATE(totw_in)
8344	REAL(r_std), SAVE :: totw_out !! Sum of the water flow out to the routing scheme
8345	!$OMP THREADPRIVATE(totw_out)
8346	REAL(r_std), SAVE :: totw_return !!
8347	!$OMP THREADPRIVATE(totw_return)
8348	REAL(r_std), SAVE :: totw_irrig !!
8349	!$OMP THREADPRIVATE(totw_irrig)
8350	REAL(r_std), SAVE :: totw_river !!
8351	!$OMP THREADPRIVATE(totw_river)
8352	REAL(r_std), SAVE :: totw_coastal !!
8353	!$OMP THREADPRIVATE(totw_coastal)
8354	REAL(r_std) :: totarea !! Total area of basin (m^2)
8355	REAL(r_std) :: area !! Total area of routing (m^2)
8356	INTEGER(i_std) :: ig !!
8357	!
8358	! Just to make sure we do not get too large numbers !
8359	!
8360	!! PARAMETERS
8361	REAL(r_std), PARAMETER :: scaling = 1.0E+6 !!
8362	REAL(r_std), PARAMETER :: allowed_err = 50. !!
8363
8364	!_ ================================================================================================================================
8365	!
8366	IF ( reinit ) THEN
8367	!
8368	totw_flood = zero
8369	totw_stream = zero
8370	totw_fast = zero
8371	totw_slow = zero
8372	totw_lake = zero
8373	totw_pond = zero
8374	totw_in = zero
8375	!
8376	DO ig=1,nbpt
8377	!
8378	totarea = SUM(routing_area(ig,:))
8379	!
8380	totw_flood = totw_flood + SUM(flood_reservoir(ig,:)/scaling)
8381	totw_stream = totw_stream + SUM(stream_reservoir(ig,:)/scaling)
8382	totw_fast = totw_fast + SUM(fast_reservoir(ig,:)/scaling)
8383	totw_slow = totw_slow + SUM(slow_reservoir(ig,:)/scaling)
8384	totw_lake = totw_lake + lake_reservoir(ig)/scaling
8385	totw_pond = totw_pond + pond_reservoir(ig)/scaling
8386	!
8387	totw_in = totw_in + (runoff(ig)totarea + drainage(ig)totarea - floodout(ig)*totarea)/scaling
8388	!
8389	ENDDO
8390	!
8391	ELSE
8392	!
8393	totw_out = zero
8394	totw_return = zero
8395	totw_irrig = zero
8396	totw_river = zero
8397	totw_coastal = zero
8398	area = zero
8399	!
8400	DO ig=1,nbpt
8401	!
8402	totarea = SUM(routing_area(ig,:))
8403	!
8404	totw_flood = totw_flood - SUM(flood_reservoir(ig,:)/scaling)
8405	totw_stream = totw_stream - SUM(stream_reservoir(ig,:)/scaling)
8406	totw_fast = totw_fast - SUM(fast_reservoir(ig,:)/scaling)
8407	totw_slow = totw_slow - SUM(slow_reservoir(ig,:)/scaling)
8408	totw_lake = totw_lake - lake_reservoir(ig)/scaling
8409	totw_pond = totw_pond - pond_reservoir(ig)/scaling
8410	!
8411	totw_return = totw_return + (reinfiltration(ig)+returnflow(ig))*totarea/scaling
8412	totw_irrig = totw_irrig + irrigation(ig)*totarea/scaling
8413	totw_river = totw_river + riverflow(ig)/scaling
8414	totw_coastal = totw_coastal + coastalflow(ig)/scaling
8415	!
8416	area = area + totarea
8417	!
8418	ENDDO
8419	totw_out = totw_return + totw_irrig + totw_river + totw_coastal
8420	!
8421	! Now we have all the information to balance our water
8422	!
8423	IF ( ABS((totw_flood + totw_stream + totw_fast + totw_slow + totw_lake + totw_pond) - &
8424	& (totw_out - totw_in)) > allowed_err ) THEN
8425	WRITE(numout,*) 'WARNING : Water not conserved in routing. Limit at ', allowed_err, ' 10^6 kg'
8426	WRITE(numout,*) '--Water-- change : flood stream fast ', totw_flood, totw_stream, totw_fast
8427	WRITE(numout,*) '--Water-- change : slow, lake ', totw_slow, totw_lake
8428	WRITE(numout,*) '--Water>>> change in the routing res. : ', totw_flood + totw_stream + totw_fast + totw_slow + totw_lake
8429	WRITE(numout,*) '--Water input : ', totw_in
8430	WRITE(numout,*) '--Water output : ', totw_out
8431	WRITE(numout,*) '--Water output : return, irrig ', totw_return, totw_irrig
8432	WRITE(numout,*) '--Water output : river, coastal ',totw_river, totw_coastal
8433	WRITE(numout,*) '--Water>>> change by fluxes : ', totw_out - totw_in, ' Diff [mm/dt]: ', &
8434	& ((totw_flood + totw_stream + totw_fast + totw_slow + totw_lake) - (totw_out - totw_in))/area
8435
8436	! Stop the model
8437	CALL ipslerr_p(3, 'routing_waterbal', 'Water is not conserved in routing.','','')
8438	ENDIF
8439	!
8440	ENDIF
8441	!
8442	END SUBROUTINE routing_waterbal
8443	!
8444	END MODULE routing

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

Download in other formats: