Context Navigation

source: branches/publications/ORCHIDEE_CN_CAN_r5698/src_sechiba/routing.f90 @ 8076

Last change on this file since 8076 was 5553, checked in by josefine.ghattas, 6 years ago
Removed option CHECK_WATERBAL as done in the trunk [5454]. See ticket #431
Property svn:keywords set to `Revision Date HeadURL Date Author Revision`
File size: 369.0 KB

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

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

Download in other formats: