Context Navigation

source: branches/publications/ORCHIDEE-PEAT_r5488/src_sechiba/routing.f90 @ 8787

Last change on this file since 8787 was 5080, checked in by chunjing.qiu, 7 years ago
soil freezing, soil moisture, fwet bugs fixed
Property svn:keywords set to `Revision Date HeadURL Date Author Revision`
File size: 375.2 KB

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

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

Download in other formats: