Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Blame
Revision Log

routing.f90 @ 5501

Last change on this file since 5501 was 5501, checked in by aclsce, 4 years ago
First import of IPSLCM6.5_work_ENSEMBLES working configuration
File size: 370.0 KB

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

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

Context Navigation

source: CONFIG_DEVT/IPSLCM6.5_work_ENSEMBLES/modeles/ORCHIDEE/src_sechiba/routing.f90 @ 5501

Download in other formats: