Context Navigation

source: branches/publications/ORCHIDEE_DFv1.0_site/src_sechiba/routing.f90 @ 7346

Last change on this file since 7346 was 4824, checked in by josefine.ghattas, 7 years ago
Corrected comment on default values.
Property svn:keywords set to `Revision Date HeadURL Date Author Revision`
File size: 373.0 KB

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

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

Download in other formats: