Context Navigation

routing.f90 @ 8005

Last change on this file since 8005 was 5313, checked in by albert.jornet, 7 years ago
Merge: from revisions [4753:4828/trunk/ORCHIDEE]
Property svn:keywords set to `Revision Date HeadURL Date Author Revision`
File size: 376.4 KB

Line
1	! =================================================================================================================================
2	! MODULE : routing
3	!
4	! CONTACT : orchidee-help _at_ listes.ipsl.fr
5	!
6	! LICENCE : IPSL (2006)
7	! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
8	!
9	!>\BRIEF This module routes the water over the continents into the oceans and computes the water
10	!! stored in floodplains or taken for irrigation.
11	!!
12	!!\n DESCRIPTION: None
13	!!
14	!! RECENT CHANGE(S): None
15	!!
16	!! REFERENCE(S) :
17	!!
18	!! SVN :
19	!! $HeadURL$
20	!! $Date$
21	!! $Revision$
22	!! \n
23	!_ ================================================================================================================================
24	!
25	!
26	! Histoire Salee
27	!---------------
28	! La douce riviere
29	! Sortant de son lit
30	! S'est jetee ma chere
31	! dans les bras mais oui
32	! du beau fleuve
33	!
34	! L'eau coule sous les ponts
35	! Et puis les flots s'emeuvent
36	! - N'etes vous pas au courant ?
37	! Il parait que la riviere
38	! Va devenir mer
39	! Roland Bacri
40	!
41
42
43	MODULE routing
44
45	USE ioipsl
46	USE xios_orchidee
47	USE ioipsl_para
48	USE constantes
49	USE time, ONLY : one_day, dt_sechiba
50	USE constantes_soil
51	USE pft_parameters
52	USE sechiba_io_p
53	USE interpol_help
54	USE grid
55	USE mod_orchidee_para
56
57
58	IMPLICIT NONE
59	PRIVATE
60	PUBLIC :: routing_main, routing_initialize, routing_finalize, routing_clear
61
62	!! PARAMETERS
63	INTEGER(i_std), PARAMETER :: nbasmax=5 !! The maximum number of basins we wish to have per grid box (truncation of the model) (unitless)
64	INTEGER(i_std), SAVE :: nbvmax !! The maximum number of basins we can handle at any time during the generation of the maps (unitless)
65	!$OMP THREADPRIVATE(nbvmax)
66	REAL(r_std), PARAMETER :: slow_tcst_cwrr = 25.0 !! Property of the slow reservoir, when CWRR hydrology is activated (day/m)
67	REAL(r_std), PARAMETER :: fast_tcst_cwrr = 3.0 !! Property of the fast reservoir, when CWRR hydrology is activated (day/m)
68	REAL(r_std), PARAMETER :: stream_tcst_cwrr = 0.24 !! Property of the stream reservoir, when CWRR hydrology is activated (day/m)
69	REAL(r_std), PARAMETER :: flood_tcst_cwrr = 4.0 !! Property of the floodplains reservoir, when CWRR hydrology is activated (day/m)
70	REAL(r_std), PARAMETER :: swamp_cst_cwrr = 0.2 !! Fraction of the river transport that flows to the swamps, when CWRR hydrology is activated (unitless;0-1)
71	!
72	REAL(r_std), PARAMETER :: slow_tcst_chois = 25.0 !! Property of the slow reservoir, when Choisnel hydrology is activated (day/m)
73	REAL(r_std), PARAMETER :: fast_tcst_chois = 3.0 !! Property of the fast reservoir, when Choisnel hydrology is activated (day/m)
74	REAL(r_std), PARAMETER :: stream_tcst_chois = 0.24 !! Property of the stream reservoir, when Choisnel hydrology is activated (day/m)
75	REAL(r_std), PARAMETER :: flood_tcst_chois = 4.0 !! Property of the floodplains reservoir, when Choisnel hydrology is activated (day/m)
76	REAL(r_std), PARAMETER :: swamp_cst_chois = 0.2 !! Fraction of the river transport that flows to the swamps, when Choisnel hydrology is activated (unitless;0-1)
77	!
78	REAL(r_std), SAVE :: fast_tcst !! Property of the fast reservoir, (day/m)
79	!$OMP THREADPRIVATE(fast_tcst)
80	REAL(r_std), SAVE :: slow_tcst !! Property of the slow reservoir, (day/m)
81	!$OMP THREADPRIVATE(slow_tcst)
82	REAL(r_std), SAVE :: stream_tcst !! Property of the stream reservoir, (day/m)
83	!$OMP THREADPRIVATE(stream_tcst)
84	REAL(r_std), SAVE :: flood_tcst !! Property of the floodplains reservoir, (day/m)
85	!$OMP THREADPRIVATE(flood_tcst)
86	REAL(r_std), SAVE :: swamp_cst !! Fraction of the river transport that flows to the swamps (unitless;0-1)
87	!$OMP THREADPRIVATE(swamp_cst)
88	!
89	! Relation between volume and fraction of floodplains
90	!
91	REAL(r_std), SAVE :: beta = 2.0 !! Parameter to fix the shape of the floodplain (>1 for convex edges, <1 for concave edges) (unitless)
92	!$OMP THREADPRIVATE(beta)
93	REAL(r_std), SAVE :: betap = 0.5 !! Ratio of the basin surface intercepted by ponds and the maximum surface of ponds (unitless;0-1)
94	!$OMP THREADPRIVATE(betap)
95	REAL(r_std), SAVE :: floodcri = 2000.0 !! Potential height for which all the basin is flooded (mm)
96	!$OMP THREADPRIVATE(floodcri)
97	!
98	! Relation between maximum surface of ponds and basin surface, and drainage (mm/j) to the slow_res
99	!
100	REAL(r_std), PARAMETER :: pond_bas = 50.0 !! [DISPENSABLE] - not used
101	REAL(r_std), SAVE :: pondcri = 2000.0 !! Potential height for which all the basin is a pond (mm)
102	!$OMP THREADPRIVATE(pondcri)
103	!
104	REAL(r_std), PARAMETER :: maxevap_lake = 7.5/86400. !! Maximum evaporation rate from lakes (kg/m^2/s)
105	!
106	REAL(r_std),SAVE :: dt_routing !! Routing time step (s)
107	!$OMP THREADPRIVATE(dt_routing)
108	!
109	INTEGER(i_std), SAVE :: diagunit = 87 !! Diagnostic file unit (unitless)
110	!$OMP THREADPRIVATE(diagunit)
111	!
112	! Logicals to control model configuration
113	!
114	LOGICAL, SAVE :: dofloodinfilt = .FALSE. !! Logical to choose if floodplains infiltration is activated or not (true/false)
115	!$OMP THREADPRIVATE(dofloodinfilt)
116	LOGICAL, SAVE :: doswamps = .FALSE. !! Logical to choose if swamps are activated or not (true/false)
117	!$OMP THREADPRIVATE(doswamps)
118	LOGICAL, SAVE :: doponds = .FALSE. !! Logical to choose if ponds are activated or not (true/false)
119	!$OMP THREADPRIVATE(doponds)
120	!
121	! The variables describing the basins and their routing, need to be in the restart file.
122	!
123	INTEGER(i_std), SAVE :: num_largest !! Number of largest river basins which should be treated as independently as rivers
124	!! (not flow into ocean as diffusion coastal flow) (unitless)
125	!$OMP THREADPRIVATE(num_largest)
126	REAL(r_std), SAVE :: time_counter !! Time counter (s)
127	!$OMP THREADPRIVATE(time_counter)
128	REAL(r_std), SAVE, ALLOCATABLE, TARGET, DIMENSION(:,:) :: routing_area_loc !! Surface of basin (m^2)
129	!$OMP THREADPRIVATE(routing_area_loc)
130	REAL(r_std), SAVE, ALLOCATABLE, TARGET, DIMENSION(:,:) :: topo_resid_loc !! Topographic index of the retention time (m)
131	!$OMP THREADPRIVATE(topo_resid_loc)
132	INTEGER(i_std), SAVE, ALLOCATABLE, TARGET, DIMENSION(:,:) :: route_togrid_loc !! Grid into which the basin flows (unitless)
133	!$OMP THREADPRIVATE(route_togrid_loc)
134	INTEGER(i_std), SAVE, ALLOCATABLE, TARGET, DIMENSION(:,:) :: route_tobasin_loc !! Basin in to which the water goes (unitless)
135	!$OMP THREADPRIVATE(route_tobasin_loc)
136	INTEGER(i_std), SAVE, ALLOCATABLE, TARGET, DIMENSION(:,:) :: route_nbintobas_loc !! Number of basin into current one (unitless)
137	!$OMP THREADPRIVATE(route_nbintobas_loc)
138	INTEGER(i_std), SAVE, ALLOCATABLE, TARGET, DIMENSION(:,:) :: global_basinid_loc !! ID of basin (unitless)
139	!$OMP THREADPRIVATE(global_basinid_loc)
140	INTEGER(i_std), SAVE, ALLOCATABLE, TARGET, DIMENSION(:,:) :: hydrodiag_loc !! Variable to diagnose the hydrographs
141	!$OMP THREADPRIVATE(hydrodiag_loc)
142	REAL(r_std), SAVE, ALLOCATABLE, TARGET, DIMENSION(:) :: hydroupbasin_loc !! The area upstream of the gauging station (m^2)
143	!$OMP THREADPRIVATE(hydroupbasin_loc)
144	!
145	! parallelism
146	REAL(r_std), SAVE, ALLOCATABLE, TARGET, DIMENSION(:,:) :: routing_area_glo !! Surface of basin (m^2)
147	!$OMP THREADPRIVATE(routing_area_glo)
148	REAL(r_std), SAVE, ALLOCATABLE, TARGET, DIMENSION(:,:) :: topo_resid_glo !! Topographic index of the retention time (m)
149	!$OMP THREADPRIVATE(topo_resid_glo)
150	INTEGER(i_std), SAVE, ALLOCATABLE, TARGET, DIMENSION(:,:) :: route_togrid_glo !! Grid into which the basin flows (unitless)
151	!$OMP THREADPRIVATE(route_togrid_glo)
152	INTEGER(i_std), SAVE, ALLOCATABLE, TARGET, DIMENSION(:,:) :: route_tobasin_glo !! Basin in to which the water goes (unitless)
153	!$OMP THREADPRIVATE(route_tobasin_glo)
154	INTEGER(i_std), SAVE, ALLOCATABLE, TARGET, DIMENSION(:,:) :: route_nbintobas_glo !! Number of basin into current one (unitless)
155	!$OMP THREADPRIVATE(route_nbintobas_glo)
156	INTEGER(i_std), SAVE, ALLOCATABLE, TARGET, DIMENSION(:,:) :: global_basinid_glo !! ID of basin (unitless)
157	!$OMP THREADPRIVATE(global_basinid_glo)
158	INTEGER(i_std), SAVE, ALLOCATABLE, TARGET, DIMENSION(:,:) :: hydrodiag_glo !! Variable to diagnose the hydrographs
159	!$OMP THREADPRIVATE(hydrodiag_glo)
160	REAL(r_std), SAVE, ALLOCATABLE, TARGET, DIMENSION(:) :: hydroupbasin_glo !! The area upstream of the gauging station (m^2)
161	!$OMP THREADPRIVATE(hydroupbasin_glo)
162	!
163	REAL(r_std), SAVE, POINTER, DIMENSION(:,:) :: routing_area !! Surface of basin (m^2)
164	!$OMP THREADPRIVATE(routing_area)
165	REAL(r_std), SAVE, POINTER, DIMENSION(:,:) :: topo_resid !! Topographic index of the retention time (m)
166	!$OMP THREADPRIVATE(topo_resid)
167	INTEGER(i_std), SAVE, POINTER, DIMENSION(:,:) :: route_togrid !! Grid into which the basin flows (unitless)
168	!$OMP THREADPRIVATE(route_togrid)
169	INTEGER(i_std), SAVE, POINTER, DIMENSION(:,:) :: route_tobasin !! Basin in to which the water goes (unitless)
170	!$OMP THREADPRIVATE(route_tobasin)
171	INTEGER(i_std), SAVE, POINTER, DIMENSION(:,:) :: route_nbintobas !! Number of basin into current one (unitless)
172	!$OMP THREADPRIVATE(route_nbintobas)
173	INTEGER(i_std), SAVE, POINTER, DIMENSION(:,:) :: global_basinid !! ID of basin (unitless)
174	!$OMP THREADPRIVATE(global_basinid)
175	INTEGER(i_std), SAVE, POINTER, DIMENSION(:,:) :: hydrodiag !! Variable to diagnose the hydrographs
176	!$OMP THREADPRIVATE(hydrodiag)
177	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: slowflow_diag !! Diagnostic slow flow hydrographs (kg/dt)
178	!$OMP THREADPRIVATE(slowflow_diag)
179	REAL(r_std), SAVE, POINTER, DIMENSION(:) :: hydroupbasin !! The area upstream of the gauging station (m^2)
180	!$OMP THREADPRIVATE(hydroupbasin)
181	!
182	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: irrigated !! Area equipped for irrigation in each grid box (m^2)
183	!$OMP THREADPRIVATE(irrigated)
184	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: floodplains !! Maximal surface which can be inundated in each grid box (m^2)
185	!$OMP THREADPRIVATE(floodplains)
186	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: swamp !! Maximal surface of swamps in each grid box (m^2)
187	!$OMP THREADPRIVATE(swamp)
188	!
189	! The reservoirs, also to be put into the restart file.
190	!
191	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:,:) :: fast_reservoir !! Water amount in the fast reservoir (kg)
192	!$OMP THREADPRIVATE(fast_reservoir)
193	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:,:) :: slow_reservoir !! Water amount in the slow reservoir (kg)
194	!$OMP THREADPRIVATE(slow_reservoir)
195	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:,:) :: stream_reservoir !! Water amount in the stream reservoir (kg)
196	!$OMP THREADPRIVATE(stream_reservoir)
197	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:,:) :: flood_reservoir !! Water amount in the floodplains reservoir (kg)
198	!$OMP THREADPRIVATE(flood_reservoir)
199	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: lake_reservoir !! Water amount in the lake reservoir (kg)
200	!$OMP THREADPRIVATE(lake_reservoir)
201	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: pond_reservoir !! Water amount in the pond reservoir (kg)
202	!$OMP THREADPRIVATE(pond_reservoir)
203	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:,:) :: flood_frac_bas !! Flooded fraction per basin (unitless;0-1)
204	!$OMP THREADPRIVATE(flood_frac_bas)
205	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: pond_frac !! Pond fraction per grid box (unitless;0-1)
206	!$OMP THREADPRIVATE(pond_frac)
207	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: flood_height !! Floodplain height (mm)
208	!$OMP THREADPRIVATE(flood_height)
209	!
210	! The accumulated fluxes.
211	!
212	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: floodout_mean !! Accumulated flow out of floodplains (kg/m^2/dt)
213	!$OMP THREADPRIVATE(floodout_mean)
214	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: runoff_mean !! Accumulated runoff (kg/m^2/dt)
215	!$OMP THREADPRIVATE(runoff_mean)
216	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: drainage_mean !! Accumulated drainage (kg/m^2/dt)
217	!$OMP THREADPRIVATE(drainage_mean)
218	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: transpot_mean !! Mean potential transpiration from the plants (kg/m^2/dt)
219	!$OMP THREADPRIVATE(transpot_mean)
220	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: precip_mean !! Accumulated precipitation (kg/m^2/dt)
221	!$OMP THREADPRIVATE(precip_mean)
222	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: humrel_mean !! Mean soil moisture stress, mean root extraction potential (unitless)
223	!$OMP THREADPRIVATE(humrel_mean)
224	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: totnobio_mean !! Mean last total fraction of no bio (unitless;0-1)
225	!$OMP THREADPRIVATE(totnobio_mean)
226	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: vegtot_mean !! Mean potentially vegetated fraction (unitless;0-1)
227	!$OMP THREADPRIVATE(vegtot_mean)
228	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: k_litt_mean !! Mean averaged conductivity for saturated infiltration in the 'litter' layer (kg/m^2/dt)
229	!$OMP THREADPRIVATE(k_litt_mean)
230	!
231	! The averaged outflow fluxes.
232	!
233	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: lakeinflow_mean !! Mean lake inflow (kg/m^2/dt)
234	!$OMP THREADPRIVATE(lakeinflow_mean)
235	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: returnflow_mean !! Mean water flow from lakes and swamps which returns to the grid box.
236	!! This water will go back into the hydrol or hydrolc module to allow re-evaporation (kg/m^2/dt)
237	!$OMP THREADPRIVATE(returnflow_mean)
238	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: reinfiltration_mean !! Mean water flow which returns to the grid box (kg/m^2/dt)
239	!$OMP THREADPRIVATE(reinfiltration_mean)
240	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: irrigation_mean !! Mean irrigation flux.
241	!! This is the water taken from the reservoirs and beeing put into the upper layers of the soil (kg/m^2/dt)
242	!$OMP THREADPRIVATE(irrigation_mean)
243	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: riverflow_mean !! Mean Outflow of the major rivers.
244	!! The flux will be located on the continental grid but this should be a coastal point (kg/dt)
245	!$OMP THREADPRIVATE(riverflow_mean)
246	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: coastalflow_mean !! Mean outflow on coastal points by small basins.
247	!! This is the water which flows in a disperse way into the ocean (kg/dt)
248	!$OMP THREADPRIVATE(coastalflow_mean)
249	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: floodtemp !! Temperature to decide if floodplains work (K)
250	!$OMP THREADPRIVATE(floodtemp)
251	INTEGER(i_std), SAVE :: floodtemp_lev !! Temperature level to decide if floodplains work (K)
252	!$OMP THREADPRIVATE(floodtemp_lev)
253	!
254	! Diagnostic variables ... well sort of !
255	!
256	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: irrig_netereq !! Irrigation requirement (water requirements by the crop for its optimal growth (kg/m^2/dt)
257	!$OMP THREADPRIVATE(irrig_netereq)
258	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: hydrographs !! Hydrographs at the outflow of the grid box for major basins (kg/dt)
259	!$OMP THREADPRIVATE(hydrographs)
260	!
261	! Diagnostics for the various reservoirs we use (Kg/m^2)
262	!
263	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: fast_diag !! Diagnostic for the fast reservoir (kg/m^2)
264	!$OMP THREADPRIVATE(fast_diag)
265	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: slow_diag !! Diagnostic for the slow reservoir (kg/m^2)
266	!$OMP THREADPRIVATE(slow_diag)
267	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: stream_diag !! Diagnostic for the stream reservoir (kg/m^2)
268	!$OMP THREADPRIVATE(stream_diag)
269	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: flood_diag !! Diagnostic for the floodplain reservoir (kg/m^2)
270	!$OMP THREADPRIVATE(flood_diag)
271	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: pond_diag !! Diagnostic for the pond reservoir (kg/m^2)
272	!$OMP THREADPRIVATE(pond_diag)
273	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: lake_diag !! Diagnostic for the lake reservoir (kg/m^2)
274	!$OMP THREADPRIVATE(lake_diag)
275
276	REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: mask_coast !! Mask with coastal gridcells on local grid(1/0)
277	!$OMP THREADPRIVATE(mask_coast)
278	REAL(r_std), SAVE :: max_lake_reservoir !! Maximum limit of water in lake_reservoir [kg/m2]
279	!$OMP THREADPRIVATE(max_lake_reservoir)
280	INTEGER(i_std), SAVE :: nb_coast_gridcells !! Number of gridcells which can receive coastalflow
281
282
283	CONTAINS
284	!! =============================================================================================================================
285	!! SUBROUTINE: routing_initialize
286	!!
287	!>\BRIEF Initialize the routing module
288	!!
289	!! DESCRIPTION: Initialize the routing module. Read from restart file or read the routing.nc file to initialize the
290	!! routing scheme.
291	!!
292	!! RECENT CHANGE(S)
293	!!
294	!! REFERENCE(S)
295	!!
296	!! FLOWCHART
297	!! \n
298	!_ ==============================================================================================================================
299
300	SUBROUTINE routing_initialize( kjit, nbpt, index, &
301	rest_id, hist_id, hist2_id, lalo, &
302	neighbours, resolution, contfrac, stempdiag, &
303	returnflow, reinfiltration, irrigation, riverflow, &
304	coastalflow, flood_frac, flood_res )
305
306	IMPLICIT NONE
307
308	!! 0.1 Input variables
309	INTEGER(i_std), INTENT(in) :: kjit !! Time step number (unitless)
310	INTEGER(i_std), INTENT(in) :: nbpt !! Domain size (unitless)
311	INTEGER(i_std), INTENT(in) :: index(nbpt) !! Indices of the points on the map (unitless)
312	INTEGER(i_std),INTENT(in) :: rest_id !! Restart file identifier (unitless)
313	INTEGER(i_std),INTENT(in) :: hist_id !! Access to history file (unitless)
314	INTEGER(i_std),INTENT(in) :: hist2_id !! Access to history file 2 (unitless)
315	REAL(r_std), INTENT(in) :: lalo(nbpt,2) !! Vector of latitude and longitudes (beware of the order !)
316
317	INTEGER(i_std), INTENT(in) :: neighbours(nbpt,NbNeighb) !! Vector of neighbours for each grid point
318	!! (1=N, 2=NE, 3=E, 4=SE, 5=S, 6=SW, 7=W, 8=NW) (unitless)
319	REAL(r_std), INTENT(in) :: resolution(nbpt,2) !! The size of each grid box in X and Y (m)
320	REAL(r_std), INTENT(in) :: contfrac(nbpt) !! Fraction of land in each grid box (unitless;0-1)
321	REAL(r_std), INTENT(in) :: stempdiag(nbpt,nslm) !! Diagnostic soil temperature profile
322
323	!! 0.2 Output variables
324	REAL(r_std), INTENT(out) :: returnflow(nbpt) !! The water flow from lakes and swamps which returns to the grid box.
325	!! This water will go back into the hydrol or hydrolc module to allow re-evaporation (kg/m^2/dt)
326	REAL(r_std), INTENT(out) :: reinfiltration(nbpt) !! Water flow from ponds and floodplains which returns to the grid box (kg/m^2/dt)
327	REAL(r_std), INTENT(out) :: irrigation(nbpt) !! Irrigation flux. This is the water taken from the reservoirs and beeing put into the upper layers of the soil (kg/m^2/dt)
328	REAL(r_std), INTENT(out) :: riverflow(nbpt) !! Outflow of the major rivers. The flux will be located on the continental grid but this should be a coastal point (kg/dt)
329
330	REAL(r_std), INTENT(out) :: coastalflow(nbpt) !! Outflow on coastal points by small basins. This is the water which flows in a disperse way into the ocean (kg/dt)
331	REAL(r_std), INTENT(out) :: flood_frac(nbpt) !! Flooded fraction of the grid box (unitless;0-1)
332	REAL(r_std), INTENT(out) :: flood_res(nbpt) !! Diagnostic of water amount in the floodplains reservoir (kg)
333
334	!! 0.3 Local variables
335	REAL(r_std), DIMENSION(nbp_glo):: mask_coast_glo !! Mask with coastal gridcells on global grid (1/0)
336	LOGICAL :: init_irrig !! Logical to initialize the irrigation (true/false)
337	LOGICAL :: init_flood !! Logical to initialize the floodplains (true/false)
338	LOGICAL :: init_swamp !! Logical to initialize the swamps (true/false)
339	INTEGER :: ig, ib, rtg, rtb !! Index
340	INTEGER :: ier !! Error handeling
341	!_ ================================================================================================================================
342
343	!
344	! do initialisation
345	!
346	nbvmax = 440
347	! Here we will allocate the memory and get the fixed fields from the restart file.
348	! If the info is not found then we will compute the routing map.
349	!
350
351	CALL routing_init (kjit, nbpt, index, returnflow, reinfiltration, irrigation, &
352	riverflow, coastalflow, flood_frac, flood_res, stempdiag, rest_id)
353
354	routing_area => routing_area_loc
355	topo_resid => topo_resid_loc
356	route_togrid => route_togrid_loc
357	route_tobasin => route_tobasin_loc
358	global_basinid => global_basinid_loc
359	hydrodiag => hydrodiag_loc
360
361	! This routine computes the routing map if the route_togrid_glo is undefined. This means that the
362	! map has not been initialized during the restart process..
363	!
364	!! Reads in the map of the basins and flow directions to construct the catchments of each grid box
365	!
366	IF ( COUNT(route_togrid_glo .GE. undef_int) .GT. 0 ) THEN
367	CALL routing_basins_p(nbpt, lalo, neighbours, resolution, contfrac)
368	ENDIF
369
370	!! Create a mask containing all possible coastal gridcells and count total number of coastal gridcells
371	IF (is_root_prc) THEN
372	mask_coast_glo(:)=0
373	DO ib=1,nbasmax
374	DO ig=1,nbp_glo
375	rtg = route_togrid_glo(ig,ib)
376	rtb = route_tobasin_glo(ig,ib)
377	! Coastal gridcells are stored in nbasmax+2
378	IF (rtb == nbasmax+2) THEN
379	mask_coast_glo(rtg) = 1
380	END IF
381	END DO
382	END DO
383	nb_coast_gridcells=SUM(mask_coast_glo)
384	IF (printlev>=3) WRITE(numout,*) 'Number of coastal gridcells = ', nb_coast_gridcells
385	ENDIF
386	CALL bcast(nb_coast_gridcells)
387
388	ALLOCATE(mask_coast(nbpt), stat=ier)
389	IF (ier /= 0) CALL ipslerr_p(3,'routing_inititalize','Pb in allocate for mask_coast','','')
390	CALL scatter(mask_coast_glo, mask_coast)
391	CALL xios_orchidee_send_field("mask_coast",mask_coast)
392
393
394	!
395	! Do we have what we need if we want to do irrigation
396	!! Initialisation of flags for irrigated land, flood plains and swamps
397	!
398	init_irrig = .FALSE.
399	IF ( do_irrigation ) THEN
400	IF (COUNT(irrigated .GE. undef_sechiba-1) > 0) init_irrig = .TRUE.
401	END IF
402
403	init_flood = .FALSE.
404	IF ( do_floodplains ) THEN
405	IF (COUNT(floodplains .GE. undef_sechiba-1) > 0) init_flood = .TRUE.
406	END IF
407
408	init_swamp = .FALSE.
409	IF ( doswamps ) THEN
410	IF (COUNT(swamp .GE. undef_sechiba-1) > 0 ) init_swamp = .TRUE.
411	END IF
412
413	!! If we have irrigated land, flood plains or swamps then we need to interpolate the 0.5 degree
414	!! base data set to the resolution of the model.
415
416	IF ( init_irrig .OR. init_flood .OR. init_swamp ) THEN
417	CALL routing_irrigmap(nbpt, index, lalo, neighbours, resolution, &
418	contfrac, init_irrig, irrigated, init_flood, floodplains, init_swamp, swamp, hist_id, hist2_id)
419	ENDIF
420
421	IF ( do_irrigation ) THEN
422	CALL xios_orchidee_send_field("irrigmap",irrigated)
423
424	IF (printlev >= 3) WRITE(numout,*) 'Verification : range of irrigated : ', MINVAL(irrigated), MAXVAL(irrigated)
425	IF ( .NOT. almaoutput ) THEN
426	CALL histwrite_p(hist_id, 'irrigmap', 1, irrigated, nbpt, index)
427	ELSE
428	CALL histwrite_p(hist_id, 'IrrigationMap', 1, irrigated, nbpt, index)
429	ENDIF
430	IF ( hist2_id > 0 ) THEN
431	IF ( .NOT. almaoutput ) THEN
432	CALL histwrite_p(hist2_id, 'irrigmap', 1, irrigated, nbpt, index)
433	ELSE
434	CALL histwrite_p(hist2_id, 'IrrigationMap', 1, irrigated, nbpt, index)
435	ENDIF
436	ENDIF
437	ENDIF
438
439	IF ( do_floodplains ) THEN
440	CALL xios_orchidee_send_field("floodmap",floodplains)
441
442	IF (printlev>=3) WRITE(numout,*) 'Verification : range of floodplains : ', MINVAL(floodplains), MAXVAL(floodplains)
443	IF ( .NOT. almaoutput ) THEN
444	CALL histwrite_p(hist_id, 'floodmap', 1, floodplains, nbpt, index)
445	ELSE
446	CALL histwrite_p(hist_id, 'FloodplainsMap', 1, floodplains, nbpt, index)
447	ENDIF
448	IF ( hist2_id > 0 ) THEN
449	IF ( .NOT. almaoutput ) THEN
450	CALL histwrite_p(hist2_id, 'floodmap', 1, floodplains, nbpt, index)
451	ELSE
452	CALL histwrite_p(hist2_id, 'FloodplainsMap', 1, floodplains, nbpt, index)
453	ENDIF
454	ENDIF
455	ENDIF
456
457	IF ( doswamps ) THEN
458	CALL xios_orchidee_send_field("swampmap",swamp)
459
460	IF (printlev>=3) WRITE(numout,*) 'Verification : range of swamp : ', MINVAL(swamp), MAXVAL(swamp)
461	IF ( .NOT. almaoutput ) THEN
462	CALL histwrite_p(hist_id, 'swampmap', 1, swamp, nbpt, index)
463	ELSE
464	CALL histwrite_p(hist_id, 'SwampMap', 1, swamp, nbpt, index)
465	ENDIF
466	IF ( hist2_id > 0 ) THEN
467	IF ( .NOT. almaoutput ) THEN
468	CALL histwrite_p(hist2_id, 'swampmap', 1, swamp, nbpt, index)
469	ELSE
470	CALL histwrite_p(hist2_id, 'SwampMap', 1, swamp, nbpt, index)
471	ENDIF
472	ENDIF
473	ENDIF
474
475	!! This routine gives a diagnostic of the basins used.
476	CALL routing_diagnostic_p(nbpt, index, lalo, resolution, contfrac, hist_id, hist2_id)
477
478	END SUBROUTINE routing_initialize
479
480	!! ================================================================================================================================
481	!! SUBROUTINE : routing_main
482	!!
483	!>\BRIEF This module routes the water over the continents (runoff and
484	!! drainage produced by the hydrolc or hydrol module) into the oceans.
485	!!
486	!! DESCRIPTION (definitions, functional, design, flags):
487	!! The routing scheme (Polcher, 2003) carries the water from the runoff and drainage simulated by SECHIBA
488	!! to the ocean through reservoirs, with some delay. The routing scheme is based on
489	!! a parametrization of the water flow on a global scale (Miller et al., 1994; Hagemann
490	!! and Dumenil, 1998). Given the global map of the main watersheds (Oki et al., 1999;
491	!! Fekete et al., 1999; Vorosmarty et al., 2000) which delineates the boundaries of subbasins
492	!! and gives the eight possible directions of water flow within the pixel, the surface
493	!! runoff and the deep drainage are routed to the ocean. The time-step of the routing is one day.
494	!! The scheme also diagnoses how much water is retained in the foodplains and thus return to soil
495	!! moisture or is taken out of the rivers for irrigation. \n
496	!!
497	!! RECENT CHANGE(S): None
498	!!
499	!! MAIN OUTPUT VARIABLE(S):
500	!! The result of the routing are 3 fluxes :
501	!! - riverflow : The water which flows out from the major rivers. The flux will be located
502	!! on the continental grid but this should be a coastal point.
503	!! - coastalflow : This is the water which flows in a disperse way into the ocean. Essentially these
504	!! are the outflows from all of the small rivers.
505	!! - returnflow : This is the water which flows into a land-point - typically rivers which end in
506	!! the desert. This water will go back into the hydrol module to allow re-evaporation.
507	!! - irrigation : This is water taken from the reservoir and is being put into the upper
508	!! layers of the soil.
509	!! The two first fluxes are in kg/dt and the last two fluxes are in kg/(m^2dt).\n
510	!!
511	!! REFERENCE(S) :
512	!! - Miller JR, Russell GL, Caliri G (1994)
513	!! Continental-scale river flow in climate models.
514	!! J. Clim., 7:914-928
515	!! - Hagemann S and Dumenil L. (1998)
516	!! A parametrization of the lateral waterflow for the global scale.
517	!! Clim. Dyn., 14:17-31
518	!! - Oki, T., T. Nishimura, and P. Dirmeyer (1999)
519	!! Assessment of annual runoff from land surface models using total runoff integrating pathways (TRIP)
520	!! J. Meteorol. Soc. Jpn., 77, 235-255
521	!! - Fekete BM, Charles V, Grabs W (2000)
522	!! Global, composite runoff fields based on observed river discharge and simulated water balances.
523	!! Technical report, UNH/GRDC, Global Runoff Data Centre, Koblenz
524	!! - Vorosmarty, C., B. Fekete, B. Meybeck, and R. Lammers (2000)
525	!! Global system of rivers: Its role in organizing continental land mass and defining land-to-ocean linkages
526	!! Global Biogeochem. Cycles, 14, 599-621
527	!! - Vivant, A-C. (?? 2002)
528	!! DÃ©veloppement du schÃ©ma de routage et des plaines d'inondation, MSc Thesis, Paris VI University
529	!! - J. Polcher (2003)
530	!! Les processus de surface a l'echelle globale et leurs interactions avec l'atmosphere
531	!! Habilitation a diriger les recherches, Paris VI University, 67pp.
532	!!
533	!! FLOWCHART :
534	!! \latexonly
535	!! \includegraphics[scale=0.75]{routing_main_flowchart.png}
536	!! \endlatexonly
537	!! \n
538	!_ ================================================================================================================================
539
540	SUBROUTINE routing_main(kjit, nbpt, index, &
541	& lalo, neighbours, resolution, contfrac, totfrac_nobio, veget, veget_max, soil_deficit, floodout, runoff, &
542	& drainage, transpot, evapot_corr, vegstress, precip_rain, humrel, k_litt, flood_frac, flood_res, &
543	& stempdiag, reinf_slope, returnflow, reinfiltration, irrigation, riverflow, coastalflow, rest_id, hist_id, hist2_id)
544
545	IMPLICIT NONE
546
547	!! 0.1 Input variables
548	INTEGER(i_std), INTENT(in) :: kjit !! Time step number (unitless)
549	INTEGER(i_std), INTENT(in) :: nbpt !! Domain size (unitless)
550	INTEGER(i_std),INTENT(in) :: rest_id !! Restart file identifier (unitless)
551	INTEGER(i_std),INTENT(in) :: hist_id !! Access to history file (unitless)
552	INTEGER(i_std),INTENT(in) :: hist2_id !! Access to history file 2 (unitless)
553	INTEGER(i_std), INTENT(in) :: index(nbpt) !! Indices of the points on the map (unitless)
554	REAL(r_std), INTENT(in) :: lalo(nbpt,2) !! Vector of latitude and longitudes (beware of the order !)
555	INTEGER(i_std), INTENT(in) :: neighbours(nbpt,NbNeighb) !! Vector of neighbours for each grid point (1=N, 2=NE, 3=E, 4=SE, 5=S, 6=SW, 7=W, 8=NW) (unitless)
556	REAL(r_std), INTENT(in) :: resolution(nbpt,2) !! The size of each grid box in X and Y (m)
557	REAL(r_std), INTENT(in) :: contfrac(nbpt) !! Fraction of land in each grid box (unitless;0-1)
558	REAL(r_std), INTENT(in) :: totfrac_nobio(nbpt) !! Total fraction of no-vegetation (continental ice, lakes ...) (unitless;0-1)
559	REAL(r_std), INTENT(in) :: veget(nbpt,nvm) !! fraction of vegetation (unitless;0-1)
560	REAL(r_std), INTENT(in) :: veget_max(nbpt,nvm) !! Maximal fraction of vegetation (unitless;0-1)
561	REAL(r_std), INTENT(in) :: soil_deficit(nbpt,nvm) !! soil water deficit
562	REAL(r_std), INTENT(in) :: floodout(nbpt) !! Grid-point flow out of floodplains (kg/m^2/dt)
563	REAL(r_std), INTENT(in) :: runoff(nbpt) !! Grid-point runoff (kg/m^2/dt)
564	REAL(r_std), INTENT(in) :: drainage(nbpt) !! Grid-point drainage (kg/m^2/dt)
565	REAL(r_std), INTENT(in) :: transpot(nbpt,nvm) !! Potential transpiration of the vegetation (kg/m^2/dt)
566	REAL(r_std), INTENT(in) :: evapot_corr(nbpt) !! Potential soil evaporation (kg/m^2/dt)
567	REAL(r_std), INTENT(in) :: vegstress(nbpt,nvm) !! stress for vegetation growth (unitless; 0-1)
568	REAL(r_std), INTENT(in) :: precip_rain(nbpt) !! Rainfall (kg/m^2/dt)
569	REAL(r_std), INTENT(in) :: k_litt(nbpt) !! Averaged conductivity for saturated infiltration in the 'litter' layer (kg/m^2/dt)
570	REAL(r_std), INTENT(in) :: humrel(nbpt,nvm) !! Soil moisture stress, root extraction potential (unitless)
571	REAL(r_std), INTENT(in) :: stempdiag(nbpt,nslm) !! Diagnostic soil temperature profile
572	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)
573
574	!! 0.2 Output variables
575	REAL(r_std), INTENT(out) :: returnflow(nbpt) !! The water flow from lakes and swamps which returns to the grid box.
576	!! This water will go back into the hydrol or hydrolc module to allow re-evaporation (kg/m^2/dt)
577	REAL(r_std), INTENT(out) :: reinfiltration(nbpt) !! Water flow from ponds and floodplains which returns to the grid box (kg/m^2/dt)
578	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)
579	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)
580	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)
581	REAL(r_std), INTENT(out) :: flood_frac(nbpt) !! Flooded fraction of the grid box (unitless;0-1)
582	REAL(r_std), INTENT(out) :: flood_res(nbpt) !! Diagnostic of water amount in the floodplains reservoir (kg)
583
584	!! 0.3 Local variables
585	CHARACTER(LEN=30) :: var_name !! To store variables names for I/O (unitless)
586	REAL(r_std), DIMENSION(1) :: tmp_day !!
587	REAL(r_std), DIMENSION(nbpt) :: return_lakes !! Water from lakes flowing back into soil moisture (kg/m^2/dt)
588
589	INTEGER(i_std) :: ig, jv !! Indices (unitless)
590	REAL(r_std), DIMENSION(nbpt) :: tot_vegfrac_nowoody !! Total fraction occupied by grass (0-1,unitless)
591	REAL(r_std), DIMENSION(nbpt) :: tot_vegfrac_crop !! Total fraction occupied by croplands (0-1,unitless)
592
593	REAL(r_std), DIMENSION(nbpt) :: fast_diag_old !! Reservoir in the beginning of the time step
594	REAL(r_std), DIMENSION(nbpt) :: slow_diag_old !! Reservoir in the beginning of the time step
595	REAL(r_std), DIMENSION(nbpt) :: stream_diag_old !! Reservoir in the beginning of the time step
596	REAL(r_std), DIMENSION(nbpt) :: lake_diag_old !! Reservoir in the beginning of the time step
597	REAL(r_std), DIMENSION(nbpt) :: pond_diag_old !! Reservoir in the beginning of the time step
598	REAL(r_std), DIMENSION(nbpt) :: flood_diag_old !! Reservoir in the beginning of the time step
599
600	!! For water budget check in the three routing reservoirs (positive if input > output)
601	!! Net fluxes averaged over each grid cell in kg/m^2/dt
602	REAL(r_std), DIMENSION(nbpt) :: netflow_stream_diag !! Input - Output flow to stream reservoir
603	REAL(r_std), DIMENSION(nbpt) :: netflow_fast_diag !! Input - Output flow to fast reservoir
604	REAL(r_std), DIMENSION(nbpt) :: netflow_slow_diag !! Input - Output flow to slow reservoir
605
606
607	!_ ================================================================================================================================
608
609	! Save reservoirs in beginning of time step to calculate the water budget
610	fast_diag_old = fast_diag
611	slow_diag_old = slow_diag
612	stream_diag_old = stream_diag
613	lake_diag_old = lake_diag
614	pond_diag_old = pond_diag
615	flood_diag_old = flood_diag
616
617	!
618	!! Computes the variables averaged between routing time steps and which will be used in subsequent calculations
619	!
620	floodout_mean(:) = floodout_mean(:) + floodout(:)
621	runoff_mean(:) = runoff_mean(:) + runoff(:)
622	drainage_mean(:) = drainage_mean(:) + drainage(:)
623	floodtemp(:) = stempdiag(:,floodtemp_lev)
624	precip_mean(:) = precip_mean(:) + precip_rain(:)
625	!
626	!! Computes the total fraction occupied by the grasses and the crops for each grid cell
627	tot_vegfrac_nowoody(:) = zero
628	tot_vegfrac_crop(:) = zero
629	DO jv = 1, nvm
630	IF ( (jv /= ibare_sechiba) .AND. .NOT.(is_tree(jv)) ) THEN
631	tot_vegfrac_nowoody(:) = tot_vegfrac_nowoody(:) + veget_max(:,jv)
632	END IF
633	IF ( (jv /= ibare_sechiba) .AND. ok_LAIdev(jv) ) THEN ! cropland judgement using ok_LAIdev, xuhui
634	tot_vegfrac_crop(:) = tot_vegfrac_crop(:) + veget_max(:,jv)
635	ENDIF
636	END DO
637
638	DO ig = 1, nbpt
639	IF ( tot_vegfrac_nowoody(ig) .GT. min_sechiba ) THEN
640	DO jv = 1,nvm
641	IF ( (jv /= ibare_sechiba) .AND. .NOT.(is_tree(jv)) ) THEN
642	transpot_mean(ig) = transpot_mean(ig) + transpot(ig,jv) * veget_max(ig,jv)/tot_vegfrac_nowoody(ig)
643	END IF
644	END DO
645	ELSE
646	IF (MAXVAL(veget_max(ig,2:nvm)) .GT. min_sechiba) THEN
647	DO jv = 2, nvm
648	transpot_mean(ig) = transpot_mean(ig) + transpot(ig,jv) * veget_max(ig,jv)/ SUM(veget_max(ig,2:nvm))
649	ENDDO
650	ENDIF
651	ENDIF
652	ENDDO
653
654	!
655	! Averaged variables (i.e. *dt_sechiba/dt_routing). This accounts for the difference between the shorter
656	! timestep dt_sechiba of other parts of the model and the long dt_routing timestep (set to one day at present)
657	!
658	totnobio_mean(:) = totnobio_mean(:) + totfrac_nobio(:)*dt_sechiba/dt_routing
659	k_litt_mean(:) = k_litt_mean(:) + k_litt(:)*dt_sechiba/dt_routing
660	!
661	! Only potentially vegetated surfaces are taken into account. At the start of
662	! the growing seasons we will give more weight to these areas.
663	!
664	DO jv=2,nvm
665	DO ig=1,nbpt
666	humrel_mean(ig) = humrel_mean(ig) + humrel(ig,jv)veget_max(ig,jv)dt_sechiba/dt_routing
667	vegtot_mean(ig) = vegtot_mean(ig) + veget_max(ig,jv)*dt_sechiba/dt_routing
668	ENDDO
669	ENDDO
670	!
671	time_counter = time_counter + dt_sechiba
672	!
673	! If the time has come we do the routing.
674	!
675	IF ( NINT(time_counter) .GE. NINT(dt_routing) ) THEN
676	!
677	! Check the water balance if needed
678	!
679	IF ( check_waterbal ) THEN
680	CALL routing_waterbal(nbpt, .TRUE., floodout_mean, runoff_mean, drainage_mean, returnflow_mean, &
681	& reinfiltration_mean, irrigation_mean, riverflow_mean, coastalflow_mean)
682	ENDIF
683	!
684	!! Computes the transport of water in the various reservoirs
685	!
686	CALL routing_flow(nbpt, dt_routing, lalo, floodout_mean, runoff_mean, drainage_mean, &
687	& vegtot_mean, totnobio_mean, transpot_mean, transpot, evapot_corr, veget, veget_max, soil_deficit, &
688	& precip_mean, humrel_mean, k_litt_mean, floodtemp, reinf_slope, &
689	& lakeinflow_mean, returnflow_mean, reinfiltration_mean, irrigation_mean, riverflow_mean, &
690	& coastalflow_mean, hydrographs, slowflow_diag, flood_frac, flood_res, vegstress, &
691	& netflow_stream_diag, netflow_fast_diag, netflow_slow_diag)
692	!
693	!! Responsible for storing the water in lakes
694	!
695	CALL routing_lake(nbpt, dt_routing, lakeinflow_mean, humrel_mean, return_lakes)
696	!
697	returnflow_mean(:) = returnflow_mean(:) + return_lakes(:)
698	!
699	!! Check the water balance in the routing scheme
700	!
701	IF ( check_waterbal ) THEN
702	CALL routing_waterbal(nbpt, .FALSE., floodout_mean, runoff_mean, drainage_mean, returnflow_mean, &
703	& reinfiltration_mean, irrigation_mean, riverflow_mean, coastalflow_mean)
704	ENDIF
705	!
706	time_counter = zero
707	!
708	floodout_mean(:) = zero
709	runoff_mean(:) = zero
710	drainage_mean(:) = zero
711	transpot_mean(:) = zero
712	precip_mean(:) = zero
713	!
714	humrel_mean(:) = zero
715	totnobio_mean(:) = zero
716	k_litt_mean(:) = zero
717	vegtot_mean(:) = zero
718
719	! Change the units of the routing fluxes from kg/dt_routing into kg/dt_sechiba
720	hydrographs(:) = hydrographs(:)/dt_routing*dt_sechiba
721	slowflow_diag(:) = slowflow_diag(:)/dt_routing*dt_sechiba
722
723	! Change the units of the routing fluxes from kg/m^2/dt_routing into kg/m^2/dt_sechiba
724	returnflow_mean(:) = returnflow_mean(:)/dt_routing*dt_sechiba
725	reinfiltration_mean(:) = reinfiltration_mean(:)/dt_routing*dt_sechiba
726	irrigation_mean(:) = irrigation_mean(:)/dt_routing*dt_sechiba
727	irrig_netereq(:) = irrig_netereq(:)/dt_routing*dt_sechiba
728
729	! Change units as above but at the same time transform the kg/dt_routing to m^3/dt_sechiba
730	riverflow_mean(:) = riverflow_mean(:)/dt_routing*dt_sechiba/mille
731	coastalflow_mean(:) = coastalflow_mean(:)/dt_routing*dt_sechiba/mille
732
733	! Water budget residu of the three routing reservoirs (in kg/m^2/s)
734	! Note that these diagnostics are done using local variables only calculated
735	! during the time steps when the routing is calculated
736	CALL xios_orchidee_send_field("wbr_stream",(stream_diag - stream_diag_old - netflow_stream_diag)/dt_routing)
737	CALL xios_orchidee_send_field("wbr_fast", (fast_diag - fast_diag_old - netflow_fast_diag)/dt_routing)
738	CALL xios_orchidee_send_field("wbr_slow", (slow_diag - slow_diag_old - netflow_slow_diag)/dt_routing)
739	CALL xios_orchidee_send_field("wbr_lake", (lake_diag - lake_diag_old - &
740	lakeinflow_mean + return_lakes)/dt_routing)
741	ENDIF
742
743	!
744	! Return the fraction of routed water for this time step.
745	!
746	returnflow(:) = returnflow_mean(:)
747	reinfiltration(:) = reinfiltration_mean(:)
748	irrigation(:) = irrigation_mean(:)
749	riverflow(:) = riverflow_mean(:)
750	coastalflow(:) = coastalflow_mean(:)
751	!
752	! Write diagnostics
753	!
754	! Water storage in reservoirs [kg/m^2]
755	CALL xios_orchidee_send_field("fastr",fast_diag)
756	CALL xios_orchidee_send_field("slowr",slow_diag)
757	CALL xios_orchidee_send_field("streamr",stream_diag)
758	CALL xios_orchidee_send_field("laker",lake_diag)
759	CALL xios_orchidee_send_field("pondr",pond_diag)
760	CALL xios_orchidee_send_field("floodr",flood_diag)
761	CALL xios_orchidee_send_field("floodh",flood_height)
762
763	! Difference between the end and the beginning of the routing time step [kg/m^2]
764	CALL xios_orchidee_send_field("delfastr", fast_diag - fast_diag_old)
765	CALL xios_orchidee_send_field("delslowr", slow_diag - slow_diag_old)
766	CALL xios_orchidee_send_field("delstreamr", stream_diag - stream_diag_old)
767	CALL xios_orchidee_send_field("dellaker", lake_diag - lake_diag_old)
768	CALL xios_orchidee_send_field("delpondr", pond_diag - pond_diag_old)
769	CALL xios_orchidee_send_field("delfloodr", flood_diag - flood_diag_old)
770
771	! Water fluxes converted from kg/m^2/dt_sechiba into kg/m^2/s
772	CALL xios_orchidee_send_field("irrigation",irrigation/dt_sechiba)
773	CALL xios_orchidee_send_field("netirrig",irrig_netereq/dt_sechiba)
774	CALL xios_orchidee_send_field("riversret",returnflow/dt_sechiba)
775	CALL xios_orchidee_send_field("reinfiltration",reinfiltration/dt_sechiba)
776
777	! Transform from kg/dt_sechiba into m^3/s
778	CALL xios_orchidee_send_field("hydrographs",hydrographs/mille/dt_sechiba)
779	CALL xios_orchidee_send_field("slowflow",slowflow_diag/mille/dt_sechiba) ! previous id name: Qb
780	CALL xios_orchidee_send_field("coastalflow",coastalflow/dt_sechiba)
781	CALL xios_orchidee_send_field("riverflow",riverflow/dt_sechiba)
782
783	IF ( .NOT. almaoutput ) THEN
784	!
785	CALL histwrite_p(hist_id, 'riversret', kjit, returnflow, nbpt, index)
786	IF (do_floodplains .OR. doponds) THEN
787	CALL histwrite_p(hist_id, 'reinfiltration', kjit, reinfiltration, nbpt, index)
788	ENDIF
789	CALL histwrite_p(hist_id, 'hydrographs', kjit, hydrographs/mille, nbpt, index)
790	!
791	CALL histwrite_p(hist_id, 'fastr', kjit, fast_diag, nbpt, index)
792	CALL histwrite_p(hist_id, 'slowr', kjit, slow_diag, nbpt, index)
793	CALL histwrite_p(hist_id, 'streamr', kjit, stream_diag, nbpt, index)
794	IF ( do_floodplains ) THEN
795	CALL histwrite_p(hist_id, 'floodr', kjit, flood_diag, nbpt, index)
796	CALL histwrite_p(hist_id, 'floodh', kjit, flood_height, nbpt, index)
797	ENDIF
798	CALL histwrite_p(hist_id, 'pondr', kjit, pond_diag, nbpt, index)
799	CALL histwrite_p(hist_id, 'lakevol', kjit, lake_diag, nbpt, index)
800	!
801	IF ( do_irrigation ) THEN
802	CALL histwrite_p(hist_id, 'irrigation', kjit, irrigation, nbpt, index)
803	CALL histwrite_p(hist_id, 'returnflow', kjit, returnflow, nbpt, index)
804	CALL histwrite_p(hist_id, 'netirrig', kjit, irrig_netereq, nbpt, index)
805	ENDIF
806	!
807	ELSE
808	CALL histwrite_p(hist_id, 'SurfStor', kjit, flood_diag+pond_diag+lake_diag, nbpt, index)
809	CALL histwrite_p(hist_id, 'Dis', kjit, hydrographs/mille, nbpt, index)
810	!
811	CALL histwrite_p(hist_id, 'slowr', kjit, slow_diag, nbpt, index)
812	CALL histwrite_p(hist_id, 'fastr', kjit, fast_diag, nbpt, index)
813	CALL histwrite_p(hist_id, 'streamr', kjit, stream_diag, nbpt, index)
814	CALL histwrite_p(hist_id, 'lakevol', kjit, lake_diag, nbpt, index)
815	CALL histwrite_p(hist_id, 'pondr', kjit, pond_diag, nbpt, index)
816	!
817	IF ( do_irrigation ) THEN
818	CALL histwrite_p(hist_id, 'Qirrig', kjit, irrigation, nbpt, index)
819	CALL histwrite_p(hist_id, 'Qirrig_req', kjit, irrig_netereq, nbpt, index)
820	ENDIF
821	!
822	ENDIF
823	IF ( hist2_id > 0 ) THEN
824	IF ( .NOT. almaoutput ) THEN
825	!
826	CALL histwrite_p(hist2_id, 'riversret', kjit, returnflow, nbpt, index)
827	IF (do_floodplains .OR. doponds) THEN
828	CALL histwrite_p(hist2_id, 'reinfiltration', kjit, reinfiltration, nbpt, index)
829	ENDIF
830	CALL histwrite_p(hist2_id, 'hydrographs', kjit, hydrographs/mille, nbpt, index)
831	!
832	CALL histwrite_p(hist2_id, 'fastr', kjit, fast_diag, nbpt, index)
833	CALL histwrite_p(hist2_id, 'slowr', kjit, slow_diag, nbpt, index)
834	IF ( do_floodplains ) THEN
835	CALL histwrite_p(hist2_id, 'floodr', kjit, flood_diag, nbpt, index)
836	CALL histwrite_p(hist2_id, 'floodh', kjit, flood_height, nbpt, index)
837	ENDIF
838	CALL histwrite_p(hist2_id, 'pondr', kjit, pond_diag, nbpt, index)
839	CALL histwrite_p(hist2_id, 'streamr', kjit, stream_diag, nbpt, index)
840	CALL histwrite_p(hist2_id, 'lakevol', kjit, lake_diag, nbpt, index)
841	!
842	IF ( do_irrigation ) THEN
843	CALL histwrite_p(hist2_id, 'irrigation', kjit, irrigation, nbpt, index)
844	CALL histwrite_p(hist2_id, 'returnflow', kjit, returnflow, nbpt, index)
845	CALL histwrite_p(hist2_id, 'netirrig', kjit, irrig_netereq, nbpt, index)
846	ENDIF
847	!
848	ELSE
849	!
850	CALL histwrite_p(hist2_id, 'SurfStor', kjit, flood_diag+pond_diag+lake_diag, nbpt, index)
851	CALL histwrite_p(hist2_id, 'Dis', kjit, hydrographs/mille, nbpt, index)
852	!
853	ENDIF
854	ENDIF
855	!
856	!
857	END SUBROUTINE routing_main
858
859	!! =============================================================================================================================
860	!! SUBROUTINE: routing_finalize
861	!!
862	!>\BRIEF Write to restart file
863	!!
864	!! DESCRIPTION: Write module variables to restart file
865	!!
866	!! RECENT CHANGE(S)
867	!!
868	!! REFERENCE(S)
869	!!
870	!! FLOWCHART
871	!! \n
872	!_ ==============================================================================================================================
873
874	SUBROUTINE routing_finalize( kjit, nbpt, rest_id, flood_frac, flood_res )
875
876	IMPLICIT NONE
877
878	!! 0.1 Input variables
879	INTEGER(i_std), INTENT(in) :: kjit !! Time step number (unitless)
880	INTEGER(i_std), INTENT(in) :: nbpt !! Domain size (unitless)
881	INTEGER(i_std),INTENT(in) :: rest_id !! Restart file identifier (unitless)
882	REAL(r_std), INTENT(in) :: flood_frac(nbpt) !! Flooded fraction of the grid box (unitless;0-1)
883	REAL(r_std), INTENT(in) :: flood_res(nbpt) !! Diagnostic of water amount in the floodplains reservoir (kg)
884
885	!! 0.2 Local variables
886	REAL(r_std), DIMENSION(1) :: tmp_day
887
888	!_ ================================================================================================================================
889
890	!
891	! Write restart variables
892	!
893	CALL restput_p (rest_id, 'routingcounter', kjit, time_counter)
894
895	CALL restput_p (rest_id, 'routingarea', nbp_glo, nbasmax, 1, kjit, routing_area, 'scatter', nbp_glo, index_g)
896	CALL restput_p (rest_id, 'routetogrid', nbp_glo, nbasmax, 1, kjit, REAL(route_togrid,r_std), 'scatter', &
897	nbp_glo, index_g)
898	CALL restput_p (rest_id, 'routetobasin', nbp_glo, nbasmax, 1, kjit, REAL(route_tobasin,r_std), 'scatter', &
899	nbp_glo, index_g)
900	CALL restput_p (rest_id, 'basinid', nbp_glo, nbasmax, 1, kjit, REAL(global_basinid,r_std), 'scatter', &
901	nbp_glo, index_g)
902	CALL restput_p (rest_id, 'topoindex', nbp_glo, nbasmax, 1, kjit, topo_resid, 'scatter', nbp_glo, index_g)
903	CALL restput_p (rest_id, 'fastres', nbp_glo, nbasmax, 1, kjit, fast_reservoir, 'scatter', nbp_glo, index_g)
904	CALL restput_p (rest_id, 'slowres', nbp_glo, nbasmax, 1, kjit, slow_reservoir, 'scatter', nbp_glo, index_g)
905	CALL restput_p (rest_id, 'streamres', nbp_glo, nbasmax, 1, kjit, stream_reservoir, 'scatter',nbp_glo,index_g)
906	CALL restput_p (rest_id, 'floodres', nbp_glo, nbasmax, 1, kjit, flood_reservoir, 'scatter', nbp_glo, index_g)
907	CALL restput_p (rest_id, 'floodh', nbp_glo, 1, 1, kjit, flood_height, 'scatter', nbp_glo, index_g)
908	CALL restput_p (rest_id, 'flood_frac_bas', nbp_glo, nbasmax, 1, kjit, flood_frac_bas, 'scatter', nbp_glo, index_g)
909	CALL restput_p (rest_id, 'pond_frac', nbp_glo, 1, 1, kjit, pond_frac, 'scatter', nbp_glo, index_g)
910	CALL restput_p (rest_id, 'flood_frac', nbp_glo, 1, 1, kjit, flood_frac, 'scatter', nbp_glo, index_g)
911	CALL restput_p (rest_id, 'flood_res', nbp_glo, 1, 1, kjit, flood_res, 'scatter', nbp_glo, index_g)
912
913	CALL restput_p (rest_id, 'lakeres', nbp_glo, 1, 1, kjit, lake_reservoir, 'scatter', nbp_glo, index_g)
914	CALL restput_p (rest_id, 'pondres', nbp_glo, 1, 1, kjit, pond_reservoir, 'scatter', nbp_glo, index_g)
915
916	CALL restput_p (rest_id, 'lakeinflow', nbp_glo, 1, 1, kjit, lakeinflow_mean, 'scatter', nbp_glo, index_g)
917	CALL restput_p (rest_id, 'returnflow', nbp_glo, 1, 1, kjit, returnflow_mean, 'scatter', nbp_glo, index_g)
918	CALL restput_p (rest_id, 'reinfiltration', nbp_glo, 1, 1, kjit, reinfiltration_mean, 'scatter', nbp_glo, index_g)
919	CALL restput_p (rest_id, 'riverflow', nbp_glo, 1, 1, kjit, riverflow_mean, 'scatter', nbp_glo, index_g)
920	CALL restput_p (rest_id, 'coastalflow', nbp_glo, 1, 1, kjit, coastalflow_mean, 'scatter', nbp_glo, index_g)
921	CALL restput_p (rest_id, 'hydrographs', nbp_glo, 1, 1, kjit, hydrographs, 'scatter', nbp_glo, index_g)
922	CALL restput_p (rest_id, 'slowflow_diag', nbp_glo, 1, 1, kjit, slowflow_diag, 'scatter', nbp_glo, index_g)
923	!
924	! Keep track of the accumulated variables
925	!
926	CALL restput_p (rest_id, 'floodout_route', nbp_glo, 1, 1, kjit, floodout_mean, 'scatter', nbp_glo, index_g)
927	CALL restput_p (rest_id, 'runoff_route', nbp_glo, 1, 1, kjit, runoff_mean, 'scatter', nbp_glo, index_g)
928	CALL restput_p (rest_id, 'drainage_route', nbp_glo, 1, 1, kjit, drainage_mean, 'scatter', nbp_glo, index_g)
929	CALL restput_p (rest_id, 'transpot_route', nbp_glo, 1, 1, kjit, transpot_mean, 'scatter', nbp_glo, index_g)
930	CALL restput_p (rest_id, 'precip_route', nbp_glo, 1, 1, kjit, precip_mean, 'scatter', nbp_glo, index_g)
931	CALL restput_p (rest_id, 'humrel_route', nbp_glo, 1, 1, kjit, humrel_mean, 'scatter', nbp_glo, index_g)
932	CALL restput_p (rest_id, 'totnobio_route', nbp_glo, 1, 1, kjit, totnobio_mean, 'scatter', nbp_glo, index_g)
933	CALL restput_p (rest_id, 'k_litt_route', nbp_glo, 1, 1, kjit, k_litt_mean, 'scatter', nbp_glo, index_g)
934	CALL restput_p (rest_id, 'vegtot_route', nbp_glo, 1, 1, kjit, vegtot_mean, 'scatter', nbp_glo, index_g)
935
936	IF ( do_irrigation ) THEN
937	CALL restput_p (rest_id, 'irrigated', nbp_glo, 1, 1, kjit, irrigated, 'scatter', nbp_glo, index_g)
938	CALL restput_p (rest_id, 'irrigation', nbp_glo, 1, 1, kjit, irrigation_mean, 'scatter', nbp_glo, index_g)
939	ENDIF
940
941	IF ( do_floodplains ) THEN
942	CALL restput_p (rest_id, 'floodplains', nbp_glo, 1, 1, kjit, floodplains, 'scatter', nbp_glo, index_g)
943	ENDIF
944	IF ( doswamps ) THEN
945	CALL restput_p (rest_id, 'swamp', nbp_glo, 1, 1, kjit, swamp, 'scatter', nbp_glo, index_g)
946	ENDIF
947
948	END SUBROUTINE routing_finalize
949
950	!! ================================================================================================================================
951	!! SUBROUTINE : routing_init
952	!!
953	!>\BRIEF This subroutine allocates the memory and get the fixed fields from the restart file.
954	!!
955	!! DESCRIPTION (definitions, functional, design, flags) : None
956	!!
957	!! RECENT CHANGE(S): None
958	!!
959	!! MAIN OUTPUT VARIABLE(S):
960	!!
961	!! REFERENCES : None
962	!!
963	!! FLOWCHART :None
964	!! \n
965	!_ ================================================================================================================================
966
967	SUBROUTINE routing_init(kjit, nbpt, index, returnflow, reinfiltration, irrigation, &
968	& riverflow, coastalflow, flood_frac, flood_res, stempdiag, rest_id)
969	!
970	IMPLICIT NONE
971	!
972	! interface description
973	!
974	!! INPUT VARIABLES
975	INTEGER(i_std), INTENT(in) :: kjit !! Time step number (unitless)
976	INTEGER(i_std), INTENT(in) :: nbpt !! Domain size (unitless)
977	INTEGER(i_std), DIMENSION (nbpt), INTENT(in) :: index !! Indices of the points on the map (unitless)
978	REAL(r_std), DIMENSION(nbpt,nslm),INTENT(in) :: stempdiag !! Temperature profile in soil
979	INTEGER(i_std), INTENT(in) :: rest_id !! Restart file identifier (unitless)
980	!
981	!! OUTPUT VARIABLES
982	REAL(r_std), DIMENSION (nbpt),INTENT(out) :: returnflow !! The water flow from lakes and swamps which returns into the grid box.
983	!! This water will go back into the hydrol or hydrolc module to allow re-evaporation (kg/m^2/dt)
984	REAL(r_std), DIMENSION (nbpt),INTENT(out) :: reinfiltration !! Water flow from ponds and floodplains which returns to the grid box (kg/m^2/dt)
985	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)
986	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)
987	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)
988	REAL(r_std), DIMENSION (nbpt),INTENT(out) :: flood_frac !! Flooded fraction of the grid box (unitless;0-1)
989	REAL(r_std), DIMENSION (nbpt),INTENT(out) :: flood_res !! Diagnostic of water amount in the floodplains reservoir (kg)
990	!
991	!! LOCAL VARIABLES
992	CHARACTER(LEN=80) :: var_name !! To store variables names for I/O (unitless)
993	REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: tmp_real_g !! A temporary real array for the integers
994	REAL(r_std), DIMENSION(1) :: tmp_day !!
995	REAL(r_std) :: ratio !! Diagnostic ratio to check that dt_routing is a multiple of dt_sechiba (unitless)
996	REAL(r_std) :: totarea !! Total area of basin (m^2)
997	INTEGER(i_std) :: ier, ig, ib, ipn(1) !! Indices (unitless)
998
999	!_ ================================================================================================================================
1000	!
1001	!
1002	! These variables will require the configuration infrastructure
1003	!
1004	!Config Key = ROUTING_TIMESTEP
1005	!Config If = RIVER_ROUTING
1006	!Config Desc = Time step of the routing scheme
1007	!Config Def = one_day
1008	!Config Help = This values gives the time step in seconds of the routing scheme.
1009	!Config It should be multiple of the main time step of ORCHIDEE. One day
1010	!Config is a good value.
1011	!Config Units = [seconds]
1012	!
1013	dt_routing = one_day
1014	CALL getin_p('DT_ROUTING', dt_routing)
1015	!
1016	!Config Key = ROUTING_RIVERS
1017	!Config If = RIVER_ROUTING
1018	!Config Desc = Number of rivers
1019	!Config Def = 50
1020	!Config Help = This parameter chooses the number of largest river basins
1021	!Config which should be treated as independently as rivers and not
1022	!Config flow into the oceans as diffusion coastal flow.
1023	!Config Units = [-]
1024	num_largest = 50
1025	CALL getin_p('ROUTING_RIVERS', num_largest)
1026	!
1027	!Config Key = DO_FLOODINFILT
1028	!Config Desc = Should floodplains reinfiltrate into the soil
1029	!Config If = RIVER_ROUTING
1030	!Config Def = n
1031	!Config Help = This parameters allows the user to ask the model
1032	!Config to take into account the flood plains reinfiltration
1033	!Config into the soil moisture. It then can go
1034	!Config back to the slow and fast reservoirs
1035	!Config Units = [FLAG]
1036	!
1037	dofloodinfilt = .FALSE.
1038	CALL getin_p('DO_FLOODINFILT', dofloodinfilt)
1039	!
1040	!Config Key = DO_SWAMPS
1041	!Config Desc = Should we include swamp parameterization
1042	!Config If = RIVER_ROUTING
1043	!Config Def = n
1044	!Config Help = This parameters allows the user to ask the model
1045	!Config to take into account the swamps and return
1046	!Config the water into the bottom of the soil. It then can go
1047	!Config back to the atmopshere. This tried to simulate
1048	!Config internal deltas of rivers.
1049	!Config Units = [FLAG]
1050	!
1051	doswamps = .FALSE.
1052	CALL getin_p('DO_SWAMPS', doswamps)
1053	!
1054	!Config Key = DO_PONDS
1055	!Config Desc = Should we include ponds
1056	!Config If = RIVER_ROUTING
1057	!Config Def = n
1058	!Config Help = This parameters allows the user to ask the model
1059	!Config to take into account the ponds and return
1060	!Config the water into the soil moisture. It then can go
1061	!Config back to the atmopshere. This tried to simulate
1062	!Config little ponds especially in West Africa.
1063	!Config Units = [FLAG]
1064	!
1065	doponds = .FALSE.
1066	CALL getin_p('DO_PONDS', doponds)
1067	!
1068	! Fix the time constants according to hydrol_cwrr flag
1069	!
1070	!
1071	!Config Key = SLOW_TCST
1072	!Config Desc = Time constant for the slow reservoir
1073	!Config If = RIVER_ROUTING
1074	!Config Def = 25.0
1075	!Config Help = This parameters allows the user to fix the
1076	!Config time constant (in days) of the slow reservoir
1077	!Config in order to get better river flows for
1078	!Config particular regions.
1079	!Config Units = [days]
1080	!
1081	!> A value for property of each reservoir (in day/m) is given to compute a time constant (in day)
1082	!> for each reservoir (product of tcst and topo_resid).
1083	!> The value of tcst has been calibrated for the three reservoirs over the Senegal river basin only,
1084	!> during the 1 degree NCEP Corrected by Cru (NCC) resolution simulations (Ngo-Duc et al., 2005, Ngo-Duc et al., 2006) and
1085	!> generalized for all the basins of the world. The "slow reservoir" and the "fast reservoir"
1086	!> have the highest value in order to simulate the groundwater.
1087	!> The "stream reservoir", which represents all the water of the stream, has the lowest value.
1088	!> Those figures are the same for all the basins of the world.
1089	!> The value of slow_tcst is equal to fast_tcst when CWRR is activated.
1090	!> This assumption should be re-discussed.
1091	!
1092	IF ( hydrol_cwrr ) THEN
1093	slow_tcst = slow_tcst_cwrr
1094	ELSE
1095	slow_tcst = slow_tcst_chois
1096	ENDIF
1097	CALL getin_p('SLOW_TCST', slow_tcst)
1098	!
1099	!Config Key = FAST_TCST
1100	!Config Desc = Time constant for the fast reservoir
1101	!Config If = RIVER_ROUTING
1102	!Config Def = 3.0
1103	!Config Help = This parameters allows the user to fix the
1104	!Config time constant (in days) of the fast reservoir
1105	!Config in order to get better river flows for
1106	!Config particular regions.
1107	!Config Units = [days]
1108	!
1109	IF ( hydrol_cwrr ) THEN
1110	fast_tcst = fast_tcst_cwrr
1111	ELSE
1112	fast_tcst = fast_tcst_chois
1113	ENDIF
1114	CALL getin_p('FAST_TCST', fast_tcst)
1115	!
1116	!Config Key = STREAM_TCST
1117	!Config Desc = Time constant for the stream reservoir
1118	!Config If = RIVER_ROUTING
1119	!Config Def = 0.24
1120	!Config Help = This parameters allows the user to fix the
1121	!Config time constant (in days) of the stream reservoir
1122	!Config in order to get better river flows for
1123	!Config particular regions.
1124	!Config Units = [days]
1125	!
1126	IF ( hydrol_cwrr ) THEN
1127	stream_tcst = stream_tcst_cwrr
1128	ELSE
1129	stream_tcst = stream_tcst_chois
1130	ENDIF
1131	CALL getin_p('STREAM_TCST', stream_tcst)
1132	!
1133	!Config Key = FLOOD_TCST
1134	!Config Desc = Time constant for the flood reservoir
1135	!Config If = RIVER_ROUTING
1136	!Config Def = 4.0
1137	!Config Help = This parameters allows the user to fix the
1138	!Config time constant (in days) of the flood reservoir
1139	!Config in order to get better river flows for
1140	!Config particular regions.
1141	!Config Units = [days]
1142	!
1143	IF ( hydrol_cwrr ) THEN
1144	flood_tcst = flood_tcst_cwrr
1145	ELSE
1146	flood_tcst = flood_tcst_chois
1147	ENDIF
1148	CALL getin_p('FLOOD_TCST', flood_tcst)
1149	!
1150	!Config Key = SWAMP_CST
1151	!Config Desc = Fraction of the river that flows back to swamps
1152	!Config If = RIVER_ROUTING
1153	!Config Def = 0.2
1154	!Config Help = This parameters allows the user to fix the
1155	!Config fraction of the river transport
1156	!Config that flows to swamps
1157	!Config Units = [-]
1158	!
1159	IF ( hydrol_cwrr ) THEN
1160	swamp_cst = swamp_cst_cwrr
1161	ELSE
1162	swamp_cst = swamp_cst_chois
1163	ENDIF
1164	CALL getin_p('SWAMP_CST', swamp_cst)
1165	!
1166	!Config Key = FLOOD_BETA
1167	!Config Desc = Parameter to fix the shape of the floodplain
1168	!Config If = RIVER_ROUTING
1169	!Config Def = 2.0
1170	!Config Help = Parameter to fix the shape of the floodplain
1171	!Config (>1 for convex edges, <1 for concave edges)
1172	!Config Units = [-]
1173	CALL getin_p("FLOOD_BETA", beta)
1174	!
1175	!Config Key = POND_BETAP
1176	!Config Desc = Ratio of the basin surface intercepted by ponds and the maximum surface of ponds
1177	!Config If = RIVER_ROUTING
1178	!Config Def = 0.5
1179	!Config Help =
1180	!Config Units = [-]
1181	CALL getin_p("POND_BETAP", betap)
1182	!
1183	!Config Key = FLOOD_CRI
1184	!Config Desc = Potential height for which all the basin is flooded
1185	!Config If = DO_FLOODPLAINS or DO_PONDS
1186	!Config Def = 2000.
1187	!Config Help =
1188	!Config Units = [mm]
1189	CALL getin_p("FLOOD_CRI", floodcri)
1190	!
1191	!Config Key = POND_CRI
1192	!Config Desc = Potential height for which all the basin is a pond
1193	!Config If = DO_FLOODPLAINS or DO_PONDS
1194	!Config Def = 2000.
1195	!Config Help =
1196	!Config Units = [mm]
1197	CALL getin_p("POND_CRI", pondcri)
1198
1199	!Config Key = MAX_LAKE_RESERVOIR
1200	!Config Desc = Maximum limit of water in lake_reservoir
1201	!Config If = RIVER_ROUTING
1202	!Config Def = 7000
1203	!Config Help =
1204	!Config Units = [kg/m2(routing area)]
1205	max_lake_reservoir = 7000
1206	CALL getin_p("MAX_LAKE_RESERVOIR", max_lake_reservoir)
1207
1208	!
1209	!
1210	! In order to simplify the time cascade check that dt_routing
1211	! is a multiple of dt_sechiba
1212	!
1213	ratio = dt_routing/dt_sechiba
1214	IF ( ABS(NINT(ratio) - ratio) .GT. 10*EPSILON(ratio)) THEN
1215	WRITE(numout,*) 'WARNING -- WARNING -- WARNING -- WARNING'
1216	WRITE(numout,*) "The chosen time step for the routing is not a multiple of the"
1217	WRITE(numout,*) "main time step of the model. We will change dt_routing so that"
1218	WRITE(numout,*) "this condition os fulfilled"
1219	dt_routing = NINT(ratio) * dt_sechiba
1220	WRITE(numout,*) 'THE NEW DT_ROUTING IS : ', dt_routing
1221	ENDIF
1222	!
1223	IF ( dt_routing .LT. dt_sechiba) THEN
1224	WRITE(numout,*) 'WARNING -- WARNING -- WARNING -- WARNING'
1225	WRITE(numout,*) 'The routing timestep can not be smaller than the one'
1226	WRITE(numout,*) 'of the model. We reset its value to the model''s timestep.'
1227	WRITE(numout,*) 'The old DT_ROUTING is : ', dt_routing
1228	dt_routing = dt_sechiba
1229	WRITE(numout,*) 'THE NEW DT_ROUTING IS : ', dt_routing
1230	ENDIF
1231	!
1232	var_name ="routingcounter"
1233	CALL ioconf_setatt_p('UNITS', 's')
1234	CALL ioconf_setatt_p('LONG_NAME','Time counter for the routing scheme')
1235	CALL restget_p (rest_id, var_name, kjit, .TRUE., zero, time_counter)
1236	CALL setvar_p (time_counter, val_exp, 'NO_KEYWORD', zero)
1237
1238	ALLOCATE (routing_area_loc(nbpt,nbasmax), stat=ier)
1239	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for routing_area_loc','','')
1240
1241	ALLOCATE (routing_area_glo(nbp_glo,nbasmax))
1242	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for routing_area_glo','','')
1243	var_name = 'routingarea'
1244	IF (is_root_prc) THEN
1245	CALL ioconf_setatt('UNITS', 'm^2')
1246	CALL ioconf_setatt('LONG_NAME','Area of basin')
1247	CALL restget (rest_id, var_name, nbp_glo, nbasmax, 1, kjit, .TRUE., routing_area_glo, "gather", nbp_glo, index_g)
1248	ENDIF
1249	CALL scatter(routing_area_glo,routing_area_loc)
1250	routing_area=>routing_area_loc
1251
1252	ALLOCATE (tmp_real_g(nbp_glo,nbasmax), stat=ier)
1253	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for tmp_real_g','','')
1254
1255	ALLOCATE (route_togrid_loc(nbpt,nbasmax), stat=ier)
1256	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for route_togrid_loc','','')
1257	ALLOCATE (route_togrid_glo(nbp_glo,nbasmax), stat=ier) ! used in global in routing_flow
1258	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for route_togrid_glo','','')
1259
1260	IF (is_root_prc) THEN
1261	var_name = 'routetogrid'
1262	CALL ioconf_setatt('UNITS', '-')
1263	CALL ioconf_setatt('LONG_NAME','Grid into which the basin flows')
1264	CALL restget (rest_id, var_name, nbp_glo, nbasmax, 1, kjit, .TRUE., tmp_real_g, "gather", nbp_glo, index_g)
1265	route_togrid_glo(:,:) = undef_int
1266	WHERE ( tmp_real_g .LT. val_exp )
1267	route_togrid_glo = NINT(tmp_real_g)
1268	ENDWHERE
1269	ENDIF
1270	CALL bcast(route_togrid_glo) ! used in global in routing_flow
1271	CALL scatter(route_togrid_glo,route_togrid_loc)
1272	route_togrid=>route_togrid_loc
1273	!
1274	ALLOCATE (route_tobasin_loc(nbpt,nbasmax), stat=ier)
1275	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for route_tobasin_loc','','')
1276
1277	ALLOCATE (route_tobasin_glo(nbp_glo,nbasmax), stat=ier)
1278	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for route_tobasin_glo','','')
1279
1280	IF (is_root_prc) THEN
1281	var_name = 'routetobasin'
1282	CALL ioconf_setatt('UNITS', '-')
1283	CALL ioconf_setatt('LONG_NAME','Basin in to which the water goes')
1284	CALL restget (rest_id, var_name, nbp_glo, nbasmax, 1, kjit, .TRUE., tmp_real_g, "gather", nbp_glo, index_g)
1285	route_tobasin_glo = undef_int
1286	WHERE ( tmp_real_g .LT. val_exp )
1287	route_tobasin_glo = NINT(tmp_real_g)
1288	ENDWHERE
1289	ENDIF
1290	CALL scatter(route_tobasin_glo,route_tobasin_loc)
1291	route_tobasin=>route_tobasin_loc
1292	!
1293	! nbintobasin
1294	!
1295	ALLOCATE (route_nbintobas_loc(nbpt,nbasmax), stat=ier)
1296	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for route_nbintobas_loc','','')
1297	ALLOCATE (route_nbintobas_glo(nbp_glo,nbasmax), stat=ier)
1298	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for route_nbintobas_glo','','')
1299
1300	IF (is_root_prc) THEN
1301	var_name = 'routenbintobas'
1302	CALL ioconf_setatt('UNITS', '-')
1303	CALL ioconf_setatt('LONG_NAME','Number of basin into current one')
1304	CALL restget (rest_id, var_name, nbp_glo, nbasmax, 1, kjit, .TRUE., tmp_real_g, "gather", nbp_glo, index_g)
1305	route_nbintobas_glo = undef_int
1306	WHERE ( tmp_real_g .LT. val_exp )
1307	route_nbintobas_glo = NINT(tmp_real_g)
1308	ENDWHERE
1309	ENDIF
1310	CALL scatter(route_nbintobas_glo,route_nbintobas_loc)
1311	route_nbintobas=>route_nbintobas_loc
1312	!
1313	ALLOCATE (global_basinid_loc(nbpt,nbasmax), stat=ier)
1314	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for global_basinid_loc','','')
1315	ALLOCATE (global_basinid_glo(nbp_glo,nbasmax), stat=ier)
1316	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for global_basinid_glo','','')
1317
1318	IF (is_root_prc) THEN
1319	var_name = 'basinid'
1320	CALL ioconf_setatt('UNITS', '-')
1321	CALL ioconf_setatt('LONG_NAME','ID of basin')
1322	CALL restget (rest_id, var_name, nbp_glo, nbasmax, 1, kjit, .TRUE., tmp_real_g, "gather", nbp_glo, index_g)
1323	global_basinid_glo = undef_int
1324	WHERE ( tmp_real_g .LT. val_exp )
1325	global_basinid_glo = NINT(tmp_real_g)
1326	ENDWHERE
1327	ENDIF
1328	CALL scatter(global_basinid_glo,global_basinid_loc)
1329	global_basinid=>global_basinid_loc
1330	!
1331	ALLOCATE (topo_resid_loc(nbpt,nbasmax), stat=ier)
1332	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for topo_resid_loc','','')
1333	ALLOCATE (topo_resid_glo(nbp_glo,nbasmax), stat=ier)
1334	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for topo_resid_glo','','')
1335
1336	IF (is_root_prc) THEN
1337	var_name = 'topoindex'
1338	CALL ioconf_setatt('UNITS', 'm')
1339	CALL ioconf_setatt('LONG_NAME','Topographic index of the residence time')
1340	CALL restget (rest_id, var_name, nbp_glo, nbasmax, 1, kjit, .TRUE., topo_resid_glo, "gather", nbp_glo, index_g)
1341	ENDIF
1342	CALL scatter(topo_resid_glo,topo_resid_loc)
1343	topo_resid=>topo_resid_loc
1344
1345	ALLOCATE (fast_reservoir(nbpt,nbasmax), stat=ier)
1346	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for fast_reservoir','','')
1347	var_name = 'fastres'
1348	CALL ioconf_setatt_p('UNITS', 'Kg')
1349	CALL ioconf_setatt_p('LONG_NAME','Water in the fast reservoir')
1350	CALL restget_p (rest_id, var_name, nbp_glo, nbasmax, 1, kjit, .TRUE., fast_reservoir, "gather", nbp_glo, index_g)
1351	CALL setvar_p (fast_reservoir, val_exp, 'NO_KEYWORD', zero)
1352
1353	ALLOCATE (slow_reservoir(nbpt,nbasmax), stat=ier)
1354	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for slow_reservoir','','')
1355	var_name = 'slowres'
1356	CALL ioconf_setatt_p('UNITS', 'Kg')
1357	CALL ioconf_setatt_p('LONG_NAME','Water in the slow reservoir')
1358	CALL restget_p (rest_id, var_name, nbp_glo, nbasmax, 1, kjit, .TRUE., slow_reservoir, "gather", nbp_glo, index_g)
1359	CALL setvar_p (slow_reservoir, val_exp, 'NO_KEYWORD', zero)
1360
1361	ALLOCATE (stream_reservoir(nbpt,nbasmax), stat=ier)
1362	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for stream_reservoir','','')
1363	var_name = 'streamres'
1364	CALL ioconf_setatt_p('UNITS', 'Kg')
1365	CALL ioconf_setatt_p('LONG_NAME','Water in the stream reservoir')
1366	CALL restget_p (rest_id, var_name, nbp_glo, nbasmax, 1, kjit, .TRUE., stream_reservoir, "gather", nbp_glo, index_g)
1367	CALL setvar_p (stream_reservoir, val_exp, 'NO_KEYWORD', zero)
1368
1369	ALLOCATE (flood_reservoir(nbpt,nbasmax), stat=ier)
1370	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for flood_reservoir','','')
1371	var_name = 'floodres'
1372	CALL ioconf_setatt_p('UNITS', 'Kg')
1373	CALL ioconf_setatt_p('LONG_NAME','Water in the flood reservoir')
1374	CALL restget_p (rest_id, var_name, nbp_glo, nbasmax, 1, kjit, .TRUE., flood_reservoir, "gather", nbp_glo, index_g)
1375	CALL setvar_p (flood_reservoir, val_exp, 'NO_KEYWORD', zero)
1376
1377	ALLOCATE (flood_frac_bas(nbpt,nbasmax), stat=ier)
1378	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for flood_frac_bas','','')
1379	var_name = 'flood_frac_bas'
1380	CALL ioconf_setatt_p('UNITS', '-')
1381	CALL ioconf_setatt_p('LONG_NAME','Flooded fraction per basin')
1382	CALL restget_p (rest_id, var_name, nbp_glo, nbasmax, 1, kjit, .TRUE., flood_frac_bas, "gather", nbp_glo, index_g)
1383	CALL setvar_p (flood_frac_bas, val_exp, 'NO_KEYWORD', zero)
1384
1385	ALLOCATE (flood_height(nbpt), stat=ier)
1386	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for flood_height','','')
1387	var_name = 'floodh'
1388	CALL ioconf_setatt_p('UNITS', '-')
1389	CALL ioconf_setatt_p('LONG_NAME','')
1390	CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., flood_height, "gather", nbp_glo, index_g)
1391	CALL setvar_p (flood_height, val_exp, 'NO_KEYWORD', zero)
1392
1393	ALLOCATE (pond_frac(nbpt), stat=ier)
1394	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for pond_frac','','')
1395	var_name = 'pond_frac'
1396	CALL ioconf_setatt_p('UNITS', '-')
1397	CALL ioconf_setatt_p('LONG_NAME','Pond fraction per grid box')
1398	CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., pond_frac, "gather", nbp_glo, index_g)
1399	CALL setvar_p (pond_frac, val_exp, 'NO_KEYWORD', zero)
1400
1401	var_name = 'flood_frac'
1402	CALL ioconf_setatt_p('UNITS', '-')
1403	CALL ioconf_setatt_p('LONG_NAME','Flooded fraction per grid box')
1404	CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., flood_frac, "gather", nbp_glo, index_g)
1405	CALL setvar_p (flood_frac, val_exp, 'NO_KEYWORD', zero)
1406
1407	var_name = 'flood_res'
1408	CALL ioconf_setatt_p('UNITS','mm')
1409	CALL ioconf_setatt_p('LONG_NAME','Flooded quantity (estimation)')
1410	CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., flood_res, "gather", nbp_glo, index_g)
1411	CALL setvar_p (flood_res, val_exp, 'NO_KEYWORD', zero)
1412	! flood_res = zero
1413
1414	ALLOCATE (lake_reservoir(nbpt), stat=ier)
1415	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for lake_reservoir','','')
1416	var_name = 'lakeres'
1417	CALL ioconf_setatt_p('UNITS', 'Kg')
1418	CALL ioconf_setatt_p('LONG_NAME','Water in the lake reservoir')
1419	CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., lake_reservoir, "gather", nbp_glo, index_g)
1420	CALL setvar_p (lake_reservoir, val_exp, 'NO_KEYWORD', zero)
1421
1422	ALLOCATE (pond_reservoir(nbpt), stat=ier)
1423	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for pond_reservoir','','')
1424	var_name = 'pondres'
1425	CALL ioconf_setatt_p('UNITS', 'Kg')
1426	CALL ioconf_setatt_p('LONG_NAME','Water in the pond reservoir')
1427	CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., pond_reservoir, "gather", nbp_glo, index_g)
1428	CALL setvar_p (pond_reservoir, val_exp, 'NO_KEYWORD', zero)
1429	!
1430	! Map of irrigated areas
1431	!
1432	IF ( do_irrigation ) THEN
1433	ALLOCATE (irrigated(nbpt), stat=ier)
1434	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for irrigated','','')
1435	var_name = 'irrigated'
1436	CALL ioconf_setatt_p('UNITS', 'm^2')
1437	CALL ioconf_setatt_p('LONG_NAME','Surface of irrigated area')
1438	CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., irrigated, "gather", nbp_glo, index_g)
1439	CALL setvar_p (irrigated, val_exp, 'NO_KEYWORD', undef_sechiba)
1440	ENDIF
1441
1442	IF ( do_floodplains ) THEN
1443	ALLOCATE (floodplains(nbpt), stat=ier)
1444	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for floodplains','','')
1445	var_name = 'floodplains'
1446	CALL ioconf_setatt_p('UNITS', 'm^2')
1447	CALL ioconf_setatt_p('LONG_NAME','Surface which can be flooded')
1448	CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., floodplains, "gather", nbp_glo, index_g)
1449	CALL setvar_p (floodplains, val_exp, 'NO_KEYWORD', undef_sechiba)
1450	ENDIF
1451	IF ( doswamps ) THEN
1452	ALLOCATE (swamp(nbpt), stat=ier)
1453	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for swamp','','')
1454	var_name = 'swamp'
1455	CALL ioconf_setatt_p('UNITS', 'm^2')
1456	CALL ioconf_setatt_p('LONG_NAME','Surface which can become swamp')
1457	CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., swamp, "gather", nbp_glo, index_g)
1458	CALL setvar_p (swamp, val_exp, 'NO_KEYWORD', undef_sechiba)
1459	ENDIF
1460	!
1461	! Put into the restart file the fluxes so that they can be regenerated at restart.
1462	!
1463	ALLOCATE (lakeinflow_mean(nbpt), stat=ier)
1464	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for lakeinflow_mean','','')
1465	var_name = 'lakeinflow'
1466	CALL ioconf_setatt_p('UNITS', 'Kg/dt')
1467	CALL ioconf_setatt_p('LONG_NAME','Lake inflow')
1468	CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., lakeinflow_mean, "gather", nbp_glo, index_g)
1469	CALL setvar_p (lakeinflow_mean, val_exp, 'NO_KEYWORD', zero)
1470
1471	ALLOCATE (returnflow_mean(nbpt), stat=ier)
1472	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for returnflow_mean','','')
1473	var_name = 'returnflow'
1474	CALL ioconf_setatt_p('UNITS', 'Kg/m^2/dt')
1475	CALL ioconf_setatt_p('LONG_NAME','Deep return flux')
1476	CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., returnflow_mean, "gather", nbp_glo, index_g)
1477	CALL setvar_p (returnflow_mean, val_exp, 'NO_KEYWORD', zero)
1478	returnflow(:) = returnflow_mean(:)
1479
1480	ALLOCATE (reinfiltration_mean(nbpt), stat=ier)
1481	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for reinfiltration_mean','','')
1482	var_name = 'reinfiltration'
1483	CALL ioconf_setatt_p('UNITS', 'Kg/m^2/dt')
1484	CALL ioconf_setatt_p('LONG_NAME','Top return flux')
1485	CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., reinfiltration_mean, "gather", nbp_glo, index_g)
1486	CALL setvar_p (reinfiltration_mean, val_exp, 'NO_KEYWORD', zero)
1487	reinfiltration(:) = reinfiltration_mean(:)
1488
1489	ALLOCATE (irrigation_mean(nbpt), stat=ier)
1490	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for irrigation_mean','','')
1491	ALLOCATE (irrig_netereq(nbpt), stat=ier)
1492	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for irrig_netereq','','')
1493	irrig_netereq(:) = zero
1494
1495	IF ( do_irrigation ) THEN
1496	var_name = 'irrigation'
1497	CALL ioconf_setatt_p('UNITS', 'Kg/dt')
1498	CALL ioconf_setatt_p('LONG_NAME','Artificial irrigation flux')
1499	CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., irrigation_mean, "gather", nbp_glo, index_g)
1500	CALL setvar_p (irrigation_mean, val_exp, 'NO_KEYWORD', zero)
1501	ELSE
1502	irrigation_mean(:) = zero
1503	ENDIF
1504	irrigation(:) = irrigation_mean(:)
1505
1506	ALLOCATE (riverflow_mean(nbpt), stat=ier)
1507	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for riverflow_mean','','')
1508	var_name = 'riverflow'
1509	CALL ioconf_setatt_p('UNITS', 'Kg/dt')
1510	CALL ioconf_setatt_p('LONG_NAME','River flux into the sea')
1511	CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., riverflow_mean, "gather", nbp_glo, index_g)
1512	CALL setvar_p (riverflow_mean, val_exp, 'NO_KEYWORD', zero)
1513	riverflow(:) = riverflow_mean(:)
1514
1515	ALLOCATE (coastalflow_mean(nbpt), stat=ier)
1516	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for coastalflow_mean','','')
1517	var_name = 'coastalflow'
1518	CALL ioconf_setatt_p('UNITS', 'Kg/dt')
1519	CALL ioconf_setatt_p('LONG_NAME','Diffuse flux into the sea')
1520	CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., coastalflow_mean, "gather", nbp_glo, index_g)
1521	CALL setvar_p (coastalflow_mean, val_exp, 'NO_KEYWORD', zero)
1522	coastalflow(:) = coastalflow_mean(:)
1523
1524	! Locate it at the 2m level
1525	ipn = MINLOC(ABS(diaglev-2))
1526	floodtemp_lev = ipn(1)
1527	ALLOCATE (floodtemp(nbpt), stat=ier)
1528	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for floodtemp','','')
1529	floodtemp(:) = stempdiag(:,floodtemp_lev)
1530
1531	ALLOCATE(hydrographs(nbpt), stat=ier)
1532	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for hydrographs','','')
1533	var_name = 'hydrographs'
1534	CALL ioconf_setatt_p('UNITS', 'kg/dt_sechiba')
1535	CALL ioconf_setatt_p('LONG_NAME','Hydrograph at outlow of grid')
1536	CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., hydrographs, "gather", nbp_glo, index_g)
1537	CALL setvar_p (hydrographs, val_exp, 'NO_KEYWORD', zero)
1538
1539	ALLOCATE(slowflow_diag(nbpt), stat=ier)
1540	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for slowflow_diag','','')
1541	var_name = 'slowflow_diag'
1542	CALL ioconf_setatt_p('UNITS', 'kg/dt_sechiba')
1543	CALL ioconf_setatt_p('LONG_NAME','Slowflow hydrograph at outlow of grid')
1544	CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE.,slowflow_diag, "gather", nbp_glo, index_g)
1545	CALL setvar_p (slowflow_diag, val_exp, 'NO_KEYWORD', zero)
1546
1547	!
1548	! The diagnostic variables, they are initialized from the above restart variables.
1549	!
1550	ALLOCATE(fast_diag(nbpt), slow_diag(nbpt), stream_diag(nbpt), flood_diag(nbpt), &
1551	& pond_diag(nbpt), lake_diag(nbpt), stat=ier)
1552	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for fast_diag,..','','')
1553
1554	fast_diag(:) = zero
1555	slow_diag(:) = zero
1556	stream_diag(:) = zero
1557	flood_diag(:) = zero
1558	pond_diag(:) = zero
1559	lake_diag(:) = zero
1560
1561	DO ig=1,nbpt
1562	totarea = zero
1563	DO ib=1,nbasmax
1564	totarea = totarea + routing_area(ig,ib)
1565	fast_diag(ig) = fast_diag(ig) + fast_reservoir(ig,ib)
1566	slow_diag(ig) = slow_diag(ig) + slow_reservoir(ig,ib)
1567	stream_diag(ig) = stream_diag(ig) + stream_reservoir(ig,ib)
1568	flood_diag(ig) = flood_diag(ig) + flood_reservoir(ig,ib)
1569	ENDDO
1570	!
1571	fast_diag(ig) = fast_diag(ig)/totarea
1572	slow_diag(ig) = slow_diag(ig)/totarea
1573	stream_diag(ig) = stream_diag(ig)/totarea
1574	flood_diag(ig) = flood_diag(ig)/totarea
1575	!
1576	! This is the volume of the lake scaled to the entire grid.
1577	! It would be better to scale it to the size of the lake
1578	! but this information is not yet available.
1579	!
1580	lake_diag(ig) = lake_reservoir(ig)/totarea
1581	!
1582	ENDDO
1583	!
1584	! Get from the restart the fluxes we accumulated.
1585	!
1586	ALLOCATE (floodout_mean(nbpt), stat=ier)
1587	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for floodout_mean','','')
1588	var_name = 'floodout_route'
1589	CALL ioconf_setatt_p('UNITS', 'Kg')
1590	CALL ioconf_setatt_p('LONG_NAME','Accumulated flow out of floodplains for routing')
1591	CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., floodout_mean, "gather", nbp_glo, index_g)
1592	CALL setvar_p (floodout_mean, val_exp, 'NO_KEYWORD', zero)
1593
1594	ALLOCATE (runoff_mean(nbpt), stat=ier)
1595	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for runoff_mean','','')
1596	var_name = 'runoff_route'
1597	CALL ioconf_setatt_p('UNITS', 'Kg')
1598	CALL ioconf_setatt_p('LONG_NAME','Accumulated runoff for routing')
1599	CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., runoff_mean, "gather", nbp_glo, index_g)
1600	CALL setvar_p (runoff_mean, val_exp, 'NO_KEYWORD', zero)
1601
1602	ALLOCATE(drainage_mean(nbpt), stat=ier)
1603	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for drainage_mean','','')
1604	var_name = 'drainage_route'
1605	CALL ioconf_setatt_p('UNITS', 'Kg')
1606	CALL ioconf_setatt_p('LONG_NAME','Accumulated drainage for routing')
1607	CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., drainage_mean, "gather", nbp_glo, index_g)
1608	CALL setvar_p (drainage_mean, val_exp, 'NO_KEYWORD', zero)
1609
1610	ALLOCATE(transpot_mean(nbpt), stat=ier)
1611	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for transpot_mean','','')
1612	var_name = 'transpot_route'
1613	CALL ioconf_setatt_p('UNITS', 'Kg/m^2')
1614	CALL ioconf_setatt_p('LONG_NAME','Accumulated potential transpiration for routing/irrigation')
1615	CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., transpot_mean, "gather", nbp_glo, index_g)
1616	CALL setvar_p (transpot_mean, val_exp, 'NO_KEYWORD', zero)
1617
1618	ALLOCATE(precip_mean(nbpt), stat=ier)
1619	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for precip_mean','','')
1620	var_name = 'precip_route'
1621	CALL ioconf_setatt_p('UNITS', 'Kg/m^2')
1622	CALL ioconf_setatt_p('LONG_NAME','Accumulated rain precipitation for irrigation')
1623	CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., precip_mean, "gather", nbp_glo, index_g)
1624	CALL setvar_p (precip_mean, val_exp, 'NO_KEYWORD', zero)
1625
1626	ALLOCATE(humrel_mean(nbpt), stat=ier)
1627	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for humrel_mean','','')
1628	var_name = 'humrel_route'
1629	CALL ioconf_setatt_p('UNITS', '-')
1630	CALL ioconf_setatt_p('LONG_NAME','Mean humrel for irrigation')
1631	CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., humrel_mean, "gather", nbp_glo, index_g)
1632	CALL setvar_p (humrel_mean, val_exp, 'NO_KEYWORD', un)
1633
1634	ALLOCATE(k_litt_mean(nbpt), stat=ier)
1635	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for k_litt_mean','','')
1636	var_name = 'k_litt_route'
1637	CALL ioconf_setatt_p('UNITS', '-')
1638	CALL ioconf_setatt_p('LONG_NAME','Mean cond. for litter')
1639	CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., k_litt_mean, "gather", nbp_glo, index_g)
1640	CALL setvar_p (k_litt_mean, val_exp, 'NO_KEYWORD', zero)
1641
1642	ALLOCATE(totnobio_mean(nbpt), stat=ier)
1643	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for totnobio_mean','','')
1644	var_name = 'totnobio_route'
1645	CALL ioconf_setatt_p('UNITS', '-')
1646	CALL ioconf_setatt_p('LONG_NAME','Last Total fraction of no bio for irrigation')
1647	CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., totnobio_mean, "gather", nbp_glo, index_g)
1648	CALL setvar_p (totnobio_mean, val_exp, 'NO_KEYWORD', zero)
1649
1650	ALLOCATE(vegtot_mean(nbpt), stat=ier)
1651	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for vegtot_mean','','')
1652	var_name = 'vegtot_route'
1653	CALL ioconf_setatt_p('UNITS', '-')
1654	CALL ioconf_setatt_p('LONG_NAME','Last Total fraction of vegetation')
1655	CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., vegtot_mean, "gather", nbp_glo, index_g)
1656	CALL setvar_p (vegtot_mean, val_exp, 'NO_KEYWORD', un)
1657	!
1658	!
1659	DEALLOCATE(tmp_real_g)
1660	!
1661	! Allocate diagnostic variables
1662	!
1663	ALLOCATE(hydrodiag_loc(nbpt,nbasmax),hydrodiag_glo(nbp_glo,nbasmax),stat=ier)
1664	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for hydrodiag_glo','','')
1665	hydrodiag=>hydrodiag_loc
1666
1667	ALLOCATE(hydroupbasin_loc(nbpt),hydroupbasin_glo(nbp_glo), stat=ier)
1668	IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for hydroupbasin_glo','','')
1669	hydroupbasin=>hydroupbasin_loc
1670
1671	END SUBROUTINE routing_init
1672	!
1673	!! ================================================================================================================================
1674	!! SUBROUTINE : routing_clear
1675	!!
1676	!>\BRIEF : This subroutine deallocates the block memory previously allocated.
1677	!! \n
1678	!_ ================================================================================================================================
1679
1680	SUBROUTINE routing_clear()
1681
1682	IF (ALLOCATED(routing_area_loc)) DEALLOCATE(routing_area_loc)
1683	IF (ALLOCATED(route_togrid_loc)) DEALLOCATE(route_togrid_loc)
1684	IF (ALLOCATED(route_tobasin_loc)) DEALLOCATE(route_tobasin_loc)
1685	IF (ALLOCATED(route_nbintobas_loc)) DEALLOCATE(route_nbintobas_loc)
1686	IF (ALLOCATED(global_basinid_loc)) DEALLOCATE(global_basinid_loc)
1687	IF (ALLOCATED(topo_resid_loc)) DEALLOCATE(topo_resid_loc)
1688	IF (ALLOCATED(routing_area_glo)) DEALLOCATE(routing_area_glo)
1689	IF (ALLOCATED(route_togrid_glo)) DEALLOCATE(route_togrid_glo)
1690	IF (ALLOCATED(route_tobasin_glo)) DEALLOCATE(route_tobasin_glo)
1691	IF (ALLOCATED(route_nbintobas_glo)) DEALLOCATE(route_nbintobas_glo)
1692	IF (ALLOCATED(global_basinid_glo)) DEALLOCATE(global_basinid_glo)
1693	IF (ALLOCATED(topo_resid_glo)) DEALLOCATE(topo_resid_glo)
1694	IF (ALLOCATED(fast_reservoir)) DEALLOCATE(fast_reservoir)
1695	IF (ALLOCATED(slow_reservoir)) DEALLOCATE(slow_reservoir)
1696	IF (ALLOCATED(stream_reservoir)) DEALLOCATE(stream_reservoir)
1697	IF (ALLOCATED(flood_reservoir)) DEALLOCATE(flood_reservoir)
1698	IF (ALLOCATED(flood_frac_bas)) DEALLOCATE(flood_frac_bas)
1699	IF (ALLOCATED(flood_height)) DEALLOCATE(flood_height)
1700	IF (ALLOCATED(pond_frac)) DEALLOCATE(pond_frac)
1701	IF (ALLOCATED(lake_reservoir)) DEALLOCATE(lake_reservoir)
1702	IF (ALLOCATED(pond_reservoir)) DEALLOCATE(pond_reservoir)
1703	IF (ALLOCATED(returnflow_mean)) DEALLOCATE(returnflow_mean)
1704	IF (ALLOCATED(reinfiltration_mean)) DEALLOCATE(reinfiltration_mean)
1705	IF (ALLOCATED(riverflow_mean)) DEALLOCATE(riverflow_mean)
1706	IF (ALLOCATED(coastalflow_mean)) DEALLOCATE(coastalflow_mean)
1707	IF (ALLOCATED(lakeinflow_mean)) DEALLOCATE(lakeinflow_mean)
1708	IF (ALLOCATED(runoff_mean)) DEALLOCATE(runoff_mean)
1709	IF (ALLOCATED(floodout_mean)) DEALLOCATE(floodout_mean)
1710	IF (ALLOCATED(drainage_mean)) DEALLOCATE(drainage_mean)
1711	IF (ALLOCATED(transpot_mean)) DEALLOCATE(transpot_mean)
1712	IF (ALLOCATED(precip_mean)) DEALLOCATE(precip_mean)
1713	IF (ALLOCATED(humrel_mean)) DEALLOCATE(humrel_mean)
1714	IF (ALLOCATED(k_litt_mean)) DEALLOCATE(k_litt_mean)
1715	IF (ALLOCATED(totnobio_mean)) DEALLOCATE(totnobio_mean)
1716	IF (ALLOCATED(vegtot_mean)) DEALLOCATE(vegtot_mean)
1717	IF (ALLOCATED(floodtemp)) DEALLOCATE(floodtemp)
1718	IF (ALLOCATED(hydrodiag_loc)) DEALLOCATE(hydrodiag_loc)
1719	IF (ALLOCATED(hydrodiag_glo)) DEALLOCATE(hydrodiag_glo)
1720	IF (ALLOCATED(hydroupbasin_loc)) DEALLOCATE(hydroupbasin_loc)
1721	IF (ALLOCATED(hydroupbasin_glo)) DEALLOCATE(hydroupbasin_glo)
1722	IF (ALLOCATED(hydrographs)) DEALLOCATE(hydrographs)
1723	IF (ALLOCATED(slowflow_diag)) DEALLOCATE(slowflow_diag)
1724	IF (ALLOCATED(irrigation_mean)) DEALLOCATE(irrigation_mean)
1725	IF (ALLOCATED(irrigated)) DEALLOCATE(irrigated)
1726	IF (ALLOCATED(floodplains)) DEALLOCATE(floodplains)
1727	IF (ALLOCATED(swamp)) DEALLOCATE(swamp)
1728	IF (ALLOCATED(fast_diag)) DEALLOCATE(fast_diag)
1729	IF (ALLOCATED(slow_diag)) DEALLOCATE(slow_diag)
1730	IF (ALLOCATED(stream_diag)) DEALLOCATE(stream_diag)
1731	IF (ALLOCATED(flood_diag)) DEALLOCATE(flood_diag)
1732	IF (ALLOCATED(pond_diag)) DEALLOCATE(pond_diag)
1733	IF (ALLOCATED(lake_diag)) DEALLOCATE(lake_diag)
1734
1735	END SUBROUTINE routing_clear
1736	!
1737
1738	!! ================================================================================================================================
1739	!! SUBROUTINE : routing_flow
1740	!!
1741	!>\BRIEF This subroutine computes the transport of water in the various reservoirs
1742	!! (including ponds and floodplains) and the water withdrawals from the reservoirs for irrigation.
1743	!!
1744	!! DESCRIPTION (definitions, functional, design, flags) :
1745	!! This will first compute the amount of water which flows out of each of the 3 reservoirs using the assumption of an
1746	!! exponential decrease of water in the reservoir (see Hagemann S and Dumenil L. (1998)). Then we compute the fluxes
1747	!! for floodplains and ponds. All this will then be used in order to update each of the basins : taking water out of
1748	!! the up-stream basin and adding it to the down-stream one.
1749	!! As this step happens globaly we have to stop the parallel processing in order to exchange the information. Once
1750	!! all reservoirs are updated we deal with irrigation. The final step is to compute diagnostic fluxes. Among them
1751	!! the hydrographs of the largest rivers we have chosen to monitor.
1752	!!
1753	!! RECENT CHANGE(S): None
1754	!!
1755	!! MAIN OUTPUT VARIABLE(S): lakeinflow, returnflow, reinfiltration, irrigation, riverflow, coastalflow, hydrographs, flood_frac, flood_res
1756	!!
1757	!! REFERENCES :
1758	!! - Ngo-Duc, T., K. Laval, G. Ramillien, J. Polcher, and A. Cazenave (2007)
1759	!! Validation of the land water storage simulated by Organising Carbon and Hydrology in Dynamic Ecosystems (ORCHIDEE) with Gravity Recovery and Climate Experiment (GRACE) data.
1760	!! Water Resour. Res., 43, W04427, doi:10.1029/2006WR004941.
1761	!! * Irrigation:
1762	!! - de Rosnay, P., J. Polcher, K. Laval, and M. Sabre (2003)
1763	!! Integrated parameterization of irrigation in the land surface model ORCHIDEE. Validation over Indian Peninsula.
1764	!! Geophys. Res. Lett., 30(19), 1986, doi:10.1029/2003GL018024.
1765	!! - A.C. Vivant (2003)
1766	!! Les plaines d'inondations et l'irrigation dans ORCHIDEE, impacts de leur prise en compte.
1767	!! , , 51pp.
1768	!! - N. Culson (2004)
1769	!! Impact de l'irrigation sur le cycle de l'eau
1770	!! Master thesis, Paris VI University, 55pp.
1771	!! - X.-T. Nguyen-Vinh (2005)
1772	!! Analyse de l'impact de l'irrigation en Amerique du Nord - plaine du Mississippi - sur la climatologie regionale
1773	!! Master thesis, Paris VI University, 33pp.
1774	!! - M. Guimberteau (2006)
1775	!! Analyse et modifications proposees de la modelisation de l'irrigation dans un modele de surface.
1776	!! Master thesis, Paris VI University, 46pp.
1777	!! - Guimberteau M. (2010)
1778	!! Modelisation de l'hydrologie continentale et influences de l'irrigation sur le cycle de l'eau.
1779	!! Ph.D. thesis, Paris VI University, 195pp.
1780	!! - Guimberteau M., Laval K., Perrier A. and Polcher J. (2011).
1781	!! Global effect of irrigation and its impact on the onset of the Indian summer monsoon.
1782	!! In press, Climate Dynamics, doi: 10.1007/s00382-011-1252-5.
1783	!! * Floodplains:
1784	!! - A.C. Vivant (2002)
1785	!! L'ecoulement lateral de l'eau sur les surfaces continentales. Prise en compte des plaines d'inondations dans ORCHIDEE.
1786	!! Master thesis, Paris VI University, 46pp.
1787	!! - A.C. Vivant (2003)
1788	!! Les plaines d'inondations et l'irrigation dans ORCHIDEE, impacts de leur prise en compte.
1789	!! , , 51pp.
1790	!! - T. d'Orgeval (2006)
1791	!! Impact du changement climatique sur le cycle de l'eau en Afrique de l'Ouest: modelisation et incertitudes.
1792	!! Ph.D. thesis, Paris VI University, 188pp.
1793	!! - T. d'Orgeval, J. Polcher, and P. de Rosnay (2008)
1794	!! Sensitivity of the West African hydrological cycle in ORCHIDEE to infiltration processes.
1795	!! Hydrol. Earth Syst. Sci., 12, 1387-1401
1796	!! - M. Guimberteau, G. Drapeau, J. Ronchail, B. Sultan, J. Polcher, J.-M. Martinez, C. Prigent, J.-L. Guyot, G. Cochonneau,
1797	!! J. C. Espinoza, N. Filizola, P. Fraizy, W. Lavado, E. De Oliveira, R. Pombosa, L. Noriega, and P. Vauchel (2011)
1798	!! Discharge simulation in the sub-basins of the Amazon using ORCHIDEE forced by new datasets.
1799	!! Hydrol. Earth Syst. Sci. Discuss., 8, 11171-11232, doi:10.5194/hessd-8-11171-2011
1800	!!
1801	!! FLOWCHART :None
1802	!! \n
1803	!_ ================================================================================================================================
1804
1805	SUBROUTINE routing_flow(nbpt, dt_routing, lalo, floodout, runoff, drainage, &
1806	& vegtot, totnobio, transpot_mean, transpot, evapot_corr, veget, veget_max, soil_deficit, &
1807	& precip, humrel, k_litt, floodtemp, reinf_slope, &
1808	& lakeinflow, returnflow, reinfiltration, irrigation, riverflow, &
1809	& coastalflow, hydrographs, slowflow_diag, flood_frac, flood_res, vegstress, &
1810	netflow_stream_diag, netflow_fast_diag, netflow_slow_diag)
1811	!
1812	IMPLICIT NONE
1813	!
1814	!! INPUT VARIABLES
1815	INTEGER(i_std), INTENT(in) :: nbpt !! Domain size (unitless)
1816	REAL(r_std), INTENT (in) :: dt_routing !! Routing time step (s)
1817	REAL(r_std), INTENT(in) :: lalo(nbpt,2) !! Vector of latitude and longitudes
1818	REAL(r_std), INTENT(in) :: runoff(nbpt) !! Grid-point runoff (kg/m^2/dt)
1819	REAL(r_std), INTENT(in) :: floodout(nbpt) !! Grid-point flow out of floodplains (kg/m^2/dt)
1820	REAL(r_std), INTENT(in) :: drainage(nbpt) !! Grid-point drainage (kg/m^2/dt)
1821	REAL(r_std), INTENT(in) :: vegtot(nbpt) !! Potentially vegetated fraction (unitless;0-1)
1822	REAL(r_std), INTENT(in) :: totnobio(nbpt) !! Other areas which can not have vegetation
1823	REAL(r_std), INTENT(in) :: transpot_mean(nbpt) !! Mean potential transpiration of the vegetation (kg/m^2/dt)
1824	REAL(r_std), INTENT(in) :: transpot(nbpt,nvm) !! potential transpiration of each pft(kg/m^2/dt)
1825	REAL(r_std), INTENT(in) :: evapot_corr(nbpt) !! potential soil evaporation(kg/m^2/dt)
1826	REAL(r_std), INTENT(in) :: veget(nbpt,nvm) !! vegetation fraction of each pft (unitless;0-1)
1827	REAL(r_std), INTENT(in) :: veget_max(nbpt,nvm) !! maximum vegetation fraction of each pft (unitless;0-1)
1828	REAL(r_std), INTENT(in) :: soil_deficit(nbpt,nvm) !!
1829	REAL(r_std), INTENT(in) :: precip(nbpt) !! Rainfall (kg/m^2/dt)
1830	REAL(r_std), INTENT(in) :: humrel(nbpt) !! Soil moisture stress, root extraction potential (unitless)
1831	REAL(r_std), INTENT(in) :: k_litt(nbpt) !! Averaged conductivity for saturated infiltration in the 'litter' layer (kg/m^2/dt)
1832	REAL(r_std), INTENT(in) :: floodtemp(nbpt) !! Temperature to decide if floodplains work (K)
1833	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)
1834	REAL(r_std), INTENT(out) :: lakeinflow(nbpt) !! Water inflow to the lakes (kg/dt)
1835	REAL(r_std), INTENT(in) :: vegstress(nbpt,nvm) !! vegetation growth stress
1836	!
1837	!! OUTPUT VARIABLES
1838	REAL(r_std), INTENT(out) :: returnflow(nbpt) !! The water flow from lakes and swamps which returns into the grid box.
1839	!! This water will go back into the hydrol or hydrolc module to allow re-evaporation (kg/m^2/dt_routing)
1840	REAL(r_std), INTENT(out) :: reinfiltration(nbpt) !! Water flow from ponds and floodplains which returns to the grid box (kg/m^2/dt)
1841	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)
1842	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)
1843	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)
1844	REAL(r_std), INTENT(out) :: hydrographs(nbpt) !! Hydrographs at the outflow of the grid box for major basins (kg/dt)
1845	REAL(r_std), INTENT(out) :: slowflow_diag(nbpt) !! Hydrographs of slow_flow = routed slow_flow for major basins (kg/dt)
1846	REAL(r_std), INTENT(out) :: flood_frac(nbpt) !! Flooded fraction of the grid box (unitless;0-1)
1847	REAL(r_std), INTENT(out) :: flood_res(nbpt) !! Diagnostic of water amount in the floodplains reservoir (kg)
1848
1849	REAL(r_std), INTENT(out) :: netflow_stream_diag(nbpt) !! Input - Output flow to stream reservoir
1850	REAL(r_std), INTENT(out) :: netflow_fast_diag(nbpt) !! Input - Output flow to fast reservoir
1851	REAL(r_std), INTENT(out) :: netflow_slow_diag(nbpt) !! Input - Output flow to slow reservoir
1852	!
1853	!! LOCAL VARIABLES
1854	REAL(r_std), DIMENSION(nbpt, nbasmax) :: fast_flow !! Outflow from the fast reservoir (kg/dt)
1855	REAL(r_std), DIMENSION(nbpt, nbasmax) :: slow_flow !! Outflow from the slow reservoir (kg/dt)
1856	REAL(r_std), DIMENSION(nbpt, nbasmax) :: stream_flow !! Outflow from the stream reservoir (kg/dt)
1857	REAL(r_std), DIMENSION(nbpt, nbasmax) :: flood_flow !! Outflow from the floodplain reservoir (kg/dt)
1858	REAL(r_std), DIMENSION(nbpt, nbasmax) :: pond_inflow !! Inflow to the pond reservoir (kg/dt)
1859	REAL(r_std), DIMENSION(nbpt, nbasmax) :: pond_drainage !! Drainage from pond (kg/m^2/dt)
1860	REAL(r_std), DIMENSION(nbpt, nbasmax) :: flood_drainage !! Drainage from floodplains (kg/m^2/dt)
1861	REAL(r_std), DIMENSION(nbpt, nbasmax) :: return_swamp !! Inflow to the swamp (kg/dt)
1862	!
1863	! Irrigation per basin
1864	!
1865	REAL(r_std), DIMENSION(nbpt, nbasmax) :: irrig_needs !! Total irrigation requirement (water requirements by the crop for its optimal growth) (kg)
1866	REAL(r_std), DIMENSION(nbpt, nbasmax) :: irrig_actual !! Possible irrigation according to the water availability in the reservoirs (kg)
1867	REAL(r_std), DIMENSION(nbpt, nbasmax) :: irrig_deficit !! Amount of water missing for irrigation (kg)
1868	REAL(r_std), DIMENSION(nbpt, nbasmax) :: irrig_adduct !! Amount of water carried over from other basins for irrigation (kg)
1869	!
1870	REAL(r_std), DIMENSION(nbpt, 0:nbasmax+3) :: transport !! Water transport between basins (kg/dt)
1871	REAL(r_std), DIMENSION(nbp_glo, 0:nbasmax+3) :: transport_glo !! Water transport between basins (kg/dt)
1872	REAL(r_std), DIMENSION(nbpt, nbasmax) :: floods !! Water flow in to the floodplains (kg/dt)
1873	REAL(r_std), DIMENSION(nbpt, nbasmax) :: potflood !! Potential inflow to the swamps (kg/dt)
1874	REAL(r_std), DIMENSION(nbpt) :: tobeflooded !! Maximal surface which can be inundated in each grid box (m^2)
1875	REAL(r_std), DIMENSION(nbpt) :: totarea !! Total area of basin (m^2)
1876	REAL(r_std), DIMENSION(nbpt) :: totflood !! Total amount of water in the floodplains reservoir (kg)
1877	REAL(r_std), DIMENSION(nbasmax) :: pond_excessflow !!
1878	REAL(r_std) :: flow !! Outflow computation for the reservoirs (kg/dt)
1879	REAL(r_std) :: floodindex !! Fraction of grid box area inundated (unitless;0-1)
1880	REAL(r_std) :: pondex !!
1881	REAL(r_std) :: flood_frac_pot !! Total fraction of the grid box which is flooded at optimum repartition (unitless;0-1)
1882	REAL(r_std) :: stream_tot !! Total water amount in the stream reservoirs (kg)
1883	REAL(r_std) :: adduction !! Importation of water from a stream reservoir of a neighboring grid box (kg)
1884	REAL(r_std), DIMENSION(nbp_glo) :: lake_overflow_g !! Removed water from lake reservoir on global grid (kg/gridcell/dt_routing)
1885	REAL(r_std), DIMENSION(nbpt) :: lake_overflow !! Removed water from lake reservoir on local grid (kg/gridcell/dt_routing)
1886	REAL(r_std), DIMENSION(nbpt) :: lake_overflow_coast !! lake_overflow distributed on coast gridcells, only diag(kg/gridcell/dt_routing)
1887	REAL(r_std) :: total_lake_overflow !! Sum of lake_overflow over full grid (kg)
1888	REAL(r_std), DIMENSION(8,nbasmax) :: streams_around !! Stream reservoirs of the neighboring grid boxes (kg)
1889	INTEGER(i_std), DIMENSION(8) :: igrd !!
1890	INTEGER(i_std), DIMENSION(2) :: ff !!
1891	INTEGER(i_std), DIMENSION(1) :: fi !!
1892	INTEGER(i_std) :: ig, ib, ib2, ig2, jv !! Indices (unitless)
1893	INTEGER(i_std) :: rtg, rtb, in !! Indices (unitless)
1894	INTEGER(i_std) :: ier !! Error handling
1895	REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: fast_flow_g !! Outflow from the fast reservoir (kg/dt)
1896	REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: slow_flow_g !! Outflow from the slow reservoir (kg/dt)
1897	REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: stream_flow_g !! Outflow from the stream reservoir (kg/dt)
1898	REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: irrig_deficit_glo !! Amount of water missing for irrigation (kg)
1899	REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: stream_reservoir_glo !! Water amount in the stream reservoir (kg)
1900	REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: irrig_adduct_glo !! Amount of water carried over from other basins for irrigation (kg)
1901
1902	REAL(r_std), DIMENSION(nbpt, nbasmax) :: netflow_stream !! Input - Output flow to stream reservoir
1903	REAL(r_std), DIMENSION(nbpt, nbasmax) :: netflow_fast !! Input - Output flow to fast reservoir
1904	REAL(r_std), DIMENSION(nbpt, nbasmax) :: netflow_slow !! Input - Output flow to slow reservoir
1905
1906
1907	!! PARAMETERS
1908	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)
1909	!_ ================================================================================================================================
1910	!
1911	transport(:,:) = zero
1912	transport_glo(:,:) = zero
1913	irrig_netereq(:) = zero
1914	irrig_needs(:,:) = zero
1915	irrig_actual(:,:) = zero
1916	irrig_deficit(:,:) = zero
1917	irrig_adduct(:,:) = zero
1918	totarea(:) = zero
1919	totflood(:) = zero
1920	!
1921	! Compute all the fluxes
1922	!
1923	DO ib=1,nbasmax
1924	DO ig=1,nbpt
1925	!
1926	totarea(ig) = totarea(ig) + routing_area(ig,ib)
1927	totflood(ig) = totflood(ig) + flood_reservoir(ig,ib)
1928	ENDDO
1929	ENDDO
1930	!
1931	!> The outflow fluxes from the three reservoirs are computed.
1932	!> The outflow of volume of water Vi into the reservoir i is assumed to be linearly related to its volume.
1933	!> The water travel simulated by the routing scheme is dependent on the water retention index topo_resid
1934	!> given by a 0.5 degree resolution map for each pixel performed from a simplification of Manning's formula
1935	!> (Dingman, 1994; Ducharne et al., 2003).
1936	!> The resulting product of tcst (in day/m) and topo_resid (in m) represents the time constant (day)
1937	!> which is an e-folding time, the time necessary for the water amount
1938	!> in the stream reservoir to decrease by a factor e. Hence, it gives an order of
1939	!> magnitude of the travel time through this reservoir between
1940	!> the sub-basin considered and its downstream neighbor.
1941
1942	DO ib=1,nbasmax
1943	DO ig=1,nbpt
1944	IF ( route_tobasin(ig,ib) .GT. 0 ) THEN
1945	!
1946	! Each of the fluxes is limited by the water in the reservoir and a small margin
1947	! (min_reservoir) to avoid rounding errors.
1948	!
1949	flow = MIN(fast_reservoir(ig,ib)/((topo_resid(ig,ib)/1000.)fast_tcstone_day/dt_routing),&
1950	& fast_reservoir(ig,ib)-min_sechiba)
1951	fast_flow(ig,ib) = MAX(flow, zero)
1952
1953	flow = MIN(slow_reservoir(ig,ib)/((topo_resid(ig,ib)/1000.)slow_tcstone_day/dt_routing),&
1954	& slow_reservoir(ig,ib)-min_sechiba)
1955	slow_flow(ig,ib) = MAX(flow, zero)
1956
1957	flow = MIN(stream_reservoir(ig,ib)/((topo_resid(ig,ib)/1000.)stream_tcst &
1958	& MAX(un-SQRT(flood_frac_bas(ig,ib)),min_sechiba)*one_day/dt_routing),&
1959	& stream_reservoir(ig,ib)-min_sechiba)
1960	stream_flow(ig,ib) = MAX(flow, zero)
1961	!
1962	ELSE
1963	fast_flow(ig,ib) = zero
1964	slow_flow(ig,ib) = zero
1965	stream_flow(ig,ib) = zero
1966	ENDIF
1967	ENDDO
1968	ENDDO
1969	!-
1970	!- Compute the fluxes out of the floodplains and ponds if they exist.
1971	!-
1972	IF (do_floodplains .OR. doponds) THEN
1973	DO ig=1,nbpt
1974	IF (flood_frac(ig) .GT. min_sechiba) THEN
1975	!
1976	flow = MIN(floodout(ig)totarea(ig)pond_frac(ig)/flood_frac(ig), pond_reservoir(ig)+totflood(ig))
1977	pondex = MAX(flow - pond_reservoir(ig), zero)
1978	pond_reservoir(ig) = pond_reservoir(ig) - (flow - pondex)
1979	!
1980	! If demand was over reservoir size, we will take it out from floodplains
1981	!
1982	pond_excessflow(:) = zero
1983	DO ib=1,nbasmax
1984	pond_excessflow(ib) = MIN(pondex*flood_frac_bas(ig,ib)/(flood_frac(ig)-pond_frac(ig)),&
1985	& flood_reservoir(ig,ib))
1986	pondex = pondex - pond_excessflow(ib)
1987	ENDDO
1988	!
1989	IF ( pondex .GT. min_sechiba) THEN
1990	WRITE(numout,*) "Unable to redistribute the excess pond outflow over the water available in the floodplain."
1991	WRITE(numout,*) "Pondex = ", pondex
1992	WRITE(numout,*) "pond_excessflow(:) = ", pond_excessflow(:)
1993	ENDIF
1994	!
1995	DO ib=1,nbasmax
1996	!
1997	flow = floodout(ig)routing_area(ig,ib)flood_frac_bas(ig,ib)/flood_frac(ig) + pond_excessflow(ib)
1998	!
1999	flood_reservoir(ig,ib) = flood_reservoir(ig,ib) - flow
2000	!
2001	!
2002	IF (flood_reservoir(ig,ib) .LT. min_sechiba) THEN
2003	flood_reservoir(ig,ib) = zero
2004	ENDIF
2005	IF (pond_reservoir(ig) .LT. min_sechiba) THEN
2006	pond_reservoir(ig) = zero
2007	ENDIF
2008	ENDDO
2009	ENDIF
2010	ENDDO
2011	ENDIF
2012
2013	!-
2014	!- Computing the drainage and outflow from floodplains
2015	!> Drainage from floodplains is depending on a averaged conductivity (k_litt)
2016	!> for saturated infiltration in the 'litter' layer. Flood_drainage will be
2017	!> a component of the total reinfiltration that leaves the routing scheme.
2018	!-
2019	IF (do_floodplains) THEN
2020	IF (dofloodinfilt) THEN
2021	DO ib=1,nbasmax
2022	DO ig=1,nbpt
2023	flood_drainage(ig,ib) = MAX(zero, MIN(flood_reservoir(ig,ib), &
2024	& flood_frac(ig)routing_area(ig,ib)k_litt(ig)*dt_routing/one_day))
2025	flood_reservoir(ig,ib) = flood_reservoir(ig,ib) - flood_drainage(ig,ib)
2026	ENDDO
2027	ENDDO
2028	ELSE
2029	DO ib=1,nbasmax
2030	DO ig=1,nbpt
2031	flood_drainage(ig,ib) = zero
2032	ENDDO
2033	ENDDO
2034	ENDIF
2035	!> Outflow from floodplains is computed depending a delay. This delay is characterized by a time constant
2036	!> function of the surface of the floodplains and the product of topo_resid and flood_tcst. flood_tcst
2037	!> has been calibrated through observations in the Niger Inner Delta (D'Orgeval, 2006).
2038	!
2039	DO ib=1,nbasmax
2040	DO ig=1,nbpt
2041	IF ( route_tobasin(ig,ib) .GT. 0 ) THEN
2042	IF (flood_frac_bas(ig,ib) .GT. min_sechiba) THEN
2043	flow = MIN(flood_reservoir(ig,ib) &
2044	& /((topo_resid(ig,ib)/1000.)flood_tcst &
2045	& flood_frac_bas(ig,ib)*one_day/dt_routing),&
2046	& flood_reservoir(ig,ib))
2047	ELSE
2048	flow = zero
2049	ENDIF
2050	flood_flow(ig,ib) = flow
2051	ELSE
2052	flood_flow(ig,ib) = zero
2053	ENDIF
2054	ENDDO
2055	ENDDO
2056	ELSE
2057	DO ib=1,nbasmax
2058	DO ig=1,nbpt
2059	flood_drainage(ig,ib) = zero
2060	flood_flow(ig,ib) = zero
2061	flood_reservoir(ig,ib) = zero
2062	ENDDO
2063	ENDDO
2064	ENDIF
2065
2066	!-
2067	!- Computing drainage and inflow for ponds
2068	!> Drainage from ponds is computed in the same way than for floodplains.
2069	!> Reinfiltrated fraction from the runoff (i.e. the outflow from the fast reservoir)
2070	!> is the inflow of the pond reservoir.
2071	!-
2072	IF (doponds) THEN
2073	! If used, the slope coef is not used in hydrol for water2infilt
2074	DO ib=1,nbasmax
2075	DO ig=1,nbpt
2076	pond_inflow(ig,ib) = fast_flow(ig,ib) * reinf_slope(ig)
2077	pond_drainage(ig,ib) = MIN(pond_reservoir(ig)*routing_area(ig,ib)/totarea(ig), &
2078	& pond_frac(ig)routing_area(ig,ib)k_litt(ig)*dt_routing/one_day)
2079	fast_flow(ig,ib) = fast_flow(ig,ib) - pond_inflow(ig,ib)
2080	ENDDO
2081	ENDDO
2082	ELSE
2083	DO ib=1,nbasmax
2084	DO ig=1,nbpt
2085	pond_inflow(ig,ib) = zero
2086	pond_drainage(ig,ib) = zero
2087	pond_reservoir(ig) = zero
2088	ENDDO
2089	ENDDO
2090	ENDIF
2091
2092	!ym cette methode conserve les erreurs d'arrondie
2093	!ym mais n'est pas la plus efficace
2094
2095	!-
2096	!- Compute the transport from one basin to another
2097	!-
2098
2099	IF (is_root_prc) THEN
2100	ALLOCATE( fast_flow_g(nbp_glo, nbasmax), slow_flow_g(nbp_glo, nbasmax), &
2101	stream_flow_g(nbp_glo, nbasmax), stat=ier)
2102	ELSE
2103	ALLOCATE( fast_flow_g(1,1), slow_flow_g(1,1), &
2104	stream_flow_g(1, 1), stat=ier)
2105	ENDIF
2106	IF (ier /= 0) CALL ipslerr_p(3,'routing_flow','Pb in allocate for fast_flow_g','','')
2107
2108	CALL gather(fast_flow,fast_flow_g)
2109	CALL gather(slow_flow,slow_flow_g)
2110	CALL gather(stream_flow,stream_flow_g)
2111
2112	IF (is_root_prc) THEN
2113	DO ib=1,nbasmax
2114	DO ig=1,nbp_glo
2115	!
2116	rtg = route_togrid_glo(ig,ib)
2117	rtb = route_tobasin_glo(ig,ib)
2118	transport_glo(rtg,rtb) = transport_glo(rtg,rtb) + fast_flow_g(ig,ib) + slow_flow_g(ig,ib) + &
2119	& stream_flow_g(ig,ib)
2120	!
2121	ENDDO
2122	ENDDO
2123	ENDIF
2124
2125	DEALLOCATE( fast_flow_g, slow_flow_g, stream_flow_g )
2126
2127	CALL scatter(transport_glo,transport)
2128
2129	!-
2130	!- Do the floodings - First initialize
2131	!-
2132	return_swamp(:,:)=zero
2133	floods(:,:)=zero
2134	!-
2135	!> Over swamp areas, a fraction of water (return_swamp) is withdrawn from the river depending on the
2136	!> parameter swamp_cst.
2137	!> It will be transferred into soil moisture and thus does not return directly to the river.
2138	!
2139	!- 1. Swamps: Take out water from the river to put it to the swamps
2140	!-
2141	!
2142	IF ( doswamps ) THEN
2143	tobeflooded(:) = swamp(:)
2144	DO ib=1,nbasmax
2145	DO ig=1,nbpt
2146	potflood(ig,ib) = transport(ig,ib)
2147	!
2148	IF ( tobeflooded(ig) > 0. .AND. potflood(ig,ib) > 0. .AND. floodtemp(ig) > tp_00 ) THEN
2149	!
2150	IF (routing_area(ig,ib) > tobeflooded(ig)) THEN
2151	floodindex = tobeflooded(ig) / routing_area(ig,ib)
2152	ELSE
2153	floodindex = 1.0
2154	ENDIF
2155	return_swamp(ig,ib) = swamp_cst * potflood(ig,ib) * floodindex
2156	!
2157	tobeflooded(ig) = tobeflooded(ig) - routing_area(ig,ib)
2158	!
2159	ENDIF
2160	ENDDO
2161	ENDDO
2162	ENDIF
2163	!-
2164	!- 2. Floodplains: Update the reservoir with the flux computed above.
2165	!-
2166	IF ( do_floodplains ) THEN
2167	DO ig=1,nbpt
2168	IF (floodplains(ig) .GT. min_sechiba .AND. floodtemp(ig) .GT. tp_00) THEN
2169	DO ib=1,nbasmax
2170	floods(ig,ib) = transport(ig,ib) - return_swamp(ig,ib)
2171	ENDDO
2172	ENDIF
2173	ENDDO
2174	ENDIF
2175	!
2176	! Update all reservoirs
2177	!> The slow and deep reservoir (slow_reservoir) collect the deep drainage whereas the
2178	!> fast_reservoir collects the computed surface runoff. Both discharge into a third reservoir
2179	!> (stream_reservoir) of the next sub-basin downstream.
2180	!> Water from the floodplains reservoir (flood_reservoir) flows also into the stream_reservoir of the next sub-basin downstream.
2181	!> Water that flows into the pond_reservoir is withdrawn from the fast_reservoir.
2182	!
2183	DO ig=1,nbpt
2184	DO ib=1,nbasmax
2185	!
2186	fast_reservoir(ig,ib) = fast_reservoir(ig,ib) + runoff(ig)*routing_area(ig,ib) - &
2187	& fast_flow(ig,ib) - pond_inflow(ig,ib)
2188	!
2189	slow_reservoir(ig,ib) = slow_reservoir(ig,ib) + drainage(ig)*routing_area(ig,ib) - &
2190	& slow_flow(ig,ib)
2191	!
2192	stream_reservoir(ig,ib) = stream_reservoir(ig,ib) + flood_flow(ig,ib) + transport(ig,ib) - &
2193	& stream_flow(ig,ib) - return_swamp(ig,ib) - floods(ig,ib)
2194	!
2195	flood_reservoir(ig,ib) = flood_reservoir(ig,ib) + floods(ig,ib) - &
2196	& flood_flow(ig,ib)
2197	!
2198	pond_reservoir(ig) = pond_reservoir(ig) + pond_inflow(ig,ib) - pond_drainage(ig,ib)
2199	!
2200	IF ( flood_reservoir(ig,ib) .LT. zero ) THEN
2201	IF ( check_reservoir ) THEN
2202	WRITE(numout,*) "WARNING : negative flood reservoir at :", ig, ib, ". Problem is being corrected."
2203	WRITE(numout,*) "flood_reservoir, floods, flood_flow : ", flood_reservoir(ig,ib), floods(ig,ib), &
2204	& flood_flow(ig,ib)
2205	ENDIF
2206	stream_reservoir(ig,ib) = stream_reservoir(ig,ib) + flood_reservoir(ig,ib)
2207	flood_reservoir(ig,ib) = zero
2208	ENDIF
2209	!
2210	IF ( stream_reservoir(ig,ib) .LT. zero ) THEN
2211	IF ( check_reservoir ) THEN
2212	WRITE(numout,*) "WARNING : negative stream reservoir at :", ig, ib, ". Problem is being corrected."
2213	WRITE(numout,*) "stream_reservoir, flood_flow, transport : ", stream_reservoir(ig,ib), flood_flow(ig,ib), &
2214	& transport(ig,ib)
2215	WRITE(numout,*) "stream_flow, return_swamp, floods :", stream_flow(ig,ib), return_swamp(ig,ib), floods(ig,ib)
2216	ENDIF
2217	fast_reservoir(ig,ib) = fast_reservoir(ig,ib) + stream_reservoir(ig,ib)
2218	stream_reservoir(ig,ib) = zero
2219	ENDIF
2220	!
2221	IF ( fast_reservoir(ig,ib) .LT. zero ) THEN
2222	IF ( check_reservoir ) THEN
2223	WRITE(numout,*) "WARNING : negative fast reservoir at :", ig, ib, ". Problem is being corrected."
2224	WRITE(numout,*) "fast_reservoir, runoff, fast_flow, ponf_inflow : ", fast_reservoir(ig,ib), &
2225	&runoff(ig), fast_flow(ig,ib), pond_inflow(ig,ib)
2226	ENDIF
2227	slow_reservoir(ig,ib) = slow_reservoir(ig,ib) + fast_reservoir(ig,ib)
2228	fast_reservoir(ig,ib) = zero
2229	ENDIF
2230
2231	IF ( slow_reservoir(ig,ib) .LT. - min_sechiba ) THEN
2232	IF ( check_reservoir ) THEN
2233	WRITE(numout,*) 'WARNING : There is a negative reservoir at :', ig, ib,lalo(ig,:)
2234	WRITE(numout,*) 'WARNING : slowr, slow_flow, drainage', &
2235	& slow_reservoir(ig,ib), slow_flow(ig,ib), drainage(ig)
2236	WRITE(numout,*) 'WARNING : pondr, pond_inflow, pond_drainage', &
2237	& pond_reservoir(ig), pond_inflow(ig,ib), pond_drainage(ig,ib)
2238	ENDIF
2239	CALL ipslerr_p(2, 'routing_flow', 'WARNING negative slow_reservoir.','','')
2240	ENDIF
2241
2242	ENDDO
2243	ENDDO
2244
2245
2246	totflood(:) = zero
2247	DO ig=1,nbpt
2248	DO ib=1,nbasmax
2249	totflood(ig) = totflood(ig) + flood_reservoir(ig,ib)
2250	ENDDO
2251	ENDDO
2252
2253	!-
2254	!- Computes the fraction of floodplains and ponds according to their volume
2255	!-
2256	IF (do_floodplains .OR. doponds) THEN
2257	flood_frac(:) = zero
2258	flood_height(:) = zero
2259	flood_frac_bas(:,:) = zero
2260	DO ig=1, nbpt
2261	IF (totflood(ig) .GT. min_sechiba) THEN
2262	! We first compute the total fraction of the grid box which is flooded at optimum repartition
2263	flood_frac_pot = (totflood(ig) / (totarea(ig)floodcri/(beta+un)))*(beta/(beta+un))
2264	flood_frac(ig) = MIN(floodplains(ig) / totarea(ig), flood_frac_pot)
2265	! Then we diagnose the fraction for each basin with the size of its flood_reservoir
2266	! (flood_frac_bas may be > 1)
2267	DO ib=1,nbasmax
2268	IF (routing_area(ig,ib) .GT. min_sechiba) THEN
2269	flood_frac_bas(ig,ib) = flood_frac(ig) * &
2270	& (flood_reservoir(ig,ib) / totflood(ig)) / (routing_area(ig,ib) / totarea(ig))
2271	ENDIF
2272	ENDDO
2273	! We diagnose the maximum height of floodplain
2274	flood_height(ig) = (beta/(beta+1))floodcri(flood_frac(ig))*(un/beta) + totflood(ig)/(totarea(ig)flood_frac(ig))
2275	! And finally add the pond surface
2276	pond_frac(ig) = MIN(un-flood_frac(ig), ((betap+1)pond_reservoir(ig) / (pondcritotarea(ig)))**(betap/(betap+1)) )
2277	flood_frac(ig) = flood_frac(ig) + pond_frac(ig)
2278	!
2279	ENDIF
2280	ENDDO
2281	ELSE
2282	flood_frac(:) = zero
2283	flood_height(:) = zero
2284	flood_frac_bas(:,:) = zero
2285	ENDIF
2286
2287	!-
2288	!- Compute the total reinfiltration and returnflow to the grid box
2289	!> A term of returnflow is computed including the water from the swamps that does not return directly to the river
2290	!> but will be put into soil moisture (see hydrol module).
2291	!> A term of reinfiltration is computed including the water that reinfiltrated from the ponds and floodplains areas.
2292	!> It will be put into soil moisture (see hydrol module).
2293	!-
2294	IF (do_floodplains .OR. doswamps .OR. doponds) THEN
2295	returnflow(:) = zero
2296	reinfiltration(:) = zero
2297	!
2298	DO ib=1,nbasmax
2299	DO ig=1,nbpt
2300	returnflow(ig) = returnflow(ig) + return_swamp(ig,ib)
2301	reinfiltration(ig) = reinfiltration(ig) + pond_drainage(ig,ib) + flood_drainage(ig,ib)
2302	ENDDO
2303	ENDDO
2304	!
2305	DO ig=1,nbpt
2306	returnflow(ig) = returnflow(ig)/totarea(ig)
2307	reinfiltration(ig) = reinfiltration(ig)/totarea(ig)
2308	ENDDO
2309	ELSE
2310	returnflow(:) = zero
2311	reinfiltration(:) = zero
2312	ENDIF
2313
2314	!
2315	! Compute the net irrigation requirement from Univ of Kassel
2316	!
2317	! This is a very low priority process and thus only applies if
2318	! there is some water left in the reservoirs after all other things.
2319	!
2320	!> The computation of the irrigation is performed here.
2321	!> * First step
2322	!> In a first time, the water requirements (irrig_netereq) by the crops for their optimal growth are calculated
2323	!> over each irrigated fraction (irrigated(ig)/totarea(ig)). It is the difference
2324	!> between the maximal water loss by the crops (transpot_mean) and the net water amount kept by the soil
2325	!> (precipitation and reinfiltration). Transpot_mean is computed in the routines enerbil and diffuco. It
2326	!> is derived from the effective transpiration parametrization under stress-free conditions, called potential transpiration.
2327	!> Crop_coef was used by a previous parametrization of irrigation in the code. Here, its value is equal to one.
2328	!> The crop coefficient was constant in space and time to represent a mean resistance of the vegetation to the potential evaporation.
2329	!> Now, the term crop_coef*Epot is substituted by transpot_mean (see Guimberteau et al., 2011).
2330	!> * Second step
2331	!> We compute irrigation needs in order to supply Irrig_netereq. Water for irrigation (irrig_actual) is withdrawn
2332	!> from the reservoirs. The amount of water is withdrawn in priority from the stream reservoir.
2333	!> If the irrigation requirement is higher than the water availability of the reservoir, water is withdrawn
2334	!> from the fast reservoir or, in the extreme case, from the slow reservoir.
2335	!> * Third step
2336	!> We compute a deficit in water for irrigation. If it is positive, irrigation (depending on water availibility in the reservoirs)
2337	!> has not supplied the crops requirements.
2338	!
2339	IF ( do_irrigation ) THEN
2340	DO ig=1,nbpt
2341	!
2342	IF ((vegtot(ig) .GT. min_sechiba) .AND. (humrel(ig) .LT. un-min_sechiba) .AND. &
2343	& (runoff(ig) .LT. min_sechiba) ) THEN
2344
2345	! irrig_netereq(ig) = (irrigated(ig) / totarea(ig) ) * MAX(zero, transpot_mean(ig) - &
2346	! & (precip(ig)+reinfiltration(ig)) )
2347	! irrig_netereq(ig) = (irrigated(ig) / tot_vegfrac_crop(ig) ) * MAX(zero, transpot_agr(ig) - &
2348	! & (precip(ig)+reinfiltration(ig)) )
2349	irrig_netereq(ig) = zero
2350	DO jv=2,nvm
2351	IF ( veget_max(ig,jv) .GT. 0 ) THEN
2352	IF ( ok_LAIdev(jv) .AND. (vegstress(ig,jv) .LT. irrig_threshold(jv)) ) THEN
2353	IF (irrig_drip) THEN
2354	irrig_netereq(ig) = irrig_netereq(ig) + MIN( irrig_dosmax, ( irrigated(ig) * irrig_fulfill(jv) * &
2355	& MAX(zero, transpot(ig,jv) * (veget(ig,jv)/veget_max(ig,jv)) + &
2356	& evapot_corr(ig) * (1-veget(ig,jv)/veget_max(ig,jv)) - &
2357	& (precip(ig)+reinfiltration(ig)) ) ) ) * veget_max(ig,jv)
2358	ELSE !flooding
2359	irrig_netereq(ig) = irrig_netereq(ig) + MIN( irrig_dosmax, irrigated(ig) * &
2360	& MAX(zero, soil_deficit(ig,jv)) ) * veget_max(ig,jv)
2361	ENDIF
2362	! irrigated must be the percentage of croplands irrigated
2363	ENDIF
2364	ENDIF
2365	ENDDO
2366	! irrig_netereq is the needs (mm) over the entire grid
2367
2368	ENDIF
2369	!
2370	DO ib=1,nbasmax
2371	IF ( routing_area(ig,ib) .GT. 0 ) THEN
2372
2373	irrig_needs(ig,ib) = irrig_netereq(ig) * routing_area(ig,ib)
2374	! irrig_needs(ig,ib) = irrig_netereq(ig) * tot_vegfrac_crop(ig) * routing_area(ig,ib)
2375
2376	irrig_actual(ig,ib) = MIN(irrig_needs(ig,ib),&
2377	& stream_reservoir(ig,ib) + fast_reservoir(ig,ib) + slow_reservoir(ig,ib) )
2378
2379	slow_reservoir(ig,ib) = MAX(zero, slow_reservoir(ig,ib) + &
2380	& MIN(zero, fast_reservoir(ig,ib) + MIN(zero, stream_reservoir(ig,ib)-irrig_actual(ig,ib))))
2381
2382	fast_reservoir(ig,ib) = MAX( zero, &
2383	& fast_reservoir(ig,ib) + MIN(zero, stream_reservoir(ig,ib)-irrig_actual(ig,ib)))
2384
2385	stream_reservoir(ig,ib) = MAX(zero, stream_reservoir(ig,ib)-irrig_actual(ig,ib) )
2386
2387	irrig_deficit(ig,ib) = irrig_needs(ig,ib)-irrig_actual(ig,ib)
2388
2389	ENDIF
2390	ENDDO
2391	!
2392	! Check if we cannot find the missing water in another basin of the same grid (stream reservoir only).
2393	! If we find that then we create some adduction from that subbasin to the one where we need it for
2394	! irrigation.
2395	!
2396	!> If crops water requirements have not been supplied (irrig_deficit>0), we check if we cannot find the missing water
2397	!> in another basin of the same grid. If there is water in the stream reservoir of this subbasin, we create some adduction
2398	!> from that subbasin to the one where we need it for irrigation.
2399	!>
2400	DO ib=1,nbasmax
2401
2402	stream_tot = SUM(stream_reservoir(ig,:))
2403
2404	DO WHILE ( irrig_deficit(ig,ib) > min_sechiba .AND. stream_tot > min_sechiba)
2405
2406	fi = MAXLOC(stream_reservoir(ig,:))
2407	ib2 = fi(1)
2408
2409	irrig_adduct(ig,ib) = MIN(irrig_deficit(ig,ib), stream_reservoir(ig,ib2))
2410	stream_reservoir(ig,ib2) = stream_reservoir(ig,ib2)-irrig_adduct(ig,ib)
2411	irrig_deficit(ig,ib) = irrig_deficit(ig,ib)-irrig_adduct(ig,ib)
2412
2413	stream_tot = SUM(stream_reservoir(ig,:))
2414
2415	ENDDO
2416
2417	ENDDO
2418	!
2419	ENDDO
2420	!
2421	! If we are at higher resolution we might need to look at neighboring grid boxes to find the streams
2422	! which can feed irrigation
2423	!
2424	!> At higher resolution (grid box smaller than 100x100km), we can import water from neighboring grid boxes
2425	!> to the one where we need it for irrigation.
2426	!
2427	IF (is_root_prc) THEN
2428	ALLOCATE(irrig_deficit_glo(nbp_glo, nbasmax), stream_reservoir_glo(nbp_glo, nbasmax), &
2429	& irrig_adduct_glo(nbp_glo, nbasmax), stat=ier)
2430	ELSE
2431	ALLOCATE(irrig_deficit_glo(0, 0), stream_reservoir_glo(0, 0), &
2432	& irrig_adduct_glo(0, 0), stat=ier)
2433	ENDIF
2434	IF (ier /= 0) CALL ipslerr_p(3,'routing_flow','Pb in allocate for irrig_deficit_glo, stream_reservoir_glo,...','','')
2435
2436	CALL gather(irrig_deficit, irrig_deficit_glo)
2437	CALL gather(stream_reservoir, stream_reservoir_glo)
2438	CALL gather(irrig_adduct, irrig_adduct_glo)
2439
2440	IF (is_root_prc) THEN
2441	!
2442	DO ig=1,nbp_glo
2443	! Only work if the grid box is smaller than 100x100km. Else the piplines we build
2444	! here would be too long to be reasonable.
2445	IF ( resolution_g(ig,1) < 100000. .AND. resolution_g(ig,2) < 100000. ) THEN
2446	DO ib=1,nbasmax
2447	!
2448	IF ( irrig_deficit_glo(ig,ib) > min_sechiba ) THEN
2449	!
2450	streams_around(:,:) = zero
2451	!
2452	DO in=1,NbNeighb
2453	ig2 = neighbours_g(ig,in)
2454	IF (ig2 .GT. 0 ) THEN
2455	streams_around(in,:) = stream_reservoir_glo(ig2,:)
2456	igrd(in) = ig2
2457	ENDIF
2458	ENDDO
2459	!
2460	IF ( MAXVAL(streams_around) .GT. zero ) THEN
2461	!
2462	ff=MAXLOC(streams_around)
2463	ig2=igrd(ff(1))
2464	ib2=ff(2)
2465	!
2466	IF ( routing_area_glo(ig2,ib2) .GT. 0 .AND. stream_reservoir_glo(ig2,ib2) > zero ) THEN
2467	adduction = MIN(irrig_deficit_glo(ig,ib), stream_reservoir_glo(ig2,ib2))
2468	stream_reservoir_glo(ig2,ib2) = stream_reservoir_glo(ig2,ib2) - adduction
2469	irrig_deficit_glo(ig,ib) = irrig_deficit_glo(ig,ib) - adduction
2470	irrig_adduct_glo(ig,ib) = irrig_adduct_glo(ig,ib) + adduction
2471	ENDIF
2472	!
2473	ENDIF
2474	!
2475	ENDIF
2476	!
2477	ENDDO
2478	ENDIF
2479	ENDDO
2480	!
2481	ENDIF
2482	!
2483
2484	CALL scatter(irrig_deficit_glo, irrig_deficit)
2485	CALL scatter(stream_reservoir_glo, stream_reservoir)
2486	CALL scatter(irrig_adduct_glo, irrig_adduct)
2487
2488	DEALLOCATE(irrig_deficit_glo, stream_reservoir_glo, irrig_adduct_glo)
2489
2490	ENDIF
2491
2492	!! Calculate the net water flow to each routing reservoir (in kg/dt)
2493	!! to further diagnose the corresponding water budget residu
2494	!! in routing_main
2495
2496	netflow_fast_diag(:) = zero
2497	netflow_slow_diag(:) = zero
2498	netflow_stream_diag(:) = zero
2499
2500	DO ib=1,nbasmax
2501	DO ig=1,nbpt
2502	netflow_fast_diag(ig) = netflow_fast_diag(ig) + runoff(ig)*routing_area(ig,ib) &
2503	- fast_flow(ig,ib) - pond_inflow(ig,ib)
2504	netflow_slow_diag(ig) = netflow_slow_diag(ig) + drainage(ig)*routing_area(ig,ib) &
2505	- slow_flow(ig,ib)
2506	netflow_stream_diag(ig) = netflow_stream_diag(ig) + flood_flow(ig,ib) + transport(ig,ib) &
2507	- stream_flow(ig,ib) - return_swamp(ig,ib) - floods(ig,ib)
2508	ENDDO
2509	ENDDO
2510
2511	!! Grid cell averaging
2512	DO ig=1,nbpt
2513	netflow_fast_diag(ig) = netflow_fast_diag(ig)/totarea(ig)
2514	netflow_slow_diag(ig) = netflow_slow_diag(ig)/totarea(ig)
2515	netflow_stream_diag(ig) = netflow_stream_diag(ig)/totarea(ig)
2516	ENDDO
2517
2518	!
2519	!
2520	! Compute the fluxes which leave the routing scheme
2521	!
2522	! Lakeinflow is in Kg/dt
2523	! returnflow is in Kg/m^2/dt
2524	!
2525	hydrographs(:) = zero
2526	slowflow_diag(:) = zero
2527	fast_diag(:) = zero
2528	slow_diag(:) = zero
2529	stream_diag(:) = zero
2530	flood_diag(:) = zero
2531	pond_diag(:) = zero
2532	irrigation(:) = zero
2533	!
2534	!
2535	DO ib=1,nbasmax
2536	!
2537	DO ig=1,nbpt
2538	IF (hydrodiag(ig,ib) > 0 ) THEN
2539	hydrographs(ig) = hydrographs(ig) + fast_flow(ig,ib) + slow_flow(ig,ib) + &
2540	& stream_flow(ig,ib)
2541	slowflow_diag(ig) = slowflow_diag(ig) + slow_flow(ig,ib)
2542	ENDIF
2543	fast_diag(ig) = fast_diag(ig) + fast_reservoir(ig,ib)
2544	slow_diag(ig) = slow_diag(ig) + slow_reservoir(ig,ib)
2545	stream_diag(ig) = stream_diag(ig) + stream_reservoir(ig,ib)
2546	flood_diag(ig) = flood_diag(ig) + flood_reservoir(ig,ib)
2547	IF (do_fullirr) THEN
2548	irrigation(ig) = irrigation(ig) + irrig_needs(ig,ib)
2549	! when fully irrigated, we interrupt the water balance, and bring
2550	! magic water
2551	ELSE
2552	irrigation (ig) = irrigation (ig) + irrig_actual(ig,ib) + irrig_adduct(ig,ib)
2553	ENDIF
2554	ENDDO
2555	ENDDO
2556	!
2557	DO ig=1,nbpt
2558	fast_diag(ig) = fast_diag(ig)/totarea(ig)
2559	slow_diag(ig) = slow_diag(ig)/totarea(ig)
2560	stream_diag(ig) = stream_diag(ig)/totarea(ig)
2561	flood_diag(ig) = flood_diag(ig)/totarea(ig)
2562	pond_diag(ig) = pond_reservoir(ig)/totarea(ig)
2563	!
2564	irrigation(ig) = irrigation(ig)/totarea(ig)
2565	!
2566	! The three output types for the routing : endoheric basins,, rivers and
2567	! diffuse coastal flow.
2568	!
2569	lakeinflow(ig) = transport(ig,nbasmax+1)
2570	coastalflow(ig) = transport(ig,nbasmax+2)
2571	riverflow(ig) = transport(ig,nbasmax+3)
2572	!
2573	ENDDO
2574	!
2575	flood_res = flood_diag + pond_diag
2576
2577
2578	!! Remove water from lake reservoir if it exceeds the maximum limit and distribute it
2579	!! uniformly over all possible the coastflow gridcells
2580
2581	! Calculate lake_overflow and remove it from lake_reservoir
2582	DO ig=1,nbpt
2583	lake_overflow(ig) = MAX(0., lake_reservoir(ig) - max_lake_reservoir*totarea(ig))
2584	lake_reservoir(ig) = lake_reservoir(ig) - lake_overflow(ig)
2585	END DO
2586	! Transform lake_overflow from kg/grid-cell/dt_routing into kg/m^2/s
2587	CALL xios_orchidee_send_field("lake_overflow",lake_overflow(:)/totarea(:)/dt_routing)
2588
2589	! Calculate the sum of the lake_overflow and distribute it uniformly over all gridboxes
2590	CALL gather(lake_overflow,lake_overflow_g)
2591	IF (is_root_prc) THEN
2592	total_lake_overflow=SUM(lake_overflow_g)
2593	END IF
2594	CALL bcast(total_lake_overflow)
2595
2596	! Distribute the lake_overflow uniformly over all coastal gridcells
2597	! lake_overflow_coast is only calculated to be used as diagnostics if needed
2598	DO ig=1,nbpt
2599	coastalflow(ig) = coastalflow(ig) + total_lake_overflow/nb_coast_gridcells * mask_coast(ig)
2600	lake_overflow_coast(ig) = total_lake_overflow/nb_coast_gridcells * mask_coast(ig)
2601	END DO
2602	! Transform from kg/grid-cell/dt_routing into m^3/grid-cell/s to match output unit of coastalflow
2603	CALL xios_orchidee_send_field("lake_overflow_coast",lake_overflow_coast/mille/dt_routing)
2604
2605
2606	END SUBROUTINE routing_flow
2607	!
2608	!! ================================================================================================================================
2609	!! SUBROUTINE : routing_lake
2610	!!
2611	!>\BRIEF : This subroutine stores water in lakes so that it does not cycle through the runoff.
2612	!! For the moment it only works for endoheric lakes but I can be extended in the future.
2613	!!
2614	!! DESCRIPTION (definitions, functional, design, flags): The return flow to the soil moisture reservoir
2615	!! is based on a maximum lake evaporation rate (maxevap_lake). \n
2616	!!
2617	!! RECENT CHANGE(S): None
2618	!!
2619	!! MAIN OUTPUT VARIABLE(S):
2620	!!
2621	!! REFERENCES : None
2622	!!
2623	!! FLOWCHART :None
2624	!! \n
2625	!_ ================================================================================================================================
2626
2627	SUBROUTINE routing_lake(nbpt, dt_routing, lakeinflow, humrel, return_lakes)
2628	!
2629	IMPLICIT NONE
2630	!
2631	!! INPUT VARIABLES
2632	INTEGER(i_std), INTENT(in) :: nbpt !! Domain size (unitless)
2633	REAL(r_std), INTENT (in) :: dt_routing !! Routing time step (s)
2634	REAL(r_std), INTENT(out) :: lakeinflow(nbpt) !! Water inflow to the lakes (kg/dt)
2635	REAL(r_std), INTENT(in) :: humrel(nbpt) !! Soil moisture stress, root extraction potential (unitless)
2636	!
2637	!! OUTPUT VARIABLES
2638	REAL(r_std), INTENT(out) :: return_lakes(nbpt) !! Water from lakes flowing back into soil moisture (kg/m^2/dt)
2639	!
2640	!! LOCAL VARIABLES
2641	INTEGER(i_std) :: ig !! Indices (unitless)
2642	REAL(r_std) :: refill !!
2643	REAL(r_std) :: total_area !! Sum of all the surfaces of the basins (m^2)
2644
2645	!_ ================================================================================================================================
2646	!
2647	!
2648	DO ig=1,nbpt
2649	!
2650	total_area = SUM(routing_area(ig,:))
2651	!
2652	lake_reservoir(ig) = lake_reservoir(ig) + lakeinflow(ig)
2653
2654	IF ( doswamps ) THEN
2655	! Calculate a return flow that will be extracted from the lake reservoir and reinserted in the soil in hydrol
2656	! Uptake in Kg/dt
2657	refill = MAX(zero, maxevap_lake * (un - humrel(ig)) * dt_routing * total_area)
2658	return_lakes(ig) = MIN(refill, lake_reservoir(ig))
2659	lake_reservoir(ig) = lake_reservoir(ig) - return_lakes(ig)
2660	! Return in Kg/m^2/dt
2661	return_lakes(ig) = return_lakes(ig)/total_area
2662	ELSE
2663	return_lakes(ig) = zero
2664	ENDIF
2665
2666	! This is the volume of the lake scaled to the entire grid.
2667	! It would be better to scale it to the size of the lake
2668	! but this information is not yet available.
2669	lake_diag(ig) = lake_reservoir(ig)/total_area
2670
2671	lakeinflow(ig) = lakeinflow(ig)/total_area
2672
2673	ENDDO
2674	!
2675	END SUBROUTINE routing_lake
2676	!
2677
2678	!! ================================================================================================================================
2679	!! SUBROUTINE : routing_diagnostic_p
2680	!!
2681	!>\BRIEF This parallelized subroutine gives a diagnostic of the basins used
2682	!!
2683	!! DESCRIPTION (definitions, functional, design, flags) : None
2684	!!
2685	!! RECENT CHANGE(S): None
2686	!!
2687	!! MAIN OUTPUT VARIABLE(S):
2688	!!
2689	!! REFERENCES : None
2690	!!
2691	!! FLOWCHART : None
2692	!! \n
2693	!_ ================================================================================================================================
2694
2695	SUBROUTINE routing_diagnostic_p(nbpt, index, lalo, resolution, contfrac, hist_id, hist2_id)
2696	!
2697	IMPLICIT NONE
2698
2699	!! INPUT VARIABLES
2700	INTEGER(i_std), INTENT(in) :: nbpt !! Domain size (unitless)
2701	INTEGER(i_std), INTENT(in) :: index(nbpt) !! Indices of the points on the map (unitless)
2702	REAL(r_std), INTENT(in) :: lalo(nbpt,2) !! Vector of latitude and longitudes (beware of the order !)
2703	REAL(r_std), INTENT(in) :: resolution(nbpt,2) !! The size of each grid box in X and Y (m)
2704	REAL(r_std), INTENT(in) :: contfrac(nbpt) !! Fraction of land in each grid box (unitless;0-1)
2705	INTEGER(i_std),INTENT (in) :: hist_id !! Access to history file (unitless)
2706	INTEGER(i_std),INTENT (in) :: hist2_id !! Access to history file 2 (unitless)
2707	!
2708	!! LOCAL VARIABLES
2709	REAL(r_std), DIMENSION(nbpt) :: nbrivers !! Number of rivers in the grid (unitless)
2710	REAL(r_std), DIMENSION(nbpt) :: basinmap !! Map of basins (unitless)
2711	REAL(r_std), DIMENSION(nbp_glo) :: nbrivers_g !! Number of rivers in the grid (unitless)
2712	REAL(r_std), DIMENSION(nbp_glo) :: basinmap_g !! Map of basins (unitless)
2713
2714	!_ ================================================================================================================================
2715	routing_area => routing_area_glo
2716	topo_resid => topo_resid_glo
2717	route_togrid => route_togrid_glo
2718	route_tobasin => route_tobasin_glo
2719	route_nbintobas => route_nbintobas_glo
2720	global_basinid => global_basinid_glo
2721	hydrodiag=>hydrodiag_glo
2722	hydroupbasin=>hydroupbasin_glo
2723
2724	IF (is_root_prc) CALL routing_diagnostic(nbp_glo, index_g, lalo_g, resolution_g, contfrac_g, nbrivers_g,basinmap_g)
2725
2726	routing_area => routing_area_loc
2727	topo_resid => topo_resid_loc
2728	route_togrid => route_togrid_loc
2729	route_tobasin => route_tobasin_loc
2730	route_nbintobas => route_nbintobas_loc
2731	global_basinid => global_basinid_loc
2732	hydrodiag=>hydrodiag_loc
2733	hydroupbasin=>hydroupbasin_loc
2734
2735	CALL scatter(nbrivers_g,nbrivers)
2736	CALL scatter(basinmap_g,basinmap)
2737	CALL scatter(hydrodiag_glo,hydrodiag_loc)
2738	CALL scatter(hydroupbasin_glo,hydroupbasin_loc)
2739
2740	CALL xios_orchidee_send_field("basinmap",basinmap)
2741	CALL xios_orchidee_send_field("nbrivers",nbrivers)
2742
2743	IF ( .NOT. almaoutput ) THEN
2744	CALL histwrite_p(hist_id, 'basinmap', 1, basinmap, nbpt, index)
2745	CALL histwrite_p(hist_id, 'nbrivers', 1, nbrivers, nbpt, index)
2746	ELSE
2747	ENDIF
2748	IF ( hist2_id > 0 ) THEN
2749	IF ( .NOT. almaoutput ) THEN
2750	CALL histwrite_p(hist2_id, 'basinmap', 1, basinmap, nbpt, index)
2751	CALL histwrite_p(hist2_id, 'nbrivers', 1, nbrivers, nbpt, index)
2752	ELSE
2753	ENDIF
2754	ENDIF
2755
2756
2757	END SUBROUTINE routing_diagnostic_p
2758
2759	!! ================================================================================================================================
2760	!! SUBROUTINE : routing_diagnostic
2761	!!
2762	!>\BRIEF This non-parallelized subroutine gives a diagnostic of the basins used. This produces some information
2763	!! on the rivers which are being diagnosed.
2764	!!
2765	!! DESCRIPTION (definitions, functional, design, flags) : As not all rivers can be monitored in the model, we will only
2766	!! archive num_largest rivers. In this routine we will diagnose the num_largest largest rivers and print to the standard
2767	!! 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
2768	!! routine routing_names. As this standard output is not sufficient, we will also write it to a netCDF file with the routine
2769	!! routing_diagncfile. It is important to keep for diagnostic the fraction of the largest basins in each grid box and keep information
2770	!! how they are linked one to the other.
2771	!!
2772	!! RECENT CHANGE(S): None
2773	!!
2774	!! MAIN OUTPUT VARIABLE(S): No output variables.
2775	!!
2776	!! REFERENCES : None
2777	!!
2778	!! FLOWCHART :None
2779	!! \n
2780	!_ ================================================================================================================================
2781
2782	SUBROUTINE routing_diagnostic(nbpt, l_index, lalo, resolution, contfrac, nbrivers, basinmap)
2783	!
2784	IMPLICIT NONE
2785	!
2786	!! INPUT VARIABLES
2787	INTEGER(i_std), INTENT(in) :: nbpt !! Domain size (unitless)
2788	INTEGER(i_std), INTENT(in) :: l_index(nbpt) !! Indices of the points on the map (unitless)
2789	REAL(r_std), INTENT(in) :: lalo(nbpt,2) !! Vector of latitude and longitudes (beware of the order !)
2790	REAL(r_std), INTENT(in) :: resolution(nbpt,2) !! The size of each grid box in X and Y (m)
2791	REAL(r_std), INTENT(in) :: contfrac(nbpt) !! Fraction of land in each grid box (unitless;0-1)
2792	!
2793	!! OUTPUT VARIABLES
2794	REAL(r_std), DIMENSION(nbpt), INTENT(out) :: nbrivers !! Number of rivers in the grid (unitless)
2795	REAL(r_std), DIMENSION(nbpt), INTENT(out) :: basinmap !! Map of basins (unitless)
2796	!
2797	!! LOCAL VARIABLES
2798	INTEGER(i_std), DIMENSION(nbpt,nbasmax) :: outids !! IDs of river to which this basin contributes (unitless)
2799	INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:) :: pts !! List the points belonging to the basin (unitless)
2800	INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:) :: ptbas !! List the basin number for this point (unitless)
2801	INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:) :: outpt !! Outflow point for each basin (unitless)
2802	INTEGER(i_std), ALLOCATABLE, DIMENSION(:) :: nb_pts !! Number of points in the basin (unitless)
2803	REAL(r_std), ALLOCATABLE, DIMENSION(:) :: totarea !! Total area of basin (m^2)
2804	REAL(r_std), ALLOCATABLE, DIMENSION(:) :: tmparea !!
2805	INTEGER(i_std), ALLOCATABLE, DIMENSION(:) :: topids !! The IDs of the first num_largest basins (unitless)
2806	CHARACTER(LEN=25), ALLOCATABLE, DIMENSION(:) :: basin_names !! Names of the rivers (unitless)
2807	CHARACTER(LEN=25) :: name_str !!
2808	!
2809	LOGICAL :: river_file !! Choose to write a description of the rivers (true/false)
2810	CHARACTER(LEN=80) :: river_file_name !! Filename in which we write the description of the rivers (unitless)
2811	!
2812	CHARACTER(LEN=25), ALLOCATABLE, DIMENSION(:) :: sorted_names !!
2813	INTEGER(i_std), ALLOCATABLE, DIMENSION(:) :: streams_nb !! Number of streams in basin (unitless)
2814	INTEGER(i_std), ALLOCATABLE, DIMENSION(:) :: streams_avehops !! Average number of hops in streams (unitless)
2815	INTEGER(i_std), ALLOCATABLE, DIMENSION(:) :: streams_minhops !! Minimum number of hops in streams (unitless)
2816	INTEGER(i_std), ALLOCATABLE, DIMENSION(:) :: streams_maxhops !! Minimum number of hops in streams (unitless)
2817	REAL(r_std), ALLOCATABLE, DIMENSION(:) :: streams_resid !! Average residence time
2818	!
2819	REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: lbasin_area !!
2820	REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: lbasin_uparea !!
2821	INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:) :: lrivercode !!
2822	!
2823	INTEGER(i_std) :: ig, ib, og, ob, ign, ibn, ff(1), ic, icc, nb_small, idbas, slen, ii !! Indices (unitless)
2824	INTEGER(i_std) :: ier !! Error handling
2825	CHARACTER(LEN=3) :: nn !!
2826	INTEGER(i_std) :: name_found !!
2827	!
2828	REAL(r_std) :: averesid !!
2829	REAL(r_std), DIMENSION(nbasmax) :: tmpbas !!
2830	REAL(r_std), DIMENSION(nbpt,nbasmax) :: areaupbasin !!
2831	INTEGER(i_std), ALLOCATABLE, DIMENSION(:) :: sortedrivs !!
2832	!
2833	! Variables for the river coding
2834	!
2835	INTEGER(i_std) :: longest_river !!
2836	INTEGER(i_std) :: nbmax !!
2837	INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:) :: allstreams !!
2838	REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: upstreamchange !!
2839	INTEGER(i_std), ALLOCATABLE, DIMENSION(:) :: tstreams, tslen, tpts, tptbas, tcode !!
2840	REAL(r_std), ALLOCATABLE, DIMENSION(:) :: tuparea !!
2841	REAL(r_std), ALLOCATABLE, DIMENSION(:) :: tupstreamchange !!
2842	!
2843	LOGICAL :: err_nbpt_grid_basin !! (true/false)
2844	LOGICAL :: err_basin_number !! (true/false)
2845
2846	!_ ================================================================================================================================
2847	!
2848	!
2849	ALLOCATE(pts(num_largest, nbpt), stat=ier)
2850	IF (ier /= 0) CALL ipslerr_p(3,'routing_diagnostic','Pb in allocate for pts','','')
2851
2852	ALLOCATE(ptbas(num_largest, nbpt), stat=ier)
2853	IF (ier /= 0) CALL ipslerr_p(3,'routing_diagnostic','Pb in allocate for ptbas','','')
2854
2855	ALLOCATE(outpt(num_largest, 2), stat=ier)
2856	IF (ier /= 0) CALL ipslerr_p(3,'routing_diagnostic','Pb in allocate for outpt','','')
2857
2858	ALLOCATE(nb_pts(num_largest), stat=ier)
2859	IF (ier /= 0) CALL ipslerr_p(3,'routing_diagnostic','Pb in allocate for nb_pts','','')
2860
2861	ALLOCATE(totarea(num_largest), tmparea(num_largest), stat=ier)
2862	IF (ier /= 0) CALL ipslerr_p(3,'routing_diagnostic','Pb in allocate for totarea','','')
2863
2864	ALLOCATE(topids(num_largest), stat=ier)
2865	IF (ier /= 0) CALL ipslerr_p(3,'routing_diagnostic','Pb in allocate for topids','','')
2866
2867	ALLOCATE(sortedrivs(num_largest), stat=ier)
2868	IF (ier /= 0) CALL ipslerr_p(3,'routing_diagnostic','Pb in allocate for sortedrivs','','')
2869
2870	ALLOCATE(sorted_names(num_largest), stat=ier)
2871	IF (ier /= 0) CALL ipslerr_p(3,'routing_diagnostic','Pb in allocate for sorted_names','','')
2872
2873	ALLOCATE(streams_nb(num_largest), streams_avehops(num_largest), streams_minhops(num_largest), stat=ier)
2874	IF (ier /= 0) CALL ipslerr_p(3,'routing_diagnostic','Pb in allocate for streams_nb','','')
2875
2876	ALLOCATE(streams_maxhops(num_largest), stat=ier)
2877	IF (ier /= 0) CALL ipslerr_p(3,'routing_diagnostic','Pb in allocate for streams_maxhops','','')
2878
2879	ALLOCATE(streams_resid(num_largest), stat=ier)
2880	IF (ier /= 0) CALL ipslerr_p(3,'routing_diagnostic','Pb in allocate for streams_resid','','')
2881
2882	ALLOCATE(lbasin_area(num_largest,nbpt), lbasin_uparea(num_largest,nbpt), lrivercode(num_largest,nbpt), stat=ier)
2883	IF (ier /= 0) CALL ipslerr_p(3,'routing_diagnostic','Pb in allocate for lbasin_area','','')
2884
2885	IF ( .NOT. is_root_prc) THEN
2886	WRITE(numout,*) "routing_diagnostic is not suitable for running in parallel"
2887	WRITE(numout,*) "We are here on a non root processor. is_root_prc = ", is_root_prc
2888	WRITE(numout,*) "STOP from routing_diagnostic"
2889	CALL ipslerr_p(3,'routing_diagnostic','This routine is not suitable for running in parallel','','')
2890	ENDIF
2891
2892
2893	!Config Key = RIVER_DESC
2894	!Config Desc = Writes out a description of the rivers
2895	!Config If = RIVER_ROUTING
2896	!Config Def = n
2897	!Config Help = This flag allows to write out a file containing the list of
2898	!Config rivers which are beeing simulated. It provides location of outflow
2899	!Config drainage area, name and ID.
2900	!Config Units = [FLAG]
2901	!
2902	river_file=.FALSE.
2903	CALL getin('RIVER_DESC', river_file)
2904	!
2905	!Config Key = RIVER_DESC_FILE
2906	!Config Desc = Filename in which we write the description of the rivers. If suffix is ".nc" a netCDF file is created
2907	!Config If = RIVER_DESC
2908	!Config Def = river_desc.nc
2909	!Config Help = File name where we will write the information. If the suffix is ".nc" a netCDF file is generated. Else
2910	!Config a simple text file will contain some information. The netCDF file is valuable for post-processing the
2911	! data as it will contain the fraction of the large basins in each grid box.
2912	!Config Units = [FILE]
2913	!
2914	river_file_name="river_desc.nc"
2915	CALL getin('RIVER_DESC_FILE', river_file_name)
2916	!
2917	!
2918	! First we get the list of all river outflow points
2919	! We work under the assumption that we only have num_largest basins finishing with
2920	! nbasmax+3. This is checked in routing_truncate.
2921	!
2922	nb_small = 1
2923	outpt(:,:) = -1
2924	ic = 0
2925	DO ig=1,nbpt
2926	DO ib=1,nbasmax
2927	ign = route_togrid(ig, ib)
2928	ibn = route_tobasin(ig, ib)
2929	IF ( ibn .EQ. nbasmax+3) THEN
2930	ic = ic + 1
2931	outpt(ic,1) = ig
2932	outpt(ic,2) = ib
2933	!
2934	! Get the largest id of the basins we call a river. This is
2935	! to extract the names of all rivers.
2936	!
2937	IF ( global_basinid(ig,ib) > nb_small ) THEN
2938	nb_small = global_basinid(ig,ib)
2939	ENDIF
2940	ENDIF
2941	ENDDO
2942	ENDDO
2943
2944	nb_small = MIN(nb_small, 349)
2945
2946	ALLOCATE(basin_names(nb_small), stat=ier)
2947	IF (ier /= 0) CALL ipslerr_p(3,'routing_diagnostic','Pb in allocate for basins_names','','')
2948
2949	CALL routing_names(nb_small, basin_names)
2950	!
2951	! Go through all points and basins to see if they outflow as a river and store the
2952	! information needed in the various arrays.
2953	!
2954	nb_pts(:) = 0
2955	totarea(:) = zero
2956	hydrodiag(:,:) = 0
2957	areaupbasin(:,:) = zero
2958	outids(:,:) = -1
2959	ob = -1
2960	og = -1
2961	lbasin_area(:,:) = zero
2962	lbasin_uparea(:,:) = zero
2963	longest_river = 0
2964	!
2965	err_nbpt_grid_basin = .FALSE.
2966	loopgridbasin : DO ig=1,nbpt
2967	!
2968	DO ib=1,nbasmax
2969	IF ( routing_area(ig,ib) .GT. zero ) THEN
2970	ic = 0
2971	ign = ig
2972	ibn = ib
2973	! Locate outflow point
2974	DO WHILE (ibn .GT. 0 .AND. ibn .LE. nbasmax .AND. ic .LT. nbasmax*nbpt)
2975	ic = ic + 1
2976	og = ign
2977	ob = ibn
2978	ign = route_togrid(og, ob)
2979	ibn = route_tobasin(og, ob)
2980	areaupbasin(og, ob) = areaupbasin(og, ob) + routing_area(ig,ib)
2981	ENDDO
2982	!
2983	longest_river = MAX(longest_river, ic)
2984	!
2985	! Now that we have an outflow check if it is one of the num_largest rivers.
2986	! In this case we keeps the location so we diagnose it.
2987	!
2988	IF ( ibn .EQ. nbasmax + 3) THEN
2989	DO icc = 1,num_largest
2990	IF ( outpt(icc,1) .EQ. og .AND. outpt(icc,2) .EQ. ob ) THEN
2991	!
2992	! We only keep this point for our map if it is large enough.
2993	!
2994	nb_pts(icc) = nb_pts(icc) + 1
2995	!
2996	!
2997	IF ( nb_pts(icc) > nbpt ) THEN
2998	err_nbpt_grid_basin = .TRUE.
2999	EXIT loopgridbasin
3000	ENDIF
3001	!
3002	pts(icc, nb_pts(icc)) = ig
3003	ptbas(icc, nb_pts(icc)) = ib
3004	totarea(icc) = totarea(icc) + routing_area(ig,ib)
3005	!
3006	lbasin_area(icc,nb_pts(icc)) = routing_area(ig,ib)
3007	!
3008	! ID of the river is taken from the last point before the outflow.
3009	topids(icc) = global_basinid(og,ob)
3010	outids(ig,ib) = global_basinid(og,ob)
3011	!
3012	! On this gridbox and basin we will diagnose the hydrograph
3013	!
3014	hydrodiag(ig, ib) = 1
3015	!
3016	ENDIF
3017	ENDDO
3018	ENDIF
3019	ENDIF
3020	!
3021	ENDDO
3022	!
3023	ENDDO loopgridbasin
3024	!
3025	IF ( err_nbpt_grid_basin ) THEN
3026	WRITE(numout, *) "routing_diagnostic : The number of grid points in basin ", icc
3027	WRITE(numout, *) "routing_diagnostic : is larger than anticiped. "
3028	CALL ipslerr_p(3, 'routing_diagnostic', 'We are heading for a out of bounds in arrays pts, ptsbas and lbasin_area.',&
3029	& 'Increase the last dimension of these arrays.','')
3030	ENDIF
3031	!
3032	! Now we decide which points we will keep from the largest basins
3033	!
3034	! Temporary fix
3035	route_nbintobas(:,:) = 0
3036	!
3037	basinmap(:) = zero
3038	DO ig=1,nbpt
3039	!
3040	! Look for the dominant basin in this grid. This information only affects some
3041	! diagnostics : hydrographs and saved area upstream.
3042	!
3043	icc = 0
3044	idbas = -1
3045	!
3046	DO ib=1,nbasmax
3047	IF ( outids(ig,ib) > 0 ) THEN
3048	IF ( COUNT(outids(ig,:) == outids(ig,ib)) > icc ) THEN
3049	icc = COUNT(outids(ig,:) == outids(ig,ib))
3050	idbas = outids(ig,ib)
3051	ENDIF
3052	ENDIF
3053	ENDDO
3054	!
3055	! If we have found a point from the large basins and decided which one
3056	! takes over this grid then we note it on the map.
3057	! Clean-up a little the hydrodiag array
3058	!
3059	IF ( idbas > 0 ) THEN
3060	basinmap(ig) = REAL(idbas, r_std)
3061	ENDIF
3062	!
3063	! Now place the hydrograph diagnostic on the point closest to the
3064	! ocean.
3065	!
3066	tmpbas(:) = zero
3067	DO ib=1,nbasmax
3068	IF ( outids(ig,ib) .EQ. idbas) THEN
3069	tmpbas(ib) = areaupbasin(ig,ib)
3070	ENDIF
3071	ENDDO
3072	hydrodiag(ig,:) = 0
3073	ff=MAXLOC(tmpbas)
3074	hydrodiag(ig,ff(1)) = 1
3075	hydroupbasin(ig) = areaupbasin(ig,ff(1))
3076	!
3077	ENDDO
3078	!
3079	!
3080	!
3081	tmparea(:) = totarea(:)
3082	DO icc = 1, num_largest
3083	ff = MAXLOC(tmparea)
3084	sortedrivs(icc) = ff(1)
3085	tmparea(ff(1)) = 0.0
3086	ENDDO
3087	!
3088	! Diagnose the complexity of the basins obtained and determine their code in the Pfafstetter system
3089	!
3090	nbmax=MAXVAL(nb_pts)
3091	ALLOCATE(allstreams(nbmax, longest_river), upstreamchange(nbmax, longest_river), stat=ier)
3092	IF (ier /= 0) CALL ipslerr_p(3,'routing_diagnostic','Pb in allocate for allstreams','','')
3093
3094	ALLOCATE(tstreams(longest_river), tupstreamchange(longest_river), stat=ier)
3095	IF (ier /= 0) CALL ipslerr_p(3,'routing_diagnostic','Pb in allocate for tstreams','','')
3096
3097	ALLOCATE(tslen(nbmax), tpts(nbmax), tptbas(nbmax), tuparea(nbmax), stat=ier)
3098	IF (ier /= 0) CALL ipslerr_p(3,'routing_diagnostic','Pb in allocate for tslen','','')
3099
3100	ALLOCATE(tcode(nbmax), stat=ier)
3101	IF (ier /= 0) CALL ipslerr_p(3,'routing_diagnostic','Pb in allocate for tcode','','')
3102
3103	DO icc = 1, num_largest
3104	!
3105	! Work through the largest basins
3106	!
3107	idbas = sortedrivs(icc)
3108	!
3109	streams_nb(idbas) = 0
3110	streams_avehops(idbas) = 0
3111	streams_minhops(idbas) = undef_int
3112	streams_maxhops(idbas) = 0
3113	streams_resid(idbas) = zero
3114	tslen(:) = 0
3115	!
3116	allstreams(:,:) = 0
3117	upstreamchange(:,:) = zero
3118	!
3119	DO ii=1,nb_pts(idbas)
3120	!
3121	ig = pts(idbas, ii)
3122	ib = ptbas(idbas, ii)
3123	!
3124	lbasin_uparea(idbas,ii) = areaupbasin(ig,ib)
3125	!
3126	slen = 0
3127	ign = ig
3128	ibn = ib
3129	og = ig
3130	ob = ib
3131	!
3132	averesid = zero
3133	tupstreamchange(:) = zero
3134	! go to outflow point to count the number of hops
3135	DO WHILE (ibn .GT. 0 .AND. ibn .LE. nbasmax)
3136	! Store data
3137	slen = slen + 1
3138	tstreams(slen) = ign
3139	tupstreamchange(slen) = areaupbasin(ign,ibn)-areaupbasin(og,ob)
3140	! Move to next point
3141	og = ign
3142	ob = ibn
3143	ign = route_togrid(og, ob)
3144	ibn = route_tobasin(og, ob)
3145	averesid = averesid + topo_resid(og, ob)**2
3146	ENDDO
3147	!
3148	allstreams(ii,1:slen) = tstreams(slen:1:-1)
3149	upstreamchange(ii,1:slen) = tupstreamchange(slen:1:-1)
3150	tslen(ii) = slen
3151	!
3152	! Save diagnostics
3153	!
3154	streams_nb(idbas) = streams_nb(idbas) + 1
3155	streams_avehops(idbas) = streams_avehops(idbas) + slen
3156	streams_resid(idbas) = streams_resid(idbas) + SQRT(averesid)
3157	IF ( slen < streams_minhops(idbas) ) THEN
3158	streams_minhops(idbas) = slen
3159	ENDIF
3160	IF ( slen > streams_maxhops(idbas) ) THEN
3161	streams_maxhops(idbas) = slen
3162	ENDIF
3163	!
3164	ENDDO
3165	! build the average
3166	IF ( streams_nb(idbas) > 0 ) THEN
3167	streams_avehops(idbas) = streams_avehops(idbas)/streams_nb(idbas)
3168	streams_resid(idbas) = streams_resid(idbas)/REAL(streams_nb(idbas), r_std)
3169	ELSE
3170	! River without streams ... very rare but happens
3171	streams_avehops(idbas) = zero
3172	streams_resid(idbas) = zero
3173	streams_maxhops(idbas) = zero
3174	streams_minhops(idbas) = zero
3175	ENDIF
3176	!
3177	!
3178	ii=nb_pts(idbas)
3179	tpts(:) = 0
3180	tpts(1:ii) = pts(idbas,1:ii)
3181	tptbas(:) = 0
3182	tptbas(1:ii) = ptbas(idbas,1:ii)
3183	tuparea(:) = 0
3184	tuparea(1:ii) = lbasin_uparea(idbas,1:ii)
3185	!
3186	CALL routing_diagcode(ii, tpts, tptbas, tuparea, tslen, MAXVAL(tslen), allstreams, upstreamchange, tcode)
3187	!
3188	lrivercode(idbas,:) = 0
3189	lrivercode(idbas,1:ii) = tcode(1:ii)
3190	!
3191	ENDDO
3192	!
3193	! Create the sorted list of names
3194	!
3195	err_basin_number = .FALSE.
3196	DO icc = 1, num_largest
3197	!
3198	ib=sortedrivs(icc)
3199	!
3200	IF ( topids(ib) .GT. nb_small ) THEN
3201	IF (topids(ib) <= 99 ) THEN
3202	WRITE(sorted_names(icc), '("Nb_",I2.2)') topids(ib)
3203	ELSE IF (topids(ib) <= 999 ) THEN
3204	WRITE(sorted_names(icc), '("Nb_",I3.3)') topids(ib)
3205	ELSE IF (topids(ib) <= 9999 ) THEN
3206	WRITE(sorted_names(icc), '("Nb_",I4.4)') topids(ib)
3207	ELSE IF (topids(ib) <= 99999 ) THEN
3208	WRITE(sorted_names(icc), '("Nb_",I5.5)') topids(ib)
3209	ELSE IF (topids(ib) <= 999999 ) THEN
3210	WRITE(sorted_names(icc), '("Nb_",I6.6)') topids(ib)
3211	ELSE
3212	err_basin_number = .TRUE.
3213	EXIT
3214	ENDIF
3215
3216	ELSE
3217	IF (topids(ib) <= -1 ) THEN
3218	WRITE(sorted_names(icc), '("Ne_",I2.2)') -1*topids(ib)
3219	ELSE
3220	IF (printlev >=6) WRITE(numout,*) ">>> nb_small, ib, topids :", nb_small, ib, topids(ib)
3221	sorted_names(icc) = basin_names(topids(ib))
3222	ENDIF
3223	ENDIF
3224	!
3225	ENDDO
3226	!
3227	IF ( err_basin_number ) THEN
3228	CALL ipslerr_p(3, 'routing_diagnostic', 'We found a basin number larger than 999999.',&
3229	& 'This is impossible. Please verify your configuration.','')
3230	ENDIF
3231	!
3232	! Check for doubles and rename if needed
3233	!
3234	DO icc = 1, num_largest
3235	name_found=0
3236	DO ic=1, num_largest
3237	IF ( TRIM(sorted_names(icc)) == TRIM(sorted_names(ic)) ) THEN
3238	name_found = name_found + 1
3239	ENDIF
3240	ENDDO
3241
3242	IF ( name_found > 1 ) THEN
3243	DO ic=num_largest,1,-1
3244	IF ( TRIM(sorted_names(icc)) == TRIM(sorted_names(ic)) .AND. name_found > 1 ) THEN
3245	IF ( name_found < 10 ) THEN
3246	WRITE(nn,'(I1)') name_found
3247	ELSE IF ( name_found < 100 ) THEN
3248	WRITE(nn,'(I2)') name_found
3249	ELSE IF ( name_found < 1000 ) THEN
3250	WRITE(nn,'(I3)') name_found
3251	ELSE
3252	! Make sur to increase nn size when adding more cases
3253	CALL ipslerr_p(3, 'routing_diagnostic', &
3254	'Non of the previous values can fit in the new char', &
3255	'Add a new condition to deal with it', '')
3256	ENDIF
3257	sorted_names(ic) = TRIM(sorted_names(ic))//TRIM(nn)
3258	name_found = name_found - 1
3259	ENDIF
3260	ENDDO
3261	ENDIF
3262
3263	ENDDO
3264	!
3265	! Print to stdout on ROOT_PROC the diagnostics for the largest basins we have found.
3266	!
3267	IF (printlev>=1) THEN
3268	DO icc = 1, num_largest
3269	IF ( nb_pts(sortedrivs(icc)) .GT. 2 ) THEN
3270	name_str = sorted_names(icc)
3271	WRITE(numout,'("Basin ID ", I5," ", A15, " Area [km^2] : ", F13.4, " Nb points : ", I4)')&
3272	& topids(sortedrivs(icc)), name_str(1:15), totarea(sortedrivs(icc))/1.e6, nb_pts(sortedrivs(icc))
3273	ENDIF
3274	ENDDO
3275	END IF
3276	!
3277	! Save some of the basin information into files.
3278	!
3279	IF ( river_file ) THEN
3280
3281	IF ( INDEX(river_file_name,".nc") > 1 ) THEN
3282
3283	CALL routing_diagncfile(river_file_name, nbpt, lalo, nb_pts, topids, sorted_names, sortedrivs, &
3284	& pts, lbasin_area, lbasin_uparea, lrivercode, outpt, streams_nb, streams_avehops, &
3285	& streams_minhops, streams_maxhops, streams_resid)
3286
3287	ELSE
3288
3289	OPEN(diagunit, FILE=river_file_name)
3290	WRITE(diagunit,'(A)') "Basin ID, Area [km^2], Nb points, Lon and Lat of outflow"
3291	WRITE(diagunit,'(A)') "Nb streams, total number of hops, min, ave and max number of hops per stream"
3292	!
3293	DO icc = 1, num_largest
3294	!
3295	IF ( nb_pts(sortedrivs(icc)) .GT. 2 ) THEN
3296	!
3297	name_str = sorted_names(icc)
3298	!
3299	WRITE(diagunit,'(I5,A25,F14.5,I5,2F9.2)') topids(sortedrivs(icc)), name_str(1:15), totarea(sortedrivs(icc))/1.e6, &
3300	& nb_pts(sortedrivs(icc)), lalo(outpt(sortedrivs(icc),1),2), lalo(outpt(sortedrivs(icc),1),1)
3301	WRITE(diagunit,'(5I9,F16.4)') streams_nb(sortedrivs(icc)), &
3302	& streams_avehops(sortedrivs(icc))*streams_nb(sortedrivs(icc)), &
3303	& streams_minhops(sortedrivs(icc)), &
3304	& streams_avehops(sortedrivs(icc)), &
3305	& streams_maxhops(sortedrivs(icc)), streams_resid(sortedrivs(icc))
3306	!
3307	ENDIF
3308	!
3309	ENDDO
3310	!
3311	CLOSE(diagunit)
3312	!
3313	ENDIF
3314	!
3315	ENDIF
3316	!
3317	!
3318	nbrivers(:) = zero
3319	DO ig=1,nbpt
3320	nbrivers(ig) = COUNT(route_tobasin(ig,1:nbasmax) == nbasmax+3)
3321	ENDDO
3322	DO ig=1,nbpt
3323	IF ( nbrivers(ig) > 1 ) THEN
3324	WRITE(numout,*) 'Grid box ', ig, ' has ', NINT(nbrivers(ig)), ' outflow points.'
3325	WRITE(numout,*) 'The rivers which flow into the ocean at this point are :'
3326	DO icc=1,nbasmax
3327	IF ( route_tobasin(ig,icc) == nbasmax+3) THEN
3328	IF ( global_basinid(ig,icc) <= nb_small ) THEN
3329	WRITE(numout,*) 'ID = ',global_basinid(ig,icc), ' Name = ', basin_names(global_basinid(ig,icc))
3330	ELSE
3331	WRITE(numout,*) 'ID = ',global_basinid(ig,icc), ' Problem ===== ID is larger than possible'
3332	ENDIF
3333	ENDIF
3334	ENDDO
3335	ENDIF
3336	ENDDO
3337	!
3338	ic = COUNT(topo_resid .GT. 0.)
3339	IF (printlev>=1) THEN
3340	WRITE(numout,*) 'Maximum topographic index :', MAXVAL(topo_resid)
3341	WRITE(numout,*) 'Mean topographic index :', SUM(topo_resid, MASK=topo_resid .GT. zero)/ic
3342	WRITE(numout,*) 'Minimum topographic index :', MINVAL(topo_resid, MASK=topo_resid .GT. zero)
3343	END IF
3344
3345	DEALLOCATE(pts)
3346	DEALLOCATE(outpt)
3347	DEALLOCATE(nb_pts)
3348	DEALLOCATE(totarea, tmparea)
3349	DEALLOCATE(streams_nb, streams_avehops, streams_minhops, streams_maxhops)
3350	!
3351	DEALLOCATE(lbasin_area, lbasin_uparea, lrivercode)
3352	!
3353	DEALLOCATE(allstreams)
3354	DEALLOCATE(tstreams)
3355	DEALLOCATE(tslen, tpts, tptbas, tuparea)
3356	DEALLOCATE(tcode)
3357	!
3358	ic = COUNT(topo_resid .GT. 0.)
3359	IF (printlev>=1) THEN
3360	WRITE(numout,*) 'Maximum topographic index :', MAXVAL(topo_resid)
3361	WRITE(numout,*) 'Mean topographic index :', SUM(topo_resid, MASK=topo_resid .GT. 0.)/ic
3362	WRITE(numout,*) 'Minimum topographic index :', MINVAL(topo_resid, MASK=topo_resid .GT. 0.)
3363	END IF
3364
3365	END SUBROUTINE routing_diagnostic
3366	!
3367	!! ================================================================================================================================
3368	!! SUBROUTINE : routing_diagcode
3369	!!
3370	!>\BRIEF This subroutine determines the code in the Pfafstetter system for all points
3371	!! within the given catchment.
3372	!!
3373	!! DESCRIPTION (definitions, functional, design, flags) : None
3374	!!
3375	!! RECENT CHANGE(S): None
3376	!!
3377	!! MAIN OUTPUT VARIABLE(S): streamcode
3378	!!
3379	!! REFERENCES : None
3380	!!
3381	!! FLOWCHART :None
3382	!! \n
3383	!_ ================================================================================================================================
3384
3385	SUBROUTINE routing_diagcode(ip, tpts, tpbas, tuparea, tslen, ls, allstreams, upstreamchange, streamcode)
3386	!
3387	IMPLICIT NONE
3388	!
3389	!! INPUT VARIABLES
3390	INTEGER(i_std), INTENT(in) :: ip !!
3391	INTEGER(i_std), INTENT(in) :: ls !!
3392	INTEGER(i_std), DIMENSION(ip), INTENT(in) :: tpts !!
3393	INTEGER(i_std), DIMENSION(ip), INTENT(in) :: tpbas !!
3394	REAL(r_std), DIMENSION(ip), INTENT(in) :: tuparea !!
3395	INTEGER(i_std), DIMENSION(ip), INTENT(in) :: tslen !!
3396	INTEGER(i_std), DIMENSION(ip,ls), INTENT(in) :: allstreams !!
3397	REAL(r_std), DIMENSION(ip,ls), INTENT(in) :: upstreamchange !!
3398	!
3399	!! OUTPUT VARIABLES
3400	INTEGER(i_std), DIMENSION(ip), INTENT(out) :: streamcode !!
3401	!
3402	!! LOCAL VARIABLES
3403	INTEGER(i_std) :: ilev, cntsubbas, ib, ic, i, it, ilevmax, imaxlen, nbzero !!
3404	INTEGER(i_std) :: tstreamcode(ip)!!
3405	INTEGER(i_std) :: indsubbas(ip) !!
3406	INTEGER(i_std) :: iw(ip) !!
3407	INTEGER(i_std) :: tdiff(ip) !!
3408	INTEGER(i_std) :: tmpjunc(4) !!
3409	INTEGER(i_std) :: junction(4) !!
3410	INTEGER(i_std) :: ff(1) !!
3411	INTEGER(i_std) :: ll !!
3412	REAL(r_std) :: chguparea(ip) !!
3413	REAL(r_std) :: largest !!
3414
3415	!_ ================================================================================================================================
3416	!
3417	streamcode(:) = 0
3418	!
3419	! If we accept 4 grid boxes per coded basin then per level we need at least
3420	! 4*9=36 boxes.
3421	!
3422	ilevmax = 0
3423	it = ip
3424	DO WHILE (it >= 36)
3425	ilevmax = ilevmax+1
3426	it = it/9
3427	ENDDO
3428	!
3429	DO ilev=1,ilevmax
3430	!
3431	! Count number of sub-basins we already have
3432	!
3433	cntsubbas=0
3434	tstreamcode(:) = streamcode(:)
3435	DO WHILE ( COUNT(tstreamcode(:) >= 0) > 0 )
3436	cntsubbas=cntsubbas+1
3437	indsubbas(cntsubbas) = MAXVAL(tstreamcode(:))
3438	WHERE ( tstreamcode(:) == indsubbas(cntsubbas) ) tstreamcode = -1
3439	ENDDO
3440	!
3441	! Go through all these basins in order to find the next Pfafstetter numbers
3442	!
3443	DO ib=1,cntsubbas
3444	!
3445	! Get all the streams which have the current Pfadstetter number
3446	!
3447	it=0
3448	DO ic=1,ip
3449	IF ( streamcode(ic) == indsubbas(ib) ) THEN
3450	it =it+1
3451	iw(it)=ic
3452	ENDIF
3453	ENDDO
3454	!
3455	! Which is the longest stream in this basin ?
3456	!
3457	ff=MAXLOC(tslen(iw(1:it)))
3458	imaxlen=iw(ff(1))
3459	chguparea(:) = zero
3460	chguparea(1:tslen(imaxlen)) = upstreamchange(imaxlen, 1:tslen(imaxlen))
3461	!
3462	IF ( COUNT(chguparea(1:tslen(imaxlen)) > 0) < 4 ) THEN
3463	!
3464	! If this subbasin is too small we just set all points to zero
3465	!
3466	DO i=1,it
3467	streamcode(iw(i)) = streamcode(iw(i))*10
3468	ENDDO
3469	ELSE
3470	!
3471	! Else do the Pfafstetter numbering
3472	!
3473	!
3474	! Where do we have the 4 largest change in upstream area on this stream.
3475	! This must be the confluence of 2 rivers and thus a junction point.
3476	!
3477	largest=piR_EarthR_Earth
3478	DO i=1,4
3479	ff = MAXLOC(chguparea(1:tslen(imaxlen)), MASK = chguparea(1:tslen(imaxlen)) < largest)
3480	tmpjunc(i) = ff(1)
3481	largest=chguparea(tmpjunc(i))
3482	ENDDO
3483	! sort junctions to go from the outflow up-stream
3484	ff(1)=0
3485	DO i=1,4
3486	junction(i) = MINVAL(tmpjunc, MASK=tmpjunc > ff(1))
3487	ff(1) = junction(i)
3488	ENDDO
3489	!
3490	! Find all streams which are identical up to that junction and increase their code accordingly
3491	!
3492	DO i=1,it
3493	ll=MIN(tslen(imaxlen),tslen(iw(i)))
3494	tdiff(1:ll) = allstreams(imaxlen,1:ll)-allstreams(iw(i),1:ll)
3495	nbzero = COUNT(tdiff(1:ll) == 0)
3496	IF (nbzero < junction(1) ) THEN
3497	! Before first of the 4 largest basins
3498	streamcode(iw(i)) = streamcode(iw(i))*10+1
3499	ELSE IF (nbzero == junction(1) ) THEN
3500	! Stream part of the first largest basin
3501	streamcode(iw(i)) = streamcode(iw(i))*10+2
3502	ELSE IF (nbzero < junction(2) ) THEN
3503	! Between first and second stream
3504	streamcode(iw(i)) = streamcode(iw(i))*10+3
3505	ELSE IF (nbzero == junction(2) ) THEN
3506	! Stream part of the second basin
3507	streamcode(iw(i)) = streamcode(iw(i))*10+4
3508	ELSE IF (nbzero < junction(3) ) THEN
3509	! In between stream 2 and 3
3510	streamcode(iw(i)) = streamcode(iw(i))*10+5
3511	ELSE IF (nbzero == junction(3) ) THEN
3512	! Part of 3rd basin
3513	streamcode(iw(i)) = streamcode(iw(i))*10+6
3514	ELSE IF (nbzero < junction(4) ) THEN
3515	! In between 3 and 4th basins
3516	streamcode(iw(i)) = streamcode(iw(i))*10+7
3517	ELSE IF (nbzero == junction(4) ) THEN
3518	! Final of the 4 largest basins
3519	streamcode(iw(i)) = streamcode(iw(i))*10+8
3520	ELSE
3521	! The rest of the points and also the basin of the longest stream
3522	streamcode(iw(i)) = streamcode(iw(i))*10+9
3523	ENDIF
3524	ENDDO
3525	ENDIF
3526	ENDDO
3527	!
3528	ENDDO
3529	!
3530	!
3531	END SUBROUTINE routing_diagcode
3532	!
3533	!! ================================================================================================================================
3534	!! SUBROUTINE : routing_diagncfile
3535	!!
3536	!>\BRIEF This subroutine creates a netCDF file containing all the informations
3537	!! on the largest rivers which can be used for a refined analysis.
3538	!!
3539	!! DESCRIPTION (definitions, functional, design, flags) : None
3540	!!
3541	!! RECENT CHANGE(S): None
3542	!!
3543	!! MAIN OUTPUT VARIABLE(S): None
3544	!!
3545	!! REFERENCES : None
3546	!!
3547	!! FLOWCHART : None
3548	!! \n
3549	!_ ================================================================================================================================
3550
3551	SUBROUTINE routing_diagncfile(river_file_name, nbpt, lalo, nb_pts, topids, sorted_names, sortedrivs, &
3552	& lbasin_index, lbasin_area, lbasin_uparea, lrivercode, outpt, streams_nb, streams_avehops, &
3553	& streams_minhops, streams_maxhops, streams_resid)
3554	!
3555	USE netcdf
3556	!
3557	IMPLICIT NONE
3558	!
3559	!
3560	!! INPUT VARIABLES
3561	REAL(r_std), INTENT(in) :: lalo(nbpt,2) !! Vector of latitude and longitudes (beware of the order !)
3562
3563	!! LOCAL VARIABLES
3564	CHARACTER(LEN=80) :: river_file_name !! Filename in which we write the description of the rivers (1)
3565	INTEGER(i_std) :: nbpt !! Domain size (unitless)
3566	INTEGER(i_std), DIMENSION(num_largest) :: nb_pts !! Number of points in the basin (unitless)
3567	INTEGER(i_std), DIMENSION(num_largest) :: topids !! The IDs of the first num_largest basins (unitless)
3568	CHARACTER(LEN=25), DIMENSION(num_largest) :: sorted_names !! Names of the basins to be put into the file (unitless)
3569	INTEGER(i_std), DIMENSION(num_largest) :: sortedrivs !!
3570	INTEGER(i_std), DIMENSION(num_largest,nbpt) :: lbasin_index !!
3571	REAL(r_std), DIMENSION(num_largest,nbpt) :: lbasin_area !!
3572	REAL(r_std), DIMENSION(num_largest,nbpt) :: lbasin_uparea !!
3573	INTEGER(i_std), DIMENSION(num_largest,nbpt) :: lrivercode !!
3574	!
3575	INTEGER(i_std), DIMENSION(num_largest,2) :: outpt !! Outflow point for each basin (unitless)
3576	INTEGER(i_std), DIMENSION(num_largest) :: streams_nb !! Number of streams in basin (unitless)
3577	INTEGER(i_std), DIMENSION(num_largest) :: streams_avehops !! Average number of hops in streams (unitless)
3578	INTEGER(i_std), DIMENSION(num_largest) :: streams_minhops !! Minimum number of hops in streams (unitless)
3579	INTEGER(i_std), DIMENSION(num_largest) :: streams_maxhops !! Minimum number of hops in streams (unitless)
3580	REAL(r_std), DIMENSION(num_largest) :: streams_resid !! Average residence time
3581	!
3582	INTEGER(i_std) :: icc, fid, iret, ierr_tot, ib, ij, ik, i, j, lcc !! Indices (unitless)
3583	INTEGER(i_std) :: nlonid, nlatid, varid, varid2, varid3
3584	INTEGER(i_std) :: dims(2) !!
3585	REAL(r_std) :: lon_min, lon_max, lat_min, lat_max
3586	CHARACTER(LEN=80) :: lon_name, lat_name, var_name, long_name, nc_name, att_str
3587	CHARACTER(LEN=15) :: gridtype !!
3588	!
3589	REAL(r_std) :: basinfrac(iim_g,jjm_g) !!
3590	REAL(r_std) :: basinuparea(iim_g,jjm_g) !!
3591	INTEGER(i_std) :: basincode(iim_g,jjm_g) !!
3592	!
3593	LOGICAL :: check=.FALSE. !! (true/false)
3594	!
3595	!! PARAMETERS
3596	INTEGER(i_std),PARAMETER :: kind_r_diag=NF90_REAL8 !!
3597	INTEGER(i_std),PARAMETER :: kind_i_diag=NF90_INT !!
3598
3599	!_ ================================================================================================================================
3600	!
3601	!
3602	! 1.0 Create the NETCDF file and store the coordinates.
3603	!
3604	! This variable should be defined and computed in the module grid.f90.
3605	! Jan
3606	gridtype="regular"
3607	!
3608	iret = NF90_CREATE(TRIM(river_file_name), NF90_CLOBBER, fid)
3609	IF (iret /= NF90_NOERR) THEN
3610	CALL ipslerr_p (3,'routing_diagncfile', 'Could not create file :', &
3611	& TRIM(river_file_name), '(Problem with disk place or filename ?)')
3612	ENDIF
3613	!
3614	! 1.1 Define dimensions
3615	!
3616	IF ( INDEX(gridtype, "regular") == 1 ) THEN
3617	!
3618	! 1.1.1 regular grid
3619	!
3620	iret = NF90_DEF_DIM(fid, 'lon', iim_g, dims(1))
3621	IF (iret /= NF90_NOERR) THEN
3622	CALL ipslerr_p (3,'routing_diagncfile', 'Dimension "x" can not be defined for the file : ', &
3623	& TRIM(river_file_name),'(Solution ?)')
3624	ENDIF
3625	iret = NF90_DEF_DIM(fid, 'lat', jjm_g, dims(2))
3626	IF (iret /= NF90_NOERR) THEN
3627	CALL ipslerr_p (3,'routing_diagncfile', 'Dimension "y" can not be defined for the file : ', &
3628	& TRIM(river_file_name),'(Solution ?)')
3629	ENDIF
3630	ELSE
3631	!
3632	! 1.1.2 irregular grid
3633	!
3634	iret = NF90_DEF_DIM(fid, 'x', iim_g, dims(1))
3635	IF (iret /= NF90_NOERR) THEN
3636	CALL ipslerr_p (3,'routing_diagncfile', 'Dimension "x" can not be defined for the file : ', &
3637	& TRIM(river_file_name),'(Solution ?)')
3638	ENDIF
3639
3640	iret = NF90_DEF_DIM(fid, 'y', jjm_g, dims(2))
3641	IF (iret /= NF90_NOERR) THEN
3642	CALL ipslerr_p (3,'routing_diagncfile', 'Dimension "y" can not be defined for the file : ', &
3643	& TRIM(river_file_name),'(Solution ?)')
3644	ENDIF
3645	ENDIF
3646	!
3647	!
3648	! 1.2 Define variables and attributes
3649	!
3650	IF ( INDEX(gridtype, "regular") == 1 ) THEN
3651	!
3652	! 1.2.1 regular grid
3653	!
3654	lon_name = 'lon'
3655	!
3656	iret = NF90_DEF_VAR(fid, lon_name, kind_r_diag, dims(1), nlonid)
3657	IF (iret /= NF90_NOERR) THEN
3658	CALL ipslerr_p (3,'routing_diagncfile', 'Variable '//lon_name//' can not be defined for the file : ', &
3659	& TRIM(river_file_name),'(Solution ?)')
3660	ENDIF
3661	!
3662	lat_name = 'lat'
3663	iret = NF90_DEF_VAR(fid, lat_name, kind_r_diag, dims(2), nlatid)
3664	IF (iret /= NF90_NOERR) THEN
3665	CALL ipslerr_p (3,'routing_diagncfile', 'Variable '//lat_name//' can not be defined for the file : ', &
3666	& TRIM(river_file_name),'(Solution ?)')
3667	ENDIF
3668	!
3669	ELSE
3670	!
3671	! 1.2.2 irregular grid
3672	!
3673	lon_name = 'nav_lon'
3674	!
3675	iret = NF90_DEF_VAR(fid, lon_name, kind_r_diag, dims, nlonid)
3676	IF (iret /= NF90_NOERR) THEN
3677	CALL ipslerr_p (3,'routing_diagncfile', 'Variable '//lon_name//' can not be defined for the file : ', &
3678	& TRIM(river_file_name),'(Solution ?)')
3679	ENDIF
3680	!
3681	lat_name = 'nav_lat'
3682	iret = NF90_DEF_VAR(fid, lat_name, kind_r_diag, dims, nlatid)
3683	IF (iret /= NF90_NOERR) THEN
3684	CALL ipslerr_p (3,'routing_diagncfile', 'Variable '//lat_name//' can not be defined for the file : ', &
3685	& TRIM(river_file_name),'(Solution ?)')
3686	ENDIF
3687	!
3688	ENDIF
3689	!
3690	! 1.3 Add attributes to the coordinate variables
3691	!
3692	iret = NF90_PUT_ATT(fid, nlonid, 'units', "degrees_east")
3693	IF (iret /= NF90_NOERR) THEN
3694	CALL ipslerr_p (3,'routing_diagncfile', 'Could not add attribut to variable '//lon_name//' for the file :', &
3695	& TRIM(river_file_name),'(Solution ?)')
3696	ENDIF
3697	!
3698	lon_min = -180.
3699	lon_max = 180.
3700	!
3701	iret = NF90_PUT_ATT(fid, nlonid, 'valid_min', lon_min)
3702	IF (iret /= NF90_NOERR) THEN
3703	CALL ipslerr_p (3,'routing_diagncfile', 'Could not add attribut to variable '//lon_name//' for the file :', &
3704	& TRIM(river_file_name),'(Solution ?)')
3705	ENDIF
3706	iret = NF90_PUT_ATT(fid, nlonid, 'valid_max', lon_max)
3707	IF (iret /= NF90_NOERR) THEN
3708	CALL ipslerr_p (3,'routing_diagncfile', 'Could not add attribut to variable '//lon_name//' for the file :', &
3709	& TRIM(river_file_name),'(Solution ?)')
3710	ENDIF
3711	!
3712	iret = NF90_PUT_ATT(fid, nlonid, 'long_name', "Longitude")
3713	IF (iret /= NF90_NOERR) THEN
3714	CALL ipslerr_p (3,'routing_diagncfile', 'Could not add attribut to variable '//lon_name//' for the file :', &
3715	& TRIM(river_file_name),'(Solution ?)')
3716	ENDIF
3717	iret = NF90_PUT_ATT(fid, nlatid, 'units', "degrees_north")
3718	IF (iret /= NF90_NOERR) THEN
3719	CALL ipslerr_p (3,'routing_diagncfile', 'Could not add attribut to variable '//lat_name//' for the file :', &
3720	& TRIM(river_file_name),'(Solution ?)')
3721	ENDIF
3722	!
3723	lat_max = 90.
3724	lat_min = -90.
3725	!
3726	iret = NF90_PUT_ATT(fid, nlatid, 'valid_min', lat_min)
3727	IF (iret /= NF90_NOERR) THEN
3728	CALL ipslerr_p (3,'routing_diagncfile', 'Could not add attribut to variable '//lat_name//' for the file :', &
3729	& TRIM(river_file_name),'(Solution ?)')
3730	ENDIF
3731	iret = NF90_PUT_ATT(fid, nlatid, 'valid_max', lat_max)
3732	IF (iret /= NF90_NOERR) THEN
3733	CALL ipslerr_p (3,'routing_diagncfile', 'Could not add attribut to variable '//lat_name//' for the file :', &
3734	& TRIM(river_file_name),'(Solution ?)')
3735	ENDIF
3736	iret = NF90_PUT_ATT(fid, nlatid, 'long_name', "Latitude")
3737	IF (iret /= NF90_NOERR) THEN
3738	CALL ipslerr_p (3,'routing_diagncfile', 'Could not add attribut to variable '//lat_name//' for the file :', &
3739	& TRIM(river_file_name),'(Solution ?)')
3740	ENDIF
3741	!
3742	iret = NF90_ENDDEF(fid)
3743	IF (iret /= NF90_NOERR) THEN
3744	CALL ipslerr_p (3,'routing_diagncfile', 'Could not end definitions in the file : ', &
3745	& TRIM(river_file_name),'(Solution ?)')
3746	ENDIF
3747	!
3748	! 1.4 Write coordinates
3749	!
3750	IF ( INDEX(gridtype, "regular") == 1 ) THEN
3751	!
3752	! 1.4.1 regular grid
3753	!
3754	iret = NF90_PUT_VAR(fid, nlonid, lon_g(1:iim_g,1))
3755	IF (iret /= NF90_NOERR) THEN
3756	CALL ipslerr_p (3,'routing_diagncfile', 'Could not put variable nav_lon in the file : ', &
3757	& TRIM(river_file_name),'(Solution ?)')
3758	ENDIF
3759	!
3760	iret = NF90_PUT_VAR(fid, nlatid, lat_g(1,1:jjm_g))
3761	IF (iret /= NF90_NOERR) THEN
3762	CALL ipslerr_p (3,'routing_diagncfile', 'Could not put variable nav_lat in the file : ', &
3763	& TRIM(river_file_name),'(Solution ?)')
3764	ENDIF
3765	ELSE
3766	!
3767	! 1.4.2 irregular grid
3768	!
3769	iret = NF90_PUT_VAR(fid, nlonid, lon_g)
3770	IF (iret /= NF90_NOERR) THEN
3771	CALL ipslerr_p (3,'routing_diagncfile', 'Could not put variable nav_lon in the file : ', &
3772	& TRIM(river_file_name),'(Solution ?)')
3773	ENDIF
3774	!
3775	iret = NF90_PUT_VAR(fid, nlatid, lat_g)
3776	IF (iret /= NF90_NOERR) THEN
3777	CALL ipslerr_p (3,'routing_diagncfile', 'Could not put variable nav_lat in the file : ', &
3778	& TRIM(river_file_name),'(Solution ?)')
3779	ENDIF
3780	ENDIF
3781	!
3782	! 2.0 Go through all basins and wirte the information into the netCDF file.
3783	!
3784	DO icc = 1, num_largest
3785	!
3786	! 2.1 Compute the fields to be saved in the file
3787	!
3788	ib=sortedrivs(icc)
3789	!
3790	!
3791	IF ( nb_pts(ib) > 2 ) THEN
3792	!
3793	basinfrac(:,:) = zero
3794	basinuparea(:,:) = zero
3795	basincode(:,:) = zero
3796	!
3797	DO ij=1, nb_pts(ib)
3798
3799	ik=lbasin_index(ib,ij)
3800
3801	j = ((index_g(ik)-1)/iim_g) + 1
3802	i = (index_g(ik)-(j-1)*iim_g)
3803
3804	basinfrac(i,j) = basinfrac(i,j) + lbasin_area(ib,ij)/(resolution_g(ik,1)*resolution_g(ik,2))
3805	basinuparea(i,j) = MAX(basinuparea(i,j), lbasin_uparea(ib,ij))
3806	basincode(i,j) = lrivercode(ib,ij)
3807
3808	ENDDO
3809	!
3810	DO i=1,iim_g
3811	DO j=1,jjm_g
3812	IF ( basinfrac(i,j) <= EPSILON(zero) ) THEN
3813	basinfrac(i,j) = undef_sechiba
3814	basinuparea(i,j) = undef_sechiba
3815	basincode(i,j) = undef_int
3816	ELSE
3817	basinfrac(i,j) = MIN(basinfrac(i,j), un)
3818	ENDIF
3819	ENDDO
3820	ENDDO
3821	!
3822	!
3823	! 2.2 Define the variables in the netCDF file
3824	!
3825	iret = NF90_REDEF(fid)
3826	IF (iret /= NF90_NOERR) THEN
3827	CALL ipslerr_p (3,'routing_diagncfile', &
3828	& 'Could not restart definitions in the file : ', &
3829	& TRIM(river_file_name),'(Solution ?)')
3830	ENDIF
3831	!
3832	! Create a name more suitable for a variable in a netCDF file
3833	!
3834	nc_name = TRIM(sorted_names(icc))
3835	! Take out all character which could cause problems
3836	lcc=LEN_TRIM(nc_name)
3837	DO ij=1,lcc
3838	IF ( nc_name(ij:ij) == " " ) nc_name(ij:ij) = "_"
3839	IF ( nc_name(ij:ij) == "(" ) nc_name(ij:ij) = "_"
3840	IF ( nc_name(ij:ij) == ")" ) nc_name(ij:ij) = "_"
3841	ENDDO
3842	! reduce redundant "__"
3843	DO ij=1,lcc
3844	IF ( nc_name(ij:ij+1) == "__" ) nc_name(ij+1:)=nc_name(ij+2:lcc)
3845	ENDDO
3846	lcc=LEN_TRIM(nc_name)
3847	IF ( nc_name(lcc:lcc) == "_" ) nc_name(lcc:lcc) = " "
3848	!
3849	!
3850	! 2.3 Fraction variable
3851	!
3852	IF (check) WRITE(numout,*) "Define Fraction variable and add attributes"
3853	!
3854	var_name = TRIM(nc_name)//"_frac"
3855	!
3856	iret = NF90_DEF_VAR(fid, TRIM(var_name), kind_r_diag, dims, varid)
3857	IF (iret /= NF90_NOERR) THEN
3858	CALL ipslerr_p (3,'routing_diagncfile', 'Variable '//TRIM(var_name)//' can not be defined for the file : ', &
3859	& TRIM(river_file_name),'(Solution ?)')
3860	ENDIF
3861	!
3862	ierr_tot = 0
3863	! Units
3864	iret = NF90_PUT_ATT(fid, varid, 'units', "-")
3865	IF (iret /= NF90_NOERR) THEN
3866	WRITE(numout,*) 'Units', iret
3867	WRITE(numout,*) TRIM(NF90_STRERROR(iret))
3868	ierr_tot = ierr_tot + 1
3869	ENDIF
3870	! Long name
3871	long_name = "Fraction of basin "//TRIM(sorted_names(icc))//" per grid box"
3872	iret = NF90_PUT_ATT(fid, varid, 'long_name', long_name)
3873	IF (iret /= NF90_NOERR) THEN
3874	WRITE(numout,*) 'Long_Name', long_name, iret
3875	WRITE(numout,*) TRIM(NF90_STRERROR(iret))
3876	ierr_tot = ierr_tot + 1
3877	ENDIF
3878	! Missing value
3879	iret = NF90_PUT_ATT(fid, varid, 'missing_value', undef_sechiba)
3880	IF (iret /= NF90_NOERR) THEN
3881	WRITE(numout,*) 'Missing value', undef_sechiba, iret
3882	WRITE(numout,*) TRIM(NF90_STRERROR(iret))
3883	ierr_tot = ierr_tot + 1
3884	ENDIF
3885	!
3886	ib=sortedrivs(icc)
3887	IF ( check ) WRITE(numout,*) "Doing basin ", icc," corrsdponding to index = ", ib, "num_largest : ", num_largest
3888	!
3889	! Nb of grid points in basin
3890	att_str='Nb_of_grid_points_in_basin'
3891	iret = NF90_PUT_ATT(fid, varid, att_str, nb_pts(ib))
3892	IF (iret /= NF90_NOERR) THEN
3893	WRITE(numout,*) 'Nb of grid points in basin', nb_pts(ib), iret
3894	WRITE(numout,*) TRIM(NF90_STRERROR(iret))
3895	ierr_tot = ierr_tot + 1
3896	ENDIF
3897	!
3898	! Longitude of outflow point
3899	att_str='Longitude_of_outflow_point'
3900	iret = NF90_PUT_ATT(fid, varid, att_str, lalo(outpt(ib,1),2))
3901	IF (iret /= NF90_NOERR) THEN
3902	WRITE(numout,*) 'Longitude of outflow point', lalo(outpt(ib,1),2), iret
3903	WRITE(numout,*) TRIM(NF90_STRERROR(iret))
3904	ierr_tot = ierr_tot + 1
3905	ENDIF
3906	!
3907	! Latitide of outflow point
3908	att_str='Latitude_of_outflow_point'
3909	iret = NF90_PUT_ATT(fid, varid, att_str, lalo(outpt(ib,1),1))
3910	IF (iret /= NF90_NOERR) THEN
3911	WRITE(numout,*) 'Latitude of outflow point', lalo(outpt(ib,1),1), iret
3912	WRITE(numout,*) TRIM(NF90_STRERROR(iret))
3913	ierr_tot = ierr_tot + 1
3914	ENDIF
3915	!
3916	! Number of streams
3917	att_str= 'Number_of_streams'
3918	iret = NF90_PUT_ATT(fid, varid, att_str, streams_nb(ib))
3919	IF (iret /= NF90_NOERR) THEN
3920	WRITE(numout,*) 'Number of streams', streams_nb(ib), iret
3921	WRITE(numout,*) TRIM(NF90_STRERROR(iret))
3922	ierr_tot = ierr_tot + 1
3923	ENDIF
3924	!
3925	! Total number of hops to go to the oceans
3926	att_str='Total_number_of_hops_to_ocean'
3927	iret = NF90_PUT_ATT(fid, varid, att_str, streams_avehops(ib)*streams_nb(ib))
3928	IF (iret /= NF90_NOERR) THEN
3929	WRITE(numout,) 'Total number of hops to go to the oceans ', streams_avehops(ib)streams_nb(ib), iret
3930	ierr_tot = ierr_tot + 1
3931	ENDIF
3932	!
3933	! Minimum number of hops to go to the ocean for any stream
3934	att_str='Minimum_number_of_hops_to_ocean_for_any_stream'
3935	iret = NF90_PUT_ATT(fid, varid, att_str, streams_minhops(ib))
3936	IF (iret /= NF90_NOERR) THEN
3937	WRITE(numout,*) 'Minimum number of hops to go tp the ocean for any stream', streams_minhops(ib), iret
3938	ierr_tot = ierr_tot + 1
3939	ENDIF
3940	!
3941	! Average number of hops to go to the ocean for any stream
3942	att_str='Average_number_of_hops_to_ocean_for_any_stream'
3943	iret = NF90_PUT_ATT(fid, varid, att_str, streams_avehops(ib))
3944	IF (iret /= NF90_NOERR) THEN
3945	WRITE(numout,*) 'Average number of hops to go tp the ocean for any stream', streams_avehops(ib), iret
3946	ierr_tot = ierr_tot + 1
3947	ENDIF
3948	!
3949	! Maximum number of hops to go to the ocean for any stream
3950	att_str='Maximum_number_of_hops_to_ocean_for_any_stream'
3951	iret = NF90_PUT_ATT(fid, varid, att_str, streams_maxhops(ib))
3952	IF (iret /= NF90_NOERR) THEN
3953	WRITE(numout,*) 'Maximum number of hops to go tp the ocean for any stream', streams_maxhops(ib), iret
3954	ierr_tot = ierr_tot + 1
3955	ENDIF
3956	!
3957	! Average residence time in the basin
3958	att_str='Average_residence_time_in_basin'
3959	iret = NF90_PUT_ATT(fid, varid, att_str, streams_resid(ib))
3960	IF (iret /= NF90_NOERR) THEN
3961	WRITE(numout,*) 'Average residence time in the basin', streams_resid(ib), iret
3962	ierr_tot = ierr_tot + 1
3963	ENDIF
3964	!
3965	IF (ierr_tot > 0 ) THEN
3966	CALL ipslerr_p (3,'routing_diagncfile', 'Could not add some attributes to variable '//var_name//' for the file :', &
3967	& TRIM(river_file_name),'(Solution ?)')
3968	ENDIF
3969	!
3970	! 2.4 Upstream area variable variable
3971	!
3972	IF (check) WRITE(numout,*) "Define Upstream variable and add attributes"
3973	!
3974	! Create a name more suitable for a variable in a netCDF file
3975	!
3976	var_name = TRIM(nc_name)//"_upstream"
3977	DO ij=1,LEN_TRIM(var_name)
3978	IF ( var_name(ij:ij) == " " ) var_name(ij:ij) = "_"
3979	ENDDO
3980	!
3981	iret = NF90_DEF_VAR(fid, TRIM(var_name), kind_r_diag, dims, varid2)
3982	IF (iret /= NF90_NOERR) THEN
3983	CALL ipslerr_p (3,'routing_diagncfile', 'Variable '//TRIM(var_name)//' can not be defined for the file : ', &
3984	& TRIM(river_file_name),'(Solution ?)')
3985	ENDIF
3986	!
3987	ierr_tot = 0
3988	! Units
3989	iret = NF90_PUT_ATT(fid, varid2, 'units', "m^2")
3990	IF (iret /= NF90_NOERR) ierr_tot = ierr_tot + 1
3991	! Long name
3992	long_name = "Upstream area of basin "//TRIM(sorted_names(icc))//" in the grid box"
3993	iret = NF90_PUT_ATT(fid, varid2, 'long_name', long_name)
3994	IF (iret /= NF90_NOERR) ierr_tot = ierr_tot + 1
3995	! Missing value
3996	iret = NF90_PUT_ATT(fid, varid2, 'missing_value', undef_sechiba)
3997	IF (iret /= NF90_NOERR) ierr_tot = ierr_tot + 1
3998	!
3999	IF (ierr_tot > 0 ) THEN
4000	CALL ipslerr_p (3,'routing_diagncfile', 'Could not add some attributes to variable '//var_name//' for the file :', &
4001	& TRIM(river_file_name),'(Solution ?)')
4002	ENDIF
4003	!
4004	! 2.5 Pfafstetter codes for basins
4005	!
4006	IF (check) WRITE(numout,*) "Define Pfafstetter codes variable and add attributes"
4007	!
4008	var_name = TRIM(nc_name)//"_coding"
4009	DO ij=1,LEN_TRIM(var_name)
4010	IF ( var_name(ij:ij) == " " ) var_name(ij:ij) = "_"
4011	ENDDO
4012	!
4013	iret = NF90_DEF_VAR(fid, TRIM(var_name), kind_i_diag, dims, varid3)
4014	IF (iret /= NF90_NOERR) THEN
4015	CALL ipslerr_p (3,'routing_diagncfile', 'Variable '//TRIM(var_name)//' can not be defined for the file : ', &
4016	& TRIM(river_file_name),'(Solution ?)')
4017	ENDIF
4018	!
4019	ierr_tot = 0
4020	! Units
4021	iret = NF90_PUT_ATT(fid, varid3, 'units', "-")
4022	IF (iret /= NF90_NOERR) ierr_tot = ierr_tot + 1
4023	! Long name
4024	long_name = "Pfafstetter codes of grid boxes in basin "//TRIM(sorted_names(icc))
4025	iret = NF90_PUT_ATT(fid, varid3, 'long_name', long_name)
4026	IF (iret /= NF90_NOERR) ierr_tot = ierr_tot + 1
4027	! Missing value
4028	iret = NF90_PUT_ATT(fid, varid3, 'missing_value', undef_int)
4029	IF (iret /= NF90_NOERR) ierr_tot = ierr_tot + 1
4030	!
4031	IF (ierr_tot > 0 ) THEN
4032	CALL ipslerr_p (3,'routing_diagncfile', 'Could not add some attributes to variable '//var_name//' for the file :', &
4033	& TRIM(river_file_name),'(Solution ?)')
4034	ENDIF
4035	!
4036	! 2.6 ENDDEF of netCDF file
4037	!
4038	IF (check) WRITE(numout,*) "END define"
4039	!
4040	iret = NF90_ENDDEF(fid)
4041	IF (iret /= NF90_NOERR) THEN
4042	CALL ipslerr_p (3,'routing_diagncfile', &
4043	& 'Could not end definitions in the file : ', &
4044	& TRIM(river_file_name),'(Solution ?)')
4045	ENDIF
4046	!
4047	! 2.7 Write the data to the file
4048	!
4049	IF (check) WRITE(numout,*) "Put basinfrac"
4050	iret = NF90_PUT_VAR(fid, varid, basinfrac)
4051	IF (iret /= NF90_NOERR) THEN
4052	CALL ipslerr_p (3,'routing_diagncfile', 'Could not put variable basinfrac in the file : ', &
4053	& TRIM(river_file_name),'(Solution ?)')
4054	ENDIF
4055
4056	IF (check) WRITE(numout,*) "Put basinuparea"
4057	iret = NF90_PUT_VAR(fid, varid2, basinuparea)
4058	IF (iret /= NF90_NOERR) THEN
4059	CALL ipslerr_p (3,'routing_diagncfile', 'Could not put variable basinuparea in the file : ', &
4060	& TRIM(river_file_name),'(Solution ?)')
4061	ENDIF
4062
4063	IF (check) WRITE(numout,*) "Put basincode"
4064	iret = NF90_PUT_VAR(fid, varid3, basincode)
4065	IF (iret /= NF90_NOERR) THEN
4066	CALL ipslerr_p (3,'routing_diagfile', 'Could not put variable basincode in the file : ', &
4067	& TRIM(river_file_name),'(Solution ?)')
4068	ENDIF
4069	!
4070	ENDIF
4071	!
4072	ENDDO
4073	!
4074	IF (check) WRITE(numout,*) "Close file"
4075	!
4076	! Close netCDF file and do some memory management.
4077	!
4078	iret = NF90_CLOSE(fid)
4079	IF (iret /= NF90_NOERR) THEN
4080	CALL ipslerr_p (3,'routing_diagncfile', &
4081	& 'Could not end definitions in the file : ', &
4082	& TRIM(river_file_name),'(Solution ?)')
4083	ENDIF
4084	!
4085	!
4086	END SUBROUTINE routing_diagncfile
4087	!
4088	!! ================================================================================================================================
4089	!! SUBROUTINE : routing_basins_p
4090	!!
4091	!>\BRIEF This parallelized subroutine computes the routing map if needed.
4092	!!
4093	!! DESCRIPTION (definitions, functional, design, flags) : None
4094	!!
4095	!! RECENT CHANGE(S): None
4096	!!
4097	!! MAIN OUTPUT VARIABLE(S):
4098	!!
4099	!! REFERENCES : None
4100	!!
4101	!! FLOWCHART : None
4102	!! \n
4103	!_ ================================================================================================================================
4104
4105	SUBROUTINE routing_basins_p(nbpt, lalo, neighbours, resolution, contfrac)
4106	!
4107	IMPLICIT NONE
4108	!
4109	!! INPUT VARIABLES
4110	INTEGER(i_std), INTENT(in) :: nbpt !! Domain size (unitless)
4111	REAL(r_std), INTENT(in) :: lalo(nbpt,2) !! Vector of latitude and longitudes (beware of the order !)
4112	INTEGER(i_std), INTENT(in) :: neighbours(nbpt,NbNeighb) !! Vector of neighbours for each grid point (1=North and then clockwise) (unitless)
4113	REAL(r_std), INTENT(in) :: resolution(nbpt,2) !! The size of each grid box in X and Y (m)
4114	REAL(r_std), INTENT(in) :: contfrac(nbpt) !! Fraction of land in each grid box (unitless;0-1)
4115
4116	!_ ================================================================================================================================
4117
4118	! INTEGER(i_std) :: neighbours_tmp(nbpt,8)
4119	! INTEGER(i_std) :: i,j
4120
4121	! DO i=1,nbp_loc
4122	! DO j=1,NbNeighb
4123	! IF (neighbours(i,j)==-1) THEN
4124	! neighbours_tmp(i,j)=neighbours(i,j)
4125	! ELSE
4126	! neighbours_tmp(i,j)=neighbours(i,j)+nbp_para_begin(mpi_rank)-1
4127	! ENDIF
4128	! ENDDO
4129	! ENDDO
4130
4131	routing_area => routing_area_glo
4132	topo_resid => topo_resid_glo
4133	route_togrid => route_togrid_glo
4134	route_tobasin => route_tobasin_glo
4135	route_nbintobas => route_nbintobas_glo
4136	global_basinid => global_basinid_glo
4137
4138	IF (is_root_prc) CALL routing_basins(nbp_glo,lalo_g, neighbours_g, resolution_g, contfrac_g)
4139
4140	routing_area => routing_area_loc
4141	topo_resid => topo_resid_loc
4142	route_togrid => route_togrid_loc
4143	route_tobasin => route_tobasin_loc
4144	route_nbintobas => route_nbintobas_loc
4145	global_basinid => global_basinid_loc
4146
4147	CALL scatter(routing_area_glo,routing_area_loc)
4148	CALL scatter(topo_resid_glo,topo_resid_loc)
4149	CALL scatter(route_togrid_glo,route_togrid_loc)
4150	CALL scatter(route_tobasin_glo,route_tobasin_loc)
4151	CALL scatter(route_nbintobas_glo,route_nbintobas_loc)
4152	CALL scatter(global_basinid_glo,global_basinid_loc)
4153
4154	END SUBROUTINE routing_basins_p
4155	!
4156
4157	!! ================================================================================================================================
4158	!! SUBROUTINE : routing_basins
4159	!!
4160	!>\BRIEF This non-parallelized subroutine reads in the map of basins and flow direction to construct
4161	!! the catchments of each grid box.
4162	!!
4163	!! DESCRIPTION (definitions, functional, design, flags) :
4164	!! The work is done in a number of steps which are performed locally on the
4165	!! GCM grid:
4166	!! 1) First we find the grid-points of the high resolution routing grid which are
4167	!! within the coarser grid of the GCM.
4168	!! 2) When we have these grid points we decompose them into basins in the routine
4169	!! routing_findbasins. A number of simplifications are done if needed.
4170	!! 3) In the routine routing_globalize we put the basin information of this grid
4171	!! into the global fields.
4172	!! Then we work on the global grid to perform the following tasks :
4173	!! 1) We link up the basins of the various grid points and check the global consistency.
4174	!! 2) The area of each outflow point is computed.
4175	!! 3) The final step is to reduce the number of basins in order to fit into the truncation.\n
4176	!!
4177	!! RECENT CHANGE(S): None
4178	!!
4179	!! MAIN OUTPUT VARIABLE(S): None, as the routine puts information into the global variables of the module.
4180	!!
4181	!! REFERENCES : None
4182	!!
4183	!! FLOWCHART : None
4184	!! \n
4185	!_ ================================================================================================================================
4186
4187	SUBROUTINE routing_basins(nbpt, lalo, neighbours, resolution, contfrac)
4188	!
4189	IMPLICIT NONE
4190	!
4191	!! INPUT VARIABLES
4192	INTEGER(i_std), INTENT(in) :: nbpt !! Domain size (unitless)
4193	REAL(r_std), INTENT(in) :: lalo(nbpt,2) !! Vector of latitude and longitudes (beware of the order !)
4194	INTEGER(i_std), INTENT(in) :: neighbours(nbpt,NbNeighb)!! Vector of neighbours for each grid point
4195	!! (1=North and then cloxkwise)
4196	REAL(r_std), INTENT(in) :: resolution(nbpt,2) !! The size of each grid box in X and Y (m)
4197	REAL(r_std), INTENT(in) :: contfrac(nbpt) !! Fraction of land in each grid box (unitless;0-1)
4198	!
4199	!! LOCAL VARIABLES
4200	CHARACTER(LEN=80) :: filename !! Name of the netcdf file (unitless)
4201	INTEGER(i_std) :: iml, jml, lml, tml, fid, ib, ip, jp, fopt !! Indices (unitless)
4202	REAL(r_std) :: lev(1), date, dt, coslat
4203	INTEGER(i_std) :: itau(1) !!
4204	REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: trip !! The trip field (unitless)
4205	REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: basins !! The basin field (unitless)
4206	REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: topoindex !! Topographic index of the residence time (m)
4207	REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: hierarchy !!
4208	REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: lat_rel !!
4209	REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: lon_rel !!
4210	!
4211	INTEGER(i_std) :: nbi, nbj !! Number of point in x and y within the grid (unitless)
4212	REAL(r_std) :: min_topoind !! The current minimum of topographic index (m)
4213	REAL(r_std) :: max_basins !!
4214	REAL(r_std) :: invented_basins !!
4215	!
4216	REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: area_bx !! Area of each small box in the grid box (m^2)
4217	REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: hierarchy_bx !! Level in the basin of the point
4218	REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: lon_bx !!
4219	REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: lat_bx !!
4220	REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: topoind_bx !! Topographic index of the residence time for each of the smaller boxes (m)
4221	INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:) :: trip_bx !! The trip field for each of the smaller boxes (unitless)
4222	INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:) :: basin_bx !!
4223	INTEGER(i_std), ALLOCATABLE, DIMENSION(:) :: coast_pts !! The coastal flow points (unitless)
4224	!
4225	INTEGER(i_std), ALLOCATABLE, DIMENSION(:) :: basin_count !!
4226	INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:) :: basin_id !!
4227	REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: basin_area !!
4228	REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: basin_hierarchy !!
4229	REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: basin_topoind !! Topographic index of the residence time for a basin (m)
4230	REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: fetch_basin !!
4231	INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:) :: basin_flowdir !! Water flow directions in the basin (unitless)
4232	INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:) :: outflow_grid !! Type of outflow on the grid box (unitless)
4233	INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:) :: outflow_basin !!
4234	INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:) :: inflow_number !!
4235	INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:,:) :: inflow_basin !!
4236	INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:,:) :: inflow_grid !!
4237	INTEGER(i_std), ALLOCATABLE, DIMENSION(:) :: nbcoastal !!
4238	INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:) :: coastal_basin !!
4239	!
4240	! Interpolation help variables
4241	!
4242	INTEGER(i_std) :: nix, njx !!
4243	CHARACTER(LEN=30) :: callsign !!
4244	REAL(r_std), ALLOCATABLE, DIMENSION(:,:,:) :: resol_lu !! Resolution
4245	INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:) :: mask !! Mask to exclude some points (unitless)
4246	REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: sub_area !! Area on the fine grid (m^2)
4247	INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:,:) :: sub_index !! Indices of the points we need on the fine grid (unitless)
4248	INTEGER(i_std), ALLOCATABLE, DIMENSION(:) :: sub_pts !! Number of high resolution points on this grid (unitless)
4249	INTEGER :: ALLOC_ERR !!
4250	LOGICAL :: ok_interpol = .FALSE. !! Flag for interpolation (true/false)
4251	!
4252	INTEGER(i_std) :: nb_basin !! Number of sub-basins (unitless)
4253	INTEGER(i_std) :: nwbas !!
4254	INTEGER(i_std), ALLOCATABLE, DIMENSION(:) :: basin_inbxid !!
4255	INTEGER(i_std), ALLOCATABLE, DIMENSION(:) :: basin_sz !!
4256	INTEGER(i_std), ALLOCATABLE, DIMENSION(:) :: basin_bxout !!
4257	INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:,:) :: basin_pts !!
4258	CHARACTER(LEN=7) :: fmt !!
4259	LOGICAL :: debug = .FALSE. !! (true/false)
4260	!
4261	INTEGER(i_std), DIMENSION(2) :: diagbox = (/ 1, 2 /) !!
4262
4263	!_ ================================================================================================================================
4264	!
4265	!
4266	IF ( .NOT. is_root_prc) THEN
4267	WRITE(numout,*) "is_root_prc = ", is_root_prc
4268	CALL ipslerr_p (3,'routing_basins', &
4269	& 'routing_basins is not suitable for running in parallel', &
4270	& 'We are here on a non root processor. ','(STOP from routing_basins)')
4271	ENDIF
4272	!
4273	! Test on diagbox and nbpt
4274	!
4275	IF (debug) THEN
4276	IF (ANY(diagbox .GT. nbpt)) THEN
4277	WRITE(numout,*) "Debug diganostics : nbpt, diagbox", nbpt, diagbox
4278	call ipslerr_p(3,'routing_basin', &
4279	& 'Problem with diagbox in debug mode.', &
4280	& 'diagbox values can''t be greater than land points number.', &
4281	& '(decrease diagbox wrong value)')
4282	ENDIF
4283	ENDIF
4284	!
4285	!
4286	! Needs to be a configurable variable
4287	!
4288	!
4289	!Config Key = ROUTING_FILE
4290	!Config Desc = Name of file which contains the routing information
4291	!Config If = RIVER_ROUTING
4292	!Config Def = routing.nc
4293	!Config Help = The file provided here should alow the routing module to
4294	!Config read the high resolution grid of basins and the flow direction
4295	!Config from one mesh to the other.
4296	!Config Units = [FILE]
4297	!
4298	filename = 'routing.nc'
4299	CALL getin('ROUTING_FILE',filename)
4300	!
4301	CALL flininfo(filename,iml, jml, lml, tml, fid)
4302	CALL flinclo(fid)
4303	!
4304	! soils_param.nc file is 1Â° soit texture file.
4305	!
4306	ALLOCATE(lat_rel(iml,jml), STAT=ALLOC_ERR)
4307	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for lat_rel','','')
4308
4309	ALLOCATE(lon_rel(iml,jml), STAT=ALLOC_ERR)
4310	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for lon_rel','','')
4311
4312	ALLOCATE (trip(iml,jml), STAT=ALLOC_ERR)
4313	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for trip','','')
4314
4315	ALLOCATE (basins(iml,jml), STAT=ALLOC_ERR)
4316	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for basins','','')
4317
4318	ALLOCATE (topoindex(iml,jml), STAT=ALLOC_ERR)
4319	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for topoindex','','')
4320
4321	ALLOCATE (hierarchy(iml,jml), STAT=ALLOC_ERR)
4322	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for hierarchy','','')
4323
4324	!
4325	CALL flinopen(filename, .FALSE., iml, jml, lml, lon_rel, lat_rel, lev, tml, itau, date, dt, fid)
4326	!!
4327	!! From the basin description data we will read the following variables :
4328	!!
4329	!! Trip : Provides the flow direction following the convention :
4330	!! trip = 1 : flow = N
4331	!! trip = 2 : flow = NE
4332	!! trip = 3 : flow = E
4333	!! trip = 4 : flow = SE
4334	!! trip = 5 : flow = S
4335	!! trip = 6 : flow = SW
4336	!! trip = 7 : flow = W
4337	!! trip = 8 : flow = NW
4338	!! trip = 97 : return flow into the ground
4339	!! trip = 98 : coastal flow (diffuse flow into the oceans)
4340	!! trip = 99 : river flow into the oceans
4341	!!
4342	!! Basins : Provides a uniqe ID for each basin. These IDs are also used to get
4343	!! the name of the basin from the table in routine routing_names.
4344	!!
4345	!! Topoind : is the topographic index for the retention time of the water in the
4346	!! grid box. It has been computed with the following formula : 1000 x sqrt(d^3/Dz)
4347	!! where d is the distance of the river from the current grid box to the next one
4348	!! as indicated by the variable trip.
4349	!! Dz the hight difference between between the two grid boxes.
4350	!! All these variables are in meters.
4351	!! Furthermore we have to limit the height difference to 5m in order to avoid any unpleasant
4352	!! surprises. If dz < 5m then dz=5.
4353	!!
4354	!
4355	CALL flinget(fid, 'trip', iml, jml, lml, tml, 1, 1, trip)
4356	!
4357	CALL flinget(fid, 'basins', iml, jml, lml, tml, 1, 1, basins)
4358	!
4359	CALL flinget(fid, 'topoind', iml, jml, lml, tml, 1, 1, topoindex)
4360	!
4361	CALL flinclo(fid)
4362	!
4363	min_topoind = MINVAL(topoindex, MASK=topoindex .LT. undef_sechiba-un)
4364	!
4365	DO ip=1,iml
4366	DO jp=1,jml
4367	IF ( trip(ip,jp) < 1.e10 .AND. topoindex(ip,jp) > 1.e10) THEN
4368	WRITE(numout,*) 'trip exists but not topoind :'
4369	WRITE(numout,*) 'ip, jp :', ip, jp
4370	WRITE(numout,*) 'trip, topoind : ', trip(ip,jp), topoindex(ip,jp)
4371	CALL ipslerr_p(3,'routing_basins','trip exists but not topoind','','')
4372	ENDIF
4373	ENDDO
4374	ENDDO
4375
4376	ALLOCATE(resol_lu(iml,jml,2), STAT=ALLOC_ERR)
4377	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for resol_lu','','')
4378
4379	ALLOCATE(mask(iml,jml), STAT=ALLOC_ERR)
4380	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for mask','','')
4381	!
4382	! Consider all points a priori
4383	!
4384	mask(:,:) = 0
4385	!
4386	DO ip=1,iml
4387	DO jp=1,jml
4388	!
4389	! Determine the land mask of the basin map read from the file ROUTING_FILE
4390	!
4391	IF ( trip(ip,jp) < 1.e10 ) THEN
4392	mask(ip,jp) = 1
4393	ENDIF
4394	!
4395	! Resolution in longitude
4396	!
4397	coslat = MAX( COS( lat_rel(ip,jp) * pi/180. ), mincos )
4398	IF ( ip .EQ. 1 ) THEN
4399	resol_lu(ip,jp,1) = ABS( lon_rel(ip+1,jp) - lon_rel(ip,jp) ) * pi/180. * R_Earth * coslat
4400	ELSEIF ( ip .EQ. iml ) THEN
4401	resol_lu(ip,jp,1) = ABS( lon_rel(ip,jp) - lon_rel(ip-1,jp) ) * pi/180. * R_Earth * coslat
4402	ELSE
4403	resol_lu(ip,jp,1) = ABS( lon_rel(ip+1,jp) - lon_rel(ip-1,jp) )/2. * pi/180. * R_Earth * coslat
4404	ENDIF
4405	!
4406	! Resolution in latitude
4407	!
4408	IF ( jp .EQ. 1 ) THEN
4409	resol_lu(ip,jp,2) = ABS( lat_rel(ip,jp) - lat_rel(ip,jp+1) ) * pi/180. * R_Earth
4410	ELSEIF ( jp .EQ. jml ) THEN
4411	resol_lu(ip,jp,2) = ABS( lat_rel(ip,jp-1) - lat_rel(ip,jp) ) * pi/180. * R_Earth
4412	ELSE
4413	resol_lu(ip,jp,2) = ABS( lat_rel(ip,jp-1) - lat_rel(ip,jp+1) )/2. * pi/180. * R_Earth
4414	ENDIF
4415	!
4416	ENDDO
4417	ENDDO
4418	!
4419	! The maximum number of points of the source map (basin description here) which can fit into
4420	! any grid point of the ORCHIDEE grid is stimated here.
4421	! Some margin is taken.
4422	!
4423	callsign = "routing_basins"
4424	ok_interpol = .FALSE.
4425	!
4426	nix=INT(MAXVAL(resolution_g(:,1))/MAXVAL(resol_lu(:,:,1)))+2
4427	njx=INT(MAXVAL(resolution_g(:,2))/MAXVAL(resol_lu(:,:,2)))+2
4428	nbvmax = nixnjx2
4429	!
4430	! We are on the root processor here as this routine is not in parallel. So no need to broadcast.
4431	!
4432	IF (printlev >=1) THEN
4433	WRITE(numout,*) "Projection arrays for ",callsign," : "
4434	WRITE(numout,*) "Routing : nbvmax = ", nbvmax
4435	END IF
4436
4437	ALLOCATE (sub_area(nbpt,nbvmax), STAT=ALLOC_ERR)
4438	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for sub_area','','')
4439	sub_area(:,:)=zero
4440
4441	ALLOCATE (sub_index(nbpt,nbvmax,2), STAT=ALLOC_ERR)
4442	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for sub_index','','')
4443	sub_index(:,:,:)=0
4444
4445	ALLOCATE (sub_pts(nbpt), STAT=ALLOC_ERR)
4446	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for sub_pts','','')
4447	sub_pts(:)=0
4448	!
4449	! routine aggregate will for each point of the ORCHIDEE grid determine which points
4450	! of the source grid (basin definitions here) fit in there and which fraction of
4451	! of the ORCHIDEE grid it represents.
4452	!
4453	CALL aggregate(nbpt, lalo, neighbours, resolution, contfrac, &
4454	& iml, jml, lon_rel, lat_rel, mask, callsign, &
4455	& nbvmax, sub_index, sub_area, ok_interpol)
4456	!
4457	WHERE (sub_area < 0) sub_area=zero
4458	!
4459	! Some verifications
4460	!
4461	DO ib=1,nbpt
4462	sub_pts(ib) = COUNT(sub_area(ib,:) > zero)
4463	DO fopt=1,sub_pts(ib)
4464	IF (sub_area(ib, fopt) == 0 ) THEN
4465	WRITE(numout,*) "Zero Area - Sub_area > 0 : ", ib, fopt
4466	WRITE(numout,*) "Zero Area - lon : ",lalo(ib,2)
4467	WRITE(numout,*) "Zero Area - lon_rel : ", lon_rel(sub_index(ib, fopt, 1),sub_index(ib, fopt, 2))
4468	WRITE(numout,*) "Zero Area - lat : ",lalo(ib,1)
4469	WRITE(numout,*) "Zero Area - lat_rel : ", lat_rel(sub_index(ib, fopt, 1),sub_index(ib, fopt, 2))
4470	ENDIF
4471	ENDDO
4472	ENDDO
4473	!
4474	! Do some memory management.
4475	!
4476	nwbas = MAX(MAXVAL(sub_pts), NbNeighb+1)
4477	!
4478	ALLOCATE (area_bx(nbvmax,nbvmax), stat=ALLOC_ERR)
4479	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for area_bx','','')
4480	ALLOCATE (hierarchy_bx(nbvmax,nbvmax), stat=ALLOC_ERR)
4481	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for hierarchy_bx','','')
4482	ALLOCATE (lon_bx(nbvmax,nbvmax), stat=ALLOC_ERR)
4483	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for lon_bx','','')
4484	ALLOCATE (lat_bx(nbvmax,nbvmax), stat=ALLOC_ERR)
4485	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for lat_bx','','')
4486	ALLOCATE (topoind_bx(nbvmax,nbvmax), stat=ALLOC_ERR)
4487	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for topoind_bx','','')
4488	ALLOCATE (trip_bx(nbvmax,nbvmax), stat=ALLOC_ERR)
4489	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for trip_bx','','')
4490	ALLOCATE (basin_bx(nbvmax,nbvmax), stat=ALLOC_ERR)
4491	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for basin_bx','','')
4492	ALLOCATE (coast_pts(nbvmax), stat=ALLOC_ERR)
4493	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for coast_pts','','')
4494	ALLOCATE (basin_inbxid(nbvmax), stat=ALLOC_ERR)
4495	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for basin_inbxid','','')
4496	ALLOCATE (basin_sz(nbvmax), stat=ALLOC_ERR)
4497	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for basin_sz','','')
4498	ALLOCATE (basin_pts(nbvmax,nbvmax,2), stat=ALLOC_ERR)
4499	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for basin_pts','','')
4500	ALLOCATE (basin_bxout(nbvmax), stat=ALLOC_ERR)
4501	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for basin_bxout','','')
4502	ALLOCATE (basin_count(nbpt), stat=ALLOC_ERR)
4503	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for basin_count','','')
4504	ALLOCATE (basin_area(nbpt,nwbas), basin_hierarchy(nbpt,nwbas), basin_topoind(nbpt,nwbas), stat=ALLOC_ERR)
4505	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for basin_area','','')
4506	ALLOCATE (fetch_basin(nbpt,nwbas), stat=ALLOC_ERR)
4507	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for fetch_basin','','')
4508	ALLOCATE (basin_id(nbpt,nwbas), basin_flowdir(nbpt,nwbas), stat=ALLOC_ERR)
4509	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for basin_id','','')
4510	ALLOCATE (outflow_grid(nbpt,nwbas),outflow_basin(nbpt,nwbas), stat=ALLOC_ERR)
4511	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for outflow_grid','','')
4512	ALLOCATE (inflow_number(nbpt,nwbas), stat=ALLOC_ERR)
4513	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for inflow_number','','')
4514	ALLOCATE (inflow_basin(nbpt,nwbas,nbvmax), inflow_grid(nbpt,nwbas,nbvmax), stat=ALLOC_ERR)
4515	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for inflow_basin','','')
4516	ALLOCATE (nbcoastal(nbpt), coastal_basin(nbpt,nwbas), stat=ALLOC_ERR)
4517	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for nbcoastal','','')
4518
4519	! Order all sub points in each grid_box and find the sub basins
4520	!
4521	! before we start we set the maps to empty
4522	!
4523	basin_id(:,:) = undef_int
4524	basin_count(:) = 0
4525	hierarchy(:,:) = undef_sechiba
4526	max_basins = MAXVAL(basins, MASK=basins .LT. 1.e10)
4527	invented_basins = max_basins
4528	nbcoastal(:) = 0
4529	!
4530	!! Finds,in each grid box, the distance to the outflow point ... this defines the order in which
4531	!! the water will go through the sub-basins and grid boxes.
4532	!
4533	CALL routing_hierarchy(iml, jml, trip, topoindex, hierarchy)
4534	!
4535	!
4536	DO ib =1, nbpt
4537	!
4538	!
4539	! extract the information for this grid box
4540	!
4541	!! Extracts from the global high resolution fields the data for the current grid box.
4542	!
4543	CALL routing_getgrid(nbpt, iml, jml, ib, sub_pts, sub_index, sub_area, max_basins, min_topoind, &
4544	& lon_rel, lat_rel, lalo, resolution, contfrac, trip, basins, topoindex, hierarchy, &
4545	& nbi, nbj, area_bx, trip_bx, basin_bx, topoind_bx, hierarchy_bx, lon_bx, lat_bx)
4546	!
4547	!! Finds the basins: returns the list of all points which are within the same basin of the grid box.
4548	!
4549	CALL routing_findbasins(nbi, nbj, trip_bx, basin_bx, hierarchy_bx, topoind_bx,&
4550	& nb_basin, basin_inbxid, basin_sz, basin_bxout, basin_pts, coast_pts)
4551
4552	#ifdef STRICT_CHECK
4553	IF (ANY(basin_inbxid(1:nb_basin) < 0)) THEN
4554	CALL ipslerr_p(3, 'routing_basins', 'basin_inbxid cannot have negative values.', 'Those will be later used as index in an array.', '')
4555	ENDIF
4556	#endif
4557
4558	!
4559	! Deal with the case where nb_basin=0 for this grid box. In this case all goes into coastal flow.
4560	!
4561	IF ( debug .AND. (COUNT(diagbox .EQ. ib) .GT. 0) ) THEN
4562	WRITE(numout,*) '===================== IB = :', ib
4563	WRITE(numout,*) "sub_pts(ib) :", sub_pts(ib), "sub_area(ib,:) :",sub_area(ib,1:2)
4564	WRITE(numout,*) 'LON LAT of GCM :', lalo(ib,2), lalo(ib,1)
4565	WRITE(numout,*) 'Neighbor options :', neighbours(ib,1:NbNeighb)
4566	WRITE(numout,*) 'Resolution :', resolution(ib,1:2)
4567	WRITE(fmt,"('(',I3,'I6)')") nbi
4568	WRITE(numout,*) '-------------> trip ', trip_bx(1,1)
4569	DO jp=1,nbj
4570	WRITE(numout,fmt) trip_bx(1:nbi,jp)
4571	ENDDO
4572	WRITE(numout,*) '-------------> basin ',basin_bx(1,1)
4573	DO jp=1,nbj
4574	WRITE(numout,fmt) basin_bx(1:nbi,jp)
4575	ENDDO
4576	WRITE(numout,*) '-------------> hierarchy ',hierarchy_bx(1,1)
4577	DO jp=1,nbj
4578	WRITE(numout,fmt) INT(hierarchy_bx(1:nbi,jp)/1000.)
4579	ENDDO
4580	WRITE(numout,*) '-------------> topoindex ',topoind_bx(1,1)
4581	DO jp=1,nbj
4582	WRITE(numout,fmt) INT(topoind_bx(1:nbi,jp)/1000.)
4583	ENDDO
4584	!
4585	WRITE(numout,*) '------------> The basins we retain'
4586	DO jp=1,nb_basin
4587	WRITE(numout,*) 'index, size, bxout, coast :', basin_inbxid(jp), basin_sz(jp),&
4588	& basin_bxout(jp), coast_pts(jp)
4589	ENDDO
4590	!
4591	ENDIF
4592	!
4593	!! Puts the basins found for the current grid box in the context of the global map.
4594	!
4595	CALL routing_globalize(nbpt, ib, neighbours, area_bx, trip_bx, hierarchy_bx, topoind_bx, min_topoind,&
4596	& nb_basin, basin_inbxid, basin_sz, basin_pts, basin_bxout, coast_pts, nwbas, basin_count,&
4597	& basin_area, basin_hierarchy, basin_topoind, basin_id, basin_flowdir, outflow_grid,&
4598	& nbcoastal, coastal_basin)
4599	!
4600	!
4601	IF ( debug .AND. (COUNT(diagbox .EQ. ib) .GT. 0) ) THEN
4602	WRITE(numout,*) 'GLOBAL information after routing_globalize for grid ', ib
4603	DO jp=1,basin_count(ib)
4604	WRITE(numout,*) 'Basin ID : ', basin_id(ib, jp)
4605	WRITE(numout,*) 'Basin flowdir :', basin_flowdir(ib, jp)
4606	WRITE(numout,*) 'Basin hierarchy :', basin_hierarchy(ib, jp)
4607	WRITE(numout,*) 'Basin topoindex :', basin_topoind(ib, jp)
4608	WRITE(numout,*) 'Basin outflow grid :', outflow_grid(ib,jp)
4609	ENDDO
4610	ENDIF
4611	!
4612	ENDDO
4613	!
4614	!! Makes the connections between the bains and ensures global coherence.
4615	!
4616	CALL routing_linkup(nbpt, contfrac, neighbours, nwbas, basin_count, basin_area, basin_id, basin_flowdir, &
4617	& basin_hierarchy, outflow_grid, outflow_basin, inflow_number, inflow_grid, inflow_basin, &
4618	& nbcoastal, coastal_basin, invented_basins)
4619	!
4620	!
4621	IF (printlev>=1) WRITE(numout,*) 'The maximum number of basins in any grid :', MAXVAL(basin_count)
4622	!
4623	IF ( debug ) THEN
4624	DO ib=1,SIZE(diagbox)
4625	IF ( diagbox(ib) .GT. 0 ) THEN
4626	WRITE(numout,*) 'After routing_linkup information for grid ', diagbox(ib)
4627	DO jp=1,basin_count(diagbox(ib))
4628	WRITE(numout,*) 'Basin ID : ', basin_id(diagbox(ib), jp)
4629	WRITE(numout,*) 'Basin outflow_grid :', outflow_grid(diagbox(ib), jp)
4630	WRITE(numout,*) 'Basin outflow_basin:', outflow_basin(diagbox(ib), jp)
4631	WRITE(numout,*) 'Basin hierarchy :', basin_hierarchy(diagbox(ib), jp)
4632	ENDDO
4633	ENDIF
4634	ENDDO
4635	ENDIF
4636	!
4637	!! Computes the fetch of each basin, upstream area in known.
4638	!
4639	CALL routing_fetch(nbpt, resolution, contfrac, nwbas, basin_count, basin_area, basin_id, outflow_grid, &
4640	& outflow_basin, fetch_basin)
4641	!
4642	!
4643	IF (printlev >=3) WRITE(numout,*) "Start reducing the number of basins per grid to meet the required truncation."
4644	!
4645	!! Reduces the number of basins per grid to the value chosen by the user.
4646	!
4647	CALL routing_truncate(nbpt, resolution, contfrac, nwbas, basin_count, basin_area, basin_topoind,&
4648	& fetch_basin, basin_id, basin_flowdir, outflow_grid, outflow_basin, inflow_number,&
4649	& inflow_grid, inflow_basin)
4650	!
4651	DEALLOCATE (lat_rel)
4652	DEALLOCATE (lon_rel)
4653	!
4654	DEALLOCATE (trip)
4655	DEALLOCATE (basins)
4656	DEALLOCATE (topoindex)
4657	DEALLOCATE (hierarchy)
4658	!
4659	DEALLOCATE (sub_area)
4660	DEALLOCATE (sub_index)
4661	DEALLOCATE (sub_pts)
4662	!
4663	DEALLOCATE (mask)
4664	DEALLOCATE (resol_lu)
4665	!
4666	DEALLOCATE (basin_count)
4667	DEALLOCATE (basin_area, basin_hierarchy, basin_topoind, fetch_basin)
4668	DEALLOCATE (basin_id, basin_flowdir)
4669	DEALLOCATE (outflow_grid,outflow_basin)
4670	DEALLOCATE (inflow_number)
4671	DEALLOCATE (inflow_basin, inflow_grid)
4672	DEALLOCATE (nbcoastal, coastal_basin)
4673
4674	END SUBROUTINE routing_basins
4675
4676
4677	!! ================================================================================================================================
4678	!! SUBROUTINE : routing_getgrid
4679	!!
4680	!>\BRIEF This subroutine extracts from the global high resolution fields
4681	!! the data for the current grid box we are dealing with.
4682	!!
4683	!! DESCRIPTION (definitions, functional, design, flags) :
4684	!! Convention for trip on the input :
4685	!! The trip field follows the following convention for the flow of the water :
4686	!! trip = 1 : flow = N
4687	!! trip = 2 : flow = NE
4688	!! trip = 3 : flow = E
4689	!! trip = 4 : flow = SE
4690	!! trip = 5 : flow = S
4691	!! trip = 6 : flow = SW
4692	!! trip = 7 : flow = W
4693	!! trip = 8 : flow = NW
4694	!! trip = 97 : return flow into the ground
4695	!! trip = 98 : coastal flow (diffuse flow into the oceans) These values are created here
4696	!! trip = 99 : river flow into the oceans
4697	!!
4698	!! On output, the grid boxes of the basin map which flow out of the GCM grid are identified
4699	!! by numbers larger than 100 :
4700	!! trip = 101 : flow = N out of the coarse grid
4701	!! trip = 102 : flow = NE out of the coarse grid
4702	!! trip = 103 : flow = E out of the coarse grid
4703	!! trip = 104 : flow = SE out of the coarse grid
4704	!! trip = 105 : flow = S out of the coarse grid
4705	!! trip = 106 : flow = SW out of the coarse grid
4706	!! trip = 107 : flow = W out of the coarse grid
4707	!! trip = 108 : flow = NW out of the coarse grid
4708	!! Inside the grid the convention remains the same as above (ie between 1 and 99).:\n
4709	!!
4710	!! RECENT CHANGE(S): None
4711	!!
4712	!! MAIN OUTPUT VARIABLE(S):
4713	!!
4714	!! REFERENCES : None
4715	!!
4716	!! FLOWCHART : None
4717	!! \n
4718	!_ ================================================================================================================================
4719
4720	SUBROUTINE routing_getgrid(nbpt, iml, jml, ib, sub_pts, sub_index, sub_area, max_basins, min_topoind, &
4721	& lon_rel, lat_rel, lalo, resolution, contfrac, trip, basins, topoindex, hierarchy, &
4722	& nbi, nbj, area_bx, trip_bx, basin_bx, topoind_bx, hierarchy_bx, lon_bx, lat_bx)
4723	!
4724	IMPLICIT NONE
4725	!
4726	!! INPUT VARIABLES
4727	INTEGER(i_std), INTENT(in) :: nbpt !! Domain size (unitless)
4728	INTEGER(i_std), INTENT(in) :: iml !! X resolution of the high resolution grid
4729	INTEGER(i_std), INTENT(in) :: jml !! Y resolution of the high resolution grid
4730	INTEGER(i_std), INTENT(in) :: ib !! Current basin (unitless)
4731	INTEGER(i_std), INTENT(in) :: sub_pts(nbpt) !! Number of high resolution points on this grid (unitless)
4732	INTEGER(i_std), INTENT(in) :: sub_index(nbpt,nbvmax,2) !! Indices of the points we need on the fine grid (unitless)
4733	REAL(r_std), INTENT(inout) :: max_basins !! The current maximum of basins
4734	REAL(r_std), INTENT(in) :: min_topoind !! The current minimum of topographic index (m)
4735	REAL(r_std), INTENT(in) :: sub_area(nbpt,nbvmax) !! Area on the fine grid (m^2)
4736	REAL(r_std), INTENT(in) :: lon_rel(iml,jml) !!
4737	REAL(r_std), INTENT(in) :: lat_rel(iml,jml) !! coordinates of the fine grid
4738	REAL(r_std), INTENT(in) :: lalo(nbpt,2) !! Vector of latitude and longitudes (beware of the order !)
4739	REAL(r_std), INTENT(in) :: resolution(nbpt,2) !! The size of each grid box in X and Y (m)
4740	REAL(r_std), INTENT(in) :: contfrac(nbpt) !! Fraction of land in each grid box (unitless;0-1)
4741	REAL(r_std), INTENT(inout) :: trip(iml,jml) !! The trip field (unitless)
4742	REAL(r_std), INTENT(inout) :: basins(iml,jml) !! data on the fine grid
4743	REAL(r_std), INTENT(inout) :: topoindex(iml,jml) !! Topographic index of the residence time (m)
4744	REAL(r_std), INTENT(inout) :: hierarchy(iml, jml) !! data on the fine grid
4745	!
4746	!! OUTPUT VARIABLES
4747	INTEGER(i_std), INTENT(out) :: nbi, nbj !! Number of point in x and y within the grid (unitless)
4748	REAL(r_std), INTENT(out) :: area_bx(nbvmax,nbvmax) !! Area of each small box in the grid box (m^2)
4749	REAL(r_std), INTENT(out) :: hierarchy_bx(nbvmax,nbvmax) !! Level in the basin of the point
4750	REAL(r_std), INTENT(out) :: lon_bx(nbvmax,nbvmax) !!
4751	REAL(r_std), INTENT(out) :: lat_bx(nbvmax,nbvmax) !!
4752	REAL(r_std), INTENT(out) :: topoind_bx(nbvmax,nbvmax) !! Topographic index of the residence time for each of the smaller boxes (m)
4753	INTEGER(i_std), INTENT(out) :: trip_bx(nbvmax,nbvmax) !! The trip field for each of the smaller boxes (unitless)
4754	INTEGER(i_std), INTENT(out) :: basin_bx(nbvmax,nbvmax) !!
4755	!
4756	!! LOCAL VARIABLES
4757	INTEGER(i_std) :: ip, jp, ll(1), iloc, jloc !! Indices (unitless)
4758	REAL(r_std) :: lonstr(nbvmax*nbvmax) !!
4759	REAL(r_std) :: latstr(nbvmax*nbvmax) !!
4760
4761	!_ ================================================================================================================================
4762
4763	!
4764	! Set everything to undef to locate easily empty points
4765	!
4766	trip_bx(:,:) = undef_int
4767	basin_bx(:,:) = undef_int
4768	topoind_bx(:,:) = undef_sechiba
4769	area_bx(:,:) = undef_sechiba
4770	hierarchy_bx(:,:) = undef_sechiba
4771	!
4772	IF ( sub_pts(ib) > 0 ) THEN
4773	!
4774	DO ip=1,sub_pts(ib)
4775	lonstr(ip) = lon_rel(sub_index(ib, ip, 1), sub_index(ib, ip, 2))
4776	latstr(ip) = lat_rel(sub_index(ib, ip, 1), sub_index(ib, ip, 2))
4777	ENDDO
4778	!
4779	! Get the size of the area and order the coordinates to go from North to South and West to East
4780	!
4781	CALL routing_sortcoord(sub_pts(ib), lonstr, 'WE', nbi)
4782	CALL routing_sortcoord(sub_pts(ib), latstr, 'NS', nbj)
4783	!
4784	! Transfer the data in such a way that (1,1) is the North Western corner and
4785	! (nbi, nbj) the South Eastern.
4786	!
4787	DO ip=1,sub_pts(ib)
4788	ll = MINLOC(ABS(lonstr(1:nbi) - lon_rel(sub_index(ib, ip, 1), sub_index(ib, ip, 2))))
4789	iloc = ll(1)
4790	ll = MINLOC(ABS(latstr(1:nbj) - lat_rel(sub_index(ib, ip, 1), sub_index(ib, ip, 2))))
4791	jloc = ll(1)
4792	trip_bx(iloc, jloc) = NINT(trip(sub_index(ib, ip, 1), sub_index(ib, ip, 2)))
4793	basin_bx(iloc, jloc) = NINT(basins(sub_index(ib, ip, 1), sub_index(ib, ip, 2)))
4794	area_bx(iloc, jloc) = sub_area(ib, ip)
4795	topoind_bx(iloc, jloc) = topoindex(sub_index(ib, ip, 1), sub_index(ib, ip, 2))
4796	hierarchy_bx(iloc, jloc) = hierarchy(sub_index(ib, ip, 1), sub_index(ib, ip, 2))
4797	lon_bx(iloc, jloc) = lon_rel(sub_index(ib, ip, 1), sub_index(ib, ip, 2))
4798	lat_bx(iloc, jloc) = lat_rel(sub_index(ib, ip, 1), sub_index(ib, ip, 2))
4799	ENDDO
4800	ELSE
4801	!
4802	! This is the case where the model invented a continental point
4803	!
4804	nbi = 1
4805	nbj = 1
4806	iloc = 1
4807	jloc = 1
4808	trip_bx(iloc, jloc) = 98
4809	basin_bx(iloc, jloc) = NINT(max_basins + 1)
4810	max_basins = max_basins + 1
4811	area_bx(iloc, jloc) = resolution(ib,1)resolution(ib,2)contfrac(ib)
4812	topoind_bx(iloc, jloc) = min_topoind
4813	hierarchy_bx(iloc, jloc) = min_topoind
4814	lon_bx(iloc, jloc) = lalo(ib,2)
4815	lat_bx(iloc, jloc) = lalo(ib,1)
4816	!
4817	ENDIF
4818	!
4819	! Tag in trip all the outflow conditions. The table is thus :
4820	! trip = 100+n : Outflow into another grid box
4821	! trip = 99 : River outflow into the ocean
4822	! trip = 98 : This will be coastal flow (not organized as a basin)
4823	! trip = 97 : return flow into the soil (local)
4824	!
4825	DO jp=1,nbj
4826	IF ( trip_bx(1,jp) .EQ. 8 .OR. trip_bx(1,jp) .EQ. 7 .OR. trip_bx(1,jp) .EQ. 6) THEN
4827	trip_bx(1,jp) = trip_bx(1,jp) + 100
4828	ENDIF
4829	IF ( trip_bx(nbi,jp) .EQ. 2 .OR. trip_bx(nbi,jp) .EQ. 3 .OR. trip_bx(nbi,jp) .EQ. 4) THEN
4830	trip_bx(nbi,jp) = trip_bx(nbi,jp) + 100
4831	ENDIF
4832	ENDDO
4833	DO ip=1,nbi
4834	IF ( trip_bx(ip,1) .EQ. 8 .OR. trip_bx(ip,1) .EQ. 1 .OR. trip_bx(ip,1) .EQ. 2) THEN
4835	trip_bx(ip,1) = trip_bx(ip,1) + 100
4836	ENDIF
4837	IF ( trip_bx(ip,nbj) .EQ. 6 .OR. trip_bx(ip,nbj) .EQ. 5 .OR. trip_bx(ip,nbj) .EQ. 4) THEN
4838	trip_bx(ip,nbj) = trip_bx(ip,nbj) + 100
4839	ENDIF
4840	ENDDO
4841	!
4842	!
4843	! We simplify the outflow. We only need the direction normal to the
4844	! box boundary and the 4 corners.
4845	!
4846	! Northern border
4847	IF ( trip_bx(1,1) .EQ. 102 ) trip_bx(1,1) = 101
4848	IF ( trip_bx(nbi,1) .EQ. 108 ) trip_bx(nbi,1) = 101
4849	DO ip=2,nbi-1
4850	IF ( trip_bx(ip,1) .EQ. 108 .OR. trip_bx(ip,1) .EQ. 102 ) trip_bx(ip,1) = 101
4851	ENDDO
4852	! Southern border
4853	IF ( trip_bx(1,nbj) .EQ. 104 ) trip_bx(1,nbj) = 105
4854	IF ( trip_bx(nbi,nbj) .EQ. 106 ) trip_bx(nbi,nbj) = 105
4855	DO ip=2,nbi-1
4856	IF ( trip_bx(ip,nbj) .EQ. 104 .OR. trip_bx(ip,nbj) .EQ. 106 ) trip_bx(ip,nbj) = 105
4857	ENDDO
4858	! Eastern border
4859	IF ( trip_bx(nbi,1) .EQ. 104) trip_bx(nbi,1) = 103
4860	IF ( trip_bx(nbi,nbj) .EQ. 102) trip_bx(nbi,nbj) = 103
4861	DO jp=2,nbj-1
4862	IF ( trip_bx(nbi,jp) .EQ. 104 .OR. trip_bx(nbi,jp) .EQ. 102 ) trip_bx(nbi,jp) = 103
4863	ENDDO
4864	! Western border
4865	IF ( trip_bx(1,1) .EQ. 106) trip_bx(1,1) = 107
4866	IF ( trip_bx(1,nbj) .EQ. 108) trip_bx(1,nbj) = 107
4867	DO jp=2,nbj-1
4868	IF ( trip_bx(1,jp) .EQ. 106 .OR. trip_bx(1,jp) .EQ. 108 ) trip_bx(1,jp) = 107
4869	ENDDO
4870	!
4871	!
4872	END SUBROUTINE routing_getgrid
4873	!
4874	!! ================================================================================================================================
4875	!! SUBROUTINE : routing_sortcoord
4876	!!
4877	!>\BRIEF This subroutines orders the coordinates to go from North to South and West to East.
4878	!!
4879	!! DESCRIPTION (definitions, functional, design, flags) : None
4880	!!
4881	!! RECENT CHANGE(S): None
4882	!!
4883	!! MAIN OUTPUT VARIABLE(S):
4884	!!
4885	!! REFERENCES : None
4886	!!
4887	!! FLOWCHART : None
4888	!! \n
4889	!_ ================================================================================================================================
4890
4891	SUBROUTINE routing_sortcoord(nb_in, coords, direction, nb_out)
4892	!
4893	IMPLICIT NONE
4894	!
4895	!! INPUT VARIABLES
4896	INTEGER(i_std), INTENT(in) :: nb_in !!
4897	REAL(r_std), INTENT(inout) :: coords(nb_in) !!
4898	!
4899	!! OUTPUT VARIABLES
4900	INTEGER(i_std), INTENT(out) :: nb_out !!
4901	!
4902	!! LOCAL VARIABLES
4903	CHARACTER(LEN=2) :: direction !!
4904	INTEGER(i_std) :: ipos !!
4905	REAL(r_std) :: coords_tmp(nb_in) !!
4906	INTEGER(i_std), DIMENSION(1) :: ll !!
4907	INTEGER(i_std) :: ind(nb_in) !!
4908
4909	!_ ================================================================================================================================
4910	!
4911	ipos = 1
4912	nb_out = nb_in
4913	!
4914	! Compress the coordinates array
4915	!
4916	DO WHILE ( ipos < nb_in )
4917	IF ( coords(ipos+1) /= undef_sechiba) THEN
4918	IF ( COUNT(coords(ipos:nb_out) == coords(ipos)) > 1 ) THEN
4919	coords(ipos:nb_out-1) = coords(ipos+1:nb_out)
4920	coords(nb_out:nb_in) = undef_sechiba
4921	nb_out = nb_out - 1
4922	ELSE
4923	ipos = ipos + 1
4924	ENDIF
4925	ELSE
4926	EXIT
4927	ENDIF
4928	ENDDO
4929	!
4930	! Sort it now
4931	!
4932	! First we get ready and adjust for the periodicity in longitude
4933	!
4934	coords_tmp(:) = undef_sechiba
4935	IF ( INDEX(direction, 'WE') == 1 .OR. INDEX(direction, 'EW') == 1) THEN
4936	IF ( MAXVAL(ABS(coords(1:nb_out))) .GT. 160 ) THEN
4937	coords_tmp(1:nb_out) = MOD(coords(1:nb_out) + 360.0, 360.0)
4938	ELSE
4939	coords_tmp(1:nb_out) = coords(1:nb_out)
4940	ENDIF
4941	ELSE IF ( INDEX(direction, 'NS') == 1 .OR. INDEX(direction, 'SN') == 1) THEN
4942	coords_tmp(1:nb_out) = coords(1:nb_out)
4943	ELSE
4944	WRITE(numout,*) 'The chosen direction (', direction,') is not recognized'
4945	CALL ipslerr_p(3,'routing_sortcoord','The chosen direction is not recognized','First section','')
4946	ENDIF
4947	!
4948	! Get it sorted out now
4949	!
4950	ipos = 1
4951	!
4952	IF ( INDEX(direction, 'WE') == 1 .OR. INDEX(direction, 'SN') == 1) THEN
4953	DO WHILE (COUNT(ABS(coords_tmp(:)-undef_sechiba) > EPSILON(undef_sechiba)*10.) >= 1)
4954	ll = MINLOC(coords_tmp(:), coords_tmp /= undef_sechiba)
4955	ind(ipos) = ll(1)
4956	coords_tmp(ll(1)) = undef_sechiba
4957	ipos = ipos + 1
4958	ENDDO
4959	ELSE IF ( INDEX(direction, 'EW') == 1 .OR. INDEX(direction, 'NS') == 1) THEN
4960	DO WHILE (COUNT(ABS(coords_tmp(:)-undef_sechiba) > EPSILON(undef_sechiba)*10.) >= 1)
4961	ll = MAXLOC(coords_tmp(:), coords_tmp /= undef_sechiba)
4962	ind(ipos) = ll(1)
4963	coords_tmp(ll(1)) = undef_sechiba
4964	ipos = ipos + 1
4965	ENDDO
4966	ELSE
4967	WRITE(numout,*) 'The chosen direction (', direction,') is not recognized (second)'
4968	CALL ipslerr_p(3,'routing_sortcoord','The chosen direction is not recognized','Second section','')
4969	ENDIF
4970	!
4971	coords(1:nb_out) = coords(ind(1:nb_out))
4972	IF (nb_out < nb_in) THEN
4973	coords(nb_out+1:nb_in) = zero
4974	ENDIF
4975	!
4976	END SUBROUTINE routing_sortcoord
4977	!
4978
4979	!! ================================================================================================================================
4980	!! SUBROUTINE : routing_findbasins
4981	!!
4982	!>\BRIEF This subroutine finds the basins and does some clean up.
4983	!! The aim is to return the list off all points which are within the
4984	!! same basin of the grid box.
4985	!!
4986	!! DESCRIPTION (definitions, functional, design, flags) :
4987	!! We will also collect all points which directly flow into the ocean in one basin
4988	!! Make sure that we do not have a basin with two outflows and other exceptions.
4989	!! At this stage no effort is made to come down to the truncation of the model.
4990	!!
4991	!! Convention for trip \n
4992	!! ------------------- \n
4993	!! Inside of the box : \n
4994	!! trip = 1 : flow = N \n
4995	!! trip = 2 : flow = NE \n
4996	!! trip = 3 : flow = E \n
4997	!! trip = 4 : flow = SE \n
4998	!! trip = 5 : flow = S \n
4999	!! trip = 6 : flow = SW \n
5000	!! trip = 7 : flow = W \n
5001	!! trip = 8 : flow = NW \n
5002	!! trip = 97 : return flow into the ground \n
5003	!! trip = 98 : coastal flow (diffuse flow into the oceans) These values are created here \n
5004	!! trip = 99 : river flow into the oceans \n
5005	!!
5006	!! Out flow from the grid : \n
5007	!! trip = 101 : flow = N out of the coarse grid \n
5008	!! trip = 102 : flow = NE out of the coarse grid \n
5009	!! trip = 103 : flow = E out of the coarse grid \n
5010	!! trip = 104 : flow = SE out of the coarse grid \n
5011	!! trip = 105 : flow = S out of the coarse grid \n
5012	!! trip = 106 : flow = SW out of the coarse grid \n
5013	!! trip = 107 : flow = W out of the coarse grid \n
5014	!! trip = 108 : flow = NW out of the coarse grid! \n
5015	!! RECENT CHANGE(S): None
5016	!!
5017	!! MAIN OUTPUT VARIABLE(S):
5018	!!
5019	!! REFERENCES : None
5020	!!
5021	!! FLOWCHART : None
5022	!! \n
5023	!_ ================================================================================================================================
5024
5025	SUBROUTINE routing_findbasins(nbi, nbj, trip, basin, hierarchy, topoind, nb_basin, basin_inbxid, basin_sz,&
5026	& basin_bxout, basin_pts, coast_pts)
5027	!
5028	IMPLICIT NONE
5029	!
5030	!! INPUT VARIABLES
5031	INTEGER(i_std), INTENT(in) :: nbi !! Number of point in x within the grid (unitless)
5032	INTEGER(i_std), INTENT(in) :: nbj !! Number of point in y within the grid (unitless)
5033	REAL(r_std), INTENT(in) :: hierarchy(:,:) !!
5034	REAL(r_std), INTENT(in) :: topoind(:,:) !! Topographic index of the residence time (m)
5035	!
5036	! Modified
5037	INTEGER(i_std), INTENT(inout) :: trip(:,:) !! The trip field (unitless)
5038	INTEGER(i_std), INTENT(inout) :: basin(:,:) !!
5039	!
5040	!! OUTPUT VARIABLES
5041	INTEGER(i_std), INTENT(out) :: nb_basin !! Number of sub-basins (unitless)
5042	INTEGER(i_std), INTENT(out) :: basin_inbxid(nbvmax) !!
5043	INTEGER(i_std), INTENT(out) :: basin_sz(nbvmax) !!
5044	INTEGER(i_std), INTENT(out) :: basin_bxout(nbvmax) !!
5045	INTEGER(i_std), INTENT(out) :: basin_pts(nbvmax, nbvmax, 2) !!
5046	INTEGER(i_std), INTENT(out) :: coast_pts(nbvmax) !! The coastal flow points (unitless)
5047	!
5048	!! LOCAL VARIABLES
5049	INTEGER(i_std) :: ibas, ilf, nbb, nb_in !!
5050	INTEGER(i_std) :: bname(nbvmax) !!
5051	INTEGER(i_std) :: sz(nbvmax) !!
5052	INTEGER(i_std) :: pts(nbvmax,nbvmax,2) !!
5053	INTEGER(i_std) :: nbout(nbvmax) !!
5054	INTEGER(i_std) :: new_nb !!
5055	INTEGER(i_std) :: new_bname(nbvmax) !!
5056	INTEGER(i_std) :: new_sz(nbvmax) !!
5057	INTEGER(i_std) :: new_pts(nbvmax,nbvmax,2) !!
5058	INTEGER(i_std) :: itrans !!
5059	INTEGER(i_std) :: trans(nbvmax) !!
5060	INTEGER(i_std) :: outdir(nbvmax) !!
5061	INTEGER(i_std) :: tmpsz(nbvmax) !!
5062	INTEGER(i_std) :: ip, jp, jpp(1), ipb !!
5063	INTEGER(i_std) :: sortind(nbvmax) !!
5064	CHARACTER(LEN=7) :: fmt !!
5065
5066	!_ ================================================================================================================================
5067	!
5068	nbb = 0
5069	ibas = -1
5070	bname(:) = undef_int
5071	sz(:) = 0
5072	nbout(:) = 0
5073	new_pts(:,:,:) = 0
5074	!
5075	! 1.0 Find all basins within this grid box
5076	! Sort the variables per basin so that we can more easily
5077	! access data from the same basin (The variables are :
5078	! bname, sz, pts, nbout)
5079	!
5080	DO ip=1,nbi
5081	DO jp=1,nbj
5082	IF ( basin(ip,jp) .LT. undef_int) THEN
5083	IF ( COUNT(basin(ip,jp) .EQ. bname(:)) .EQ. 0 ) THEN
5084	nbb = nbb + 1
5085	IF ( nbb .GT. nbvmax ) CALL ipslerr_p(3,'routing_findbasins','nbvmax too small','first section','')
5086	bname(nbb) = basin(ip,jp)
5087	sz(nbb) = 0
5088	ENDIF
5089	!
5090	DO ilf=1,nbb
5091	IF ( basin(ip,jp) .EQ. bname(ilf) ) THEN
5092	ibas = ilf
5093	ENDIF
5094	ENDDO
5095	!
5096	sz(ibas) = sz(ibas) + 1
5097	IF ( sz(ibas) .GT. nbvmax ) CALL ipslerr_p(3,'routing_findbasins','nbvmax too small','second section','')
5098	pts(ibas, sz(ibas), 1) = ip
5099	pts(ibas, sz(ibas), 2) = jp
5100	! We deal only with outflow and leave flow back into the grid box for later.
5101	IF ( trip(ip,jp) .GE. 97 ) THEN
5102	nbout(ibas) = nbout(ibas) + 1
5103	ENDIF
5104	!
5105	ENDIF
5106	!
5107	ENDDO
5108	ENDDO
5109	!
5110	! 2.0 All basins which have size 1 and flow to the ocean are put together.
5111	!
5112	itrans = 0
5113	coast_pts(:) = undef_int
5114	! Get all the points we can collect
5115	DO ip=1,nbb
5116	IF ( sz(ip) .EQ. 1 .AND. trip(pts(ip,1,1),pts(ip,1,2)) .EQ. 99) THEN
5117	itrans = itrans + 1
5118	trans(itrans) = ip
5119	trip(pts(ip,1,1),pts(ip,1,2)) = 98
5120	ENDIF
5121	ENDDO
5122	! put everything in the first basin
5123	IF ( itrans .GT. 1) THEN
5124	ipb = trans(1)
5125	coast_pts(sz(ipb)) = bname(ipb)
5126	bname(ipb) = -1
5127	DO ip=2,itrans
5128	sz(ipb) = sz(ipb) + 1
5129	coast_pts(sz(ipb)) = bname(trans(ip))
5130	sz(trans(ip)) = 0
5131	pts(ipb, sz(ipb), 1) = pts(trans(ip), 1, 1)
5132	pts(ipb, sz(ipb), 2) = pts(trans(ip), 1, 2)
5133	ENDDO
5134	ENDIF
5135	!
5136	! 3.0 Make sure that we have only one outflow point in each basin
5137	!
5138	! nbb is the number of basins on this grid box.
5139	new_nb = 0
5140	DO ip=1,nbb
5141	! We only do this for grid-points which have more than one outflow
5142	IF ( sz(ip) .GT. 1 .AND. nbout(ip) .GT. 1) THEN
5143	!
5144	! Pick up all points needed and store them in trans
5145	!
5146	itrans = 0
5147	DO jp=1,sz(ip)
5148	IF ( trip(pts(ip,jp,1),pts(ip,jp,2)) .GE. 97) THEN
5149	itrans = itrans + 1
5150	trans(itrans) = trip(pts(ip,jp,1),pts(ip,jp,2))
5151	ENDIF
5152	ENDDO
5153	!
5154	! First issue : We have more than one point of the basin which flows into
5155	! the ocean. In this case we put everything into coastal flow. It will go into
5156	! a separate basin in the routing_globalize routine.
5157	!
5158	IF ( (COUNT(trans(1:itrans) .EQ. 99) + COUNT(trans(1:itrans) .EQ. 98)) .GT. 1) THEN
5159	DO jp=1,sz(ip)
5160	IF ( trip(pts(ip,jp,1),pts(ip,jp,2)) .EQ. 99 ) THEN
5161	trip(pts(ip,jp,1),pts(ip,jp,2)) = 98
5162	trans(itrans) = trip(pts(ip,jp,1),pts(ip,jp,2))
5163	ENDIF
5164	ENDDO
5165	ENDIF
5166	!
5167	! Second issue : We have redundant outflows at the boundaries. That is two small grid
5168	! boxes flowing into the same GCM grid box.
5169	!
5170	IF ( COUNT(trans(1:itrans) .GT. 100) .GE. 1) THEN
5171	CALL routing_simplify(nbi, nbj, trip, basin, hierarchy, bname(ip))
5172	itrans = 0
5173	DO jp=1,sz(ip)
5174	IF ( trip(pts(ip,jp,1),pts(ip,jp,2)) .GE. 9) THEN
5175	itrans = itrans + 1
5176	trans(itrans) = trip(pts(ip,jp,1),pts(ip,jp,2))
5177	ENDIF
5178	ENDDO
5179	ENDIF
5180	!
5181	! Third issue : we have more than one outflow from the boxes. This could be
5182	! - flow into 2 or more neighboring GCM grids
5183	! - flow into a neighboring GCM grids and into the ocean or be a return flow (=97. =98, =99)
5184	! - flow into a neighboring GCM grids or ocean and back into the same GCM grid box
5185	! The only solution is to cut the basin up in as many parts.
5186	!
5187	IF ( COUNT(trans(1:itrans) .GE. 97) .GT. 1) THEN
5188	!
5189	nb_in = new_nb
5190	CALL routing_cutbasin(nbi, nbj, nbb, trip, basin, bname(ip), new_nb, new_bname, new_sz, new_pts)
5191	!
5192	! If we have split the basin then we need to cancel the old one
5193	!
5194	IF ( nb_in .NE. new_nb) THEN
5195	sz(ip) = 0
5196	ENDIF
5197	!
5198	ENDIF
5199	!
5200	ENDIF
5201	ENDDO
5202	!
5203	! Add the new basins to the end of the list
5204	!
5205	If ( nbb+new_nb .LE. nbvmax) THEN
5206	DO ip=1,new_nb
5207	bname(nbb+ip) = new_bname(ip)
5208	sz(nbb+ip) = new_sz(ip)
5209	pts(nbb+ip,:,:) = new_pts(ip,:,:)
5210	ENDDO
5211	nbb = nbb+new_nb
5212	ELSE
5213	WRITE(numout,*) 'Increase nbvmax. It is too small to contain all the basins (routing_findbasins)'
5214	CALL ipslerr_p(3,'routing_findbasins','Increase nbvmax.','It is too small to contain all the basins','')
5215	ENDIF
5216	!
5217	! Keep the output direction
5218	!
5219	DO ip=1,nbb
5220	IF ( sz(ip) .GT. 0 ) THEN
5221	trans(:) = 0
5222	DO jp=1,sz(ip)
5223	trans(jp) = trip(pts(ip,jp,1),pts(ip,jp,2))
5224	ENDDO
5225	outdir(ip) = MAXVAL(trans(1:sz(ip)))
5226	IF ( outdir(ip) .GE. 97 ) THEN
5227	outdir(ip) = outdir(ip) - 100
5228	ELSE
5229	WRITE(numout,*) 'Why are we here and can not find a trip larger than 96'
5230	WRITE(numout,*) 'Does this mean that the basin does not have any outflow ', ip, bname(ip)
5231	WRITE(fmt,"('(',I3,'I9)')") nbi
5232	WRITE(numout,*) '-----------------------> trip'
5233	DO jp=1,nbj
5234	WRITE(numout,fmt) trip(1:nbi,jp)
5235	ENDDO
5236	WRITE(numout,*) '-----------------------> basin'
5237	DO jp=1,nbj
5238	WRITE(numout,fmt) basin(1:nbi,jp)
5239	ENDDO
5240	CALL ipslerr_p(3,'routing_findbasins','Probleme finding trip','','')
5241	ENDIF
5242	ENDIF
5243	ENDDO
5244	!
5245	!
5246	! Sort the output by size of the various basins.
5247	!
5248	nb_basin = COUNT(sz(1:nbb) .GT. 0)
5249	tmpsz(:) = -1
5250	tmpsz(1:nbb) = sz(1:nbb)
5251	DO ip=1,nbb
5252	jpp = MAXLOC(tmpsz(:))
5253	IF ( sz(jpp(1)) .GT. 0) THEN
5254	sortind(ip) = jpp(1)
5255	tmpsz(jpp(1)) = -1
5256	ENDIF
5257	ENDDO
5258	basin_inbxid(1:nb_basin) = bname(sortind(1:nb_basin))
5259	basin_sz(1:nb_basin) = sz(sortind(1:nb_basin))
5260	basin_pts(1:nb_basin,:,:) = pts(sortind(1:nb_basin),:,:)
5261	basin_bxout(1:nb_basin) = outdir(sortind(1:nb_basin))
5262	!
5263	! We can only check if we have at least as many outflows as basins
5264	!
5265	ip = COUNT(trip(1:nbi,1:nbj) .GE. 97 .AND. trip(1:nbi,1:nbj) .LT. undef_int)
5266	!! ip = ip + COUNT(trip(1:nbi,1:nbj) .EQ. 97)
5267	!! IF ( COUNT(trip(1:nbi,1:nbj) .EQ. 98) .GT. 0) ip = ip + 1
5268	IF ( ip .LT. nb_basin ) THEN
5269	WRITE(numout,*) 'We have less outflow points than basins :', ip
5270	WRITE(fmt,"('(',I3,'I9)')") nbi
5271	WRITE(numout,*) '-----------------------> trip'
5272	DO jp=1,nbj
5273	WRITE(numout,fmt) trip(1:nbi,jp)
5274	ENDDO
5275	WRITE(numout,*) '-----------------------> basin'
5276	DO jp=1,nbj
5277	WRITE(numout,fmt) basin(1:nbi,jp)
5278	ENDDO
5279	WRITE(numout,*) 'nb_basin :', nb_basin
5280	WRITE(numout,*) 'Basin sized :', basin_sz(1:nb_basin)
5281	CALL ipslerr_p(3,'routing_findbasins','Probleme less outflow points than basins','','')
5282	ENDIF
5283
5284	END SUBROUTINE routing_findbasins
5285	!
5286	!! ================================================================================================================================
5287	!! SUBROUTINE : routing_simplify
5288	!!
5289	!>\BRIEF This subroutine symplifies the routing out of each basin by taking
5290	!! out redundancies at the borders of the GCM box.
5291	!! The aim is to have only one outflow point per basin and grid box.
5292	!! But here we will not change the direction of the outflow.
5293	!!
5294	!! DESCRIPTION (definitions, functional, design, flags) : None
5295	!!
5296	!! RECENT CHANGE(S): None
5297	!!
5298	!! MAIN OUTPUT VARIABLE(S):
5299	!!
5300	!! REFERENCES : None
5301	!!
5302	!! FLOWCHART : None
5303	!! \n
5304	!_ ================================================================================================================================
5305
5306	SUBROUTINE routing_simplify(nbi, nbj, trip, basin, hierarchy, basin_inbxid)
5307	!
5308	IMPLICIT NONE
5309	!
5310	!! LOCAL VARIABLES
5311	INTEGER(i_std) :: nbi !! Number of point in x within the grid (unitless)
5312	INTEGER(i_std) :: nbj !! Number of point in y within the grid (unitless)
5313	INTEGER(i_std) :: trip(:,:) !! The trip field (unitless)
5314	INTEGER(i_std) :: basin(:,:) !!
5315	REAL(r_std) :: hierarchy(:,:) !!
5316	INTEGER(i_std) :: basin_inbxid !!
5317	!
5318	INTEGER(i_std) :: ip, jp, nbout, basin_sz, iborder !!
5319	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)
5320	INTEGER(i_std), DIMENSION(nbvmax,nbvmax,2) :: trip_flow !!
5321	INTEGER(i_std), DIMENSION(nbvmax,2) :: outflow !!
5322	INTEGER(i_std), DIMENSION(nbvmax) :: outsz !!
5323	CHARACTER(LEN=7) :: fmt !!
5324	!
5325	INTEGER(i_std), DIMENSION(8,2) :: inc !!
5326	INTEGER(i_std) :: itodo, ill(1), icc, ismall, ibas, iip, jjp, ib, id !! Indices (unitless)
5327	INTEGER(i_std), DIMENSION(nbvmax) :: todopt !!
5328	!!$, todosz
5329	REAL(r_std), DIMENSION(nbvmax) :: todohi !!
5330	LOGICAL :: not_found, debug = .FALSE. !! (true/false)
5331
5332	!_ ================================================================================================================================
5333	!
5334	!
5335	! The routing code (i=1, j=2)
5336	!
5337	inc(1,1) = 0
5338	inc(1,2) = -1
5339	inc(2,1) = 1
5340	inc(2,2) = -1
5341	inc(3,1) = 1
5342	inc(3,2) = 0
5343	inc(4,1) = 1
5344	inc(4,2) = 1
5345	inc(5,1) = 0
5346	inc(5,2) = 1
5347	inc(6,1) = -1
5348	inc(6,2) = 1
5349	inc(7,1) = -1
5350	inc(7,2) = 0
5351	inc(8,1) = -1
5352	inc(8,2) = -1
5353	!
5354	!
5355	! Symplify the outflow conditions first. We are only interested in the
5356	! outflows which go to different GCM grid boxes.
5357	!
5358	IF ( debug ) THEN
5359	WRITE(numout,*) '+++++++++++++++++++ BEFORE ANYTHING ++++++++++++++++++++'
5360	WRITE(fmt,"('(',I3,'I6)')") nbi
5361	DO jp=1,nbj
5362	WRITE(numout,fmt) trip_tmp(1:nbi,jp)
5363	ENDDO
5364	ENDIF
5365	!
5366	! transfer the trips into an array which only contains the basin we are interested in
5367	!
5368	trip_tmp(:,:) = -1
5369	basin_sz = 0
5370	DO ip=1,nbi
5371	DO jp=1,nbj
5372	IF ( basin(ip,jp) .EQ. basin_inbxid) THEN
5373	trip_tmp(ip,jp) = trip(ip,jp)
5374	basin_sz = basin_sz + 1
5375	ENDIF
5376	ENDDO
5377	ENDDO
5378	!
5379	! Determine for each point where it flows to
5380	!
5381	CALL routing_findrout(nbi, nbj, trip_tmp, basin_sz, basin_inbxid, nbout, outflow, trip_flow, outsz)
5382	!
5383	!
5384	!
5385	!
5386	! Over the width of a GCM grid box we can have many outflows but we are interested
5387	! in only one for each basin. Thus we wish to collect them all to form only one outflow
5388	! to the neighboring grid box.
5389	!
5390	DO iborder = 101,107,2
5391	!
5392	! If we have more than one of these outflows then we need to merge the sub-basins
5393	!
5394	icc = COUNT(trip_tmp .EQ. iborder)-1
5395	DO WHILE ( icc .GT. 0)
5396	! Pick out all the points we will have to do
5397	itodo = 0
5398	DO ip=1,nbout
5399	IF (trip_tmp(outflow(ip,1),outflow(ip,2)) .EQ. iborder) THEN
5400	itodo = itodo + 1
5401	todopt(itodo) = ip
5402	!!$ todosz(itodo) = outsz(ip)
5403	! We take the hierarchy of the outflow point as we will try to
5404	! minimize if for the outflow of the entire basin.
5405	todohi(itodo) = hierarchy(outflow(ip,1),outflow(ip,2))
5406	ENDIF
5407	ENDDO
5408	!
5409	! We change the direction of the smallest basin.
5410	!
5411	ill=MAXLOC(todohi(1:itodo))
5412	ismall = todopt(ill(1))
5413	!
5414	DO ip=1,nbi
5415	DO jp=1,nbj
5416	IF ( trip_flow(ip,jp,1) .EQ. outflow(ismall,1) .AND.&
5417	& trip_flow(ip,jp,2) .EQ. outflow(ismall,2) ) THEN
5418	! Now that we have found a point of the smallest sub-basin we
5419	! look around for another sub-basin
5420	ib = 1
5421	not_found = .TRUE.
5422	DO WHILE ( not_found .AND. ib .LE. itodo )
5423	IF ( ib .NE. ill(1) ) THEN
5424	ibas = todopt(ib)
5425	DO id=1,8
5426	iip = ip + inc(id,1)
5427	jjp = jp + inc(id,2)
5428	! Can we look at this points or is there any need to ?
5429	IF ( iip .GE. 1 .AND. iip .LE. nbi .AND. &
5430	& jjp .GE. 1 .AND. jjp .LE. nbj .AND. not_found) THEN
5431	! Is this point the one we look for ?
5432	IF ( trip_flow(iip,jjp,1) .EQ. outflow(ibas,1) .AND. &
5433	& trip_flow(iip,jjp,2) .EQ. outflow(ibas,2)) THEN
5434	trip_flow(ip,jp,1) = outflow(ibas,1)
5435	trip_flow(ip,jp,2) = outflow(ibas,2)
5436	trip_tmp(ip,jp) = id
5437	! This last line ensures that we do not come back to this point
5438	! and that in the end the outer while will stop
5439	not_found = .FALSE.
5440	ENDIF
5441	ENDIF
5442	ENDDO
5443	ENDIF
5444	ib = ib + 1
5445	ENDDO
5446	ENDIF
5447	ENDDO
5448	ENDDO
5449	!
5450	icc = icc - 1
5451	ENDDO
5452	!
5453	!
5454	ENDDO
5455	!
5456	IF ( debug ) THEN
5457	WRITE(numout,*) '+++++++++++++++++++ AFTER +++++++++++++++++++++++++++++'
5458	WRITE(fmt,"('(',I3,'I6)')") nbi
5459	DO jp=1,nbj
5460	WRITE(numout,fmt) trip_tmp(1:nbi,jp)
5461	ENDDO
5462	ENDIF
5463	!
5464	! Put trip_tmp back into trip
5465	!
5466	DO ip=1,nbi
5467	DO jp=1,nbj
5468	IF ( trip_tmp(ip,jp) .GT. 0) THEN
5469	trip(ip,jp) = trip_tmp(ip,jp)
5470	ENDIF
5471	ENDDO
5472	ENDDO
5473	!
5474	END SUBROUTINE routing_simplify
5475	!
5476	!! ================================================================================================================================
5477	!! SUBROUTINE : routing_cutbasin
5478	!!
5479	!>\BRIEF This subroutine cuts the original basin which has more than one outflow
5480	!! into as many subbasins as outflow directions.
5481	!!
5482	!! DESCRIPTION (definitions, functional, design, flags) : None
5483	!!
5484	!! RECENT CHANGE(S): None
5485	!!
5486	!! MAIN OUTPUT VARIABLE(S):
5487	!!
5488	!! REFERENCES : None
5489	!!
5490	!! FLOWCHART : None
5491	!! \n
5492	!_ ================================================================================================================================
5493
5494	SUBROUTINE routing_cutbasin (nbi, nbj, nbbasins, trip, basin, basin_inbxid, nb, bname, sz, pts)
5495	!
5496	IMPLICIT NONE
5497	!
5498	!! INPUT VARIABLES
5499	INTEGER(i_std), INTENT(in) :: nbi, nbj !! Number of point in x and y within the grid (unitless)
5500	INTEGER(i_std), INTENT(in) :: nbbasins !!
5501	INTEGER(i_std), INTENT(in) :: basin_inbxid !!
5502	!
5503	! Modified
5504	INTEGER(i_std), INTENT(inout) :: trip(:,:) !! The trip field (unitless)
5505	INTEGER(i_std), INTENT(inout) :: basin(:,:) !!
5506	!
5507	!! OUTPUT VARIABLES
5508	INTEGER(i_std), INTENT(out) :: nb !!
5509	INTEGER(i_std), INTENT(out) :: bname(nbvmax) !!
5510	INTEGER(i_std), INTENT(out) :: sz(nbvmax) !!
5511	INTEGER(i_std), INTENT(out) :: pts(nbvmax,nbvmax,2) !!
5512	!
5513	!! LOCAL VARIABLES
5514	INTEGER(i_std) :: ip, jp, iip, jjp, ib, ibb, id, nbout !! Indices (unitless)
5515	INTEGER(i_std) :: basin_sz !!
5516	INTEGER(i_std) :: nb_in !!
5517	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)
5518	INTEGER(i_std), DIMENSION(nbvmax,nbvmax,2) :: trip_flow !!
5519	INTEGER(i_std), DIMENSION(nbvmax,2) :: outflow !!
5520	INTEGER(i_std), DIMENSION(nbvmax) :: outsz !!
5521	CHARACTER(LEN=7) :: fmt !!
5522	LOGICAL :: not_found !! (true/false)
5523	LOGICAL :: debug=.FALSE. !! (true/false)
5524	!
5525	INTEGER(i_std), DIMENSION(8,2) :: inc !!
5526
5527	!_ ================================================================================================================================
5528	!
5529	!
5530	! The routing code (i=1, j=2)
5531	!
5532	inc(1,1) = 0
5533	inc(1,2) = -1
5534	inc(2,1) = 1
5535	inc(2,2) = -1
5536	inc(3,1) = 1
5537	inc(3,2) = 0
5538	inc(4,1) = 1
5539	inc(4,2) = 1
5540	inc(5,1) = 0
5541	inc(5,2) = 1
5542	inc(6,1) = -1
5543	inc(6,2) = 1
5544	inc(7,1) = -1
5545	inc(7,2) = 0
5546	inc(8,1) = -1
5547	inc(8,2) = -1
5548	!
5549	! Set up a temporary trip field which only contains the values
5550	! for the basin on which we currently work.
5551	!
5552	trip_tmp(:,:) = -1
5553	basin_sz = 0
5554	DO ip=1,nbi
5555	DO jp=1,nbj
5556	IF ( basin(ip,jp) .EQ. basin_inbxid) THEN
5557	trip_tmp(ip,jp) = trip(ip,jp)
5558	basin_sz = basin_sz + 1
5559	ENDIF
5560	ENDDO
5561	ENDDO
5562	!
5563	CALL routing_findrout(nbi, nbj, trip_tmp, basin_sz, basin_inbxid, nbout, outflow, trip_flow, outsz)
5564	!
5565	! IF ( debug ) THEN
5566	! DO ib = nb_in+1,nb
5567	! DO ip=1,sz(ib)
5568	! trip_tmp(pts(ib, ip, 1),pts(ib, ip, 2)) = ib*(-1)-900
5569	! ENDDO
5570	! ENDDO
5571	! WRITE(fmt,"('(',I3,'I6)')") nbi
5572	! WRITE(numout,*) 'BEFORE ------------> New basins '
5573	! WRITE(numout,*) nb, ' sz :', sz(1:nb)
5574	! DO jp=1,nbj
5575	! WRITE(numout,fmt) trip_tmp(1:nbi,jp)
5576	! ENDDO
5577	! ENDIF
5578	!
5579	! Take out the small sub-basins. That is those which have only one grid box
5580	! This is only done if we need to save space in the number of basins. Else we
5581	! can take it easy and keep diverging sub-basins for the moment.
5582	!
5583	IF ( nbbasins .GE. nbasmax ) THEN
5584	DO ib=1,nbout
5585	! If the sub-basin is of size one and its larger neighbor is flowing into another
5586	! direction then we put them together.
5587	IF ( outsz(ib) .EQ. 1 .AND. trip(outflow(ib,1), outflow(ib,2)) .GT. 99 ) THEN
5588	!
5589	not_found = .TRUE.
5590	DO id=1,8
5591	ip = outflow(ib,1)
5592	jp = outflow(ib,2)
5593	iip = ip + inc(id,1)
5594	jjp = jp + inc(id,2)
5595	! Can we look at this points ?
5596	IF ( iip .GE. 1 .AND. iip .LE. nbi .AND. &
5597	& jjp .GE. 1 .AND. jjp .LE. nbj .AND. not_found) THEN
5598	! Did we find a direct neighbor which is an outflow point ?
5599	IF ( trip_tmp(iip,jjp) .GT. 100 ) THEN
5600	! IF so direct the flow towards it and update the tables.
5601	not_found = .FALSE.
5602	trip(ip,jp) = id
5603	trip_tmp(ip,jp) = id
5604	outsz(ib) = 0
5605	! update the table of this basin
5606	DO ibb=1,nbout
5607	IF ( iip .EQ. outflow(ibb,1) .AND. jjp .EQ. outflow(ibb,2) ) THEN
5608	outsz(ibb) = outsz(ibb)+1
5609	trip_flow(ip,jp,1) = outflow(ibb,1)
5610	trip_flow(ip,jp,2) = outflow(ibb,2)
5611	ENDIF
5612	ENDDO
5613	ENDIF
5614	ENDIF
5615	ENDDO
5616	ENDIF
5617	ENDDO
5618	ENDIF
5619	!
5620	!
5621	! Cut the basin if we have more than 1 left.
5622	!
5623	!
5624	IF ( COUNT(outsz(1:nbout) .GT. 0) .GT. 1 ) THEN
5625	!
5626	nb_in = nb
5627	!
5628	DO ib = 1,nbout
5629	IF ( outsz(ib) .GT. 0) THEN
5630	nb = nb+1
5631	IF ( nb .GT. nbvmax) THEN
5632	WRITE(numout,*) 'nbvmax too small, increase it (routing_cutbasin)'
5633	ENDIF
5634	bname(nb) = basin_inbxid
5635	sz(nb) = 0
5636	DO ip=1,nbi
5637	DO jp=1,nbj
5638	IF ( (trip_flow(ip,jp,1) + trip_flow(ip,jp,1)) .GT. 0 .AND. &
5639	& trip_flow(ip,jp,1) .EQ. outflow(ib,1) .AND. &
5640	& trip_flow(ip,jp,2) .EQ. outflow(ib,2) ) THEN
5641	sz(nb) = sz(nb) + 1
5642	pts(nb, sz(nb), 1) = ip
5643	pts(nb, sz(nb), 2) = jp
5644	ENDIF
5645	ENDDO
5646	ENDDO
5647	ENDIF
5648	ENDDO
5649	! A short verification
5650	IF ( SUM(sz(nb_in+1:nb)) .NE. basin_sz) THEN
5651	WRITE(numout,*) 'Lost some points while spliting the basin'
5652	WRITE(numout,*) 'nbout :', nbout
5653	DO ib = nb_in+1,nb
5654	WRITE(numout,*) 'ib, SZ :', ib, sz(ib)
5655	ENDDO
5656	WRITE(fmt,"('(',I3,'I6)')") nbi
5657	WRITE(numout,*) '-------------> trip '
5658	DO jp=1,nbj
5659	WRITE(numout,fmt) trip_tmp(1:nbi,jp)
5660	ENDDO
5661	CALL ipslerr_p(3,'routing_cutbasin','Lost some points while spliting the basin','','')
5662	ENDIF
5663
5664	IF ( debug ) THEN
5665	DO ib = nb_in+1,nb
5666	DO ip=1,sz(ib)
5667	trip_tmp(pts(ib, ip, 1),pts(ib, ip, 2)) = ib*(-1)-900
5668	ENDDO
5669	ENDDO
5670	WRITE(fmt,"('(',I3,'I6)')") nbi
5671	WRITE(numout,*) 'AFTER-------------> New basins '
5672	WRITE(numout,*) nb, ' sz :', sz(1:nb)
5673	DO jp=1,nbj
5674	WRITE(numout,fmt) trip_tmp(1:nbi,jp)
5675	ENDDO
5676	IF ( MAXVAl(trip_tmp(1:nbi,1:nbj)) .GT. 0) THEN
5677	CALL ipslerr_p(3,'routing_cutbasin','Error in debug checking','','')
5678	ENDIF
5679	ENDIF
5680	ENDIF
5681	!
5682	END SUBROUTINE routing_cutbasin
5683	!
5684	!! ================================================================================================================================
5685	!! SUBROUTINE : routing_hierarchy
5686	!!
5687	!>\BRIEF This subroutine finds, for each point, the distance to the outflow
5688	!! point along the flowlines of the basin.
5689	!!
5690	!! DESCRIPTION (definitions, functional, design, flags) : None
5691	!!
5692	!! RECENT CHANGE(S): None
5693	!!
5694	!! MAIN OUTPUT VARIABLE(S):
5695	!!
5696	!! REFERENCES : None
5697	!!
5698	!! FLOWCHART : None
5699	!! \n
5700	!_ ================================================================================================================================
5701
5702	SUBROUTINE routing_hierarchy(iml, jml, trip, topoindex, hierarchy)
5703	!
5704	IMPLICIT NONE
5705	!
5706	!! LOCAL VARIABLES
5707	INTEGER(i_std) :: iml !! X resolution of the high resolution grid
5708	INTEGER(i_std) :: jml !! Y resolution of the high resolution grid
5709	REAL(r_std), DIMENSION(iml,jml) :: trip !! The trip field (unitless)
5710	REAL(r_std), DIMENSION(iml,jml) :: hierarchy !!
5711	REAL(r_std), DIMENSION(iml,jml) :: topoindex !! Topographic index of the residence time (m)
5712	!
5713	INTEGER(i_std), DIMENSION(8,2) :: inc !!
5714	INTEGER(i_std) :: ip, jp, ib, ntripi, ntripj, cnt, trp !!
5715	REAL(r_std) :: topohier !! The new value of topographically weighted hierarchy (m)
5716	REAL(r_std) :: topohier_old !! The old value of topographically weighted hierarchy (m)
5717	CHARACTER(LEN=7) :: fmt !!
5718
5719	!_ ================================================================================================================================
5720	!
5721	! The routing code (i=1, j=2)
5722	!
5723	inc(1,1) = 0
5724	inc(1,2) = -1
5725	inc(2,1) = 1
5726	inc(2,2) = -1
5727	inc(3,1) = 1
5728	inc(3,2) = 0
5729	inc(4,1) = 1
5730	inc(4,2) = 1
5731	inc(5,1) = 0
5732	inc(5,2) = 1
5733	inc(6,1) = -1
5734	inc(6,2) = 1
5735	inc(7,1) = -1
5736	inc(7,2) = 0
5737	inc(8,1) = -1
5738	inc(8,2) = -1
5739	!
5740	DO ip=1,iml
5741	DO jp=1,jml
5742	IF ( trip(ip,jp) .LT. undef_sechiba ) THEN
5743	ntripi = ip
5744	ntripj = jp
5745	trp = NINT(trip(ip,jp))
5746	cnt = 1
5747	! Warn for extreme numbers
5748	IF ( topoindex(ip,jp) .GT. 1.e10 ) THEN
5749	WRITE(numout,*) 'We have a very large topographic index for point ', ip, jp
5750	WRITE(numout,*) 'This can not be right :', topoindex(ip,jp)
5751	CALL ipslerr_p(3,'routing_hierarchy','Too large topographic index','','')
5752	ELSE
5753	topohier = topoindex(ip,jp)
5754	ENDIF
5755	!
5756	DO WHILE ( trp .GT. 0 .AND. trp .LT. 9 .AND. cnt .LT. iml*jml)
5757	cnt = cnt + 1
5758	ntripi = ntripi + inc(trp,1)
5759	IF ( ntripi .LT. 1) ntripi = iml
5760	IF ( ntripi .GT. iml) ntripi = 1
5761	ntripj = ntripj + inc(trp,2)
5762	topohier_old = topohier
5763	topohier = topohier + topoindex(ntripi, ntripj)
5764	IF ( topohier_old .GT. topohier) THEN
5765	WRITE(numout,*) 'Big Problem, how comes we climb up a hill ?'
5766	WRITE(numout,*) 'The old value of topographicaly weighted hierarchy was : ', topohier_old
5767	WRITE(numout,*) 'The new one is :', topohier
5768	CALL ipslerr_p(3,'routing_hierarchy','Big Problem, how comes we climb up a hill ?','','')
5769	ENDIF
5770	trp = NINT(trip(ntripi, ntripj))
5771	ENDDO
5772
5773	IF ( cnt .EQ. iml*jml) THEN
5774	WRITE(numout,*) 'We could not route point (routing_findrout) :', ip, jp
5775	WRITE(numout,*) '-------------> trip '
5776	WRITE(fmt,"('(',I3,'I6)')") iml
5777	DO ib=1,jml
5778	WRITE(numout,fmt) trip(1:iml,ib)
5779	ENDDO
5780	CALL ipslerr_p(3,'routing_hierarchy','We could not route point','','')
5781	ENDIF
5782
5783	hierarchy(ip,jp) = topohier
5784
5785	ENDIF
5786	ENDDO
5787	ENDDO
5788	!
5789	!
5790	END SUBROUTINE routing_hierarchy
5791	!
5792	!! ================================================================================================================================
5793	!! SUBROUTINE : routing_findrout
5794	!!
5795	!>\BRIEF This subroutine simply computes the route to each outflow point
5796	!! and returns the outflow point for each point in the basin.
5797	!!
5798	!! DESCRIPTION (definitions, functional, design, flags) : None
5799	!!
5800	!! RECENT CHANGE(S): None
5801	!!
5802	!! MAIN OUTPUT VARIABLE(S):
5803	!!
5804	!! REFERENCES : None
5805	!!
5806	!! FLOWCHART : None
5807	!! \n
5808	!_ ================================================================================================================================
5809
5810	SUBROUTINE routing_findrout(nbi, nbj, trip, basin_sz, basinid, nbout, outflow, trip_flow, outsz)
5811	!
5812	IMPLICIT NONE
5813	!
5814	!! INPUT VARIABLES
5815	INTEGER(i_std) :: nbi !! Number of point in x within the grid (unitless)
5816	INTEGER(i_std) :: nbj !! Number of point in y within the grid (unitless)
5817	INTEGER(i_std), DIMENSION(nbvmax,nbvmax) :: trip !! The trip field (unitless)
5818	INTEGER(i_std) :: basin_sz !!
5819	INTEGER(i_std) :: basinid !!
5820	!
5821	!! OUTPUT VARIABLES
5822	INTEGER(i_std), DIMENSION(nbvmax,2), INTENT(out) :: outflow !!
5823	INTEGER(i_std), DIMENSION(nbvmax,nbvmax,2), INTENT(out) :: trip_flow !!
5824	INTEGER(i_std), INTENT(out) :: nbout !!
5825	INTEGER(i_std), DIMENSION(nbvmax), INTENT(out) :: outsz !!
5826	!
5827	!! LOCAL VARIABLES
5828	INTEGER(i_std), DIMENSION(8,2) :: inc !!
5829	INTEGER(i_std) :: ip, jp, ib, cnt, trp, totsz !! Indices (unitless)
5830	CHARACTER(LEN=7) :: fmt !!
5831
5832	!_ ================================================================================================================================
5833	!
5834	!
5835	! The routing code (i=1, j=2)
5836	!
5837	inc(1,1) = 0
5838	inc(1,2) = -1
5839	inc(2,1) = 1
5840	inc(2,2) = -1
5841	inc(3,1) = 1
5842	inc(3,2) = 0
5843	inc(4,1) = 1
5844	inc(4,2) = 1
5845	inc(5,1) = 0
5846	inc(5,2) = 1
5847	inc(6,1) = -1
5848	inc(6,2) = 1
5849	inc(7,1) = -1
5850	inc(7,2) = 0
5851	inc(8,1) = -1
5852	inc(8,2) = -1
5853	!
5854	!
5855	! Get the outflows and determine for each point to which outflow point it belong
5856	!
5857	nbout = 0
5858	trip_flow(:,:,:) = 0
5859	DO ip=1,nbi
5860	DO jp=1,nbj
5861	IF ( trip(ip,jp) .GT. 9) THEN
5862	nbout = nbout + 1
5863	outflow(nbout,1) = ip
5864	outflow(nbout,2) = jp
5865	ENDIF
5866	IF ( trip(ip,jp) .GT. 0) THEN
5867	trip_flow(ip,jp,1) = ip
5868	trip_flow(ip,jp,2) = jp
5869	ENDIF
5870	ENDDO
5871	ENDDO
5872	!
5873	! Follow the flow of the water
5874	!
5875	DO ip=1,nbi
5876	DO jp=1,nbj
5877	IF ( (trip_flow(ip,jp,1) + trip_flow(ip,jp,2)) .GT. 0) THEN
5878	trp = trip(trip_flow(ip,jp,1), trip_flow(ip,jp,2))
5879	cnt = 0
5880	DO WHILE ( trp .GT. 0 .AND. trp .LT. 9 .AND. cnt .LT. nbi*nbj)
5881	cnt = cnt + 1
5882	trip_flow(ip,jp,1) = trip_flow(ip,jp,1) + inc(trp,1)
5883	trip_flow(ip,jp,2) = trip_flow(ip,jp,2) + inc(trp,2)
5884	trp = trip(trip_flow(ip,jp,1), trip_flow(ip,jp,2))
5885	ENDDO
5886	IF ( cnt .EQ. nbi*nbj) THEN
5887	WRITE(numout,*) 'We could not route point (routing_findrout) :', ip, jp
5888	WRITE(numout,*) '-------------> trip '
5889	WRITE(fmt,"('(',I3,'I6)')") nbi
5890	DO ib=1,nbj
5891	WRITE(numout,fmt) trip(1:nbi,ib)
5892	ENDDO
5893	CALL ipslerr_p(3,'routing_findrout','We could not route point','','')
5894	ENDIF
5895	ENDIF
5896	ENDDO
5897	ENDDO
5898	!
5899	! What is the size of the region behind each outflow point ?
5900	!
5901	totsz = 0
5902	DO ip=1,nbout
5903	outsz(ip) = COUNT(trip_flow(:,:,1) .EQ. outflow(ip,1) .AND. trip_flow(:,:,2) .EQ. outflow(ip,2))
5904	totsz = totsz + outsz(ip)
5905	ENDDO
5906	IF ( basin_sz .NE. totsz) THEN
5907	WRITE(numout,*) 'Water got lost while I tried to follow it '
5908	WRITE(numout,*) basin_sz, totsz
5909	WRITE(numout,*) 'Basin id :', basinid
5910	DO ip=1,nbout
5911	WRITE(numout,*) 'ip :', ip, ' outsz :', outsz(ip), ' outflow :', outflow(ip,1), outflow(ip,2)
5912	ENDDO
5913	WRITE(numout,*) '-------------> trip '
5914	WRITE(fmt,"('(',I3,'I6)')") nbi
5915	DO jp=1,nbj
5916	WRITE(numout,fmt) trip(1:nbi,jp)
5917	ENDDO
5918	CALL ipslerr_p(3,'routing_findrout','Water got lost while I tried to follow it','','')
5919	ENDIF
5920	!
5921	END SUBROUTINE routing_findrout
5922	!
5923	!! ================================================================================================================================
5924	!! SUBROUTINE : routing_globalize
5925	!!
5926	!>\BRIEF This subroutine puts the basins found for grid box in the global map.
5927	!! Connection can only be made later when all information is together.
5928	!!
5929	!! DESCRIPTION (definitions, functional, design, flags) : None
5930	!!
5931	!! RECENT CHANGE(S): None
5932	!!
5933	!! MAIN OUTPUT VARIABLE(S):
5934	!! One of the outputs is basin_flowdir. Its convention is 1-8 for the directions from North to North
5935	!! West going through South. The negative values will be -3 for return flow, -2 for coastal flow
5936	!!
5937	!! REFERENCES : None
5938	!!
5939	!! FLOWCHART : None
5940	!! \n
5941	!_ ================================================================================================================================
5942
5943	SUBROUTINE routing_globalize(nbpt, ib, neighbours, area_bx, trip_bx, hierarchy_bx, topoind_bx, min_topoind,&
5944	& nb_basin, basin_inbxid, basin_sz, basin_pts, basin_bxout, coast_pts, nwbas, basin_count,&
5945	& basin_area, basin_hierarchy, basin_topoind, basin_id, basin_flowdir, outflow_grid,&
5946	& nbcoastal, coastal_basin)
5947	!
5948	IMPLICIT NONE
5949	!
5950	!! INPUT VARIABLES
5951	INTEGER(i_std), INTENT (in) :: nbpt !! Domain size (unitless)
5952	INTEGER(i_std), INTENT (in) :: ib !! Current basin (unitless)
5953	INTEGER(i_std), INTENT(in) :: neighbours(nbpt,NbNeighb)!! Vector of neighbours for each grid point
5954	!! (1=North and then clockwise)
5955	!! LOCAL VARIABLES
5956	REAL(r_std), DIMENSION(nbvmax,nbvmax) :: area_bx !! Area of each small box in the grid box (m^2)
5957	INTEGER(i_std), DIMENSION(nbvmax,nbvmax) :: trip_bx !! The trip field for each of the smaller boxes (unitless)
5958	REAL(r_std), DIMENSION(nbvmax,nbvmax) :: hierarchy_bx !! Level in the basin of the point
5959	REAL(r_std), DIMENSION(nbvmax,nbvmax) :: topoind_bx !! Topographic index of the residence time for each of the smaller boxes (m)
5960	REAL(r_std) :: min_topoind !! The current minimum of topographic index (m)
5961	INTEGER(i_std) :: nb_basin !! Number of sub-basins (unitless)
5962	INTEGER(i_std), DIMENSION(nbvmax) :: basin_inbxid, basin_sz !! ID of basin, number of points in the basin
5963	INTEGER(i_std), DIMENSION(nbvmax,nbvmax,2) :: basin_pts !! Points in each basin
5964	INTEGER(i_std), DIMENSION(nbvmax) :: basin_bxout !! outflow direction
5965	INTEGER(i_std) :: coast_pts(nbvmax) !! The coastal flow points (unitless)
5966	! global maps
5967	INTEGER(i_std) :: nwbas !!
5968	INTEGER(i_std), DIMENSION(nbpt) :: basin_count !!
5969	INTEGER(i_std), DIMENSION(nbpt,nwbas) :: basin_id !!
5970	INTEGER(i_std), DIMENSION(nbpt,nwbas) :: basin_flowdir !! Water flow directions in the basin (unitless)
5971	REAL(r_std), DIMENSION(nbpt,nwbas) :: basin_area !!
5972	REAL(r_std), DIMENSION(nbpt,nwbas) :: basin_hierarchy !!
5973	REAL(r_std), DIMENSION(nbpt,nwbas) :: basin_topoind !! Topographic index of the residence time for a basin (m)
5974	INTEGER(i_std), DIMENSION(nbpt,nwbas) :: outflow_grid !! Type of outflow on the grid box (unitless)
5975	INTEGER(i_std), DIMENSION(nbpt) :: nbcoastal !!
5976	INTEGER(i_std), DIMENSION(nbpt,nwbas) :: coastal_basin !!
5977	!
5978	INTEGER(i_std) :: ij, iz !! Indices (unitless)
5979	CHARACTER(LEN=4) :: hierar_method = 'OUTP' !!
5980
5981	!_ ================================================================================================================================
5982	!
5983	!
5984	DO ij=1, nb_basin
5985	!
5986	! Count the basins and keep their ID
5987	!
5988	basin_count(ib) = basin_count(ib)+1
5989	if (basin_count(ib) > nwbas) then
5990	WRITE(numout,*) 'ib=',ib
5991	call ipslerr_p(3,'routing_globalize', &
5992	& 'Problem with basin_count : ', &
5993	& 'It is greater than number of allocated basin nwbas.', &
5994	& '(stop to count basins)')
5995	endif
5996	basin_id(ib,basin_count(ib)) = basin_inbxid(ij)
5997	!
5998	! Transfer the list of basins which flow into the ocean as coastal flow.
5999	!
6000	IF ( basin_id(ib,basin_count(ib)) .LT. 0) THEN
6001	nbcoastal(ib) = basin_sz(ij)
6002	coastal_basin(ib,1:nbcoastal(ib)) = coast_pts(1:nbcoastal(ib))
6003	ENDIF
6004	!
6005	!
6006	! Compute the area of the basin
6007	!
6008	basin_area(ib,ij) = zero
6009	basin_hierarchy(ib,ij) = zero
6010	!
6011	SELECT CASE (hierar_method)
6012	!
6013	CASE("MINI")
6014	basin_hierarchy(ib,ij) = undef_sechiba
6015	!
6016	END SELECT
6017	basin_topoind(ib,ij) = zero
6018	!
6019	DO iz=1,basin_sz(ij)
6020	!
6021	basin_area(ib,ij) = basin_area(ib,ij) + area_bx(basin_pts(ij,iz,1),basin_pts(ij,iz,2))
6022	basin_topoind(ib,ij) = basin_topoind(ib,ij) + topoind_bx(basin_pts(ij,iz,1),basin_pts(ij,iz,2))
6023	!
6024	! There are a number of ways to determine the hierarchy of the entire basin.
6025	! We allow for three here :
6026	! - Take the mean value
6027	! - Take the minimum value within the basin
6028	! - Take the value at the outflow point
6029	! Probably taking the value of the outflow point is the best solution.
6030	!
6031	SELECT CASE (hierar_method)
6032	!
6033	CASE("MEAN")
6034	! Mean hierarchy of the basin
6035	basin_hierarchy(ib,ij) = basin_hierarchy(ib,ij) + &
6036	& hierarchy_bx(basin_pts(ij,iz,1),basin_pts(ij,iz,2))
6037	CASE("MINI")
6038	! The smallest value of the basin
6039	IF ( hierarchy_bx(basin_pts(ij,iz,1),basin_pts(ij,iz,2)) .LT. basin_hierarchy(ib,ij)) THEN
6040	basin_hierarchy(ib,ij) = hierarchy_bx(basin_pts(ij,iz,1),basin_pts(ij,iz,2))
6041	ENDIF
6042	CASE("OUTP")
6043	! Value at the outflow point
6044	IF ( trip_bx(basin_pts(ij,iz,1),basin_pts(ij,iz,2)) .GT. 100 ) THEN
6045	basin_hierarchy(ib,ij) = hierarchy_bx(basin_pts(ij,iz,1),basin_pts(ij,iz,2))
6046	ENDIF
6047	CASE DEFAULT
6048	WRITE(numout,*) 'Unknown method for computing the hierarchy of the basin'
6049	CALL ipslerr_p(3,'routing_globalize','Unknown method for computing the hierarchy of the basin','','')
6050	END SELECT
6051	!
6052	ENDDO
6053	!
6054	basin_topoind(ib,ij) = basin_topoind(ib,ij)/REAL(basin_sz(ij),r_std)
6055	!
6056	SELECT CASE (hierar_method)
6057	!
6058	CASE("MEAN")
6059	basin_hierarchy(ib,ij) = basin_hierarchy(ib,ij)/REAL(basin_sz(ij),r_std)
6060	!
6061	END SELECT
6062	!
6063	! To make sure that it has the lowest number if this is an outflow point we reset basin_hierarchy
6064	!
6065	IF (basin_bxout(ij) .LT. 0) THEN
6066	basin_hierarchy(ib,ij) = min_topoind
6067	basin_topoind(ib,ij) = min_topoind
6068	ENDIF
6069	!
6070	!
6071	! Keep the outflow boxes and basin
6072	!
6073	basin_flowdir(ib,ij) = basin_bxout(ij)
6074	IF (basin_bxout(ij) .GT. 0) THEN
6075	outflow_grid(ib,ij) = neighbours(ib,basin_bxout(ij))
6076	ELSE
6077	outflow_grid(ib,ij) = basin_bxout(ij)
6078	ENDIF
6079	!
6080	!
6081	ENDDO
6082	!
6083
6084	!
6085	END SUBROUTINE routing_globalize
6086	!
6087	!! ================================================================================================================================
6088	!! SUBROUTINE : routing_linkup
6089	!!
6090	!>\BRIEF This subroutine makes the connections between the basins and ensure global coherence.
6091	!!
6092	!! DESCRIPTION (definitions, functional, design, flags) :
6093	!! The convention for outflow_grid is :
6094	!! outflow_grid = -1 : River flow
6095	!! outflow_grid = -2 : Coastal flow
6096	!! outflow_grid = -3 : Return flow\n
6097	!!
6098	!! RECENT CHANGE(S): None
6099	!!
6100	!! MAIN OUTPUT VARIABLE(S):
6101	!!
6102	!! REFERENCES : None
6103	!!
6104	!! FLOWCHART : None
6105	!! \n
6106	!_ ================================================================================================================================
6107
6108	SUBROUTINE routing_linkup(nbpt, contfrac, neighbours, nwbas, basin_count, basin_area, basin_id, basin_flowdir, &
6109	& basin_hierarchy, outflow_grid, outflow_basin, inflow_number, inflow_grid, inflow_basin, nbcoastal,&
6110	& coastal_basin, invented_basins)
6111	!
6112	IMPLICIT NONE
6113	!
6114	!! INPUT VARIABLES
6115	INTEGER(i_std), INTENT (in) :: nbpt !! Domain size (unitless)
6116	REAL(r_std), DIMENSION(nbpt) :: contfrac
6117	INTEGER(i_std), DIMENSION(nbpt,NbNeighb), INTENT (in) :: neighbours !!
6118	REAL(r_std), INTENT(in) :: invented_basins !!
6119	!
6120	INTEGER(i_std) :: nwbas !!
6121	INTEGER(i_std), DIMENSION(nbpt) :: basin_count !!
6122	INTEGER(i_std), DIMENSION(nbpt,nwbas) :: basin_id !!
6123	INTEGER(i_std), DIMENSION(nbpt,nwbas) :: basin_flowdir !! Water flow directions in the basin (unitless)
6124	REAL(r_std), DIMENSION(nbpt,nwbas) :: basin_area !!
6125	REAL(r_std), DIMENSION(nbpt,nwbas) :: basin_hierarchy !!
6126	INTEGER(i_std), DIMENSION(nbpt,nwbas) :: outflow_grid !! Type of outflow on the grid box (unitless)
6127	INTEGER(i_std), DIMENSION(nbpt,nwbas) :: outflow_basin !!
6128	INTEGER(i_std), DIMENSION(nbpt,nwbas) :: inflow_number !!
6129	INTEGER(i_std), DIMENSION(nbpt,nwbas,nbvmax) :: inflow_basin !!
6130	INTEGER(i_std), DIMENSION(nbpt,nwbas,nbvmax) :: inflow_grid !!
6131	INTEGER(i_std), DIMENSION(nbpt) :: nbcoastal !!
6132	INTEGER(i_std), DIMENSION(nbpt,nwbas) :: coastal_basin !!
6133	!
6134	!! LOCAL VARIABLES
6135	INTEGER(i_std) :: sp, sb, sbl, inp, bid, outdm1, outdp1 !! Indices (unitless)
6136	INTEGER(i_std) :: dp1, dm1, dm1i, dp1i, bp1, bm1 !! Indices (unitless)
6137	INTEGER(i_std) :: dop, bop !!
6138	INTEGER(i_std) :: fbas(nwbas), nbfbas !!
6139	REAL(r_std) :: fbas_hierarchy(nwbas) !!
6140	REAL(r_std) :: angle
6141	INTEGER(i_std) :: ff(1) !!
6142	!
6143	! ERRORS
6144	LOGICAL :: error1, error2, error3, error4, error5 !! (true/false)
6145	!
6146	!! PARAMETERS
6147	LOGICAL, PARAMETER :: check = .TRUE. !! (true/false)
6148
6149	!_ ================================================================================================================================
6150	error1=.FALSE.
6151	error2=.FALSE.
6152	error3=.FALSE.
6153	error4=.FALSE.
6154	error5=.FALSE.
6155
6156	outflow_basin(:,:) = undef_int
6157	inflow_number(:,:) = 0
6158	!
6159	DO sp=1,nbpt
6160	DO sb=1,basin_count(sp)
6161	!
6162	inp = outflow_grid(sp,sb)
6163	bid = basin_id(sp,sb)
6164	!
6165	! We only work on this point if it does not flow into the ocean
6166	! At this point any of the outflows is designated by a negative values in
6167	! outflow_grid
6168	!
6169	IF ( inp .GT. 0 ) THEN
6170	!
6171	! Now find the basin in the onflow point (inp)
6172	!
6173	nbfbas = 0
6174	!
6175	!
6176	DO sbl=1,basin_count(inp)
6177	!
6178	! Either it is a standard basin or one aggregated from ocean flow points.
6179	! If we flow into a another grid box we have to make sure that its hierarchy in the
6180	! basin is lower.
6181	!
6182	!
6183	IF ( basin_id(inp,sbl) .GT. 0 ) THEN
6184	IF ( basin_id(inp,sbl) .EQ. bid .OR. basin_id(inp,sbl) .GT. invented_basins) THEN
6185	nbfbas =nbfbas + 1
6186	fbas(nbfbas) = sbl
6187	fbas_hierarchy(nbfbas) = basin_hierarchy(inp,sbl)
6188	ENDIF
6189	ELSE
6190	IF ( COUNT(coastal_basin(inp,1:nbcoastal(inp)) .EQ. bid) .GT. 0 ) THEN
6191	nbfbas =nbfbas + 1
6192	fbas(nbfbas) = sbl
6193	fbas_hierarchy(nbfbas) = basin_hierarchy(inp,sbl)
6194	ENDIF
6195	ENDIF
6196	!
6197	ENDDO
6198	!
6199	! If we have more than one basin we will take the one which is lowest
6200	! in the hierarchy.
6201	!
6202	IF (nbfbas .GE. 1) THEN
6203	ff = MINLOC(fbas_hierarchy(1:nbfbas))
6204	sbl = fbas(ff(1))
6205	!
6206	bop = undef_int
6207	IF ( basin_hierarchy(inp,sbl) .LE. basin_hierarchy(sp,sb) ) THEN
6208	IF ( basin_hierarchy(inp,sbl) .LT. basin_hierarchy(sp,sb) ) THEN
6209	bop = sbl
6210	ELSE
6211	! The same hierarchy is allowed if both grids flow in about
6212	! the same direction :
6213	IF ( ( MOD(basin_flowdir(inp,sbl)+1-1, 8)+1 .EQ. basin_flowdir(sp,sb)).OR. &
6214	& ( basin_flowdir(inp,sbl) .EQ. basin_flowdir(sp,sb)).OR. &
6215	& ( MOD(basin_flowdir(inp,sbl)+7-1, 8)+1 .EQ. basin_flowdir(sp,sb)) ) THEN
6216	bop = sbl
6217	ENDIF
6218	ENDIF
6219	ENDIF
6220	!
6221	! If the basin is suitable (bop < undef_int) then take it
6222	!
6223	IF ( bop .LT. undef_int ) THEN
6224	outflow_basin(sp,sb) = bop
6225	inflow_number(inp,bop) = inflow_number(inp,bop) + 1
6226	IF ( inflow_number(inp,bop) .LE. nbvmax ) THEN
6227	inflow_grid(inp, bop, inflow_number(inp,bop)) = sp
6228	inflow_basin(inp, bop, inflow_number(inp,bop)) = sb
6229	ELSE
6230	error1=.TRUE.
6231	EXIT
6232	ENDIF
6233	ENDIF
6234	ENDIF
6235	!
6236	!
6237	ENDIF
6238	!
6239	!
6240	!
6241	! Did we find it ?
6242	!
6243	! In case the outflow point was ocean or we did not find the correct basin we start to look
6244	! around. We find two options for the outflow direction (dp1 & dm1) and the corresponding
6245	! basin index (bp1 & bm1).
6246	!
6247	!
6248	IF ( outflow_basin(sp,sb) .EQ. undef_int &
6249	& .AND. basin_flowdir(sp,sb) .GT. 0) THEN
6250	!
6251	dp1i = MOD(basin_flowdir(sp,sb)+1-1, NbNeighb)+1
6252	dp1 = neighbours(sp,dp1i)
6253	dm1i = MOD(basin_flowdir(sp,sb)+7-1, NbNeighb)+1
6254	IF ( dm1i .LT. 1 ) dm1i = 8
6255	dm1 = neighbours(sp,dm1i)
6256	!
6257	!
6258	bp1 = -1
6259	IF ( dp1 .GT. 0 ) THEN
6260	DO sbl=1,basin_count(dp1)
6261	IF (basin_id(dp1,sbl) .EQ. bid .AND.&
6262	& basin_hierarchy(sp,sb) .GE. basin_hierarchy(dp1,sbl) .AND. &
6263	& bp1 .LT. 0) THEN
6264	IF ( basin_hierarchy(sp,sb) .GT. basin_hierarchy(dp1,sbl) ) THEN
6265	bp1 = sbl
6266	ELSE
6267	! The same hierarchy is allowed if both grids flow in about
6268	! the same direction :
6269	angle=MODULO(basin_flowdir(dp1,sbl)-basin_flowdir(sp,sb)+8,8)
6270	IF ( angle >= 4 ) angle = angle-8
6271	!
6272	IF ( ABS(angle) <= 1 ) THEN
6273	bp1 = sbl
6274	ENDIF
6275	ENDIF
6276	ENDIF
6277	ENDDO
6278	ENDIF
6279	!
6280	bm1 = -1
6281	IF ( dm1 .GT. 0 ) THEN
6282	DO sbl=1,basin_count(dm1)
6283	IF (basin_id(dm1,sbl) .EQ. bid .AND.&
6284	& basin_hierarchy(sp,sb) .GE. basin_hierarchy(dm1,sbl) .AND. &
6285	& bm1 .LT. 0) THEN
6286	IF ( basin_hierarchy(sp,sb) .GT. basin_hierarchy(dm1,sbl) ) THEN
6287	bm1 = sbl
6288	ELSE
6289	! The same hierarchy is allowed if both grids flow in about
6290	! the same direction :
6291	angle=MODULO(basin_flowdir(dm1,sbl)-basin_flowdir(sp,sb)+8,8)
6292	IF ( angle >= 4 ) angle = angle-8
6293	!
6294	IF ( ABS(angle) <= 1 ) THEN
6295	bm1 = sbl
6296	ENDIF
6297	ENDIF
6298	ENDIF
6299	ENDDO
6300	ENDIF
6301	!
6302	!
6303	! First deal with the case on land.
6304	!
6305	! For that we need to check if the water will be able to flow out of the grid dp1 or dm1
6306	! and not return to our current grid. If it is the current grid
6307	! then we can not do anything with that neighbour. Thus we set the
6308	! value of outdm1 and outdp1 back to -1
6309	!
6310	outdp1 = undef_int
6311	IF ( dp1 .GT. 0 .AND. bp1 .GT. 0 ) THEN
6312	! if the outflow is into the ocean then we put something less than undef_int in outdp1!
6313	IF (basin_flowdir(dp1,bp1) .GT. 0) THEN
6314	outdp1 = neighbours(dp1,basin_flowdir(dp1,bp1))
6315	IF ( outdp1 .EQ. sp ) outdp1 = undef_int
6316	ELSE
6317	outdp1 = nbpt + 1
6318	ENDIF
6319	ENDIF
6320	outdm1 = undef_int
6321	IF ( dm1 .GT. 0 .AND. bm1 .GT. 0 ) THEN
6322	IF (basin_flowdir(dm1,bm1) .GT. 0) THEN
6323	outdm1 = neighbours(dm1,basin_flowdir(dm1,bm1))
6324	IF ( outdm1 .EQ. sp ) outdm1 = undef_int
6325	ELSE
6326	outdm1 = nbpt + 1
6327	ENDIF
6328	ENDIF
6329	!
6330	! Now that we know our options we need go through them.
6331	!
6332	dop = undef_int
6333	bop = undef_int
6334	IF ( outdp1 .LT. undef_int .AND. outdm1 .LT. undef_int) THEN
6335	!
6336	! In this case we let the current basin flow into the smaller one
6337	!
6338	IF ( basin_area(dp1,bp1) .LT. basin_area(dm1,bm1) ) THEN
6339	dop = dp1
6340	bop = bp1
6341	ELSE
6342	dop = dm1
6343	bop = bm1
6344	ENDIF
6345	!
6346	!
6347	ELSE IF ( outdp1 .LT. undef_int ) THEN
6348	! If only the first one is possible
6349	dop = dp1
6350	bop = bp1
6351	ELSE IF ( outdm1 .LT. undef_int ) THEN
6352	! If only the second one is possible
6353	dop = dm1
6354	bop = bm1
6355	ELSE
6356	!
6357	! Now we are at the point where none of the neighboring points is suitable
6358	! or we have a coastal point.
6359	!
6360	! If there is an option to put the water into the ocean go for it.
6361	!
6362	IF ( outflow_grid(sp,sb) .LT. 0 .OR. dm1 .LT. 0 .OR. dp1 .LT. 0 ) THEN
6363	dop = -1
6364	ELSE
6365	!
6366	! If we are on a land point with only land neighbors but no one suitable to let the
6367	! water flow into we have to look for a solution in the current grid box.
6368	!
6369	!
6370	IF ( bp1 .LT. 0 .AND. bm1 .LT. 0 ) THEN
6371	!
6372	! Do we have more than one basin with the same ID ?
6373	!
6374	IF ( COUNT(basin_id(sp,1:basin_count(sp)) .EQ. bid) .GE. 2) THEN
6375	!
6376	! Now we can try the option of flowing into the basin of the same grid box.
6377	!
6378	DO sbl=1,basin_count(sp)
6379	IF (sbl .NE. sb .AND. basin_id(sp,sbl) .EQ. bid) THEN
6380	! In case this basin has a lower hierarchy or flows into a totaly
6381	! different direction we go for it.
6382	IF ( (basin_hierarchy(sp,sb) .GE. basin_hierarchy(sp,sbl)) .OR. &
6383	& (basin_flowdir(sp,sbl) .LT. dm1i .AND.&
6384	& basin_flowdir(sp,sbl) .GT. dp1i) ) THEN
6385	dop = sp
6386	bop = sbl
6387	IF (check) THEN
6388	IF (basin_hierarchy(sp,sb) .LT. basin_hierarchy(sp,sbl)) THEN
6389	WRITE(numout,*) '>>>>>>> POINT CORRECTED against hierarchy :',&
6390	& sp, sb, 'into', sbl
6391	ENDIF
6392	ENDIF
6393	ENDIF
6394	!
6395	ENDIF
6396	ENDDO
6397	!
6398	ENDIF
6399	ENDIF
6400	ENDIF
6401	!
6402	IF ( dop .EQ. undef_int .AND. bop .EQ. undef_int ) THEN
6403	IF (check) THEN
6404	WRITE(numout,*) 'Why are we here with point ', sp, sb
6405	WRITE(numout,*) 'Coordinates : (lon,lat) = ', lalo_g(sp,2), lalo_g(sp,1)
6406	WRITE(numout,*) 'neighbours :', neighbours_g(sp,:)
6407	WRITE(numout,*) 'Contfrac : = ', contfrac(sp)
6408	WRITE(numout,*) 'Local Basin ID :', basin_id(sp,1:basin_count(sp))
6409	WRITE(numout,*) 'Local hierarchies :', basin_hierarchy(sp,1:basin_count(sp))
6410	WRITE(numout,*) 'Local basin_flowdir :', basin_flowdir(sp,1:basin_count(sp))
6411	WRITE(numout,*) 'Local outflowgrid :', outflow_grid(sp,1:basin_count(sp))
6412	WRITE(numout,*) 'outflow_grid :', inp
6413	WRITE(numout,*) 'Coodinates outflow : (lon,lat) = ', lalo_g(inp,2), lalo_g(inp,1)
6414	WRITE(numout,*) 'Contfrac : = ', contfrac(inp)
6415	WRITE(numout,*) 'Outflow Basin ID :', basin_id(inp,1:basin_count(inp))
6416	WRITE(numout,*) 'Outflow hierarchies :', basin_hierarchy(inp,1:basin_count(inp))
6417	WRITE(numout,*) 'Outflow basin_flowdir :', basin_flowdir(inp,1:basin_count(inp))
6418	WRITE(numout,*) 'Explored options +1 :', dp1, bp1, outdp1
6419	WRITE(numout,*) 'Explored +1 Basin ID :', basin_id(dp1,1:basin_count(dp1))
6420	WRITE(numout,*) 'Explored +1 hierarchies :', basin_hierarchy(dp1,1:basin_count(dp1))
6421	WRITE(numout,*) 'Explored +1 basin_flowdir :', basin_flowdir(dp1,1:basin_count(dp1))
6422	WRITE(numout,*) 'Explored options -1 :', dm1, bm1, outdm1
6423	WRITE(numout,*) 'Explored -1 Basin ID :', basin_id(dm1,1:basin_count(dm1))
6424	WRITE(numout,*) 'Explored -1 hierarchies :', basin_hierarchy(dm1,1:basin_count(dm1))
6425	WRITE(numout,*) 'Explored -1 basin_flowdir :', basin_flowdir(dm1,1:basin_count(dm1))
6426	WRITE(numout,) '***************************'
6427	CALL FLUSH(numout)
6428	ENDIF
6429	IF ( contfrac(sp) > 0.01 ) THEN
6430	error2=.TRUE.
6431	EXIT
6432	ENDIF
6433	ENDIF
6434	!
6435	ENDIF
6436	!
6437	! Now that we know where we want the water to flow to we write the
6438	! the information in the right fields.
6439	!
6440	IF ( dop .GT. 0 .AND. dop .NE. undef_int ) THEN
6441	outflow_grid(sp,sb) = dop
6442	outflow_basin(sp,sb) = bop
6443	inflow_number(dop,bop) = inflow_number(dop,bop) + 1
6444	IF ( inflow_number(dop,bop) .LE. nbvmax ) THEN
6445	inflow_grid(dop, bop, inflow_number(dop,bop)) = sp
6446	inflow_basin(dop, bop, inflow_number(dop,bop)) = sb
6447	ELSE
6448	error3=.TRUE.
6449	EXIT
6450	ENDIF
6451	!
6452	ELSE
6453	outflow_grid(sp,sb) = -2
6454	outflow_basin(sp,sb) = undef_int
6455	ENDIF
6456	!
6457	ENDIF
6458	!
6459	!
6460	! If we still have not found anything then we have to check that there is not a basin
6461	! within the same grid box which has a lower hierarchy.
6462	!
6463	!
6464	IF ( outflow_grid(sp,sb) .GT. 0 .AND. outflow_basin(sp,sb) .EQ. undef_int &
6465	& .AND. basin_flowdir(sp,sb) .GT. 0) THEN
6466	!
6467
6468	IF (check) &
6469	WRITE(numout,*) 'There is no reason to here, this part of the code should be dead :', sp,sb
6470	!
6471	DO sbl=1,basin_count(sp)
6472	!
6473	! Three conditions are needed to let the water flow into another basin of the
6474	! same grid :
6475	! - another basin than the current one
6476	! - same ID
6477	! - of lower hierarchy.
6478	!
6479	IF ( (sbl .NE. sb) .AND. (basin_id(sp,sbl) .EQ. bid)&
6480	& .AND. (basin_hierarchy(sp,sb) .GT. basin_hierarchy(sp,sbl)) ) THEN
6481	outflow_basin(sp,sb) = sbl
6482	inflow_number(sp,sbl) = inflow_number(sp,sbl) + 1
6483	IF ( inflow_number(sp,sbl) .LE. nbvmax ) THEN
6484	IF ( sp .EQ. 42 .AND. sbl .EQ. 1) THEN
6485	IF (check) &
6486	WRITE(numout,*) 'ADD INFLOW (3):', sp, sb
6487	ENDIF
6488	inflow_grid(sp, sbl, inflow_number(sp,sbl)) = sp
6489	inflow_basin(sp, sbl, inflow_number(sp,sbl)) = sb
6490	ELSE
6491	error4=.TRUE.
6492	EXIT
6493	ENDIF
6494	ENDIF
6495	ENDDO
6496	ENDIF
6497	!
6498	! Ok that is it, we give up :-)
6499	!
6500	IF ( outflow_grid(sp,sb) .GT. 0 .AND. outflow_basin(sp,sb) .EQ. undef_int &
6501	& .AND. basin_flowdir(sp,sb) .GT. 0) THEN
6502	!
6503	error5=.TRUE.
6504	EXIT
6505	ENDIF
6506	ENDDO
6507	!
6508	ENDDO
6509	IF (error1) THEN
6510	WRITE(numout,*) " routing_linkup : bop .LT. undef_int",bop
6511	CALL ipslerr_p(3,'routing_linkup', &
6512	"bop .LT. undef_int",'Increase nbvmax','stop routing_linkup')
6513	ENDIF
6514	IF (error2) THEN
6515	CALL ipslerr_p(3,'routing_linkup', &
6516	& 'In the routine which make connections between the basins and ensure global coherence,', &
6517	& 'there is a problem with outflow linkup without any valid direction. Try with check=.TRUE.', &
6518	& '(Perhaps there is a problem with the grid.)')
6519	ENDIF
6520	IF (error3) THEN
6521	WRITE(numout,*) " routing_linkup : dop .GT. 0 .AND. dop .NE. undef_int",dop
6522	CALL ipslerr_p(3,'routing_linkup', &
6523	"dop .GT. 0 .AND. dop .NE. undef_int",'Increase nbvmax. Try with check=.TRUE.','stop routing_linkup')
6524	ENDIF
6525	IF (error4) THEN
6526	WRITE(numout,*) " routing_linkup : (sbl .NE. sb) .AND. (basin_id(sp,sbl) .EQ. bid) ", &
6527	& " .AND. (basin_hierarchy(sp,sb) .GT. basin_hierarchy(sp,sbl))",sbl,sb,basin_id(sp,sbl),bid, &
6528	& basin_hierarchy(sp,sb),basin_hierarchy(sp,sbl)
6529	CALL ipslerr_p(3,'routing_linkup', &
6530	"(sbl .NE. sb) .AND. (basin_id(sp,sbl) .EQ. bid) .AND. (basin_hierarchy(sp,sb) .GT. basin_hierarchy(sp,sbl))" &
6531	,'Increase nbvmax. Try with check=.TRUE.','stop routing_linkup')
6532	ENDIF
6533	IF (error5) THEN
6534	WRITE(numout,*) 'We could not find the basin into which we need to flow'
6535	WRITE(numout,*) 'Grid point ', sp, ' and basin ', sb
6536	WRITE(numout,*) 'Explored neighbours :', dm1, dp1
6537	WRITE(numout,*) 'Outflow direction :', basin_flowdir(sp,sb)
6538	WRITE(numout,*) 'Outlfow grid :', outflow_grid(sp,sb)
6539	WRITE(numout,*) 'Outlfow basin :',outflow_basin(sp,sb)
6540	WRITE(numout,*) 'basin ID:',basin_id(sp,sb)
6541	WRITE(numout,*) 'Hierarchy :', basin_hierarchy(sp,sb)
6542	CALL ipslerr_p(3,'routing_linkup', &
6543	"We could not find the basin into which we need to flow",'Try with check=.TRUE.','stop routing_linkup')
6544	ENDIF
6545	!
6546	! Check for each outflow basin that it exists
6547	!
6548	DO sp=1,nbpt
6549	DO sb=1,basin_count(sp)
6550	!
6551	inp = outflow_grid(sp,sb)
6552	sbl = outflow_basin(sp,sb)
6553	IF ( inp .GE. 0 ) THEN
6554	IF ( basin_count(inp) .LT. sbl ) THEN
6555	WRITE(numout,*) 'point :', sp, ' basin :', sb
6556	WRITE(numout,*) 'Flows into point :', inp, ' basin :', sbl
6557	WRITE(numout,*) 'But it flows into now here as basin count = ', basin_count(inp)
6558	CALL ipslerr_p(3,'routing_linkup','Problem with outflow','','')
6559	ENDIF
6560	ENDIF
6561	ENDDO
6562	ENDDO
6563	!
6564	END SUBROUTINE routing_linkup
6565	!
6566	!! ================================================================================================================================
6567	!! SUBROUTINE : routing_fetch
6568	!!
6569	!>\BRIEF This subroutine computes the fetch of each basin. This means that for each basin we
6570	!! will know how much area is upstream. It will help decide how to procede with the
6571	!! the truncation later and allow to set correctly in outflow_grid the distinction
6572	!! between coastal and river flow.
6573	!!
6574	!! DESCRIPTION (definitions, functional, design, flags) : None
6575	!!
6576	!! RECENT CHANGE(S): None
6577	!!
6578	!! MAIN OUTPUT VARIABLE(S):
6579	!!
6580	!! REFERENCES : None
6581	!!
6582	!! FLOWCHART : None
6583	!! \n
6584	!_ ================================================================================================================================
6585
6586	SUBROUTINE routing_fetch(nbpt, resolution, contfrac, nwbas, basin_count, basin_area, basin_id,&
6587	& outflow_grid, outflow_basin, fetch_basin)
6588	!
6589	IMPLICIT NONE
6590	!
6591	!! INPUT VARIABLES
6592	INTEGER(i_std), INTENT(in) :: nbpt !! Domain size (unitless)
6593	!
6594	REAL(r_std), DIMENSION(nbpt,2), INTENT(in) :: resolution !! The size of each grid box in X and Y (m)
6595	REAL(r_std), DIMENSION(nbpt), INTENT(in) :: contfrac !! Fraction of land in each grid box (unitless;0-1)
6596	!
6597	INTEGER(i_std) :: nwbas !!
6598	INTEGER(i_std), DIMENSION(nbpt), INTENT(in) :: basin_count !!
6599	REAL(r_std), DIMENSION(nbpt,nwbas), INTENT(inout) :: basin_area !!
6600	INTEGER(i_std), DIMENSION(nbpt,nwbas), INTENT(in) :: basin_id !!
6601	INTEGER(i_std), DIMENSION(nbpt,nwbas), INTENT(inout) :: outflow_grid !! Type of outflow on the grid box (unitless)
6602	INTEGER(i_std), DIMENSION(nbpt,nwbas), INTENT(in) :: outflow_basin !!
6603	!
6604	!! OUTPUT VARIABLES
6605	REAL(r_std), DIMENSION(nbpt,nwbas), INTENT(out) :: fetch_basin !!
6606	!
6607	!! LOCAL VARIABLES
6608	INTEGER(i_std) :: ib, ij, ff(1), it, itt, igrif, ibasf, nboutflow !! Indices (unitless)
6609	REAL(r_std) :: contarea !!
6610	REAL(r_std) :: totbasins !!
6611	REAL(r_std), DIMENSION(nbpt*nbvmax) :: tmp_area !!
6612	INTEGER(i_std), DIMENSION(nbpt*nbvmax,2) :: tmpindex !!
6613
6614	!_ ================================================================================================================================
6615	!
6616	!
6617	! Normalize the area of all basins
6618	!
6619	DO ib=1,nbpt
6620	!
6621	totbasins = SUM(basin_area(ib,1:basin_count(ib)))
6622	contarea = resolution(ib,1)resolution(ib,2)contfrac(ib)
6623	!
6624	DO ij=1,basin_count(ib)
6625	basin_area(ib,ij) = basin_area(ib,ij)/totbasins*contarea
6626	ENDDO
6627	!
6628	ENDDO
6629	WRITE(numout,*) 'Normalization done'
6630	!
6631	! Compute the area upstream of each basin
6632	!
6633	fetch_basin(:,:) = zero
6634	!
6635	!
6636	DO ib=1,nbpt
6637	!
6638	DO ij=1,basin_count(ib)
6639	!
6640	fetch_basin(ib, ij) = fetch_basin(ib, ij) + basin_area(ib,ij)
6641	!
6642	igrif = outflow_grid(ib,ij)
6643	ibasf = outflow_basin(ib,ij)
6644	!
6645	itt = 0
6646	DO WHILE (igrif .GT. 0)
6647	fetch_basin(igrif,ibasf) = fetch_basin(igrif,ibasf) + basin_area(ib, ij)
6648	it = outflow_grid(igrif, ibasf)
6649	ibasf = outflow_basin(igrif, ibasf)
6650	igrif = it
6651	itt = itt + 1
6652	IF ( itt .GT. 500) THEN
6653	WRITE(numout,&
6654	"('Grid ',I5, ' and basin ',I5, 'did not converge after iteration ',I5)") ib, ij, itt
6655	WRITE(numout,*) 'Basin ID :', basin_id(igrif,ibasf)
6656	WRITE(numout,&
6657	"('We are stuck with the flow into grid ',I5,' and basin ',I5)") igrif, ibasf
6658	WRITE(numout,*) "Coordinates : ", lalo_g(igrif,2), lalo_g(igrif,1)
6659	IF ( itt .GT. 510) THEN
6660	CALL ipslerr_p(3,'routing_fetch','Problem...','','')
6661	ENDIF
6662	ENDIF
6663	ENDDO
6664	!
6665	ENDDO
6666	!
6667	ENDDO
6668	!
6669	WRITE(numout,*) 'The smallest FETCH :', MINVAL(fetch_basin)
6670	WRITE(numout,*) 'The largest FETCH :', MAXVAL(fetch_basin)
6671	!
6672	! Now we set for the 'num_largest' largest basins the outflow condition as stream flow
6673	! (i.e. outflow_grid = -1) and all other outflow basins are set to coastal flow
6674	! (i.e. outflow_grid = -2). The return flow is not touched.
6675	!
6676	nboutflow = 0
6677	!
6678	DO ib=1,nbpt
6679	!
6680	DO ij=1,basin_count(ib)
6681	!
6682	! We do not need any more the river flow flag as we are going to reset it.
6683	!
6684	IF ( outflow_grid(ib,ij) .EQ. -1) THEN
6685	outflow_grid(ib,ij) = -2
6686	ENDIF
6687	!
6688	IF ( outflow_grid(ib,ij) .EQ. -2) THEN
6689	!
6690	nboutflow = nboutflow + 1
6691	tmp_area(nboutflow) = fetch_basin(ib,ij)
6692	tmpindex(nboutflow,1) = ib
6693	tmpindex(nboutflow,2) = ij
6694	!
6695	ENDIF
6696	!
6697	ENDDO
6698	ENDDO
6699	!
6700	DO ib=1, num_largest
6701	ff = MAXLOC(tmp_area(1:nboutflow))
6702	outflow_grid(tmpindex(ff(1),1), tmpindex(ff(1),2)) = -1
6703	tmp_area(ff(1)) = zero
6704	ENDDO
6705	!
6706	END SUBROUTINE routing_fetch
6707	!
6708	!! ================================================================================================================================
6709	!! SUBROUTINE : routing_truncate
6710	!!
6711	!>\BRIEF This subroutine reduces the number of basins per grid to the value chosen by the user.
6712	!! It also computes the final field which will be used to route the water at the
6713	!! requested truncation.
6714	!!
6715	!! DESCRIPTION (definitions, functional, design, flags) :
6716	!! Truncate if needed and find the path closest to the high resolution data.
6717	!!
6718	!! The algorithm :
6719	!!
6720	!! We only go through this procedure only as many times as there are basins to take out at most.
6721	!! This is important as it allows the simplifications to spread from one grid to the other.
6722	!! The for each step of the iteration and at each grid point we check the following options for
6723	!! simplifying the pathways of water :
6724	!! 1) If the basin of a grid flows into another basin of the same grid. Kill the one which only
6725	!! served as a transition
6726	!! 2) If in one grid box we have a number of basins which flow into the ocean as coastal flow.
6727	!! We kill the smallest one and put into the largest basin. There is no need to manage many
6728	!! basins going into the ocean as coastal flows.
6729	!! 3) If we have streams run in parallel from one gird box to the others (that is these are
6730	!! different basins) we will put the smaller one in the larger one. This may hapen at any
6731	!! level of the flow but in theory it should propagate downstream.
6732	!! 4) If we have two basins with the same ID but flow into different grid boxes we sacrifice
6733	!! the smallest one and route it through the largest.
6734	!!
6735	!! Obviously if any of the options find something then we skip the rest and take out the basin.:\n
6736	!!
6737	!! RECENT CHANGE(S): None
6738	!!
6739	!! MAIN OUTPUT VARIABLE(S):
6740	!!
6741	!! REFERENCES : None
6742	!!
6743	!! FLOWCHART : None
6744	!! \n
6745	!_ ================================================================================================================================
6746
6747	SUBROUTINE routing_truncate(nbpt, resolution, contfrac, nwbas, basin_count, basin_area, basin_topoind,&
6748	& fetch_basin, basin_id, basin_flowdir, outflow_grid, outflow_basin, inflow_number,&
6749	& inflow_grid, inflow_basin)
6750	!
6751	IMPLICIT NONE
6752	!
6753	!! PARAMETERS
6754	INTEGER(i_std), PARAMETER :: pickmax = 200 !!
6755
6756	!! INPUT VARIABLES
6757	INTEGER(i_std) :: nbpt !! Domain size (unitless)
6758	!
6759	REAL(r_std), DIMENSION(nbpt,2) :: resolution !! The size of each grid box in X and Y (m)
6760	REAL(r_std), DIMENSION(nbpt), INTENT(in) :: contfrac !! Fraction of land in each grid box (unitless;0-1)
6761	!
6762	INTEGER(i_std) :: nwbas !!
6763	INTEGER(i_std), DIMENSION(nbpt) :: basin_count !!
6764	INTEGER(i_std), DIMENSION(nbpt,nwbas) :: basin_id !!
6765	INTEGER(i_std), DIMENSION(nbpt,nwbas) :: basin_flowdir !! Water flow directions in the basin (unitless)
6766	REAL(r_std), DIMENSION(nbpt,nwbas) :: basin_area !!
6767	REAL(r_std), DIMENSION(nbpt,nwbas) :: basin_topoind !! Topographic index of the residence time for a basin (m)
6768	REAL(r_std), DIMENSION(nbpt,nwbas) :: fetch_basin !!
6769	INTEGER(i_std), DIMENSION(nbpt,nwbas) :: outflow_grid !! Type of outflow on the grid box (unitless)
6770	INTEGER(i_std), DIMENSION(nbpt,nwbas) :: outflow_basin !!
6771	INTEGER(i_std), DIMENSION(nbpt,nwbas) :: inflow_number !!
6772	INTEGER(i_std), DIMENSION(nbpt,nwbas,nwbas) :: inflow_basin !!
6773	INTEGER(i_std), DIMENSION(nbpt,nwbas,nwbas) :: inflow_grid !!
6774	!
6775	!! LOCAL VARIABLES
6776	INTEGER(i_std) :: ib, ij, ibf, ijf, igrif, ibasf, cnt, pold, bold, ff(2) !! Indices (unitless)
6777	INTEGER(i_std) :: ii, kbas, sbas, ik, iter, ibt, obj !! Indices (unitless)
6778	REAL(r_std), DIMENSION(nbpt,nbasmax) :: floflo !!
6779	REAL(r_std), DIMENSION(nbpt) :: gridarea !!
6780	REAL(r_std), DIMENSION(nbpt) :: gridbasinarea !!
6781	REAL(r_std) :: ratio !!
6782	INTEGER(i_std), DIMENSION(pickmax,2) :: largest_basins !!
6783	INTEGER(i_std), DIMENSION(pickmax) :: tmp_ids !!
6784	INTEGER(i_std) :: multbas !!
6785	INTEGER(i_std) :: iml(1) !! X resolution of the high resolution grid
6786	INTEGER(i_std), DIMENSION(pickmax) :: multbas_sz !!
6787	REAL(r_std), DIMENSION(pickmax) :: tmp_area !!
6788	INTEGER(i_std), DIMENSION(pickmax,pickmax) :: multbas_list !!
6789	!
6790	INTEGER(i_std) :: nbtruncate !!
6791	INTEGER(i_std), SAVE, ALLOCATABLE, DIMENSION(:) :: indextrunc !!
6792	!$OMP THREADPRIVATE(indextrunc)
6793
6794	!_ ================================================================================================================================
6795	!
6796	!
6797	IF ( .NOT. ALLOCATED(indextrunc)) THEN
6798	ALLOCATE(indextrunc(nbpt))
6799	ENDIF
6800	!
6801	! We have to go through the grid as least as often as we have to reduce the number of basins
6802	! For good measure we add 3 more passages.
6803	!
6804	!
6805	DO iter = 1, MAXVAL(basin_count) - nbasmax +3
6806	!
6807	! Get the points over which we wish to truncate
6808	!
6809	nbtruncate = 0
6810	DO ib = 1, nbpt
6811	IF ( basin_count(ib) .GT. nbasmax ) THEN
6812	nbtruncate = nbtruncate + 1
6813	indextrunc(nbtruncate) = ib
6814	ENDIF
6815	ENDDO
6816	!
6817	! Go through the basins which need to be truncated.
6818	!
6819	DO ibt=1,nbtruncate
6820	!
6821	ib = indextrunc(ibt)
6822	!
6823	! Check if we have basin which flows into a basin in the same grid
6824	! kbas = basin we will have to kill
6825	! sbas = basin which takes over kbas
6826	!
6827	kbas = 0
6828	sbas = 0
6829	!
6830	! 1) Can we find a basin which flows into a basin of the same grid ?
6831	!
6832	DO ij=1,basin_count(ib)
6833	DO ii=1,basin_count(ib)
6834	IF ( outflow_grid(ib,ii) .EQ. ib .AND. outflow_basin(ib, ii) .EQ. ij .AND. kbas*sbas .NE. 0) THEN
6835	kbas = ii
6836	sbas = ij
6837	ENDIF
6838	ENDDO
6839	ENDDO
6840	!
6841	! 2) Merge two basins which flow into the ocean as coastal or return flow
6842	! (outflow_grid = -2 or -3). Well obviously only if we have more than 1 and
6843	! have not found anything yet!
6844	!
6845	IF ( (COUNT(outflow_grid(ib,1:basin_count(ib)) .EQ. -2) .GT. 1 .OR.&
6846	& COUNT(outflow_grid(ib,1:basin_count(ib)) .EQ. -3) .GT. 1) .AND.&
6847	& kbas*sbas .EQ. 0) THEN
6848	!
6849	multbas = 0
6850	multbas_sz(:) = 0
6851	!
6852	IF ( COUNT(outflow_grid(ib,1:basin_count(ib)) .EQ. -2) .GT. 1 ) THEN
6853	obj = -2
6854	ELSE
6855	obj = -3
6856	ENDIF
6857	!
6858	! First we get the list of all basins which go out as coastal or return flow (obj)
6859	!
6860	DO ij=1,basin_count(ib)
6861	IF ( outflow_grid(ib,ij) .EQ. obj ) THEN
6862	multbas = multbas + 1
6863	multbas_sz(multbas) = ij
6864	tmp_area(multbas) = fetch_basin(ib,ij)
6865	ENDIF
6866	ENDDO
6867	!
6868	! Now the take the smallest to be transfered to the largest
6869	!
6870	iml = MAXLOC(tmp_area(1:multbas), MASK = tmp_area(1:multbas) .GT. zero)
6871	sbas = multbas_sz(iml(1))
6872	iml = MINLOC(tmp_area(1:multbas), MASK = tmp_area(1:multbas) .GT. zero)
6873	kbas = multbas_sz(iml(1))
6874	!
6875	ENDIF
6876	!
6877	! 3) If we have basins flowing into the same grid but different basins then we put them
6878	! together. Obviously we first work with the grid which has most streams running into it
6879	! and putting the smallest in the largests catchments.
6880	!
6881	IF ( kbas*sbas .EQ. 0) THEN
6882	!
6883	tmp_ids(1:basin_count(ib)) = outflow_grid(ib,1:basin_count(ib))
6884	multbas = 0
6885	multbas_sz(:) = 0
6886	!
6887	! First obtain the list of basins which flow into the same basin
6888	!
6889	DO ij=1,basin_count(ib)
6890	IF ( outflow_grid(ib,ij) .GT. 0 .AND.&
6891	& COUNT(tmp_ids(1:basin_count(ib)) .EQ. outflow_grid(ib,ij)) .GT. 1) THEN
6892	multbas = multbas + 1
6893	DO ii=1,basin_count(ib)
6894	IF ( tmp_ids(ii) .EQ. outflow_grid(ib,ij)) THEN
6895	multbas_sz(multbas) = multbas_sz(multbas) + 1
6896	multbas_list(multbas,multbas_sz(multbas)) = ii
6897	tmp_ids(ii) = -99
6898	ENDIF
6899	ENDDO
6900	ELSE
6901	tmp_ids(ij) = -99
6902	ENDIF
6903	ENDDO
6904	!
6905	! Did we come up with any basins to deal with this way ?
6906	!
6907	IF ( multbas .GT. 0 ) THEN
6908	!
6909	iml = MAXLOC(multbas_sz(1:multbas))
6910	ik = iml(1)
6911	!
6912	! Take the smallest and largest of these basins !
6913	!
6914	DO ii=1,multbas_sz(ik)
6915	tmp_area(ii) = fetch_basin(ib, multbas_list(ik,ii))
6916	ENDDO
6917	!
6918	iml = MAXLOC(tmp_area(1:multbas_sz(ik)), MASK = tmp_area(1:multbas_sz(ik)) .GT. zero)
6919	sbas = multbas_list(ik,iml(1))
6920	iml = MINLOC(tmp_area(1:multbas_sz(ik)), MASK = tmp_area(1:multbas_sz(ik)) .GT. zero)
6921	kbas = multbas_list(ik,iml(1))
6922	!
6923	ENDIF
6924	!
6925	ENDIF
6926	!
6927	! 4) If we have twice the same basin we put them together even if they flow into different
6928	! directions. If one of them goes to the ocean it takes the advantage.
6929	!
6930	IF ( kbas*sbas .EQ. 0) THEN
6931	!
6932	tmp_ids(1:basin_count(ib)) = basin_id(ib,1:basin_count(ib))
6933	multbas = 0
6934	multbas_sz(:) = 0
6935	!
6936	! First obtain the list of basins which have sub-basins in this grid box.
6937	! (these are identified by their IDs)
6938	!
6939	DO ij=1,basin_count(ib)
6940	IF ( COUNT(tmp_ids(1:basin_count(ib)) .EQ. basin_id(ib,ij)) .GT. 1) THEN
6941	multbas = multbas + 1
6942	DO ii=1,basin_count(ib)
6943	IF ( tmp_ids(ii) .EQ. basin_id(ib,ij)) THEN
6944	multbas_sz(multbas) = multbas_sz(multbas) + 1
6945	multbas_list(multbas,multbas_sz(multbas)) = ii
6946	tmp_ids(ii) = -99
6947	ENDIF
6948	ENDDO
6949	ELSE
6950	tmp_ids(ij) = -99
6951	ENDIF
6952	ENDDO
6953	!
6954	! We are going to work on the basin with the largest number of sub-basins.
6955	! (IF we have a basin which has subbasins !)
6956	!
6957	IF ( multbas .GT. 0 ) THEN
6958	!
6959	iml = MAXLOC(multbas_sz(1:multbas))
6960	ik = iml(1)
6961	!
6962	! If one of the basins goes to the ocean then it is going to have the priority
6963	!
6964	tmp_area(:) = zero
6965	IF ( COUNT(outflow_grid(ib,multbas_list(ik,1:multbas_sz(ik))) .LT. 0) .GT. 0) THEN
6966	DO ii=1,multbas_sz(ik)
6967	IF ( outflow_grid(ib,multbas_list(ik,ii)) .LT. 0 .AND. sbas .EQ. 0 ) THEN
6968	sbas = multbas_list(ik,ii)
6969	ELSE
6970	tmp_area(ii) = fetch_basin(ib, multbas_list(ik,ii))
6971	ENDIF
6972	ENDDO
6973	! take the smallest of the subbasins
6974	iml = MINLOC(tmp_area(1:multbas_sz(ik)), MASK = tmp_area(1:multbas_sz(ik)) .GT. zero)
6975	kbas = multbas_list(ik,iml(1))
6976	ELSE
6977	!
6978	! Else we take simply the largest and smallest
6979	!
6980	DO ii=1,multbas_sz(ik)
6981	tmp_area(ii) = fetch_basin(ib, multbas_list(ik,ii))
6982	ENDDO
6983	iml = MAXLOC(tmp_area(1:multbas_sz(ik)), MASK = tmp_area(1:multbas_sz(ik)) .GT. zero)
6984	sbas = multbas_list(ik,iml(1))
6985	iml = MINLOC(tmp_area(1:multbas_sz(ik)), MASK = tmp_area(1:multbas_sz(ik)) .GT. zero)
6986	kbas = multbas_list(ik,iml(1))
6987	!
6988	ENDIF
6989	!
6990	!
6991	ENDIF
6992	ENDIF
6993	!
6994	!
6995	!
6996	! Then we call routing_killbas to clean up the basins in this grid
6997	!
6998	IF ( kbas .GT. 0 .AND. sbas .GT. 0 ) THEN
6999	CALL routing_killbas(nbpt, ib, kbas, sbas, nwbas, basin_count, basin_area, basin_topoind,&
7000	& fetch_basin, basin_id, basin_flowdir, outflow_grid, outflow_basin, inflow_number,&
7001	& inflow_grid, inflow_basin)
7002	ENDIF
7003	!
7004	ENDDO
7005	!
7006	!
7007	ENDDO
7008	!
7009	! If there are any grids left with too many basins we need to take out the big hammer !
7010	! We will only do it if this represents less than 5% of all points.
7011	!
7012	IF ( COUNT(basin_count .GT. nbasmax) .GT. 0 ) THEN
7013	!
7014	!
7015	IF ( COUNT(basin_count .GT. nbasmax)/nbpt*100 .GT. 5 ) THEN
7016	WRITE(numout,) 'We have ', COUNT(basin_count .GT. nbasmax)/nbpt100, '% of all points which do not yet'
7017	WRITE(numout,*) 'have the right trunctaction. That is too much to apply a brutal method'
7018	DO ib = 1, nbpt
7019	IF ( basin_count(ib) .GT. nbasmax ) THEN
7020	!
7021	WRITE(numout,*) 'We did not find a basin which could be supressed. We will'
7022	WRITE(numout,*) 'not be able to reduce the truncation in grid ', ib
7023	DO ij=1,basin_count(ib)
7024	WRITE(numout,*) 'grid, basin nb and id :', ib, ij, basin_id(ib,ij)
7025	WRITE(numout,*) 'Outflow grid and basin ->', outflow_grid(ib,ij), outflow_basin(ib, ij)
7026	ENDDO
7027	ENDIF
7028	ENDDO
7029	CALL ipslerr_p(3,'routing_truncate','No basin found which could be supressed.','','')
7030	ELSE
7031	!
7032	!
7033	DO ib = 1,nbpt
7034	DO WHILE ( basin_count(ib) .GT. nbasmax )
7035	!
7036	IF (printlev>=3) WRITE(numout,*) 'HAMMER, ib, basin_count :', ib, basin_count(ib)
7037	!
7038	! Here we simply put the smallest basins into the largest ones. It is really a brute force
7039	! method but it will only be applied if everything has failed.
7040	!
7041	DO ii = 1,basin_count(ib)
7042	tmp_area(ii) = fetch_basin(ib, ii)
7043	ENDDO
7044	!
7045	iml = MAXLOC(tmp_area(1:basin_count(ib)), MASK = tmp_area(1:basin_count(ib)) .GT. 0.)
7046	sbas =iml(1)
7047	iml = MINLOC(tmp_area(1:basin_count(ib)), MASK = tmp_area(1:basin_count(ib)) .GT. 0.)
7048	kbas = iml(1)
7049	!
7050	IF ( kbas .GT. 0 .AND. sbas .GT. 0 ) THEN
7051	CALL routing_killbas(nbpt, ib, kbas, sbas, nwbas, basin_count, basin_area, basin_topoind,&
7052	& fetch_basin, basin_id, basin_flowdir, outflow_grid, outflow_basin, inflow_number,&
7053	& inflow_grid, inflow_basin)
7054	ENDIF
7055	ENDDO
7056	ENDDO
7057	!
7058	ENDIF
7059	!
7060	!
7061	ENDIF
7062	!
7063	! Now that we have reached the right truncation (resolution) we will start
7064	! to produce the variables we will use to route the water.
7065	!
7066	DO ib=1,nbpt
7067	!
7068	! For non existing basins the route_tobasin variable is put to zero. This will allow us
7069	! to pick up the number of basin afterwards.
7070	!
7071	route_togrid(ib,:) = ib
7072	route_tobasin(ib,:) = 0
7073	routing_area(ib,:) = zero
7074	!
7075	ENDDO
7076	!
7077	! Transfer the info into the definitive variables
7078	!
7079	DO ib=1,nbpt
7080	DO ij=1,basin_count(ib)
7081	routing_area(ib,ij) = basin_area(ib,ij)
7082	topo_resid(ib,ij) = basin_topoind(ib,ij)
7083	global_basinid(ib,ij) = basin_id(ib,ij)
7084	route_togrid(ib,ij) = outflow_grid(ib,ij)
7085	route_tobasin(ib,ij) = outflow_basin(ib,ij)
7086	ENDDO
7087	ENDDO
7088	!
7089	!
7090	! Set the new convention for the outflow conditions
7091	! Now it is based in the outflow basin and the outflow grid will
7092	! be the same as the current.
7093	! returnflow to the grid : nbasmax + 1
7094	! coastal flow : nbasmax + 2
7095	! river outflow : nbasmax + 3
7096	!
7097	! Here we put everything here in coastal flow. It is later where we will
7098	! put the largest basins into river outflow.
7099	!
7100	DO ib=1,nbpt
7101	DO ij=1,basin_count(ib)
7102	! River flows
7103	IF ( route_togrid(ib,ij) .EQ. -1 ) THEN
7104	route_tobasin(ib,ij) = nbasmax + 2
7105	route_togrid(ib,ij) = ib
7106	! Coastal flows
7107	ELSE IF ( route_togrid(ib,ij) .EQ. -2 ) THEN
7108	route_tobasin(ib,ij) = nbasmax + 2
7109	route_togrid(ib,ij) = ib
7110	! Return flow
7111	ELSE IF ( route_togrid(ib,ij) .EQ. -3 ) THEN
7112	route_tobasin(ib,ij) = nbasmax + 1
7113	route_togrid(ib,ij) = ib
7114	ENDIF
7115	ENDDO
7116	ENDDO
7117	!
7118	! A second check on the data. Just make sure that each basin flows somewhere.
7119	!
7120	DO ib=1,nbpt
7121	DO ij=1,basin_count(ib)
7122	ibf = route_togrid(ib,ij)
7123	ijf = route_tobasin(ib,ij)
7124	IF ( ijf .GT. basin_count(ibf) .AND. ijf .LE. nbasmax) THEN
7125	WRITE(numout,*) 'Second check'
7126	WRITE(numout,*) 'point :', ib, ' basin :', ij
7127	WRITE(numout,*) 'Flows into point :', ibf, ' basin :', ijf
7128	WRITE(numout,*) 'But it flows into now here as basin count = ', basin_count(ibf)
7129	CALL ipslerr_p(3,'routing_truncate','Problem with routing..','','')
7130	ENDIF
7131	ENDDO
7132	ENDDO
7133	!
7134	! Verify areas of the continents
7135	!
7136	floflo(:,:) = zero
7137	gridarea(:) = contfrac(:)resolution(:,1)resolution(:,2)
7138	DO ib=1,nbpt
7139	gridbasinarea(ib) = SUM(routing_area(ib,:))
7140	ENDDO
7141	!
7142	DO ib=1,nbpt
7143	DO ij=1,basin_count(ib)
7144	cnt = 0
7145	igrif = ib
7146	ibasf = ij
7147	DO WHILE (ibasf .LE. nbasmax .AND. cnt .LT. nbasmax*nbpt)
7148	cnt = cnt + 1
7149	pold = igrif
7150	bold = ibasf
7151	igrif = route_togrid(pold, bold)
7152	ibasf = route_tobasin(pold, bold)
7153	IF ( ibasf .GT. basin_count(igrif) .AND. ibasf .LE. nbasmax) THEN
7154	WRITE(numout,*) 'We should not be here as the basin flows into the pampa'
7155	WRITE(numout,*) 'Last correct point :', pold, bold
7156	WRITE(numout,*) 'It pointed to in the new variables :', route_togrid(pold, bold),route_tobasin(pold, bold)
7157	WRITE(numout,*) 'The old variables gave :', outflow_grid(pold, bold), outflow_basin(pold, bold)
7158	WRITE(numout,*) 'Where we ended up :', igrif,ibasf
7159	CALL ipslerr_p(3,'routing_truncate','Problem with routing..','','')
7160	ENDIF
7161	ENDDO
7162	!
7163	IF ( ibasf .GT. nbasmax ) THEN
7164	floflo(igrif,bold) = floflo(igrif,bold) + routing_area(ib,ij)
7165	ELSE
7166	WRITE(numout,*) 'The flow did not end up in the ocean or in the grid cell.'
7167	WRITE(numout,*) 'For grid ', ib, ' and basin ', ij
7168	WRITE(numout,*) 'The last grid was ', igrif, ' and basin ', ibasf
7169	CALL ipslerr_p(3,'routing_truncate','Problem with routing..','','')
7170	ENDIF
7171	ENDDO
7172	ENDDO
7173	!
7174	DO ib=1,nbpt
7175	IF ( gridbasinarea(ib) > zero ) THEN
7176	ratio = gridarea(ib)/gridbasinarea(ib)
7177	routing_area(ib,:) = routing_area(ib,:)*ratio
7178	ELSE
7179	WRITE(numout,*) 'gridbasinarea(ib) <= zero. We should stop here :', ib
7180	ENDIF
7181	ENDDO
7182	!
7183	WRITE(numout,*) 'Sum of area of all outflow areas :',SUM(routing_area)
7184	WRITE(numout,*) 'Surface of all continents :', SUM(gridarea)
7185	!
7186	! Redo the the distinction between river outflow and coastal flow. We can not
7187	! take into account the return flow points.
7188	!
7189	ibf = 0
7190	DO ib=1, pickmax
7191	ff = MAXLOC(floflo)
7192	! tdo - To take into account rivers that do not flow to the oceans
7193	IF ( route_tobasin(ff(1), ff(2)) .GT. nbasmax ) THEN
7194	! IF ( route_tobasin(ff(1), ff(2)) .EQ. nbasmax + 2) THEN
7195	ibf = ibf + 1
7196	largest_basins(ibf,:) = ff(:)
7197	ENDIF
7198	floflo(ff(1), ff(2)) = zero
7199	ENDDO
7200	!
7201	! Put the largest basins into river flows.
7202	!
7203	IF ( ibf .LT. num_largest) THEN
7204	WRITE(numout,*) 'Not enough basins to choose the ', num_largest, 'largest'
7205	CALL ipslerr_p(3,'routing_truncate','Not enough basins','','')
7206	ENDIF
7207	!
7208	!
7209	!
7210	DO ib=1, num_largest
7211	route_tobasin(largest_basins(ib,1),largest_basins(ib,2)) = nbasmax + 3
7212	ENDDO
7213	!
7214	WRITE(numout,*) 'NUMBER OF RIVERS :', COUNT(route_tobasin .GE. nbasmax + 3)
7215	!
7216	END SUBROUTINE routing_truncate
7217	!
7218	!! ================================================================================================================================
7219	!! SUBROUTINE : routing_killbas
7220	!!
7221	!>\BRIEF The aim of this subroutine is to kill a basin (that is put into another larger one).
7222	!! When we do this we need to be careful and change all associated variables.
7223	!!
7224	!! DESCRIPTION (definitions, functional, design, flags) : None
7225	!!
7226	!! RECENT CHANGE(S): None
7227	!!
7228	!! MAIN OUTPUT VARIABLE(S):
7229	!!
7230	!! REFERENCES : None
7231	!!
7232	!! FLOWCHART : None
7233	!! \n
7234	!_ ================================================================================================================================
7235
7236	SUBROUTINE routing_killbas(nbpt, ib, tokill, totakeover, nwbas, basin_count, basin_area, basin_topoind,&
7237	& fetch_basin, basin_id, basin_flowdir, outflow_grid, outflow_basin, inflow_number,&
7238	& inflow_grid, inflow_basin)
7239	!
7240	!
7241	IMPLICIT NONE
7242	!
7243	INTEGER(i_std) :: tokill !!
7244	INTEGER(i_std) :: totakeover !!
7245	INTEGER(i_std) :: nbpt !! Domain size (unitless)
7246	INTEGER(i_std) :: ib !! Current basin (unitless)
7247	!
7248	INTEGER(i_std) :: nwbas !!
7249	INTEGER(i_std), DIMENSION(nbpt) :: basin_count !!
7250	INTEGER(i_std), DIMENSION(nbpt,nwbas) :: basin_id !!
7251	INTEGER(i_std), DIMENSION(nbpt,nwbas) :: basin_flowdir !! Water flow directions in the basin (unitless)
7252	REAL(r_std), DIMENSION(nbpt,nwbas) :: basin_area !!
7253	REAL(r_std), DIMENSION(nbpt,nwbas) :: basin_topoind !! Topographic index of the residence time for a basin (m)
7254	REAL(r_std), DIMENSION(nbpt,nwbas) :: fetch_basin !!
7255	INTEGER(i_std), DIMENSION(nbpt,nwbas) :: outflow_grid !! Type of outflow on the grid box (unitless)
7256	INTEGER(i_std), DIMENSION(nbpt,nwbas) :: outflow_basin !!
7257	INTEGER(i_std), DIMENSION(nbpt,nwbas) :: inflow_number !!
7258	INTEGER(i_std), DIMENSION(nbpt,nwbas,nwbas) :: inflow_basin !!
7259	INTEGER(i_std), DIMENSION(nbpt,nwbas,nwbas) :: inflow_grid !!
7260	!
7261	!! LOCAL VARIABLES
7262	INTEGER(i_std) :: inf, ibs, ing, inb, ibasf, igrif, it !! Indices (unitless)
7263	LOGICAL :: doshift !! (true/false)
7264
7265	!_ ================================================================================================================================
7266	!
7267	! Update the information needed in the basin "totakeover"
7268	! For the moment only area
7269	!
7270	IF (printlev>=3) THEN
7271	WRITE(numout,*) 'KILL BASIN :', ib, tokill, totakeover, basin_id(ib,tokill), basin_id(ib,totakeover)
7272	END IF
7273	!
7274	basin_area(ib, totakeover) = basin_area(ib, totakeover) + basin_area(ib, tokill)
7275	basin_topoind(ib, totakeover) = (basin_topoind(ib, totakeover) + basin_topoind(ib, tokill))/2.0
7276	!
7277	! Add the fetch of the basin will kill to the one which gets the water
7278	!
7279	fetch_basin(ib, totakeover) = fetch_basin(ib, totakeover) + fetch_basin(ib, tokill)
7280	igrif = outflow_grid(ib,totakeover)
7281	ibasf = outflow_basin(ib,totakeover)
7282	!
7283	inf = 0
7284	DO WHILE (igrif .GT. 0)
7285	fetch_basin(igrif,ibasf) = fetch_basin(igrif,ibasf) + fetch_basin(ib, tokill)
7286	it = outflow_grid(igrif, ibasf)
7287	ibasf = outflow_basin(igrif, ibasf)
7288	igrif = it
7289	inf = inf + 1
7290	ENDDO
7291	!
7292	! Take out the basin we have just rerouted from the fetch of the basins in which it used to flow.
7293	!
7294	igrif = outflow_grid(ib,tokill)
7295	ibasf = outflow_basin(ib,tokill)
7296	!
7297	DO WHILE (igrif .GT. 0)
7298	fetch_basin(igrif,ibasf) = fetch_basin(igrif,ibasf) - fetch_basin(ib, tokill)
7299	it = outflow_grid(igrif, ibasf)
7300	ibasf = outflow_basin(igrif, ibasf)
7301	igrif = it
7302	ENDDO
7303	!
7304	! Redirect the flows which went into the basin to be killed before we change everything
7305	!
7306	DO inf = 1, inflow_number(ib, tokill)
7307	outflow_basin(inflow_grid(ib, tokill, inf), inflow_basin(ib, tokill, inf)) = totakeover
7308	inflow_number(ib, totakeover) = inflow_number(ib, totakeover) + 1
7309	inflow_grid(ib, totakeover, inflow_number(ib, totakeover)) = inflow_grid(ib, tokill, inf)
7310	inflow_basin(ib, totakeover, inflow_number(ib, totakeover)) = inflow_basin(ib, tokill, inf)
7311	ENDDO
7312	!
7313	! Take out the basin to be killed from the list of inflow basins of the downstream basin
7314	! (In case the basin does not flow into an ocean or lake)
7315	!
7316	IF ( outflow_grid(ib,tokill) .GT. 0) THEN
7317	!
7318	ing = outflow_grid(ib, tokill)
7319	inb = outflow_basin(ib, tokill)
7320	doshift = .FALSE.
7321	!
7322	DO inf = 1, inflow_number(ing, inb)
7323	IF ( doshift ) THEN
7324	inflow_grid(ing, inb, inf-1) = inflow_grid(ing, inb, inf)
7325	inflow_basin(ing, inb, inf-1) = inflow_basin(ing, inb, inf)
7326	ENDIF
7327	IF ( inflow_grid(ing, inb, inf) .EQ. ib .AND. inflow_basin(ing, inb, inf) .EQ. tokill) THEN
7328	doshift = .TRUE.
7329	ENDIF
7330	ENDDO
7331	!
7332	! This is only to allow for the last check
7333	!
7334	inf = inflow_number(ing, inb)
7335	IF ( inflow_grid(ing, inb, inf) .EQ. ib .AND. inflow_basin(ing, inb, inf) .EQ. tokill) THEN
7336	doshift = .TRUE.
7337	ENDIF
7338	!
7339	IF ( .NOT. doshift ) THEN
7340	WRITE(numout,*) 'Strange we did not find the basin to kill in the downstream basin'
7341	CALL ipslerr_p(3,'routing_killbas','Basin not found','','')
7342	ENDIF
7343	inflow_number(ing, inb) = inflow_number(ing, inb) - 1
7344
7345	ENDIF
7346	!
7347	! Now remove from the arrays the information of basin "tokill"
7348	!
7349	basin_id(ib, tokill:basin_count(ib)-1) = basin_id(ib, tokill+1:basin_count(ib))
7350	basin_flowdir(ib, tokill:basin_count(ib)-1) = basin_flowdir(ib, tokill+1:basin_count(ib))
7351	basin_area(ib, tokill:basin_count(ib)-1) = basin_area(ib, tokill+1:basin_count(ib))
7352	basin_area(ib, basin_count(ib):nwbas) = zero
7353	basin_topoind(ib, tokill:basin_count(ib)-1) = basin_topoind(ib, tokill+1:basin_count(ib))
7354	basin_topoind(ib, basin_count(ib):nwbas) = zero
7355	fetch_basin(ib, tokill:basin_count(ib)-1) = fetch_basin(ib, tokill+1:basin_count(ib))
7356	fetch_basin(ib, basin_count(ib):nwbas) = zero
7357	!
7358	! Before we remove the information from the outflow fields we have to correct the corresponding inflow fields
7359	! of the grids into which the flow goes
7360	!
7361	DO ibs = tokill+1,basin_count(ib)
7362	ing = outflow_grid(ib, ibs)
7363	inb = outflow_basin(ib, ibs)
7364	IF ( ing .GT. 0 ) THEN
7365	DO inf = 1, inflow_number(ing, inb)
7366	IF ( inflow_grid(ing,inb,inf) .EQ. ib .AND. inflow_basin(ing,inb,inf) .EQ. ibs) THEN
7367	inflow_basin(ing,inb,inf) = ibs - 1
7368	ENDIF
7369	ENDDO
7370	ENDIF
7371	ENDDO
7372	outflow_grid(ib, tokill:basin_count(ib)-1) = outflow_grid(ib, tokill+1:basin_count(ib))
7373	outflow_basin(ib, tokill:basin_count(ib)-1) = outflow_basin(ib, tokill+1:basin_count(ib))
7374	!
7375	! Basins which moved down also need to redirect their incoming flows.
7376	!
7377	DO ibs=tokill+1, basin_count(ib)
7378	DO inf = 1, inflow_number(ib, ibs)
7379	outflow_basin(inflow_grid(ib, ibs, inf), inflow_basin(ib, ibs, inf)) = ibs-1
7380	ENDDO
7381	ENDDO
7382	!
7383	! Shift the inflow basins
7384	!
7385	DO it = tokill+1,basin_count(ib)
7386	inflow_grid(ib, it-1, 1:inflow_number(ib,it)) = inflow_grid(ib, it, 1:inflow_number(ib,it))
7387	inflow_basin(ib, it-1, 1:inflow_number(ib,it)) = inflow_basin(ib, it, 1:inflow_number(ib,it))
7388	inflow_number(ib,it-1) = inflow_number(ib,it)
7389	ENDDO
7390	!
7391	basin_count(ib) = basin_count(ib) - 1
7392	!
7393	END SUBROUTINE routing_killbas
7394	!
7395	!! ================================================================================================================================
7396	!! SUBROUTINE : routing_names
7397	!!
7398	!>\BRIEF This subroutine lists the name of the largest basins which are explicitly listed in the basin
7399	!! description file used by ORCHIDEE.
7400	!!
7401	!! DESCRIPTION (definitions, functional, design, flags) : None
7402	!!
7403	!! RECENT CHANGE(S): None
7404	!!
7405	!! MAIN OUTPUT VARIABLE(S):
7406	!!
7407	!! REFERENCES : None
7408	!!
7409	!! FLOWCHART : None
7410	!! \n
7411	!_ ================================================================================================================================
7412
7413	SUBROUTINE routing_names(numlar, basin_names)
7414	!
7415	IMPLICIT NONE
7416	!
7417	! Arguments
7418	!
7419	INTEGER(i_std), INTENT(in) :: numlar !!
7420	CHARACTER(LEN=*), INTENT(inout) :: basin_names(numlar) !! Name of the basins (unitless)
7421	!! PARAMETERS
7422	INTEGER(i_std), PARAMETER :: listleng=349 !!
7423	!
7424	!! LOCAL VARIABLES
7425	INTEGER(i_std) :: lenstr, i !!
7426	CHARACTER(LEN=60), DIMENSION(listleng) :: list_names !!
7427	CHARACTER(LEN=60) :: tmp_str !!
7428
7429	!_ ================================================================================================================================
7430	!
7431
7432	lenstr = LEN(basin_names(1))
7433	!
7434	list_names(1) = "Amazon"
7435	list_names(2) = "Nile"
7436	list_names(3) = "Zaire"
7437	list_names(4) = "Mississippi"
7438	list_names(5) = "Amur"
7439	list_names(6) = "Parana"
7440	list_names(7) = "Yenisei"
7441	list_names(8) = "Ob"
7442	list_names(9) = "Lena"
7443	list_names(10) = "Niger"
7444	list_names(11) = "Zambezi"
7445	list_names(12) = "Erg Iguidi (Sahara)"
7446	list_names(13) = "Chang Jiang (Yangtze)"
7447	list_names(14) = "Mackenzie"
7448	list_names(15) = "Ganges"
7449	list_names(16) = "Chari"
7450	list_names(17) = "Volga"
7451	list_names(18) = "St. Lawrence"
7452	list_names(19) = "Indus"
7453	list_names(20) = "Syr-Darya"
7454	list_names(21) = "Nelson"
7455	list_names(22) = "Orinoco"
7456	list_names(23) = "Murray"
7457	list_names(24) = "Great Artesian Basin"
7458	list_names(25) = "Shatt el Arab"
7459	list_names(26) = "Orange"
7460	list_names(27) = "Huang He"
7461	list_names(28) = "Yukon"
7462	list_names(29) = "Senegal"
7463	list_names(30) = "Chott Jerid"
7464	list_names(31) = "Jubba"
7465	list_names(32) = "Colorado (Ari)"
7466	list_names(33) = "Rio Grande (US)"
7467	list_names(34) = "Danube"
7468	list_names(35) = "Mekong"
7469	list_names(36) = "Tocantins"
7470	list_names(37) = "Wadi al Farigh"
7471	list_names(38) = "Tarim"
7472	list_names(39) = "Columbia"
7473	list_names(40) = "Komadugu Yobe (Tchad)"
7474	list_names(41) = "Kolyma"
7475	list_names(42) = "Sao Francisco"
7476	list_names(43) = "Amu-Darya"
7477	list_names(44) = "GHAASBasin51"
7478	list_names(45) = "Dnepr"
7479	list_names(46) = "GHAASBasin61"
7480	list_names(47) = "Don"
7481	list_names(48) = "Colorado (Arg)"
7482	list_names(49) = "Limpopo"
7483	list_names(50) = "GHAASBasin50"
7484	list_names(51) = "Zhujiang"
7485	list_names(52) = "Irrawaddy"
7486	list_names(53) = "Volta"
7487	list_names(54) = "GHAASBasin54"
7488	list_names(55) = "Farah"
7489	list_names(56) = "Khatanga"
7490	list_names(57) = "Dvina"
7491	list_names(58) = "Urugay"
7492	list_names(59) = "Qarqan"
7493	list_names(60) = "GHAASBasin75"
7494	list_names(61) = "Parnaiba"
7495	list_names(62) = "GHAASBasin73"
7496	list_names(63) = "Indigirka"
7497	list_names(64) = "Churchill (Hud)"
7498	list_names(65) = "Godavari"
7499	list_names(66) = "Pur - Taz"
7500	list_names(67) = "Pechora"
7501	list_names(68) = "Baker"
7502	list_names(69) = "Ural"
7503	list_names(70) = "Neva"
7504	list_names(71) = "Liao"
7505	list_names(72) = "Salween"
7506	list_names(73) = "GHAASBasin73"
7507	list_names(74) = "Jordan"
7508	list_names(75) = "GHAASBasin78"
7509	list_names(76) = "Magdalena"
7510	list_names(77) = "Krishna"
7511	list_names(78) = "Salado"
7512	list_names(79) = "Fraser"
7513	list_names(80) = "Hai Ho"
7514	list_names(81) = "Huai"
7515	list_names(82) = "Yana"
7516	list_names(83) = "GHAASBasin95"
7517	list_names(84) = "GHAASBasin105"
7518	list_names(85) = "Kura"
7519	list_names(86) = "Olenek"
7520	list_names(87) = "Ogooue"
7521	list_names(88) = "Taymyr"
7522	list_names(89) = "Negro Arg"
7523	list_names(90) = "Chubut"
7524	list_names(91) = "GHAASBasin91"
7525	list_names(92) = "GHAASBasin122"
7526	list_names(93) = "GHAASBasin120"
7527	list_names(94) = "Sacramento"
7528	list_names(95) = "Fitzroy West"
7529	list_names(96) = "Grande de Santiago"
7530	list_names(97) = "Rufiji"
7531	list_names(98) = "Wisla"
7532	list_names(99) = "GHAASBasin47"
7533	list_names(100) = "GHAASBasin127"
7534	list_names(101) = "Hong"
7535	list_names(102) = "GHAASBasin97"
7536	list_names(103) = "Swan-Avon"
7537	list_names(104) = "Rhine"
7538	list_names(105) = "Cuanza"
7539	list_names(106) = "GHAASBasin106"
7540	list_names(107) = "GHAASBasin142"
7541	list_names(108) = "Roviuna"
7542	list_names(109) = "Essequibo"
7543	list_names(110) = "Elbe"
7544	list_names(111) = "Koksoak"
7545	list_names(112) = "Chao Phraya"
7546	list_names(113) = "Brahmani"
7547	list_names(114) = "GHAASBasin165"
7548	list_names(115) = "Pyasina"
7549	list_names(116) = "Fitzroy East"
7550	list_names(117) = "GHAASBasin173"
7551	list_names(118) = "Albany"
7552	list_names(119) = "Sanaga"
7553	list_names(120) = "GHAASBasin120"
7554	list_names(121) = "GHAASBasin178"
7555	list_names(122) = "GHAASBasin148"
7556	list_names(123) = "Brazos (Tex)"
7557	list_names(124) = "GHAASBasin124"
7558	list_names(125) = "Alabama"
7559	list_names(126) = "GHAASBasin174"
7560	list_names(127) = "GHAASBasin179"
7561	list_names(128) = "Balsas"
7562	list_names(129) = "GHAASBasin172"
7563	list_names(130) = "Burdekin"
7564	list_names(131) = "Colorado (Texas)"
7565	list_names(132) = "GHAASBasin150"
7566	list_names(133) = "Odra"
7567	list_names(134) = "Loire"
7568	list_names(135) = "GHAASBasin98"
7569	list_names(136) = "Galana"
7570	list_names(137) = "Kuskowin"
7571	list_names(138) = "Moose"
7572	list_names(139) = "Narmada"
7573	list_names(140) = "GHAASBasin140"
7574	list_names(141) = "GHAASBasin141"
7575	list_names(142) = "Flinders"
7576	list_names(143) = "Kizil Irmak"
7577	list_names(144) = "GHAASBasin144"
7578	list_names(145) = "Save"
7579	list_names(146) = "Roper"
7580	list_names(147) = "Churchill (Atlantic)"
7581	list_names(148) = "GHAASBasin148"
7582	list_names(149) = "Victoria"
7583	list_names(150) = "Back"
7584	list_names(151) = "Bandama"
7585	list_names(152) = "Severn (Can)"
7586	list_names(153) = "Po"
7587	list_names(154) = "GHAASBasin154"
7588	list_names(155) = "GHAASBasin155"
7589	list_names(156) = "GHAASBasin156"
7590	list_names(157) = "Rhone"
7591	list_names(158) = "Tana (Ken)"
7592	list_names(159) = "La Grande"
7593	list_names(160) = "GHAASBasin160"
7594	list_names(161) = "Cunene"
7595	list_names(162) = "Douro"
7596	list_names(163) = "GHAASBasin163"
7597	list_names(164) = "Nemanus"
7598	list_names(165) = "GHAASBasin165"
7599	list_names(166) = "Anabar"
7600	list_names(167) = "Hayes"
7601	list_names(168) = "Mearim"
7602	list_names(169) = "GHAASBasin169"
7603	list_names(170) = "Panuco"
7604	list_names(171) = "GHAASBasin171"
7605	list_names(172) = "Doce"
7606	list_names(173) = "Gasgoyne"
7607	list_names(174) = "GHAASBasin174"
7608	list_names(175) = "GHAASBasin175"
7609	list_names(176) = "Ashburton"
7610	list_names(177) = "GHAASBasin177"
7611	list_names(178) = "Peel"
7612	list_names(179) = "Daugava"
7613	list_names(180) = "GHAASBasin180"
7614	list_names(181) = "Ebro"
7615	list_names(182) = "Comoe"
7616	list_names(183) = "Jacui"
7617	list_names(184) = "GHAASBasin184"
7618	list_names(185) = "Kapuas"
7619	list_names(186) = "GHAASBasin186"
7620	list_names(187) = "Penzhina"
7621	list_names(188) = "Cauweri"
7622	list_names(189) = "GHAASBasin189"
7623	list_names(190) = "Mamberamo"
7624	list_names(191) = "Sepik"
7625	list_names(192) = "GHAASBasin192"
7626	list_names(193) = "Sassandra"
7627	list_names(194) = "GHAASBasin194"
7628	list_names(195) = "GHAASBasin195"
7629	list_names(196) = "Nottaway"
7630	list_names(197) = "Barito"
7631	list_names(198) = "GHAASBasin198"
7632	list_names(199) = "Seine"
7633	list_names(200) = "Tejo"
7634	list_names(201) = "GHAASBasin201"
7635	list_names(202) = "Gambia"
7636	list_names(203) = "Susquehanna"
7637	list_names(204) = "Dnestr"
7638	list_names(205) = "Murchinson"
7639	list_names(206) = "Deseado"
7640	list_names(207) = "Mitchell"
7641	list_names(208) = "Mahakam"
7642	list_names(209) = "GHAASBasin209"
7643	list_names(210) = "Pangani"
7644	list_names(211) = "GHAASBasin211"
7645	list_names(212) = "GHAASBasin212"
7646	list_names(213) = "GHAASBasin213"
7647	list_names(214) = "GHAASBasin214"
7648	list_names(215) = "GHAASBasin215"
7649	list_names(216) = "Bug"
7650	list_names(217) = "GHAASBasin217"
7651	list_names(218) = "Usumacinta"
7652	list_names(219) = "Jequitinhonha"
7653	list_names(220) = "GHAASBasin220"
7654	list_names(221) = "Corantijn"
7655	list_names(222) = "Fuchun Jiang"
7656	list_names(223) = "Copper"
7657	list_names(224) = "Tapti"
7658	list_names(225) = "Menjiang"
7659	list_names(226) = "Karun"
7660	list_names(227) = "Mezen"
7661	list_names(228) = "Guadiana"
7662	list_names(229) = "Maroni"
7663	list_names(230) = "GHAASBasin230"
7664	list_names(231) = "Uda"
7665	list_names(232) = "GHAASBasin232"
7666	list_names(233) = "Kuban"
7667	list_names(234) = "Colville"
7668	list_names(235) = "Thaane"
7669	list_names(236) = "Alazeya"
7670	list_names(237) = "Paraiba do Sul"
7671	list_names(238) = "GHAASBasin238"
7672	list_names(239) = "Fortesque"
7673	list_names(240) = "GHAASBasin240"
7674	list_names(241) = "GHAASBasin241"
7675	list_names(242) = "Winisk"
7676	list_names(243) = "GHAASBasin243"
7677	list_names(244) = "GHAASBasin244"
7678	list_names(245) = "Ikopa"
7679	list_names(246) = "Gilbert"
7680	list_names(247) = "Kouilou"
7681	list_names(248) = "Fly"
7682	list_names(249) = "GHAASBasin249"
7683	list_names(250) = "GHAASBasin250"
7684	list_names(251) = "GHAASBasin251"
7685	list_names(252) = "Mangoky"
7686	list_names(253) = "Damodar"
7687	list_names(254) = "Onega"
7688	list_names(255) = "Moulouya"
7689	list_names(256) = "GHAASBasin256"
7690	list_names(257) = "Ord"
7691	list_names(258) = "GHAASBasin258"
7692	list_names(259) = "GHAASBasin259"
7693	list_names(260) = "GHAASBasin260"
7694	list_names(261) = "GHAASBasin261"
7695	list_names(262) = "Narva"
7696	list_names(263) = "GHAASBasin263"
7697	list_names(264) = "Seal"
7698	list_names(265) = "Cheliff"
7699	list_names(266) = "Garonne"
7700	list_names(267) = "Rupert"
7701	list_names(268) = "GHAASBasin268"
7702	list_names(269) = "Brahmani"
7703	list_names(270) = "Sakarya"
7704	list_names(271) = "Gourits"
7705	list_names(272) = "Sittang"
7706	list_names(273) = "Rajang"
7707	list_names(274) = "Evros"
7708	list_names(275) = "Appalachicola"
7709	list_names(276) = "Attawapiskat"
7710	list_names(277) = "Lurio"
7711	list_names(278) = "Daly"
7712	list_names(279) = "Penner"
7713	list_names(280) = "GHAASBasin280"
7714	list_names(281) = "GHAASBasin281"
7715	list_names(282) = "Guadalquivir"
7716	list_names(283) = "Nadym"
7717	list_names(284) = "GHAASBasin284"
7718	list_names(285) = "Saint John"
7719	list_names(286) = "GHAASBasin286"
7720	list_names(287) = "Cross"
7721	list_names(288) = "Omoloy"
7722	list_names(289) = "Oueme"
7723	list_names(290) = "GHAASBasin290"
7724	list_names(291) = "Gota"
7725	list_names(292) = "Nueces"
7726	list_names(293) = "Stikine"
7727	list_names(294) = "Yalu"
7728	list_names(295) = "Arnaud"
7729	list_names(296) = "GHAASBasin296"
7730	list_names(297) = "Jequitinhonha"
7731	list_names(298) = "Kamchatka"
7732	list_names(299) = "GHAASBasin299"
7733	list_names(300) = "Grijalva"
7734	list_names(301) = "GHAASBasin301"
7735	list_names(302) = "Kemijoki"
7736	list_names(303) = "Olifants"
7737	list_names(304) = "GHAASBasin304"
7738	list_names(305) = "Tsiribihina"
7739	list_names(306) = "Coppermine"
7740	list_names(307) = "GHAASBasin307"
7741	list_names(308) = "GHAASBasin308"
7742	list_names(309) = "Kovda"
7743	list_names(310) = "Trinity"
7744	list_names(311) = "Glama"
7745	list_names(312) = "GHAASBasin312"
7746	list_names(313) = "Luan"
7747	list_names(314) = "Leichhardt"
7748	list_names(315) = "GHAASBasin315"
7749	list_names(316) = "Gurupi"
7750	list_names(317) = "GR Baleine"
7751	list_names(318) = "Aux Feuilles"
7752	list_names(319) = "GHAASBasin319"
7753	list_names(320) = "Weser"
7754	list_names(321) = "GHAASBasin321"
7755	list_names(322) = "GHAASBasin322"
7756	list_names(323) = "Yesil"
7757	list_names(324) = "Incomati"
7758	list_names(325) = "GHAASBasin325"
7759	list_names(326) = "GHAASBasin326"
7760	list_names(327) = "Pungoe"
7761	list_names(328) = "GHAASBasin328"
7762	list_names(329) = "Meuse"
7763	list_names(330) = "Eastmain"
7764	list_names(331) = "Araguari"
7765	list_names(332) = "Hudson"
7766	list_names(333) = "GHAASBasin333"
7767	list_names(334) = "GHAASBasin334"
7768	list_names(335) = "GHAASBasin335"
7769	list_names(336) = "GHAASBasin336"
7770	list_names(337) = "Kobuk"
7771	list_names(338) = "Altamaha"
7772	list_names(339) = "GHAASBasin339"
7773	list_names(340) = "Mand"
7774	list_names(341) = "Santee"
7775	list_names(342) = "GHAASBasin342"
7776	list_names(343) = "GHAASBasin343"
7777	list_names(344) = "GHAASBasin344"
7778	list_names(345) = "Hari"
7779	list_names(346) = "GHAASBasin346"
7780	list_names(347) = "Wami"
7781	list_names(348) = "GHAASBasin348"
7782	list_names(349) = "GHAASBasin349"
7783	!
7784	basin_names(:) = ' '
7785	!
7786	DO i=1,numlar
7787	tmp_str = list_names(i)
7788	basin_names(i) = tmp_str(1:MIN(lenstr,LEN_TRIM(tmp_str)))
7789	ENDDO
7790	!
7791	END SUBROUTINE routing_names
7792	!
7793	!! ================================================================================================================================
7794	!! SUBROUTINE : routing_irrigmap
7795	!!
7796	!>\BRIEF This subroutine interpolates the 0.5x0.5 degree based map of irrigated areas to the resolution of the model.
7797	!!
7798	!! DESCRIPTION (definitions, functional, design, flags) : None
7799	!!
7800	!! RECENT CHANGE(S): None
7801	!!
7802	!! MAIN OUTPUT VARIABLE(S):
7803	!!
7804	!! REFERENCES : None
7805	!!
7806	!! FLOWCHART : None
7807	!! \n
7808	!_ ================================================================================================================================
7809
7810	SUBROUTINE routing_irrigmap (nbpt, index, lalo, neighbours, resolution, contfrac, &
7811	& init_irrig, irrigated, init_flood, floodplains, init_swamp, swamp, hist_id, hist2_id)
7812	!
7813	IMPLICIT NONE
7814	!
7815	!! PARAMETERS
7816	INTEGER(i_std), PARAMETER :: ilake = 1 !! Number of type of lakes area (unitless)
7817	INTEGER(i_std), PARAMETER :: idam = 2 !! Number of type of dams area (unitless)
7818	INTEGER(i_std), PARAMETER :: iflood = 3 !! Number of type of floodplains area (unitless)
7819	INTEGER(i_std), PARAMETER :: iswamp = 4 !! Number of type of swamps area (unitless)
7820	INTEGER(i_std), PARAMETER :: isal = 5 !! Number of type of salines area (unitless)
7821	INTEGER(i_std), PARAMETER :: ipond = 6 !! Number of type of ponds area (unitless)
7822	INTEGER(i_std), PARAMETER :: ntype = 6 !! Number of types of flooded surfaces (unitless)
7823
7824	!! INPUT VARIABLES
7825	INTEGER(i_std), INTENT(in) :: nbpt !! Domain size (unitless)
7826	INTEGER(i_std), INTENT(in) :: index(nbpt) !! Index on the global map.
7827	REAL(r_std), INTENT(in) :: lalo(nbpt,2) !! Vector of latitude and longitudes (beware of the order !)
7828	INTEGER(i_std), INTENT(in) :: neighbours(nbpt,NbNeighb)!! Vector of neighbours for each grid point
7829	REAL(r_std), INTENT(in) :: resolution(nbpt,2) !! The size of each grid box in X and Y (m)
7830	REAL(r_std), INTENT(in) :: contfrac(nbpt) !! Fraction of land in each grid box (unitless;0-1)
7831	INTEGER(i_std), INTENT(in) :: hist_id !! Access to history file (unitless)
7832	INTEGER(i_std), INTENT(in) :: hist2_id !! Access to history file 2 (unitless)
7833	LOGICAL, INTENT(in) :: init_irrig !! Logical to initialize the irrigation (true/false)
7834	LOGICAL, INTENT(in) :: init_flood !! Logical to initialize the floodplains (true/false)
7835	LOGICAL, INTENT(in) :: init_swamp !! Logical to initialize the swamps (true/false)
7836	!
7837	!! OUTPUT VARIABLES
7838	REAL(r_std), INTENT(out) :: irrigated(:) !! Irrigated surface in each grid box (m^2)
7839	REAL(r_std), INTENT(out) :: floodplains(:) !! Surface which can be inundated in each grid box (m^2)
7840	REAL(r_std), INTENT(out) :: swamp(:) !! Surface which can be swamp in each grid box (m^2)
7841	!
7842	!! LOCAL VARIABLES
7843	! Interpolation variables
7844	!
7845	INTEGER(i_std) :: nbpmax, nix, njx, fopt !!
7846	CHARACTER(LEN=30) :: callsign !!
7847	REAL(r_std), ALLOCATABLE, DIMENSION(:,:,:) :: resol_lu !! Resolution read on the map
7848	INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:) :: mask !! Mask to exclude some points (unitless)
7849	REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: irrsub_area !! Area on the fine grid (m^2)
7850	INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:,:) :: irrsub_index !! Indices of the points we need on the fine grid (unitless)
7851	INTEGER :: ALLOC_ERR !!
7852	LOGICAL :: ok_interpol = .FALSE. !! Flag for interpolation (true/false)
7853	!
7854	CHARACTER(LEN=80) :: filename !! Name of the netcdf file (unitless)
7855	INTEGER(i_std) :: iml, jml, lml, tml, fid, ib, ip, jp, itype !! Indices (unitless)
7856	REAL(r_std) :: lev(1), date, dt, coslat !!
7857	INTEGER(i_std) :: itau(1) !!
7858	REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: latrel !! Latitude
7859	REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: lonrel !! Longitude
7860	REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: irrigated_frac !! Irrigated fraction of the grid box (unitless;0-1)
7861	REAL(r_std), ALLOCATABLE, DIMENSION(:,:,:) :: flood_fracmax !! Maximal flooded fraction of the grid box (unitless;0-1)
7862	REAL(r_std) :: area_irrig !! Irrigated surface in the grid box (m^2)
7863	REAL(r_std) :: area_flood(ntype) !! Flooded surface in the grid box (m^2)
7864	!!$ REAL(r_std) :: irrigmap(nbpt)
7865	!!$ REAL(r_std) :: floodmap(nbpt)
7866	!!$ REAL(r_std) :: swampmap(nbpt)
7867
7868	!_ ================================================================================================================================
7869
7870	nix = 0
7871	njx = 0
7872	!
7873	!Config Key = IRRIGATION_FILE
7874	!Config Desc = Name of file which contains the map of irrigated areas
7875	!Config Def = floodplains.nc
7876	!Config If = DO_IRRIGATION OR DO_FLOODPLAINS
7877	!Config Help = The name of the file to be opened to read the field
7878	!Config with the area in m^2 of the area irrigated within each
7879	!Config 0.5 0.5 deg grid box. The map currently used is the one
7880	!Config developed by the Center for Environmental Systems Research
7881	!Config in Kassel (1995).
7882	!Config Units = [FILE]
7883	!
7884	filename = 'floodplains.nc'
7885	CALL getin_p('IRRIGATION_FILE',filename)
7886	!
7887	IF (is_root_prc) THEN
7888	CALL flininfo(filename,iml, jml, lml, tml, fid)
7889	CALL flinclo(fid)
7890	ELSE
7891	iml = 0
7892	jml = 0
7893	lml = 0
7894	tml = 0
7895	ENDIF
7896	!
7897	CALL bcast(iml)
7898	CALL bcast(jml)
7899	CALL bcast(lml)
7900	CALL bcast(tml)
7901	!
7902	!
7903	!
7904	ALLOCATE (latrel(iml,jml), STAT=ALLOC_ERR)
7905	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_irrigmap','Pb in allocate for latrel','','')
7906
7907	ALLOCATE (lonrel(iml,jml), STAT=ALLOC_ERR)
7908	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_irrigmap','Pb in allocate for lonrel','','')
7909
7910	ALLOCATE (irrigated_frac(iml,jml), STAT=ALLOC_ERR)
7911	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_irrigmap','Pb in allocate for irrigated_frac','','')
7912
7913	ALLOCATE (flood_fracmax(iml,jml,ntype), STAT=ALLOC_ERR)
7914	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_irrigmap','Pb in allocate for flood_fracmax','','')
7915
7916	IF (is_root_prc) CALL flinopen(filename, .FALSE., iml, jml, lml, lonrel, latrel, lev, tml, itau, date, dt, fid)
7917
7918	CALL bcast(lonrel)
7919	CALL bcast(latrel)
7920	!
7921	IF (is_root_prc) CALL flinget(fid, 'irrig', iml, jml, lml, tml, 1, 1, irrigated_frac)
7922	CALL bcast(irrigated_frac)
7923	IF (is_root_prc) CALL flinget(fid, 'lake', iml, jml, lml, tml, 1, 1, flood_fracmax(:,:,ilake))
7924	IF (is_root_prc) CALL flinget(fid, 'dam', iml, jml, lml, tml, 1, 1, flood_fracmax(:,:,idam))
7925	IF (is_root_prc) CALL flinget(fid, 'flood', iml, jml, lml, tml, 1, 1, flood_fracmax(:,:,iflood))
7926	IF (is_root_prc) CALL flinget(fid, 'swamp', iml, jml, lml, tml, 1, 1, flood_fracmax(:,:,iswamp))
7927	IF (is_root_prc) CALL flinget(fid, 'saline', iml, jml, lml, tml, 1, 1, flood_fracmax(:,:,isal))
7928	IF (is_root_prc) CALL flinget(fid, 'pond', iml, jml, lml, tml, 1, 1, flood_fracmax(:,:,ipond))
7929	CALL bcast(flood_fracmax)
7930	!
7931	IF (is_root_prc) CALL flinclo(fid)
7932	!
7933	! Set to zero all fraction which are less than 0.5%
7934	!
7935	DO ip=1,iml
7936	DO jp=1,jml
7937	!
7938	IF ( irrigated_frac(ip,jp) .LT. undef_sechiba-un) THEN
7939	irrigated_frac(ip,jp) = irrigated_frac(ip,jp)/100.
7940	IF ( irrigated_frac(ip,jp) < 0.005 ) irrigated_frac(ip,jp) = zero
7941	ENDIF
7942	!
7943	DO itype=1,ntype
7944	IF ( flood_fracmax(ip,jp,itype) .LT. undef_sechiba-1.) THEN
7945	flood_fracmax(ip,jp,itype) = flood_fracmax(ip,jp,itype)/100
7946	IF ( flood_fracmax(ip,jp,itype) < 0.005 ) flood_fracmax(ip,jp,itype) = zero
7947	ENDIF
7948	ENDDO
7949	!
7950	ENDDO
7951	ENDDO
7952
7953	IF (printlev>=2) THEN
7954	WRITE(numout,*) 'lonrel : ', MAXVAL(lonrel), MINVAL(lonrel)
7955	WRITE(numout,*) 'latrel : ', MAXVAL(latrel), MINVAL(latrel)
7956	WRITE(numout,*) 'irrigated_frac : ', MINVAL(irrigated_frac, MASK=irrigated_frac .GT. 0), &
7957	MAXVAL(irrigated_frac, MASK=irrigated_frac .LT. undef_sechiba)
7958	WRITE(numout,*) 'flood_fracmax : ', MINVAL(flood_fracmax, MASK=flood_fracmax .GT. 0), &
7959	MAXVAL(flood_fracmax, MASK=flood_fracmax .LT. undef_sechiba)
7960	END IF
7961
7962	! Consider all points a priori
7963	!
7964	ALLOCATE(resol_lu(iml,jml,2), STAT=ALLOC_ERR)
7965	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_irrigmap','Pb in allocate for resol_lu','','')
7966
7967	ALLOCATE(mask(iml,jml), STAT=ALLOC_ERR)
7968	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_irrigmap','Pb in allocate for mask','','')
7969	mask(:,:) = 0
7970
7971	DO ip=1,iml
7972	DO jp=1,jml
7973	!
7974	! Exclude the points where we are close to the missing value.
7975	!
7976	!MG This condition cannot be applied in floodplains/swamps configuration because
7977	! the same mask would be used for the interpolation of irrigation, floodplains and swamps maps.
7978	! IF ( irrigated_frac(ip,jp) < undef_sechiba ) THEN
7979	mask(ip,jp) = 1
7980	! ENDIF
7981	!
7982	! Resolution in longitude
7983	!
7984	coslat = MAX( COS( latrel(ip,jp) * pi/180. ), mincos )
7985	IF ( ip .EQ. 1 ) THEN
7986	resol_lu(ip,jp,1) = ABS( lonrel(ip+1,jp) - lonrel(ip,jp) ) * pi/180. * R_Earth * coslat
7987	ELSEIF ( ip .EQ. iml ) THEN
7988	resol_lu(ip,jp,1) = ABS( lonrel(ip,jp) - lonrel(ip-1,jp) ) * pi/180. * R_Earth * coslat
7989	ELSE
7990	resol_lu(ip,jp,1) = ABS( lonrel(ip+1,jp) - lonrel(ip-1,jp) )/2. * pi/180. * R_Earth * coslat
7991	ENDIF
7992	!
7993	! Resolution in latitude
7994	!
7995	IF ( jp .EQ. 1 ) THEN
7996	resol_lu(ip,jp,2) = ABS( latrel(ip,jp) - latrel(ip,jp+1) ) * pi/180. * R_Earth
7997	ELSEIF ( jp .EQ. jml ) THEN
7998	resol_lu(ip,jp,2) = ABS( latrel(ip,jp-1) - latrel(ip,jp) ) * pi/180. * R_Earth
7999	ELSE
8000	resol_lu(ip,jp,2) = ABS( latrel(ip,jp-1) - latrel(ip,jp+1) )/2. * pi/180. * R_Earth
8001	ENDIF
8002	!
8003	ENDDO
8004	ENDDO
8005	!
8006	! The number of maximum vegetation map points in the GCM grid is estimated.
8007	! Some lmargin is taken.
8008	!
8009	callsign = 'Irrigation map'
8010	ok_interpol = .FALSE.
8011	IF (is_root_prc) THEN
8012	nix=INT(MAXVAL(resolution_g(:,1))/MAXVAL(resol_lu(:,:,1)))+2
8013	njx=INT(MAXVAL(resolution_g(:,2))/MAXVAL(resol_lu(:,:,2)))+2
8014	nbpmax = nixnjx2
8015	IF (printlev>=1) THEN
8016	WRITE(numout,*) "Projection arrays for ",callsign," : "
8017	WRITE(numout,*) "nbpmax = ",nbpmax, nix, njx
8018	END IF
8019	ENDIF
8020	CALL bcast(nbpmax)
8021
8022	ALLOCATE(irrsub_index(nbpt, nbpmax, 2), STAT=ALLOC_ERR)
8023	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_irrigmap','Pb in allocate for irrsub_index','','')
8024	irrsub_index(:,:,:)=0
8025
8026	ALLOCATE(irrsub_area(nbpt, nbpmax), STAT=ALLOC_ERR)
8027	IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_irrigmap','Pb in allocate for irrsub_area','','')
8028	irrsub_area(:,:)=zero
8029
8030	CALL aggregate_p(nbpt, lalo, neighbours, resolution, contfrac, &
8031	& iml, jml, lonrel, latrel, mask, callsign, &
8032	& nbpmax, irrsub_index, irrsub_area, ok_interpol)
8033	!
8034	!
8035	WHERE (irrsub_area < 0) irrsub_area=zero
8036	!
8037	! Test here if not all sub_area are larger than 0 if so, then we need to increase nbpmax
8038	!
8039	DO ib=1,nbpt
8040	!
8041	area_irrig = 0.0
8042	area_flood = 0.0
8043	!
8044	DO fopt=1,COUNT(irrsub_area(ib,:) > zero)
8045	!
8046	ip = irrsub_index(ib, fopt, 1)
8047	jp = irrsub_index(ib, fopt, 2)
8048	!
8049	IF (irrigated_frac(ip,jp) .LT. undef_sechiba-1.) THEN
8050	area_irrig = area_irrig + irrsub_area(ib,fopt)*irrigated_frac(ip,jp)
8051	ENDIF
8052	!
8053	DO itype=1,ntype
8054	IF (flood_fracmax(ip,jp,itype) .LT. undef_sechiba-1.) THEN
8055	area_flood(itype) = area_flood(itype) + irrsub_area(ib,fopt)*flood_fracmax(ip,jp,itype)
8056	ENDIF
8057	ENDDO
8058	ENDDO
8059	!
8060	! Put the total irrigated and flooded areas in the output variables
8061	!
8062	IF ( init_irrig ) THEN
8063	irrigated(ib) = MIN(area_irrig, resolution(ib,1)resolution(ib,2)contfrac(ib))
8064	IF ( irrigated(ib) < 0 ) THEN
8065	WRITE(numout,*) 'We have a problem here : ', irrigated(ib)
8066	WRITE(numout,*) 'resolution :', resolution(ib,1), resolution(ib,2)
8067	WRITE(numout,*) area_irrig
8068	CALL ipslerr_p(3,'routing_irrigmap','Problem with irrigated...','','')
8069	ENDIF
8070	!!$ ! Compute a diagnostic of the map.
8071	!!$ IF(contfrac(ib).GT.zero) THEN
8072	!!$ irrigmap (ib) = irrigated(ib) / ( resolution(ib,1)resolution(ib,2)contfrac(ib) )
8073	!!$ ELSE
8074	!!$ irrigmap (ib) = zero
8075	!!$ ENDIF
8076	!
8077	ENDIF
8078	!
8079	IF ( init_flood ) THEN
8080	floodplains(ib) = MIN(area_flood(iflood)+area_flood(idam)+area_flood(isal), &
8081	& resolution(ib,1)resolution(ib,2)contfrac(ib))
8082	IF ( floodplains(ib) < 0 ) THEN
8083	WRITE(numout,*) 'We have a problem here : ', floodplains(ib)
8084	WRITE(numout,*) 'resolution :', resolution(ib,1), resolution(ib,2)
8085	WRITE(numout,*) area_flood
8086	CALL ipslerr_p(3,'routing_irrigmap','Problem with floodplains..','','')
8087	ENDIF
8088	!!$ ! Compute a diagnostic of the map.
8089	!!$ IF(contfrac(ib).GT.zero) THEN
8090	!!$ floodmap(ib) = floodplains(ib) / ( resolution(ib,1)resolution(ib,2)contfrac(ib) )
8091	!!$ ELSE
8092	!!$ floodmap(ib) = 0.0
8093	!!$ ENDIF
8094	ENDIF
8095	!
8096	IF ( init_swamp ) THEN
8097	swamp(ib) = MIN(area_flood(iswamp), resolution(ib,1)resolution(ib,2)contfrac(ib))
8098	IF ( swamp(ib) < 0 ) THEN
8099	WRITE(numout,*) 'We have a problem here : ', swamp(ib)
8100	WRITE(numout,*) 'resolution :', resolution(ib,1), resolution(ib,2)
8101	WRITE(numout,*) area_flood
8102	CALL ipslerr_p(3,'routing_irrigmap','Problem with swamp...','','')
8103	ENDIF
8104	!!$ ! Compute a diagnostic of the map.
8105	!!$ IF(contfrac(ib).GT.zero) THEN
8106	!!$ swampmap(ib) = swamp(ib) / ( resolution(ib,1)resolution(ib,2)contfrac(ib) )
8107	!!$ ELSE
8108	!!$ swampmap(ib) = zero
8109	!!$ ENDIF
8110	ENDIF
8111	!
8112	!
8113	ENDDO
8114	!
8115	!
8116
8117	IF (printlev>=1) THEN
8118	IF ( init_irrig ) WRITE(numout,*) "Diagnostics irrigated :", MINVAL(irrigated), MAXVAL(irrigated)
8119	IF ( init_flood ) WRITE(numout,*) "Diagnostics floodplains :", MINVAL(floodplains), MAXVAL(floodplains)
8120	IF ( init_swamp ) WRITE(numout,*) "Diagnostics swamp :", MINVAL(swamp), MAXVAL(swamp)
8121	END IF
8122
8123	! No compensation is done for overlapping floodplains, swamp and irrig. At least overlapping will not
8124	! happen between floodplains and swamp alone
8125	! IF ( init_irrig .AND. init_flood ) THEN
8126	! DO ib = 1, nbpt
8127	! surp = (floodplains(ib)+swamp(ib)+irrigated(ib)) / (resolution(ib,1)resolution(ib,2)contfrac(ib))
8128	! IF ( surp .GT. un ) THEN
8129	! floodplains(ib) = floodplains(ib) / surp
8130	! swamp(ib) = swamp(ib) / surp
8131	! irrigated(ib) = irrigated(ib) / surp
8132	! ENDIF
8133	! ENDDO
8134	! ENDIF
8135	!
8136	DEALLOCATE (irrsub_area)
8137	DEALLOCATE (irrsub_index)
8138	!
8139	DEALLOCATE (mask)
8140	DEALLOCATE (resol_lu)
8141	!
8142	DEALLOCATE (lonrel)
8143	DEALLOCATE (latrel)
8144	!
8145	END SUBROUTINE routing_irrigmap
8146	!
8147	!! ================================================================================================================================
8148	!! SUBROUTINE : routing_waterbal
8149	!!
8150	!>\BRIEF This subroutine checks the water balance in the routing module.
8151	!!
8152	!! DESCRIPTION (definitions, functional, design, flags) : None
8153	!!
8154	!! RECENT CHANGE(S): None
8155	!!
8156	!! MAIN OUTPUT VARIABLE(S):
8157	!!
8158	!! REFERENCES : None
8159	!!
8160	!! FLOWCHART : None
8161	!! \n
8162	!_ ================================================================================================================================
8163
8164	SUBROUTINE routing_waterbal(nbpt, reinit, floodout, runoff, drainage, returnflow, &
8165	& reinfiltration, irrigation, riverflow, coastalflow)
8166	!
8167	IMPLICIT NONE
8168	!
8169	!! INPUT VARIABLES
8170	INTEGER(i_std), INTENT(in) :: nbpt !! Domain size (unitless)
8171	LOGICAL, INTENT(in) :: reinit !! Controls behaviour (true/false)
8172	REAL(r_std), INTENT(in) :: floodout(nbpt) !! Grid-point flow out of floodplains (kg/m^2/dt)
8173	REAL(r_std), INTENT(in) :: runoff(nbpt) !! Grid-point runoff (kg/m^2/dt)
8174	REAL(r_std), INTENT(in) :: drainage(nbpt) !! Grid-point drainage (kg/m^2/dt)
8175	REAL(r_std), INTENT(in) :: returnflow(nbpt) !! The water flow from lakes and swamps which returns to the grid box.
8176	!! This water will go back into the hydrol or hydrolc module to allow re-evaporation (kg/m^2/dt)
8177	REAL(r_std), INTENT(in) :: reinfiltration(nbpt) !! Water flow from ponds and floodplains which returns to the grid box (kg/m^2/dt)
8178	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)
8179	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)
8180	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)
8181	!
8182	! We sum-up all the water we have in the warious reservoirs
8183	!
8184	REAL(r_std), SAVE :: totw_flood !! Sum of all the water amount in the floodplains reservoirs (kg)
8185	!$OMP THREADPRIVATE(totw_flood)
8186	REAL(r_std), SAVE :: totw_stream !! Sum of all the water amount in the stream reservoirs (kg)
8187	!$OMP THREADPRIVATE(totw_stream)
8188	REAL(r_std), SAVE :: totw_fast !! Sum of all the water amount in the fast reservoirs (kg)
8189	!$OMP THREADPRIVATE(totw_fast)
8190	REAL(r_std), SAVE :: totw_slow !! Sum of all the water amount in the slow reservoirs (kg)
8191	!$OMP THREADPRIVATE(totw_slow)
8192	REAL(r_std), SAVE :: totw_lake !! Sum of all the water amount in the lake reservoirs (kg)
8193	!$OMP THREADPRIVATE(totw_lake)
8194	REAL(r_std), SAVE :: totw_pond !! Sum of all the water amount in the pond reservoirs (kg)
8195	!$OMP THREADPRIVATE(totw_pond)
8196	REAL(r_std), SAVE :: totw_in !! Sum of the water flow in to the routing scheme
8197	!$OMP THREADPRIVATE(totw_in)
8198	REAL(r_std), SAVE :: totw_out !! Sum of the water flow out to the routing scheme
8199	!$OMP THREADPRIVATE(totw_out)
8200	REAL(r_std), SAVE :: totw_return !!
8201	!$OMP THREADPRIVATE(totw_return)
8202	REAL(r_std), SAVE :: totw_irrig !!
8203	!$OMP THREADPRIVATE(totw_irrig)
8204	REAL(r_std), SAVE :: totw_river !!
8205	!$OMP THREADPRIVATE(totw_river)
8206	REAL(r_std), SAVE :: totw_coastal !!
8207	!$OMP THREADPRIVATE(totw_coastal)
8208	REAL(r_std) :: totarea !! Total area of basin (m^2)
8209	REAL(r_std) :: area !! Total area of routing (m^2)
8210	INTEGER(i_std) :: ig !!
8211	!
8212	! Just to make sure we do not get too large numbers !
8213	!
8214	!! PARAMETERS
8215	REAL(r_std), PARAMETER :: scaling = 1.0E+6 !!
8216	REAL(r_std), PARAMETER :: allowed_err = 50. !!
8217
8218	!_ ================================================================================================================================
8219	!
8220	IF ( reinit ) THEN
8221	!
8222	totw_flood = zero
8223	totw_stream = zero
8224	totw_fast = zero
8225	totw_slow = zero
8226	totw_lake = zero
8227	totw_pond = zero
8228	totw_in = zero
8229	!
8230	DO ig=1,nbpt
8231	!
8232	totarea = SUM(routing_area(ig,:))
8233	!
8234	totw_flood = totw_flood + SUM(flood_reservoir(ig,:)/scaling)
8235	totw_stream = totw_stream + SUM(stream_reservoir(ig,:)/scaling)
8236	totw_fast = totw_fast + SUM(fast_reservoir(ig,:)/scaling)
8237	totw_slow = totw_slow + SUM(slow_reservoir(ig,:)/scaling)
8238	totw_lake = totw_lake + lake_reservoir(ig)/scaling
8239	totw_pond = totw_pond + pond_reservoir(ig)/scaling
8240	!
8241	totw_in = totw_in + (runoff(ig)totarea + drainage(ig)totarea - floodout(ig)*totarea)/scaling
8242	!
8243	ENDDO
8244	!
8245	ELSE
8246	!
8247	totw_out = zero
8248	totw_return = zero
8249	totw_irrig = zero
8250	totw_river = zero
8251	totw_coastal = zero
8252	area = zero
8253	!
8254	DO ig=1,nbpt
8255	!
8256	totarea = SUM(routing_area(ig,:))
8257	!
8258	totw_flood = totw_flood - SUM(flood_reservoir(ig,:)/scaling)
8259	totw_stream = totw_stream - SUM(stream_reservoir(ig,:)/scaling)
8260	totw_fast = totw_fast - SUM(fast_reservoir(ig,:)/scaling)
8261	totw_slow = totw_slow - SUM(slow_reservoir(ig,:)/scaling)
8262	totw_lake = totw_lake - lake_reservoir(ig)/scaling
8263	totw_pond = totw_pond - pond_reservoir(ig)/scaling
8264	!
8265	totw_return = totw_return + (reinfiltration(ig)+returnflow(ig))*totarea/scaling
8266	totw_irrig = totw_irrig + irrigation(ig)*totarea/scaling
8267	totw_river = totw_river + riverflow(ig)/scaling
8268	totw_coastal = totw_coastal + coastalflow(ig)/scaling
8269	!
8270	area = area + totarea
8271	!
8272	ENDDO
8273	totw_out = totw_return + totw_irrig + totw_river + totw_coastal
8274	!
8275	! Now we have all the information to balance our water
8276	!
8277	IF ( ABS((totw_flood + totw_stream + totw_fast + totw_slow + totw_lake + totw_pond) - &
8278	& (totw_out - totw_in)) > allowed_err ) THEN
8279	WRITE(numout,*) 'WARNING : Water not conserved in routing. Limit at ', allowed_err, ' 10^6 kg'
8280	WRITE(numout,*) '--Water-- change : flood stream fast ', totw_flood, totw_stream, totw_fast
8281	WRITE(numout,*) '--Water-- change : slow, lake ', totw_slow, totw_lake
8282	WRITE(numout,*) '--Water>>> change in the routing res. : ', totw_flood + totw_stream + totw_fast + totw_slow + totw_lake
8283	WRITE(numout,*) '--Water input : ', totw_in
8284	WRITE(numout,*) '--Water output : ', totw_out
8285	WRITE(numout,*) '--Water output : return, irrig ', totw_return, totw_irrig
8286	WRITE(numout,*) '--Water output : river, coastal ',totw_river, totw_coastal
8287	WRITE(numout,*) '--Water>>> change by fluxes : ', totw_out - totw_in, ' Diff [mm/dt]: ', &
8288	& ((totw_flood + totw_stream + totw_fast + totw_slow + totw_lake) - (totw_out - totw_in))/area
8289
8290	! Stop the model
8291	CALL ipslerr_p(3, 'routing_waterbal', 'Water is not conserved in routing.','','')
8292	ENDIF
8293	!
8294	ENDIF
8295	!
8296	END SUBROUTINE routing_waterbal
8297	!
8298	!
8299	END MODULE routing

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

Context Navigation

source: branches/publications/ORCHIDEE-MICT-OP-r6850/src_sechiba/routing.f90 @ 8005

Download in other formats: