| 1 | ! ================================================================================================================================= |
|---|
| 2 | ! MODULE : routing |
|---|
| 3 | ! |
|---|
| 4 | ! CONTACT : orchidee-help _at_ listes.ipsl.fr |
|---|
| 5 | ! |
|---|
| 6 | ! LICENCE : IPSL (2006) |
|---|
| 7 | ! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC |
|---|
| 8 | ! |
|---|
| 9 | !>\BRIEF This module routes the water over the continents into the oceans and computes the water |
|---|
| 10 | !! stored in floodplains or taken for irrigation. |
|---|
| 11 | !! |
|---|
| 12 | !!\n DESCRIPTION: None |
|---|
| 13 | !! |
|---|
| 14 | !! RECENT CHANGE(S): None |
|---|
| 15 | !! |
|---|
| 16 | !! REFERENCE(S) : |
|---|
| 17 | !! |
|---|
| 18 | !! SVN : |
|---|
| 19 | !! $HeadURL$ |
|---|
| 20 | !! $Date$ |
|---|
| 21 | !! $Revision$ |
|---|
| 22 | !! \n |
|---|
| 23 | !_ ================================================================================================================================ |
|---|
| 24 | ! |
|---|
| 25 | ! |
|---|
| 26 | ! Histoire Salee |
|---|
| 27 | !--------------- |
|---|
| 28 | ! La douce riviere |
|---|
| 29 | ! Sortant de son lit |
|---|
| 30 | ! S'est jetee ma chere |
|---|
| 31 | ! dans les bras mais oui |
|---|
| 32 | ! du beau fleuve |
|---|
| 33 | ! |
|---|
| 34 | ! L'eau coule sous les ponts |
|---|
| 35 | ! Et puis les flots s'emeuvent |
|---|
| 36 | ! - N'etes vous pas au courant ? |
|---|
| 37 | ! Il parait que la riviere |
|---|
| 38 | ! Va devenir mer |
|---|
| 39 | ! Roland Bacri |
|---|
| 40 | ! |
|---|
| 41 | |
|---|
| 42 | |
|---|
| 43 | MODULE routing |
|---|
| 44 | |
|---|
| 45 | USE ioipsl |
|---|
| 46 | USE xios_orchidee |
|---|
| 47 | USE ioipsl_para |
|---|
| 48 | USE constantes |
|---|
| 49 | USE time, ONLY : one_day, dt_sechiba |
|---|
| 50 | USE constantes_soil |
|---|
| 51 | USE pft_parameters |
|---|
| 52 | USE sechiba_io_p |
|---|
| 53 | USE interpol_help |
|---|
| 54 | USE grid |
|---|
| 55 | USE mod_orchidee_para |
|---|
| 56 | |
|---|
| 57 | |
|---|
| 58 | IMPLICIT NONE |
|---|
| 59 | PRIVATE |
|---|
| 60 | PUBLIC :: routing_main, routing_initialize, routing_finalize, routing_clear |
|---|
| 61 | |
|---|
| 62 | !! PARAMETERS |
|---|
| 63 | INTEGER(i_std), PARAMETER :: nbasmax=5 !! The maximum number of basins we wish to have per grid box (truncation of the model) (unitless) |
|---|
| 64 | INTEGER(i_std), SAVE :: nbvmax !! The maximum number of basins we can handle at any time during the generation of the maps (unitless) |
|---|
| 65 | !$OMP THREADPRIVATE(nbvmax) |
|---|
| 66 | REAL(r_std), PARAMETER :: slow_tcst_cwrr = 25.0 !! Property of the slow reservoir, when CWRR hydrology is activated (day/m) |
|---|
| 67 | REAL(r_std), PARAMETER :: fast_tcst_cwrr = 3.0 !! Property of the fast reservoir, when CWRR hydrology is activated (day/m) |
|---|
| 68 | REAL(r_std), PARAMETER :: stream_tcst_cwrr = 0.24 !! Property of the stream reservoir, when CWRR hydrology is activated (day/m) |
|---|
| 69 | REAL(r_std), PARAMETER :: flood_tcst_cwrr = 4.0 !! Property of the floodplains reservoir, when CWRR hydrology is activated (day/m) |
|---|
| 70 | REAL(r_std), PARAMETER :: swamp_cst_cwrr = 0.2 !! Fraction of the river transport that flows to the swamps, when CWRR hydrology is activated (unitless;0-1) |
|---|
| 71 | ! |
|---|
| 72 | REAL(r_std), PARAMETER :: slow_tcst_chois = 25.0 !! Property of the slow reservoir, when Choisnel hydrology is activated (day/m) |
|---|
| 73 | REAL(r_std), PARAMETER :: fast_tcst_chois = 3.0 !! Property of the fast reservoir, when Choisnel hydrology is activated (day/m) |
|---|
| 74 | REAL(r_std), PARAMETER :: stream_tcst_chois = 0.24 !! Property of the stream reservoir, when Choisnel hydrology is activated (day/m) |
|---|
| 75 | REAL(r_std), PARAMETER :: flood_tcst_chois = 4.0 !! Property of the floodplains reservoir, when Choisnel hydrology is activated (day/m) |
|---|
| 76 | REAL(r_std), PARAMETER :: swamp_cst_chois = 0.2 !! Fraction of the river transport that flows to the swamps, when Choisnel hydrology is activated (unitless;0-1) |
|---|
| 77 | ! |
|---|
| 78 | REAL(r_std), SAVE :: fast_tcst !! Property of the fast reservoir, (day/m) |
|---|
| 79 | !$OMP THREADPRIVATE(fast_tcst) |
|---|
| 80 | REAL(r_std), SAVE :: slow_tcst !! Property of the slow reservoir, (day/m) |
|---|
| 81 | !$OMP THREADPRIVATE(slow_tcst) |
|---|
| 82 | REAL(r_std), SAVE :: stream_tcst !! Property of the stream reservoir, (day/m) |
|---|
| 83 | !$OMP THREADPRIVATE(stream_tcst) |
|---|
| 84 | REAL(r_std), SAVE :: flood_tcst !! Property of the floodplains reservoir, (day/m) |
|---|
| 85 | !$OMP THREADPRIVATE(flood_tcst) |
|---|
| 86 | REAL(r_std), SAVE :: swamp_cst !! Fraction of the river transport that flows to the swamps (unitless;0-1) |
|---|
| 87 | !$OMP THREADPRIVATE(swamp_cst) |
|---|
| 88 | ! |
|---|
| 89 | ! Relation between volume and fraction of floodplains |
|---|
| 90 | ! |
|---|
| 91 | REAL(r_std), SAVE :: beta = 2.0 !! Parameter to fix the shape of the floodplain (>1 for convex edges, <1 for concave edges) (unitless) |
|---|
| 92 | !$OMP THREADPRIVATE(beta) |
|---|
| 93 | REAL(r_std), SAVE :: betap = 0.5 !! Ratio of the basin surface intercepted by ponds and the maximum surface of ponds (unitless;0-1) |
|---|
| 94 | !$OMP THREADPRIVATE(betap) |
|---|
| 95 | REAL(r_std), SAVE :: floodcri = 2000.0 !! Potential height for which all the basin is flooded (mm) |
|---|
| 96 | !$OMP THREADPRIVATE(floodcri) |
|---|
| 97 | ! |
|---|
| 98 | ! Relation between maximum surface of ponds and basin surface, and drainage (mm/j) to the slow_res |
|---|
| 99 | ! |
|---|
| 100 | REAL(r_std), PARAMETER :: pond_bas = 50.0 !! [DISPENSABLE] - not used |
|---|
| 101 | REAL(r_std), SAVE :: pondcri = 2000.0 !! Potential height for which all the basin is a pond (mm) |
|---|
| 102 | !$OMP THREADPRIVATE(pondcri) |
|---|
| 103 | ! |
|---|
| 104 | REAL(r_std), PARAMETER :: maxevap_lake = 7.5/86400. !! Maximum evaporation rate from lakes (kg/m^2/s) |
|---|
| 105 | ! |
|---|
| 106 | REAL(r_std),SAVE :: dt_routing !! Routing time step (s) |
|---|
| 107 | !$OMP THREADPRIVATE(dt_routing) |
|---|
| 108 | ! |
|---|
| 109 | INTEGER(i_std), SAVE :: diagunit = 87 !! Diagnostic file unit (unitless) |
|---|
| 110 | !$OMP THREADPRIVATE(diagunit) |
|---|
| 111 | ! |
|---|
| 112 | ! Logicals to control model configuration |
|---|
| 113 | ! |
|---|
| 114 | LOGICAL, SAVE :: dofloodinfilt = .FALSE. !! Logical to choose if floodplains infiltration is activated or not (true/false) |
|---|
| 115 | !$OMP THREADPRIVATE(dofloodinfilt) |
|---|
| 116 | LOGICAL, SAVE :: doswamps = .FALSE. !! Logical to choose if swamps are activated or not (true/false) |
|---|
| 117 | !$OMP THREADPRIVATE(doswamps) |
|---|
| 118 | LOGICAL, SAVE :: doponds = .FALSE. !! Logical to choose if ponds are activated or not (true/false) |
|---|
| 119 | !$OMP THREADPRIVATE(doponds) |
|---|
| 120 | ! |
|---|
| 121 | ! The variables describing the basins and their routing, need to be in the restart file. |
|---|
| 122 | ! |
|---|
| 123 | INTEGER(i_std), SAVE :: num_largest !! Number of largest river basins which should be treated as independently as rivers |
|---|
| 124 | !! (not flow into ocean as diffusion coastal flow) (unitless) |
|---|
| 125 | !$OMP THREADPRIVATE(num_largest) |
|---|
| 126 | REAL(r_std), SAVE :: time_counter !! Time counter (s) |
|---|
| 127 | !$OMP THREADPRIVATE(time_counter) |
|---|
| 128 | REAL(r_std), SAVE, ALLOCATABLE, TARGET, DIMENSION(:,:) :: routing_area_loc !! Surface of basin (m^2) |
|---|
| 129 | !$OMP THREADPRIVATE(routing_area_loc) |
|---|
| 130 | REAL(r_std), SAVE, ALLOCATABLE, TARGET, DIMENSION(:,:) :: topo_resid_loc !! Topographic index of the retention time (m) |
|---|
| 131 | !$OMP THREADPRIVATE(topo_resid_loc) |
|---|
| 132 | INTEGER(i_std), SAVE, ALLOCATABLE, TARGET, DIMENSION(:,:) :: route_togrid_loc !! Grid into which the basin flows (unitless) |
|---|
| 133 | !$OMP THREADPRIVATE(route_togrid_loc) |
|---|
| 134 | INTEGER(i_std), SAVE, ALLOCATABLE, TARGET, DIMENSION(:,:) :: route_tobasin_loc !! Basin in to which the water goes (unitless) |
|---|
| 135 | !$OMP THREADPRIVATE(route_tobasin_loc) |
|---|
| 136 | INTEGER(i_std), SAVE, ALLOCATABLE, TARGET, DIMENSION(:,:) :: route_nbintobas_loc !! Number of basin into current one (unitless) |
|---|
| 137 | !$OMP THREADPRIVATE(route_nbintobas_loc) |
|---|
| 138 | INTEGER(i_std), SAVE, ALLOCATABLE, TARGET, DIMENSION(:,:) :: global_basinid_loc !! ID of basin (unitless) |
|---|
| 139 | !$OMP THREADPRIVATE(global_basinid_loc) |
|---|
| 140 | INTEGER(i_std), SAVE, ALLOCATABLE, TARGET, DIMENSION(:,:) :: hydrodiag_loc !! Variable to diagnose the hydrographs |
|---|
| 141 | !$OMP THREADPRIVATE(hydrodiag_loc) |
|---|
| 142 | REAL(r_std), SAVE, ALLOCATABLE, TARGET, DIMENSION(:) :: hydroupbasin_loc !! The area upstream of the gauging station (m^2) |
|---|
| 143 | !$OMP THREADPRIVATE(hydroupbasin_loc) |
|---|
| 144 | ! |
|---|
| 145 | ! parallelism |
|---|
| 146 | REAL(r_std), SAVE, ALLOCATABLE, TARGET, DIMENSION(:,:) :: routing_area_glo !! Surface of basin (m^2) |
|---|
| 147 | !$OMP THREADPRIVATE(routing_area_glo) |
|---|
| 148 | REAL(r_std), SAVE, ALLOCATABLE, TARGET, DIMENSION(:,:) :: topo_resid_glo !! Topographic index of the retention time (m) |
|---|
| 149 | !$OMP THREADPRIVATE(topo_resid_glo) |
|---|
| 150 | INTEGER(i_std), SAVE, ALLOCATABLE, TARGET, DIMENSION(:,:) :: route_togrid_glo !! Grid into which the basin flows (unitless) |
|---|
| 151 | !$OMP THREADPRIVATE(route_togrid_glo) |
|---|
| 152 | INTEGER(i_std), SAVE, ALLOCATABLE, TARGET, DIMENSION(:,:) :: route_tobasin_glo !! Basin in to which the water goes (unitless) |
|---|
| 153 | !$OMP THREADPRIVATE(route_tobasin_glo) |
|---|
| 154 | INTEGER(i_std), SAVE, ALLOCATABLE, TARGET, DIMENSION(:,:) :: route_nbintobas_glo !! Number of basin into current one (unitless) |
|---|
| 155 | !$OMP THREADPRIVATE(route_nbintobas_glo) |
|---|
| 156 | INTEGER(i_std), SAVE, ALLOCATABLE, TARGET, DIMENSION(:,:) :: global_basinid_glo !! ID of basin (unitless) |
|---|
| 157 | !$OMP THREADPRIVATE(global_basinid_glo) |
|---|
| 158 | INTEGER(i_std), SAVE, ALLOCATABLE, TARGET, DIMENSION(:,:) :: hydrodiag_glo !! Variable to diagnose the hydrographs |
|---|
| 159 | !$OMP THREADPRIVATE(hydrodiag_glo) |
|---|
| 160 | REAL(r_std), SAVE, ALLOCATABLE, TARGET, DIMENSION(:) :: hydroupbasin_glo !! The area upstream of the gauging station (m^2) |
|---|
| 161 | !$OMP THREADPRIVATE(hydroupbasin_glo) |
|---|
| 162 | ! |
|---|
| 163 | REAL(r_std), SAVE, POINTER, DIMENSION(:,:) :: routing_area !! Surface of basin (m^2) |
|---|
| 164 | !$OMP THREADPRIVATE(routing_area) |
|---|
| 165 | REAL(r_std), SAVE, POINTER, DIMENSION(:,:) :: topo_resid !! Topographic index of the retention time (m) |
|---|
| 166 | !$OMP THREADPRIVATE(topo_resid) |
|---|
| 167 | INTEGER(i_std), SAVE, POINTER, DIMENSION(:,:) :: route_togrid !! Grid into which the basin flows (unitless) |
|---|
| 168 | !$OMP THREADPRIVATE(route_togrid) |
|---|
| 169 | INTEGER(i_std), SAVE, POINTER, DIMENSION(:,:) :: route_tobasin !! Basin in to which the water goes (unitless) |
|---|
| 170 | !$OMP THREADPRIVATE(route_tobasin) |
|---|
| 171 | INTEGER(i_std), SAVE, POINTER, DIMENSION(:,:) :: route_nbintobas !! Number of basin into current one (unitless) |
|---|
| 172 | !$OMP THREADPRIVATE(route_nbintobas) |
|---|
| 173 | INTEGER(i_std), SAVE, POINTER, DIMENSION(:,:) :: global_basinid !! ID of basin (unitless) |
|---|
| 174 | !$OMP THREADPRIVATE(global_basinid) |
|---|
| 175 | INTEGER(i_std), SAVE, POINTER, DIMENSION(:,:) :: hydrodiag !! Variable to diagnose the hydrographs |
|---|
| 176 | !$OMP THREADPRIVATE(hydrodiag) |
|---|
| 177 | REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: slowflow_diag !! Diagnostic slow flow hydrographs (kg/dt) |
|---|
| 178 | !$OMP THREADPRIVATE(slowflow_diag) |
|---|
| 179 | REAL(r_std), SAVE, POINTER, DIMENSION(:) :: hydroupbasin !! The area upstream of the gauging station (m^2) |
|---|
| 180 | !$OMP THREADPRIVATE(hydroupbasin) |
|---|
| 181 | ! |
|---|
| 182 | REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: irrigated !! Area equipped for irrigation in each grid box (m^2) |
|---|
| 183 | !$OMP THREADPRIVATE(irrigated) |
|---|
| 184 | REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: floodplains !! Maximal surface which can be inundated in each grid box (m^2) |
|---|
| 185 | !$OMP THREADPRIVATE(floodplains) |
|---|
| 186 | REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: swamp !! Maximal surface of swamps in each grid box (m^2) |
|---|
| 187 | !$OMP THREADPRIVATE(swamp) |
|---|
| 188 | ! |
|---|
| 189 | ! The reservoirs, also to be put into the restart file. |
|---|
| 190 | ! |
|---|
| 191 | REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:,:) :: fast_reservoir !! Water amount in the fast reservoir (kg) |
|---|
| 192 | !$OMP THREADPRIVATE(fast_reservoir) |
|---|
| 193 | REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:,:) :: slow_reservoir !! Water amount in the slow reservoir (kg) |
|---|
| 194 | !$OMP THREADPRIVATE(slow_reservoir) |
|---|
| 195 | REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:,:) :: stream_reservoir !! Water amount in the stream reservoir (kg) |
|---|
| 196 | !$OMP THREADPRIVATE(stream_reservoir) |
|---|
| 197 | REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:,:) :: flood_reservoir !! Water amount in the floodplains reservoir (kg) |
|---|
| 198 | !$OMP THREADPRIVATE(flood_reservoir) |
|---|
| 199 | REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: lake_reservoir !! Water amount in the lake reservoir (kg) |
|---|
| 200 | !$OMP THREADPRIVATE(lake_reservoir) |
|---|
| 201 | REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: pond_reservoir !! Water amount in the pond reservoir (kg) |
|---|
| 202 | !$OMP THREADPRIVATE(pond_reservoir) |
|---|
| 203 | REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:,:) :: flood_frac_bas !! Flooded fraction per basin (unitless;0-1) |
|---|
| 204 | !$OMP THREADPRIVATE(flood_frac_bas) |
|---|
| 205 | REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: pond_frac !! Pond fraction per grid box (unitless;0-1) |
|---|
| 206 | !$OMP THREADPRIVATE(pond_frac) |
|---|
| 207 | REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: flood_height !! Floodplain height (mm) |
|---|
| 208 | !$OMP THREADPRIVATE(flood_height) |
|---|
| 209 | ! |
|---|
| 210 | ! The accumulated fluxes. |
|---|
| 211 | ! |
|---|
| 212 | REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: floodout_mean !! Accumulated flow out of floodplains (kg/m^2/dt) |
|---|
| 213 | !$OMP THREADPRIVATE(floodout_mean) |
|---|
| 214 | REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: runoff_mean !! Accumulated runoff (kg/m^2/dt) |
|---|
| 215 | !$OMP THREADPRIVATE(runoff_mean) |
|---|
| 216 | REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: drainage_mean !! Accumulated drainage (kg/m^2/dt) |
|---|
| 217 | !$OMP THREADPRIVATE(drainage_mean) |
|---|
| 218 | REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: transpot_mean !! Mean potential transpiration from the plants (kg/m^2/dt) |
|---|
| 219 | !$OMP THREADPRIVATE(transpot_mean) |
|---|
| 220 | REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: precip_mean !! Accumulated precipitation (kg/m^2/dt) |
|---|
| 221 | !$OMP THREADPRIVATE(precip_mean) |
|---|
| 222 | REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: humrel_mean !! Mean soil moisture stress, mean root extraction potential (unitless) |
|---|
| 223 | !$OMP THREADPRIVATE(humrel_mean) |
|---|
| 224 | REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: totnobio_mean !! Mean last total fraction of no bio (unitless;0-1) |
|---|
| 225 | !$OMP THREADPRIVATE(totnobio_mean) |
|---|
| 226 | REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: vegtot_mean !! Mean potentially vegetated fraction (unitless;0-1) |
|---|
| 227 | !$OMP THREADPRIVATE(vegtot_mean) |
|---|
| 228 | REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: k_litt_mean !! Mean averaged conductivity for saturated infiltration in the 'litter' layer (kg/m^2/dt) |
|---|
| 229 | !$OMP THREADPRIVATE(k_litt_mean) |
|---|
| 230 | ! |
|---|
| 231 | ! The averaged outflow fluxes. |
|---|
| 232 | ! |
|---|
| 233 | REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: lakeinflow_mean !! Mean lake inflow (kg/m^2/dt) |
|---|
| 234 | !$OMP THREADPRIVATE(lakeinflow_mean) |
|---|
| 235 | REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: returnflow_mean !! Mean water flow from lakes and swamps which returns to the grid box. |
|---|
| 236 | !! This water will go back into the hydrol or hydrolc module to allow re-evaporation (kg/m^2/dt) |
|---|
| 237 | !$OMP THREADPRIVATE(returnflow_mean) |
|---|
| 238 | REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: reinfiltration_mean !! Mean water flow which returns to the grid box (kg/m^2/dt) |
|---|
| 239 | !$OMP THREADPRIVATE(reinfiltration_mean) |
|---|
| 240 | REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: irrigation_mean !! Mean irrigation flux. |
|---|
| 241 | !! This is the water taken from the reservoirs and beeing put into the upper layers of the soil (kg/m^2/dt) |
|---|
| 242 | !$OMP THREADPRIVATE(irrigation_mean) |
|---|
| 243 | REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: riverflow_mean !! Mean Outflow of the major rivers. |
|---|
| 244 | !! The flux will be located on the continental grid but this should be a coastal point (kg/dt) |
|---|
| 245 | !$OMP THREADPRIVATE(riverflow_mean) |
|---|
| 246 | REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: coastalflow_mean !! Mean outflow on coastal points by small basins. |
|---|
| 247 | !! This is the water which flows in a disperse way into the ocean (kg/dt) |
|---|
| 248 | !$OMP THREADPRIVATE(coastalflow_mean) |
|---|
| 249 | REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: floodtemp !! Temperature to decide if floodplains work (K) |
|---|
| 250 | !$OMP THREADPRIVATE(floodtemp) |
|---|
| 251 | INTEGER(i_std), SAVE :: floodtemp_lev !! Temperature level to decide if floodplains work (K) |
|---|
| 252 | !$OMP THREADPRIVATE(floodtemp_lev) |
|---|
| 253 | ! |
|---|
| 254 | ! Diagnostic variables ... well sort of ! |
|---|
| 255 | ! |
|---|
| 256 | REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: irrig_netereq !! Irrigation requirement (water requirements by the crop for its optimal growth (kg/m^2/dt) |
|---|
| 257 | !$OMP THREADPRIVATE(irrig_netereq) |
|---|
| 258 | REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: hydrographs !! Hydrographs at the outflow of the grid box for major basins (kg/dt) |
|---|
| 259 | !$OMP THREADPRIVATE(hydrographs) |
|---|
| 260 | ! |
|---|
| 261 | ! Diagnostics for the various reservoirs we use (Kg/m^2) |
|---|
| 262 | ! |
|---|
| 263 | REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: fast_diag !! Diagnostic for the fast reservoir (kg/m^2) |
|---|
| 264 | !$OMP THREADPRIVATE(fast_diag) |
|---|
| 265 | REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: slow_diag !! Diagnostic for the slow reservoir (kg/m^2) |
|---|
| 266 | !$OMP THREADPRIVATE(slow_diag) |
|---|
| 267 | REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: stream_diag !! Diagnostic for the stream reservoir (kg/m^2) |
|---|
| 268 | !$OMP THREADPRIVATE(stream_diag) |
|---|
| 269 | REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: flood_diag !! Diagnostic for the floodplain reservoir (kg/m^2) |
|---|
| 270 | !$OMP THREADPRIVATE(flood_diag) |
|---|
| 271 | REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: pond_diag !! Diagnostic for the pond reservoir (kg/m^2) |
|---|
| 272 | !$OMP THREADPRIVATE(pond_diag) |
|---|
| 273 | REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: lake_diag !! Diagnostic for the lake reservoir (kg/m^2) |
|---|
| 274 | !$OMP THREADPRIVATE(lake_diag) |
|---|
| 275 | |
|---|
| 276 | REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: mask_coast !! Mask with coastal gridcells on local grid(1/0) |
|---|
| 277 | !$OMP THREADPRIVATE(mask_coast) |
|---|
| 278 | REAL(r_std), SAVE :: max_lake_reservoir !! Maximum limit of water in lake_reservoir [kg/m2] |
|---|
| 279 | !$OMP THREADPRIVATE(max_lake_reservoir) |
|---|
| 280 | INTEGER(i_std), SAVE :: nb_coast_gridcells !! Number of gridcells which can receive coastalflow |
|---|
| 281 | |
|---|
| 282 | |
|---|
| 283 | CONTAINS |
|---|
| 284 | !! ============================================================================================================================= |
|---|
| 285 | !! SUBROUTINE: routing_initialize |
|---|
| 286 | !! |
|---|
| 287 | !>\BRIEF Initialize the routing module |
|---|
| 288 | !! |
|---|
| 289 | !! DESCRIPTION: Initialize the routing module. Read from restart file or read the routing.nc file to initialize the |
|---|
| 290 | !! routing scheme. |
|---|
| 291 | !! |
|---|
| 292 | !! RECENT CHANGE(S) |
|---|
| 293 | !! |
|---|
| 294 | !! REFERENCE(S) |
|---|
| 295 | !! |
|---|
| 296 | !! FLOWCHART |
|---|
| 297 | !! \n |
|---|
| 298 | !_ ============================================================================================================================== |
|---|
| 299 | |
|---|
| 300 | SUBROUTINE routing_initialize( kjit, nbpt, index, & |
|---|
| 301 | rest_id, hist_id, hist2_id, lalo, & |
|---|
| 302 | neighbours, resolution, contfrac, stempdiag, & |
|---|
| 303 | returnflow, reinfiltration, irrigation, riverflow, & |
|---|
| 304 | coastalflow, flood_frac, flood_res ) |
|---|
| 305 | |
|---|
| 306 | IMPLICIT NONE |
|---|
| 307 | |
|---|
| 308 | !! 0.1 Input variables |
|---|
| 309 | INTEGER(i_std), INTENT(in) :: kjit !! Time step number (unitless) |
|---|
| 310 | INTEGER(i_std), INTENT(in) :: nbpt !! Domain size (unitless) |
|---|
| 311 | INTEGER(i_std), INTENT(in) :: index(nbpt) !! Indices of the points on the map (unitless) |
|---|
| 312 | INTEGER(i_std),INTENT(in) :: rest_id !! Restart file identifier (unitless) |
|---|
| 313 | INTEGER(i_std),INTENT(in) :: hist_id !! Access to history file (unitless) |
|---|
| 314 | INTEGER(i_std),INTENT(in) :: hist2_id !! Access to history file 2 (unitless) |
|---|
| 315 | REAL(r_std), INTENT(in) :: lalo(nbpt,2) !! Vector of latitude and longitudes (beware of the order !) |
|---|
| 316 | |
|---|
| 317 | INTEGER(i_std), INTENT(in) :: neighbours(nbpt,NbNeighb) !! Vector of neighbours for each grid point |
|---|
| 318 | !! (1=N, 2=NE, 3=E, 4=SE, 5=S, 6=SW, 7=W, 8=NW) (unitless) |
|---|
| 319 | REAL(r_std), INTENT(in) :: resolution(nbpt,2) !! The size of each grid box in X and Y (m) |
|---|
| 320 | REAL(r_std), INTENT(in) :: contfrac(nbpt) !! Fraction of land in each grid box (unitless;0-1) |
|---|
| 321 | REAL(r_std), INTENT(in) :: stempdiag(nbpt,nslm) !! Diagnostic soil temperature profile |
|---|
| 322 | |
|---|
| 323 | !! 0.2 Output variables |
|---|
| 324 | REAL(r_std), INTENT(out) :: returnflow(nbpt) !! The water flow from lakes and swamps which returns to the grid box. |
|---|
| 325 | !! This water will go back into the hydrol or hydrolc module to allow re-evaporation (kg/m^2/dt) |
|---|
| 326 | REAL(r_std), INTENT(out) :: reinfiltration(nbpt) !! Water flow from ponds and floodplains which returns to the grid box (kg/m^2/dt) |
|---|
| 327 | REAL(r_std), INTENT(out) :: irrigation(nbpt) !! Irrigation flux. This is the water taken from the reservoirs and beeing put into the upper layers of the soil (kg/m^2/dt) |
|---|
| 328 | REAL(r_std), INTENT(out) :: riverflow(nbpt) !! Outflow of the major rivers. The flux will be located on the continental grid but this should be a coastal point (kg/dt) |
|---|
| 329 | |
|---|
| 330 | REAL(r_std), INTENT(out) :: coastalflow(nbpt) !! Outflow on coastal points by small basins. This is the water which flows in a disperse way into the ocean (kg/dt) |
|---|
| 331 | REAL(r_std), INTENT(out) :: flood_frac(nbpt) !! Flooded fraction of the grid box (unitless;0-1) |
|---|
| 332 | REAL(r_std), INTENT(out) :: flood_res(nbpt) !! Diagnostic of water amount in the floodplains reservoir (kg) |
|---|
| 333 | |
|---|
| 334 | !! 0.3 Local variables |
|---|
| 335 | REAL(r_std), DIMENSION(nbp_glo):: mask_coast_glo !! Mask with coastal gridcells on global grid (1/0) |
|---|
| 336 | LOGICAL :: init_irrig !! Logical to initialize the irrigation (true/false) |
|---|
| 337 | LOGICAL :: init_flood !! Logical to initialize the floodplains (true/false) |
|---|
| 338 | LOGICAL :: init_swamp !! Logical to initialize the swamps (true/false) |
|---|
| 339 | INTEGER :: ig, ib, rtg, rtb !! Index |
|---|
| 340 | INTEGER :: ier !! Error handeling |
|---|
| 341 | !_ ================================================================================================================================ |
|---|
| 342 | |
|---|
| 343 | ! |
|---|
| 344 | ! do initialisation |
|---|
| 345 | ! |
|---|
| 346 | nbvmax = 440 |
|---|
| 347 | ! Here we will allocate the memory and get the fixed fields from the restart file. |
|---|
| 348 | ! If the info is not found then we will compute the routing map. |
|---|
| 349 | ! |
|---|
| 350 | |
|---|
| 351 | CALL routing_init (kjit, nbpt, index, returnflow, reinfiltration, irrigation, & |
|---|
| 352 | riverflow, coastalflow, flood_frac, flood_res, stempdiag, rest_id) |
|---|
| 353 | |
|---|
| 354 | routing_area => routing_area_loc |
|---|
| 355 | topo_resid => topo_resid_loc |
|---|
| 356 | route_togrid => route_togrid_loc |
|---|
| 357 | route_tobasin => route_tobasin_loc |
|---|
| 358 | global_basinid => global_basinid_loc |
|---|
| 359 | hydrodiag => hydrodiag_loc |
|---|
| 360 | |
|---|
| 361 | ! This routine computes the routing map if the route_togrid_glo is undefined. This means that the |
|---|
| 362 | ! map has not been initialized during the restart process.. |
|---|
| 363 | ! |
|---|
| 364 | !! Reads in the map of the basins and flow directions to construct the catchments of each grid box |
|---|
| 365 | ! |
|---|
| 366 | IF ( COUNT(route_togrid_glo .GE. undef_int) .GT. 0 ) THEN |
|---|
| 367 | CALL routing_basins_p(nbpt, lalo, neighbours, resolution, contfrac) |
|---|
| 368 | ENDIF |
|---|
| 369 | |
|---|
| 370 | !! Create a mask containing all possible coastal gridcells and count total number of coastal gridcells |
|---|
| 371 | IF (is_root_prc) THEN |
|---|
| 372 | mask_coast_glo(:)=0 |
|---|
| 373 | DO ib=1,nbasmax |
|---|
| 374 | DO ig=1,nbp_glo |
|---|
| 375 | rtg = route_togrid_glo(ig,ib) |
|---|
| 376 | rtb = route_tobasin_glo(ig,ib) |
|---|
| 377 | ! Coastal gridcells are stored in nbasmax+2 |
|---|
| 378 | IF (rtb == nbasmax+2) THEN |
|---|
| 379 | mask_coast_glo(rtg) = 1 |
|---|
| 380 | END IF |
|---|
| 381 | END DO |
|---|
| 382 | END DO |
|---|
| 383 | nb_coast_gridcells=SUM(mask_coast_glo) |
|---|
| 384 | IF (printlev>=3) WRITE(numout,*) 'Number of coastal gridcells = ', nb_coast_gridcells |
|---|
| 385 | ENDIF |
|---|
| 386 | CALL bcast(nb_coast_gridcells) |
|---|
| 387 | |
|---|
| 388 | ALLOCATE(mask_coast(nbpt), stat=ier) |
|---|
| 389 | IF (ier /= 0) CALL ipslerr_p(3,'routing_inititalize','Pb in allocate for mask_coast','','') |
|---|
| 390 | CALL scatter(mask_coast_glo, mask_coast) |
|---|
| 391 | CALL xios_orchidee_send_field("mask_coast",mask_coast) |
|---|
| 392 | |
|---|
| 393 | |
|---|
| 394 | ! |
|---|
| 395 | ! Do we have what we need if we want to do irrigation |
|---|
| 396 | !! Initialisation of flags for irrigated land, flood plains and swamps |
|---|
| 397 | ! |
|---|
| 398 | init_irrig = .FALSE. |
|---|
| 399 | IF ( do_irrigation ) THEN |
|---|
| 400 | IF (COUNT(irrigated .GE. undef_sechiba-1) > 0) init_irrig = .TRUE. |
|---|
| 401 | END IF |
|---|
| 402 | |
|---|
| 403 | init_flood = .FALSE. |
|---|
| 404 | IF ( do_floodplains ) THEN |
|---|
| 405 | IF (COUNT(floodplains .GE. undef_sechiba-1) > 0) init_flood = .TRUE. |
|---|
| 406 | END IF |
|---|
| 407 | |
|---|
| 408 | init_swamp = .FALSE. |
|---|
| 409 | IF ( doswamps ) THEN |
|---|
| 410 | IF (COUNT(swamp .GE. undef_sechiba-1) > 0 ) init_swamp = .TRUE. |
|---|
| 411 | END IF |
|---|
| 412 | |
|---|
| 413 | !! If we have irrigated land, flood plains or swamps then we need to interpolate the 0.5 degree |
|---|
| 414 | !! base data set to the resolution of the model. |
|---|
| 415 | |
|---|
| 416 | IF ( init_irrig .OR. init_flood .OR. init_swamp ) THEN |
|---|
| 417 | CALL routing_irrigmap(nbpt, index, lalo, neighbours, resolution, & |
|---|
| 418 | contfrac, init_irrig, irrigated, init_flood, floodplains, init_swamp, swamp, hist_id, hist2_id) |
|---|
| 419 | ENDIF |
|---|
| 420 | |
|---|
| 421 | IF ( do_irrigation ) THEN |
|---|
| 422 | CALL xios_orchidee_send_field("irrigmap",irrigated) |
|---|
| 423 | |
|---|
| 424 | IF (printlev >= 3) WRITE(numout,*) 'Verification : range of irrigated : ', MINVAL(irrigated), MAXVAL(irrigated) |
|---|
| 425 | IF ( .NOT. almaoutput ) THEN |
|---|
| 426 | CALL histwrite_p(hist_id, 'irrigmap', 1, irrigated, nbpt, index) |
|---|
| 427 | ELSE |
|---|
| 428 | CALL histwrite_p(hist_id, 'IrrigationMap', 1, irrigated, nbpt, index) |
|---|
| 429 | ENDIF |
|---|
| 430 | IF ( hist2_id > 0 ) THEN |
|---|
| 431 | IF ( .NOT. almaoutput ) THEN |
|---|
| 432 | CALL histwrite_p(hist2_id, 'irrigmap', 1, irrigated, nbpt, index) |
|---|
| 433 | ELSE |
|---|
| 434 | CALL histwrite_p(hist2_id, 'IrrigationMap', 1, irrigated, nbpt, index) |
|---|
| 435 | ENDIF |
|---|
| 436 | ENDIF |
|---|
| 437 | ENDIF |
|---|
| 438 | |
|---|
| 439 | IF ( do_floodplains ) THEN |
|---|
| 440 | CALL xios_orchidee_send_field("floodmap",floodplains) |
|---|
| 441 | |
|---|
| 442 | IF (printlev>=3) WRITE(numout,*) 'Verification : range of floodplains : ', MINVAL(floodplains), MAXVAL(floodplains) |
|---|
| 443 | IF ( .NOT. almaoutput ) THEN |
|---|
| 444 | CALL histwrite_p(hist_id, 'floodmap', 1, floodplains, nbpt, index) |
|---|
| 445 | ELSE |
|---|
| 446 | CALL histwrite_p(hist_id, 'FloodplainsMap', 1, floodplains, nbpt, index) |
|---|
| 447 | ENDIF |
|---|
| 448 | IF ( hist2_id > 0 ) THEN |
|---|
| 449 | IF ( .NOT. almaoutput ) THEN |
|---|
| 450 | CALL histwrite_p(hist2_id, 'floodmap', 1, floodplains, nbpt, index) |
|---|
| 451 | ELSE |
|---|
| 452 | CALL histwrite_p(hist2_id, 'FloodplainsMap', 1, floodplains, nbpt, index) |
|---|
| 453 | ENDIF |
|---|
| 454 | ENDIF |
|---|
| 455 | ENDIF |
|---|
| 456 | |
|---|
| 457 | IF ( doswamps ) THEN |
|---|
| 458 | CALL xios_orchidee_send_field("swampmap",swamp) |
|---|
| 459 | |
|---|
| 460 | IF (printlev>=3) WRITE(numout,*) 'Verification : range of swamp : ', MINVAL(swamp), MAXVAL(swamp) |
|---|
| 461 | IF ( .NOT. almaoutput ) THEN |
|---|
| 462 | CALL histwrite_p(hist_id, 'swampmap', 1, swamp, nbpt, index) |
|---|
| 463 | ELSE |
|---|
| 464 | CALL histwrite_p(hist_id, 'SwampMap', 1, swamp, nbpt, index) |
|---|
| 465 | ENDIF |
|---|
| 466 | IF ( hist2_id > 0 ) THEN |
|---|
| 467 | IF ( .NOT. almaoutput ) THEN |
|---|
| 468 | CALL histwrite_p(hist2_id, 'swampmap', 1, swamp, nbpt, index) |
|---|
| 469 | ELSE |
|---|
| 470 | CALL histwrite_p(hist2_id, 'SwampMap', 1, swamp, nbpt, index) |
|---|
| 471 | ENDIF |
|---|
| 472 | ENDIF |
|---|
| 473 | ENDIF |
|---|
| 474 | |
|---|
| 475 | !! This routine gives a diagnostic of the basins used. |
|---|
| 476 | CALL routing_diagnostic_p(nbpt, index, lalo, resolution, contfrac, hist_id, hist2_id) |
|---|
| 477 | |
|---|
| 478 | END SUBROUTINE routing_initialize |
|---|
| 479 | |
|---|
| 480 | !! ================================================================================================================================ |
|---|
| 481 | !! SUBROUTINE : routing_main |
|---|
| 482 | !! |
|---|
| 483 | !>\BRIEF This module routes the water over the continents (runoff and |
|---|
| 484 | !! drainage produced by the hydrolc or hydrol module) into the oceans. |
|---|
| 485 | !! |
|---|
| 486 | !! DESCRIPTION (definitions, functional, design, flags): |
|---|
| 487 | !! The routing scheme (Polcher, 2003) carries the water from the runoff and drainage simulated by SECHIBA |
|---|
| 488 | !! to the ocean through reservoirs, with some delay. The routing scheme is based on |
|---|
| 489 | !! a parametrization of the water flow on a global scale (Miller et al., 1994; Hagemann |
|---|
| 490 | !! and Dumenil, 1998). Given the global map of the main watersheds (Oki et al., 1999; |
|---|
| 491 | !! Fekete et al., 1999; Vorosmarty et al., 2000) which delineates the boundaries of subbasins |
|---|
| 492 | !! and gives the eight possible directions of water flow within the pixel, the surface |
|---|
| 493 | !! runoff and the deep drainage are routed to the ocean. The time-step of the routing is one day. |
|---|
| 494 | !! The scheme also diagnoses how much water is retained in the foodplains and thus return to soil |
|---|
| 495 | !! moisture or is taken out of the rivers for irrigation. \n |
|---|
| 496 | !! |
|---|
| 497 | !! RECENT CHANGE(S): None |
|---|
| 498 | !! |
|---|
| 499 | !! MAIN OUTPUT VARIABLE(S): |
|---|
| 500 | !! The result of the routing are 3 fluxes : |
|---|
| 501 | !! - riverflow : The water which flows out from the major rivers. The flux will be located |
|---|
| 502 | !! on the continental grid but this should be a coastal point. |
|---|
| 503 | !! - coastalflow : This is the water which flows in a disperse way into the ocean. Essentially these |
|---|
| 504 | !! are the outflows from all of the small rivers. |
|---|
| 505 | !! - returnflow : This is the water which flows into a land-point - typically rivers which end in |
|---|
| 506 | !! the desert. This water will go back into the hydrol module to allow re-evaporation. |
|---|
| 507 | !! - irrigation : This is water taken from the reservoir and is being put into the upper |
|---|
| 508 | !! layers of the soil. |
|---|
| 509 | !! The two first fluxes are in kg/dt and the last two fluxes are in kg/(m^2dt).\n |
|---|
| 510 | !! |
|---|
| 511 | !! REFERENCE(S) : |
|---|
| 512 | !! - Miller JR, Russell GL, Caliri G (1994) |
|---|
| 513 | !! Continental-scale river flow in climate models. |
|---|
| 514 | !! J. Clim., 7:914-928 |
|---|
| 515 | !! - Hagemann S and Dumenil L. (1998) |
|---|
| 516 | !! A parametrization of the lateral waterflow for the global scale. |
|---|
| 517 | !! Clim. Dyn., 14:17-31 |
|---|
| 518 | !! - Oki, T., T. Nishimura, and P. Dirmeyer (1999) |
|---|
| 519 | !! Assessment of annual runoff from land surface models using total runoff integrating pathways (TRIP) |
|---|
| 520 | !! J. Meteorol. Soc. Jpn., 77, 235-255 |
|---|
| 521 | !! - Fekete BM, Charles V, Grabs W (2000) |
|---|
| 522 | !! Global, composite runoff fields based on observed river discharge and simulated water balances. |
|---|
| 523 | !! Technical report, UNH/GRDC, Global Runoff Data Centre, Koblenz |
|---|
| 524 | !! - Vorosmarty, C., B. Fekete, B. Meybeck, and R. Lammers (2000) |
|---|
| 525 | !! Global system of rivers: Its role in organizing continental land mass and defining land-to-ocean linkages |
|---|
| 526 | !! Global Biogeochem. Cycles, 14, 599-621 |
|---|
| 527 | !! - Vivant, A-C. (?? 2002) |
|---|
| 528 | !! Développement du schéma de routage et des plaines d'inondation, MSc Thesis, Paris VI University |
|---|
| 529 | !! - J. Polcher (2003) |
|---|
| 530 | !! Les processus de surface a l'echelle globale et leurs interactions avec l'atmosphere |
|---|
| 531 | !! Habilitation a diriger les recherches, Paris VI University, 67pp. |
|---|
| 532 | !! |
|---|
| 533 | !! FLOWCHART : |
|---|
| 534 | !! \latexonly |
|---|
| 535 | !! \includegraphics[scale=0.75]{routing_main_flowchart.png} |
|---|
| 536 | !! \endlatexonly |
|---|
| 537 | !! \n |
|---|
| 538 | !_ ================================================================================================================================ |
|---|
| 539 | |
|---|
| 540 | SUBROUTINE routing_main(kjit, nbpt, index, & |
|---|
| 541 | & lalo, neighbours, resolution, contfrac, totfrac_nobio, veget, veget_max, soil_deficit, floodout, runoff, & |
|---|
| 542 | & drainage, transpot, evapot_corr, vegstress, precip_rain, humrel, k_litt, flood_frac, flood_res, & |
|---|
| 543 | & stempdiag, reinf_slope, returnflow, reinfiltration, irrigation, riverflow, coastalflow, rest_id, hist_id, hist2_id) |
|---|
| 544 | |
|---|
| 545 | IMPLICIT NONE |
|---|
| 546 | |
|---|
| 547 | !! 0.1 Input variables |
|---|
| 548 | INTEGER(i_std), INTENT(in) :: kjit !! Time step number (unitless) |
|---|
| 549 | INTEGER(i_std), INTENT(in) :: nbpt !! Domain size (unitless) |
|---|
| 550 | INTEGER(i_std),INTENT(in) :: rest_id !! Restart file identifier (unitless) |
|---|
| 551 | INTEGER(i_std),INTENT(in) :: hist_id !! Access to history file (unitless) |
|---|
| 552 | INTEGER(i_std),INTENT(in) :: hist2_id !! Access to history file 2 (unitless) |
|---|
| 553 | INTEGER(i_std), INTENT(in) :: index(nbpt) !! Indices of the points on the map (unitless) |
|---|
| 554 | REAL(r_std), INTENT(in) :: lalo(nbpt,2) !! Vector of latitude and longitudes (beware of the order !) |
|---|
| 555 | INTEGER(i_std), INTENT(in) :: neighbours(nbpt,NbNeighb) !! Vector of neighbours for each grid point (1=N, 2=NE, 3=E, 4=SE, 5=S, 6=SW, 7=W, 8=NW) (unitless) |
|---|
| 556 | REAL(r_std), INTENT(in) :: resolution(nbpt,2) !! The size of each grid box in X and Y (m) |
|---|
| 557 | REAL(r_std), INTENT(in) :: contfrac(nbpt) !! Fraction of land in each grid box (unitless;0-1) |
|---|
| 558 | REAL(r_std), INTENT(in) :: totfrac_nobio(nbpt) !! Total fraction of no-vegetation (continental ice, lakes ...) (unitless;0-1) |
|---|
| 559 | REAL(r_std), INTENT(in) :: veget(nbpt,nvm) !! fraction of vegetation (unitless;0-1) |
|---|
| 560 | REAL(r_std), INTENT(in) :: veget_max(nbpt,nvm) !! Maximal fraction of vegetation (unitless;0-1) |
|---|
| 561 | REAL(r_std), INTENT(in) :: soil_deficit(nbpt,nvm) !! soil water deficit |
|---|
| 562 | REAL(r_std), INTENT(in) :: floodout(nbpt) !! Grid-point flow out of floodplains (kg/m^2/dt) |
|---|
| 563 | REAL(r_std), INTENT(in) :: runoff(nbpt) !! Grid-point runoff (kg/m^2/dt) |
|---|
| 564 | REAL(r_std), INTENT(in) :: drainage(nbpt) !! Grid-point drainage (kg/m^2/dt) |
|---|
| 565 | REAL(r_std), INTENT(in) :: transpot(nbpt,nvm) !! Potential transpiration of the vegetation (kg/m^2/dt) |
|---|
| 566 | REAL(r_std), INTENT(in) :: evapot_corr(nbpt) !! Potential soil evaporation (kg/m^2/dt) |
|---|
| 567 | REAL(r_std), INTENT(in) :: vegstress(nbpt,nvm) !! stress for vegetation growth (unitless; 0-1) |
|---|
| 568 | REAL(r_std), INTENT(in) :: precip_rain(nbpt) !! Rainfall (kg/m^2/dt) |
|---|
| 569 | REAL(r_std), INTENT(in) :: k_litt(nbpt) !! Averaged conductivity for saturated infiltration in the 'litter' layer (kg/m^2/dt) |
|---|
| 570 | REAL(r_std), INTENT(in) :: humrel(nbpt,nvm) !! Soil moisture stress, root extraction potential (unitless) |
|---|
| 571 | REAL(r_std), INTENT(in) :: stempdiag(nbpt,nslm) !! Diagnostic soil temperature profile |
|---|
| 572 | REAL(r_std), INTENT(in) :: reinf_slope(nbpt) !! Coefficient which determines the reinfiltration ratio in the grid box due to flat areas (unitless;0-1) |
|---|
| 573 | |
|---|
| 574 | !! 0.2 Output variables |
|---|
| 575 | REAL(r_std), INTENT(out) :: returnflow(nbpt) !! The water flow from lakes and swamps which returns to the grid box. |
|---|
| 576 | !! This water will go back into the hydrol or hydrolc module to allow re-evaporation (kg/m^2/dt) |
|---|
| 577 | REAL(r_std), INTENT(out) :: reinfiltration(nbpt) !! Water flow from ponds and floodplains which returns to the grid box (kg/m^2/dt) |
|---|
| 578 | REAL(r_std), INTENT(out) :: irrigation(nbpt) !! Irrigation flux. This is the water taken from the reservoirs and beeing put into the upper layers of the soil (kg/m^2/dt) |
|---|
| 579 | REAL(r_std), INTENT(out) :: riverflow(nbpt) !! Outflow of the major rivers. The flux will be located on the continental grid but this should be a coastal point (kg/dt) |
|---|
| 580 | REAL(r_std), INTENT(out) :: coastalflow(nbpt) !! Outflow on coastal points by small basins. This is the water which flows in a disperse way into the ocean (kg/dt) |
|---|
| 581 | REAL(r_std), INTENT(out) :: flood_frac(nbpt) !! Flooded fraction of the grid box (unitless;0-1) |
|---|
| 582 | REAL(r_std), INTENT(out) :: flood_res(nbpt) !! Diagnostic of water amount in the floodplains reservoir (kg) |
|---|
| 583 | |
|---|
| 584 | !! 0.3 Local variables |
|---|
| 585 | CHARACTER(LEN=30) :: var_name !! To store variables names for I/O (unitless) |
|---|
| 586 | REAL(r_std), DIMENSION(1) :: tmp_day !! |
|---|
| 587 | REAL(r_std), DIMENSION(nbpt) :: return_lakes !! Water from lakes flowing back into soil moisture (kg/m^2/dt) |
|---|
| 588 | |
|---|
| 589 | INTEGER(i_std) :: ig, jv !! Indices (unitless) |
|---|
| 590 | REAL(r_std), DIMENSION(nbpt) :: tot_vegfrac_nowoody !! Total fraction occupied by grass (0-1,unitless) |
|---|
| 591 | REAL(r_std), DIMENSION(nbpt) :: tot_vegfrac_crop !! Total fraction occupied by croplands (0-1,unitless) |
|---|
| 592 | |
|---|
| 593 | REAL(r_std), DIMENSION(nbpt) :: fast_diag_old !! Reservoir in the beginning of the time step |
|---|
| 594 | REAL(r_std), DIMENSION(nbpt) :: slow_diag_old !! Reservoir in the beginning of the time step |
|---|
| 595 | REAL(r_std), DIMENSION(nbpt) :: stream_diag_old !! Reservoir in the beginning of the time step |
|---|
| 596 | REAL(r_std), DIMENSION(nbpt) :: lake_diag_old !! Reservoir in the beginning of the time step |
|---|
| 597 | REAL(r_std), DIMENSION(nbpt) :: pond_diag_old !! Reservoir in the beginning of the time step |
|---|
| 598 | REAL(r_std), DIMENSION(nbpt) :: flood_diag_old !! Reservoir in the beginning of the time step |
|---|
| 599 | |
|---|
| 600 | !! For water budget check in the three routing reservoirs (positive if input > output) |
|---|
| 601 | !! Net fluxes averaged over each grid cell in kg/m^2/dt |
|---|
| 602 | REAL(r_std), DIMENSION(nbpt) :: netflow_stream_diag !! Input - Output flow to stream reservoir |
|---|
| 603 | REAL(r_std), DIMENSION(nbpt) :: netflow_fast_diag !! Input - Output flow to fast reservoir |
|---|
| 604 | REAL(r_std), DIMENSION(nbpt) :: netflow_slow_diag !! Input - Output flow to slow reservoir |
|---|
| 605 | |
|---|
| 606 | |
|---|
| 607 | !_ ================================================================================================================================ |
|---|
| 608 | |
|---|
| 609 | ! Save reservoirs in beginning of time step to calculate the water budget |
|---|
| 610 | fast_diag_old = fast_diag |
|---|
| 611 | slow_diag_old = slow_diag |
|---|
| 612 | stream_diag_old = stream_diag |
|---|
| 613 | lake_diag_old = lake_diag |
|---|
| 614 | pond_diag_old = pond_diag |
|---|
| 615 | flood_diag_old = flood_diag |
|---|
| 616 | |
|---|
| 617 | ! |
|---|
| 618 | !! Computes the variables averaged between routing time steps and which will be used in subsequent calculations |
|---|
| 619 | ! |
|---|
| 620 | floodout_mean(:) = floodout_mean(:) + floodout(:) |
|---|
| 621 | runoff_mean(:) = runoff_mean(:) + runoff(:) |
|---|
| 622 | drainage_mean(:) = drainage_mean(:) + drainage(:) |
|---|
| 623 | floodtemp(:) = stempdiag(:,floodtemp_lev) |
|---|
| 624 | precip_mean(:) = precip_mean(:) + precip_rain(:) |
|---|
| 625 | ! |
|---|
| 626 | !! Computes the total fraction occupied by the grasses and the crops for each grid cell |
|---|
| 627 | tot_vegfrac_nowoody(:) = zero |
|---|
| 628 | tot_vegfrac_crop(:) = zero |
|---|
| 629 | DO jv = 1, nvm |
|---|
| 630 | IF ( (jv /= ibare_sechiba) .AND. .NOT.(is_tree(jv)) ) THEN |
|---|
| 631 | tot_vegfrac_nowoody(:) = tot_vegfrac_nowoody(:) + veget_max(:,jv) |
|---|
| 632 | END IF |
|---|
| 633 | IF ( (jv /= ibare_sechiba) .AND. ok_LAIdev(jv) ) THEN ! cropland judgement using ok_LAIdev, xuhui |
|---|
| 634 | tot_vegfrac_crop(:) = tot_vegfrac_crop(:) + veget_max(:,jv) |
|---|
| 635 | ENDIF |
|---|
| 636 | END DO |
|---|
| 637 | |
|---|
| 638 | DO ig = 1, nbpt |
|---|
| 639 | IF ( tot_vegfrac_nowoody(ig) .GT. min_sechiba ) THEN |
|---|
| 640 | DO jv = 1,nvm |
|---|
| 641 | IF ( (jv /= ibare_sechiba) .AND. .NOT.(is_tree(jv)) ) THEN |
|---|
| 642 | transpot_mean(ig) = transpot_mean(ig) + transpot(ig,jv) * veget_max(ig,jv)/tot_vegfrac_nowoody(ig) |
|---|
| 643 | END IF |
|---|
| 644 | END DO |
|---|
| 645 | ELSE |
|---|
| 646 | IF (MAXVAL(veget_max(ig,2:nvm)) .GT. min_sechiba) THEN |
|---|
| 647 | DO jv = 2, nvm |
|---|
| 648 | transpot_mean(ig) = transpot_mean(ig) + transpot(ig,jv) * veget_max(ig,jv)/ SUM(veget_max(ig,2:nvm)) |
|---|
| 649 | ENDDO |
|---|
| 650 | ENDIF |
|---|
| 651 | ENDIF |
|---|
| 652 | ENDDO |
|---|
| 653 | |
|---|
| 654 | ! |
|---|
| 655 | ! Averaged variables (i.e. *dt_sechiba/dt_routing). This accounts for the difference between the shorter |
|---|
| 656 | ! timestep dt_sechiba of other parts of the model and the long dt_routing timestep (set to one day at present) |
|---|
| 657 | ! |
|---|
| 658 | totnobio_mean(:) = totnobio_mean(:) + totfrac_nobio(:)*dt_sechiba/dt_routing |
|---|
| 659 | k_litt_mean(:) = k_litt_mean(:) + k_litt(:)*dt_sechiba/dt_routing |
|---|
| 660 | ! |
|---|
| 661 | ! Only potentially vegetated surfaces are taken into account. At the start of |
|---|
| 662 | ! the growing seasons we will give more weight to these areas. |
|---|
| 663 | ! |
|---|
| 664 | DO jv=2,nvm |
|---|
| 665 | DO ig=1,nbpt |
|---|
| 666 | humrel_mean(ig) = humrel_mean(ig) + humrel(ig,jv)*veget_max(ig,jv)*dt_sechiba/dt_routing |
|---|
| 667 | vegtot_mean(ig) = vegtot_mean(ig) + veget_max(ig,jv)*dt_sechiba/dt_routing |
|---|
| 668 | ENDDO |
|---|
| 669 | ENDDO |
|---|
| 670 | ! |
|---|
| 671 | time_counter = time_counter + dt_sechiba |
|---|
| 672 | ! |
|---|
| 673 | ! If the time has come we do the routing. |
|---|
| 674 | ! |
|---|
| 675 | IF ( NINT(time_counter) .GE. NINT(dt_routing) ) THEN |
|---|
| 676 | ! |
|---|
| 677 | ! Check the water balance if needed |
|---|
| 678 | ! |
|---|
| 679 | IF ( check_waterbal ) THEN |
|---|
| 680 | CALL routing_waterbal(nbpt, .TRUE., floodout_mean, runoff_mean, drainage_mean, returnflow_mean, & |
|---|
| 681 | & reinfiltration_mean, irrigation_mean, riverflow_mean, coastalflow_mean) |
|---|
| 682 | ENDIF |
|---|
| 683 | ! |
|---|
| 684 | !! Computes the transport of water in the various reservoirs |
|---|
| 685 | ! |
|---|
| 686 | CALL routing_flow(nbpt, dt_routing, lalo, floodout_mean, runoff_mean, drainage_mean, & |
|---|
| 687 | & vegtot_mean, totnobio_mean, transpot_mean, transpot, evapot_corr, veget, veget_max, soil_deficit, & |
|---|
| 688 | & precip_mean, humrel_mean, k_litt_mean, floodtemp, reinf_slope, & |
|---|
| 689 | & lakeinflow_mean, returnflow_mean, reinfiltration_mean, irrigation_mean, riverflow_mean, & |
|---|
| 690 | & coastalflow_mean, hydrographs, slowflow_diag, flood_frac, flood_res, vegstress, & |
|---|
| 691 | & netflow_stream_diag, netflow_fast_diag, netflow_slow_diag) |
|---|
| 692 | ! |
|---|
| 693 | !! Responsible for storing the water in lakes |
|---|
| 694 | ! |
|---|
| 695 | CALL routing_lake(nbpt, dt_routing, lakeinflow_mean, humrel_mean, return_lakes) |
|---|
| 696 | ! |
|---|
| 697 | returnflow_mean(:) = returnflow_mean(:) + return_lakes(:) |
|---|
| 698 | ! |
|---|
| 699 | !! Check the water balance in the routing scheme |
|---|
| 700 | ! |
|---|
| 701 | IF ( check_waterbal ) THEN |
|---|
| 702 | CALL routing_waterbal(nbpt, .FALSE., floodout_mean, runoff_mean, drainage_mean, returnflow_mean, & |
|---|
| 703 | & reinfiltration_mean, irrigation_mean, riverflow_mean, coastalflow_mean) |
|---|
| 704 | ENDIF |
|---|
| 705 | ! |
|---|
| 706 | time_counter = zero |
|---|
| 707 | ! |
|---|
| 708 | floodout_mean(:) = zero |
|---|
| 709 | runoff_mean(:) = zero |
|---|
| 710 | drainage_mean(:) = zero |
|---|
| 711 | transpot_mean(:) = zero |
|---|
| 712 | precip_mean(:) = zero |
|---|
| 713 | ! |
|---|
| 714 | humrel_mean(:) = zero |
|---|
| 715 | totnobio_mean(:) = zero |
|---|
| 716 | k_litt_mean(:) = zero |
|---|
| 717 | vegtot_mean(:) = zero |
|---|
| 718 | |
|---|
| 719 | ! Change the units of the routing fluxes from kg/dt_routing into kg/dt_sechiba |
|---|
| 720 | hydrographs(:) = hydrographs(:)/dt_routing*dt_sechiba |
|---|
| 721 | slowflow_diag(:) = slowflow_diag(:)/dt_routing*dt_sechiba |
|---|
| 722 | |
|---|
| 723 | ! Change the units of the routing fluxes from kg/m^2/dt_routing into kg/m^2/dt_sechiba |
|---|
| 724 | returnflow_mean(:) = returnflow_mean(:)/dt_routing*dt_sechiba |
|---|
| 725 | reinfiltration_mean(:) = reinfiltration_mean(:)/dt_routing*dt_sechiba |
|---|
| 726 | irrigation_mean(:) = irrigation_mean(:)/dt_routing*dt_sechiba |
|---|
| 727 | irrig_netereq(:) = irrig_netereq(:)/dt_routing*dt_sechiba |
|---|
| 728 | |
|---|
| 729 | ! Change units as above but at the same time transform the kg/dt_routing to m^3/dt_sechiba |
|---|
| 730 | riverflow_mean(:) = riverflow_mean(:)/dt_routing*dt_sechiba/mille |
|---|
| 731 | coastalflow_mean(:) = coastalflow_mean(:)/dt_routing*dt_sechiba/mille |
|---|
| 732 | |
|---|
| 733 | ! Water budget residu of the three routing reservoirs (in kg/m^2/s) |
|---|
| 734 | ! Note that these diagnostics are done using local variables only calculated |
|---|
| 735 | ! during the time steps when the routing is calculated |
|---|
| 736 | CALL xios_orchidee_send_field("wbr_stream",(stream_diag - stream_diag_old - netflow_stream_diag)/dt_routing) |
|---|
| 737 | CALL xios_orchidee_send_field("wbr_fast", (fast_diag - fast_diag_old - netflow_fast_diag)/dt_routing) |
|---|
| 738 | CALL xios_orchidee_send_field("wbr_slow", (slow_diag - slow_diag_old - netflow_slow_diag)/dt_routing) |
|---|
| 739 | CALL xios_orchidee_send_field("wbr_lake", (lake_diag - lake_diag_old - & |
|---|
| 740 | lakeinflow_mean + return_lakes)/dt_routing) |
|---|
| 741 | ENDIF |
|---|
| 742 | |
|---|
| 743 | ! |
|---|
| 744 | ! Return the fraction of routed water for this time step. |
|---|
| 745 | ! |
|---|
| 746 | returnflow(:) = returnflow_mean(:) |
|---|
| 747 | reinfiltration(:) = reinfiltration_mean(:) |
|---|
| 748 | irrigation(:) = irrigation_mean(:) |
|---|
| 749 | riverflow(:) = riverflow_mean(:) |
|---|
| 750 | coastalflow(:) = coastalflow_mean(:) |
|---|
| 751 | ! |
|---|
| 752 | ! Write diagnostics |
|---|
| 753 | ! |
|---|
| 754 | ! Water storage in reservoirs [kg/m^2] |
|---|
| 755 | CALL xios_orchidee_send_field("fastr",fast_diag) |
|---|
| 756 | CALL xios_orchidee_send_field("slowr",slow_diag) |
|---|
| 757 | CALL xios_orchidee_send_field("streamr",stream_diag) |
|---|
| 758 | CALL xios_orchidee_send_field("laker",lake_diag) |
|---|
| 759 | CALL xios_orchidee_send_field("pondr",pond_diag) |
|---|
| 760 | CALL xios_orchidee_send_field("floodr",flood_diag) |
|---|
| 761 | CALL xios_orchidee_send_field("floodh",flood_height) |
|---|
| 762 | |
|---|
| 763 | ! Difference between the end and the beginning of the routing time step [kg/m^2] |
|---|
| 764 | CALL xios_orchidee_send_field("delfastr", fast_diag - fast_diag_old) |
|---|
| 765 | CALL xios_orchidee_send_field("delslowr", slow_diag - slow_diag_old) |
|---|
| 766 | CALL xios_orchidee_send_field("delstreamr", stream_diag - stream_diag_old) |
|---|
| 767 | CALL xios_orchidee_send_field("dellaker", lake_diag - lake_diag_old) |
|---|
| 768 | CALL xios_orchidee_send_field("delpondr", pond_diag - pond_diag_old) |
|---|
| 769 | CALL xios_orchidee_send_field("delfloodr", flood_diag - flood_diag_old) |
|---|
| 770 | |
|---|
| 771 | ! Water fluxes converted from kg/m^2/dt_sechiba into kg/m^2/s |
|---|
| 772 | CALL xios_orchidee_send_field("irrigation",irrigation/dt_sechiba) |
|---|
| 773 | CALL xios_orchidee_send_field("netirrig",irrig_netereq/dt_sechiba) |
|---|
| 774 | CALL xios_orchidee_send_field("riversret",returnflow/dt_sechiba) |
|---|
| 775 | CALL xios_orchidee_send_field("reinfiltration",reinfiltration/dt_sechiba) |
|---|
| 776 | |
|---|
| 777 | ! Transform from kg/dt_sechiba into m^3/s |
|---|
| 778 | CALL xios_orchidee_send_field("hydrographs",hydrographs/mille/dt_sechiba) |
|---|
| 779 | CALL xios_orchidee_send_field("slowflow",slowflow_diag/mille/dt_sechiba) ! previous id name: Qb |
|---|
| 780 | CALL xios_orchidee_send_field("coastalflow",coastalflow/dt_sechiba) |
|---|
| 781 | CALL xios_orchidee_send_field("riverflow",riverflow/dt_sechiba) |
|---|
| 782 | |
|---|
| 783 | IF ( .NOT. almaoutput ) THEN |
|---|
| 784 | ! |
|---|
| 785 | CALL histwrite_p(hist_id, 'riversret', kjit, returnflow, nbpt, index) |
|---|
| 786 | IF (do_floodplains .OR. doponds) THEN |
|---|
| 787 | CALL histwrite_p(hist_id, 'reinfiltration', kjit, reinfiltration, nbpt, index) |
|---|
| 788 | ENDIF |
|---|
| 789 | CALL histwrite_p(hist_id, 'hydrographs', kjit, hydrographs/mille, nbpt, index) |
|---|
| 790 | ! |
|---|
| 791 | CALL histwrite_p(hist_id, 'fastr', kjit, fast_diag, nbpt, index) |
|---|
| 792 | CALL histwrite_p(hist_id, 'slowr', kjit, slow_diag, nbpt, index) |
|---|
| 793 | CALL histwrite_p(hist_id, 'streamr', kjit, stream_diag, nbpt, index) |
|---|
| 794 | IF ( do_floodplains ) THEN |
|---|
| 795 | CALL histwrite_p(hist_id, 'floodr', kjit, flood_diag, nbpt, index) |
|---|
| 796 | CALL histwrite_p(hist_id, 'floodh', kjit, flood_height, nbpt, index) |
|---|
| 797 | ENDIF |
|---|
| 798 | CALL histwrite_p(hist_id, 'pondr', kjit, pond_diag, nbpt, index) |
|---|
| 799 | CALL histwrite_p(hist_id, 'lakevol', kjit, lake_diag, nbpt, index) |
|---|
| 800 | ! |
|---|
| 801 | IF ( do_irrigation ) THEN |
|---|
| 802 | CALL histwrite_p(hist_id, 'irrigation', kjit, irrigation, nbpt, index) |
|---|
| 803 | CALL histwrite_p(hist_id, 'returnflow', kjit, returnflow, nbpt, index) |
|---|
| 804 | CALL histwrite_p(hist_id, 'netirrig', kjit, irrig_netereq, nbpt, index) |
|---|
| 805 | ENDIF |
|---|
| 806 | ! |
|---|
| 807 | ELSE |
|---|
| 808 | CALL histwrite_p(hist_id, 'SurfStor', kjit, flood_diag+pond_diag+lake_diag, nbpt, index) |
|---|
| 809 | CALL histwrite_p(hist_id, 'Dis', kjit, hydrographs/mille, nbpt, index) |
|---|
| 810 | ! |
|---|
| 811 | CALL histwrite_p(hist_id, 'slowr', kjit, slow_diag, nbpt, index) |
|---|
| 812 | CALL histwrite_p(hist_id, 'fastr', kjit, fast_diag, nbpt, index) |
|---|
| 813 | CALL histwrite_p(hist_id, 'streamr', kjit, stream_diag, nbpt, index) |
|---|
| 814 | CALL histwrite_p(hist_id, 'lakevol', kjit, lake_diag, nbpt, index) |
|---|
| 815 | CALL histwrite_p(hist_id, 'pondr', kjit, pond_diag, nbpt, index) |
|---|
| 816 | ! |
|---|
| 817 | IF ( do_irrigation ) THEN |
|---|
| 818 | CALL histwrite_p(hist_id, 'Qirrig', kjit, irrigation, nbpt, index) |
|---|
| 819 | CALL histwrite_p(hist_id, 'Qirrig_req', kjit, irrig_netereq, nbpt, index) |
|---|
| 820 | ENDIF |
|---|
| 821 | ! |
|---|
| 822 | ENDIF |
|---|
| 823 | IF ( hist2_id > 0 ) THEN |
|---|
| 824 | IF ( .NOT. almaoutput ) THEN |
|---|
| 825 | ! |
|---|
| 826 | CALL histwrite_p(hist2_id, 'riversret', kjit, returnflow, nbpt, index) |
|---|
| 827 | IF (do_floodplains .OR. doponds) THEN |
|---|
| 828 | CALL histwrite_p(hist2_id, 'reinfiltration', kjit, reinfiltration, nbpt, index) |
|---|
| 829 | ENDIF |
|---|
| 830 | CALL histwrite_p(hist2_id, 'hydrographs', kjit, hydrographs/mille, nbpt, index) |
|---|
| 831 | ! |
|---|
| 832 | CALL histwrite_p(hist2_id, 'fastr', kjit, fast_diag, nbpt, index) |
|---|
| 833 | CALL histwrite_p(hist2_id, 'slowr', kjit, slow_diag, nbpt, index) |
|---|
| 834 | IF ( do_floodplains ) THEN |
|---|
| 835 | CALL histwrite_p(hist2_id, 'floodr', kjit, flood_diag, nbpt, index) |
|---|
| 836 | CALL histwrite_p(hist2_id, 'floodh', kjit, flood_height, nbpt, index) |
|---|
| 837 | ENDIF |
|---|
| 838 | CALL histwrite_p(hist2_id, 'pondr', kjit, pond_diag, nbpt, index) |
|---|
| 839 | CALL histwrite_p(hist2_id, 'streamr', kjit, stream_diag, nbpt, index) |
|---|
| 840 | CALL histwrite_p(hist2_id, 'lakevol', kjit, lake_diag, nbpt, index) |
|---|
| 841 | ! |
|---|
| 842 | IF ( do_irrigation ) THEN |
|---|
| 843 | CALL histwrite_p(hist2_id, 'irrigation', kjit, irrigation, nbpt, index) |
|---|
| 844 | CALL histwrite_p(hist2_id, 'returnflow', kjit, returnflow, nbpt, index) |
|---|
| 845 | CALL histwrite_p(hist2_id, 'netirrig', kjit, irrig_netereq, nbpt, index) |
|---|
| 846 | ENDIF |
|---|
| 847 | ! |
|---|
| 848 | ELSE |
|---|
| 849 | ! |
|---|
| 850 | CALL histwrite_p(hist2_id, 'SurfStor', kjit, flood_diag+pond_diag+lake_diag, nbpt, index) |
|---|
| 851 | CALL histwrite_p(hist2_id, 'Dis', kjit, hydrographs/mille, nbpt, index) |
|---|
| 852 | ! |
|---|
| 853 | ENDIF |
|---|
| 854 | ENDIF |
|---|
| 855 | ! |
|---|
| 856 | ! |
|---|
| 857 | END SUBROUTINE routing_main |
|---|
| 858 | |
|---|
| 859 | !! ============================================================================================================================= |
|---|
| 860 | !! SUBROUTINE: routing_finalize |
|---|
| 861 | !! |
|---|
| 862 | !>\BRIEF Write to restart file |
|---|
| 863 | !! |
|---|
| 864 | !! DESCRIPTION: Write module variables to restart file |
|---|
| 865 | !! |
|---|
| 866 | !! RECENT CHANGE(S) |
|---|
| 867 | !! |
|---|
| 868 | !! REFERENCE(S) |
|---|
| 869 | !! |
|---|
| 870 | !! FLOWCHART |
|---|
| 871 | !! \n |
|---|
| 872 | !_ ============================================================================================================================== |
|---|
| 873 | |
|---|
| 874 | SUBROUTINE routing_finalize( kjit, nbpt, rest_id, flood_frac, flood_res ) |
|---|
| 875 | |
|---|
| 876 | IMPLICIT NONE |
|---|
| 877 | |
|---|
| 878 | !! 0.1 Input variables |
|---|
| 879 | INTEGER(i_std), INTENT(in) :: kjit !! Time step number (unitless) |
|---|
| 880 | INTEGER(i_std), INTENT(in) :: nbpt !! Domain size (unitless) |
|---|
| 881 | INTEGER(i_std),INTENT(in) :: rest_id !! Restart file identifier (unitless) |
|---|
| 882 | REAL(r_std), INTENT(in) :: flood_frac(nbpt) !! Flooded fraction of the grid box (unitless;0-1) |
|---|
| 883 | REAL(r_std), INTENT(in) :: flood_res(nbpt) !! Diagnostic of water amount in the floodplains reservoir (kg) |
|---|
| 884 | |
|---|
| 885 | !! 0.2 Local variables |
|---|
| 886 | REAL(r_std), DIMENSION(1) :: tmp_day |
|---|
| 887 | |
|---|
| 888 | !_ ================================================================================================================================ |
|---|
| 889 | |
|---|
| 890 | ! |
|---|
| 891 | ! Write restart variables |
|---|
| 892 | ! |
|---|
| 893 | CALL restput_p (rest_id, 'routingcounter', kjit, time_counter) |
|---|
| 894 | |
|---|
| 895 | CALL restput_p (rest_id, 'routingarea', nbp_glo, nbasmax, 1, kjit, routing_area, 'scatter', nbp_glo, index_g) |
|---|
| 896 | CALL restput_p (rest_id, 'routetogrid', nbp_glo, nbasmax, 1, kjit, REAL(route_togrid,r_std), 'scatter', & |
|---|
| 897 | nbp_glo, index_g) |
|---|
| 898 | CALL restput_p (rest_id, 'routetobasin', nbp_glo, nbasmax, 1, kjit, REAL(route_tobasin,r_std), 'scatter', & |
|---|
| 899 | nbp_glo, index_g) |
|---|
| 900 | CALL restput_p (rest_id, 'basinid', nbp_glo, nbasmax, 1, kjit, REAL(global_basinid,r_std), 'scatter', & |
|---|
| 901 | nbp_glo, index_g) |
|---|
| 902 | CALL restput_p (rest_id, 'topoindex', nbp_glo, nbasmax, 1, kjit, topo_resid, 'scatter', nbp_glo, index_g) |
|---|
| 903 | CALL restput_p (rest_id, 'fastres', nbp_glo, nbasmax, 1, kjit, fast_reservoir, 'scatter', nbp_glo, index_g) |
|---|
| 904 | CALL restput_p (rest_id, 'slowres', nbp_glo, nbasmax, 1, kjit, slow_reservoir, 'scatter', nbp_glo, index_g) |
|---|
| 905 | CALL restput_p (rest_id, 'streamres', nbp_glo, nbasmax, 1, kjit, stream_reservoir, 'scatter',nbp_glo,index_g) |
|---|
| 906 | CALL restput_p (rest_id, 'floodres', nbp_glo, nbasmax, 1, kjit, flood_reservoir, 'scatter', nbp_glo, index_g) |
|---|
| 907 | CALL restput_p (rest_id, 'floodh', nbp_glo, 1, 1, kjit, flood_height, 'scatter', nbp_glo, index_g) |
|---|
| 908 | CALL restput_p (rest_id, 'flood_frac_bas', nbp_glo, nbasmax, 1, kjit, flood_frac_bas, 'scatter', nbp_glo, index_g) |
|---|
| 909 | CALL restput_p (rest_id, 'pond_frac', nbp_glo, 1, 1, kjit, pond_frac, 'scatter', nbp_glo, index_g) |
|---|
| 910 | CALL restput_p (rest_id, 'flood_frac', nbp_glo, 1, 1, kjit, flood_frac, 'scatter', nbp_glo, index_g) |
|---|
| 911 | CALL restput_p (rest_id, 'flood_res', nbp_glo, 1, 1, kjit, flood_res, 'scatter', nbp_glo, index_g) |
|---|
| 912 | |
|---|
| 913 | CALL restput_p (rest_id, 'lakeres', nbp_glo, 1, 1, kjit, lake_reservoir, 'scatter', nbp_glo, index_g) |
|---|
| 914 | CALL restput_p (rest_id, 'pondres', nbp_glo, 1, 1, kjit, pond_reservoir, 'scatter', nbp_glo, index_g) |
|---|
| 915 | |
|---|
| 916 | CALL restput_p (rest_id, 'lakeinflow', nbp_glo, 1, 1, kjit, lakeinflow_mean, 'scatter', nbp_glo, index_g) |
|---|
| 917 | CALL restput_p (rest_id, 'returnflow', nbp_glo, 1, 1, kjit, returnflow_mean, 'scatter', nbp_glo, index_g) |
|---|
| 918 | CALL restput_p (rest_id, 'reinfiltration', nbp_glo, 1, 1, kjit, reinfiltration_mean, 'scatter', nbp_glo, index_g) |
|---|
| 919 | CALL restput_p (rest_id, 'riverflow', nbp_glo, 1, 1, kjit, riverflow_mean, 'scatter', nbp_glo, index_g) |
|---|
| 920 | CALL restput_p (rest_id, 'coastalflow', nbp_glo, 1, 1, kjit, coastalflow_mean, 'scatter', nbp_glo, index_g) |
|---|
| 921 | CALL restput_p (rest_id, 'hydrographs', nbp_glo, 1, 1, kjit, hydrographs, 'scatter', nbp_glo, index_g) |
|---|
| 922 | CALL restput_p (rest_id, 'slowflow_diag', nbp_glo, 1, 1, kjit, slowflow_diag, 'scatter', nbp_glo, index_g) |
|---|
| 923 | ! |
|---|
| 924 | ! Keep track of the accumulated variables |
|---|
| 925 | ! |
|---|
| 926 | CALL restput_p (rest_id, 'floodout_route', nbp_glo, 1, 1, kjit, floodout_mean, 'scatter', nbp_glo, index_g) |
|---|
| 927 | CALL restput_p (rest_id, 'runoff_route', nbp_glo, 1, 1, kjit, runoff_mean, 'scatter', nbp_glo, index_g) |
|---|
| 928 | CALL restput_p (rest_id, 'drainage_route', nbp_glo, 1, 1, kjit, drainage_mean, 'scatter', nbp_glo, index_g) |
|---|
| 929 | CALL restput_p (rest_id, 'transpot_route', nbp_glo, 1, 1, kjit, transpot_mean, 'scatter', nbp_glo, index_g) |
|---|
| 930 | CALL restput_p (rest_id, 'precip_route', nbp_glo, 1, 1, kjit, precip_mean, 'scatter', nbp_glo, index_g) |
|---|
| 931 | CALL restput_p (rest_id, 'humrel_route', nbp_glo, 1, 1, kjit, humrel_mean, 'scatter', nbp_glo, index_g) |
|---|
| 932 | CALL restput_p (rest_id, 'totnobio_route', nbp_glo, 1, 1, kjit, totnobio_mean, 'scatter', nbp_glo, index_g) |
|---|
| 933 | CALL restput_p (rest_id, 'k_litt_route', nbp_glo, 1, 1, kjit, k_litt_mean, 'scatter', nbp_glo, index_g) |
|---|
| 934 | CALL restput_p (rest_id, 'vegtot_route', nbp_glo, 1, 1, kjit, vegtot_mean, 'scatter', nbp_glo, index_g) |
|---|
| 935 | |
|---|
| 936 | IF ( do_irrigation ) THEN |
|---|
| 937 | CALL restput_p (rest_id, 'irrigated', nbp_glo, 1, 1, kjit, irrigated, 'scatter', nbp_glo, index_g) |
|---|
| 938 | CALL restput_p (rest_id, 'irrigation', nbp_glo, 1, 1, kjit, irrigation_mean, 'scatter', nbp_glo, index_g) |
|---|
| 939 | ENDIF |
|---|
| 940 | |
|---|
| 941 | IF ( do_floodplains ) THEN |
|---|
| 942 | CALL restput_p (rest_id, 'floodplains', nbp_glo, 1, 1, kjit, floodplains, 'scatter', nbp_glo, index_g) |
|---|
| 943 | ENDIF |
|---|
| 944 | IF ( doswamps ) THEN |
|---|
| 945 | CALL restput_p (rest_id, 'swamp', nbp_glo, 1, 1, kjit, swamp, 'scatter', nbp_glo, index_g) |
|---|
| 946 | ENDIF |
|---|
| 947 | |
|---|
| 948 | END SUBROUTINE routing_finalize |
|---|
| 949 | |
|---|
| 950 | !! ================================================================================================================================ |
|---|
| 951 | !! SUBROUTINE : routing_init |
|---|
| 952 | !! |
|---|
| 953 | !>\BRIEF This subroutine allocates the memory and get the fixed fields from the restart file. |
|---|
| 954 | !! |
|---|
| 955 | !! DESCRIPTION (definitions, functional, design, flags) : None |
|---|
| 956 | !! |
|---|
| 957 | !! RECENT CHANGE(S): None |
|---|
| 958 | !! |
|---|
| 959 | !! MAIN OUTPUT VARIABLE(S): |
|---|
| 960 | !! |
|---|
| 961 | !! REFERENCES : None |
|---|
| 962 | !! |
|---|
| 963 | !! FLOWCHART :None |
|---|
| 964 | !! \n |
|---|
| 965 | !_ ================================================================================================================================ |
|---|
| 966 | |
|---|
| 967 | SUBROUTINE routing_init(kjit, nbpt, index, returnflow, reinfiltration, irrigation, & |
|---|
| 968 | & riverflow, coastalflow, flood_frac, flood_res, stempdiag, rest_id) |
|---|
| 969 | ! |
|---|
| 970 | IMPLICIT NONE |
|---|
| 971 | ! |
|---|
| 972 | ! interface description |
|---|
| 973 | ! |
|---|
| 974 | !! INPUT VARIABLES |
|---|
| 975 | INTEGER(i_std), INTENT(in) :: kjit !! Time step number (unitless) |
|---|
| 976 | INTEGER(i_std), INTENT(in) :: nbpt !! Domain size (unitless) |
|---|
| 977 | INTEGER(i_std), DIMENSION (nbpt), INTENT(in) :: index !! Indices of the points on the map (unitless) |
|---|
| 978 | REAL(r_std), DIMENSION(nbpt,nslm),INTENT(in) :: stempdiag !! Temperature profile in soil |
|---|
| 979 | INTEGER(i_std), INTENT(in) :: rest_id !! Restart file identifier (unitless) |
|---|
| 980 | ! |
|---|
| 981 | !! OUTPUT VARIABLES |
|---|
| 982 | REAL(r_std), DIMENSION (nbpt),INTENT(out) :: returnflow !! The water flow from lakes and swamps which returns into the grid box. |
|---|
| 983 | !! This water will go back into the hydrol or hydrolc module to allow re-evaporation (kg/m^2/dt) |
|---|
| 984 | REAL(r_std), DIMENSION (nbpt),INTENT(out) :: reinfiltration !! Water flow from ponds and floodplains which returns to the grid box (kg/m^2/dt) |
|---|
| 985 | REAL(r_std), DIMENSION (nbpt),INTENT(out) :: irrigation !! Irrigation flux. This is the water taken from the reservoirs and beeing put into the upper layers of the soil.(kg/m^2/dt) |
|---|
| 986 | REAL(r_std), DIMENSION (nbpt),INTENT(out) :: riverflow !! Outflow of the major rivers. The flux will be located on the continental grid but this should be a coastal point (kg/dt) |
|---|
| 987 | REAL(r_std), DIMENSION (nbpt),INTENT(out) :: coastalflow !! Outflow on coastal points by small basins. This is the water which flows in a disperse way into the ocean (kg/dt) |
|---|
| 988 | REAL(r_std), DIMENSION (nbpt),INTENT(out) :: flood_frac !! Flooded fraction of the grid box (unitless;0-1) |
|---|
| 989 | REAL(r_std), DIMENSION (nbpt),INTENT(out) :: flood_res !! Diagnostic of water amount in the floodplains reservoir (kg) |
|---|
| 990 | ! |
|---|
| 991 | !! LOCAL VARIABLES |
|---|
| 992 | CHARACTER(LEN=80) :: var_name !! To store variables names for I/O (unitless) |
|---|
| 993 | REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: tmp_real_g !! A temporary real array for the integers |
|---|
| 994 | REAL(r_std), DIMENSION(1) :: tmp_day !! |
|---|
| 995 | REAL(r_std) :: ratio !! Diagnostic ratio to check that dt_routing is a multiple of dt_sechiba (unitless) |
|---|
| 996 | REAL(r_std) :: totarea !! Total area of basin (m^2) |
|---|
| 997 | INTEGER(i_std) :: ier, ig, ib, ipn(1) !! Indices (unitless) |
|---|
| 998 | |
|---|
| 999 | !_ ================================================================================================================================ |
|---|
| 1000 | ! |
|---|
| 1001 | ! |
|---|
| 1002 | ! These variables will require the configuration infrastructure |
|---|
| 1003 | ! |
|---|
| 1004 | !Config Key = ROUTING_TIMESTEP |
|---|
| 1005 | !Config If = RIVER_ROUTING |
|---|
| 1006 | !Config Desc = Time step of the routing scheme |
|---|
| 1007 | !Config Def = one_day |
|---|
| 1008 | !Config Help = This values gives the time step in seconds of the routing scheme. |
|---|
| 1009 | !Config It should be multiple of the main time step of ORCHIDEE. One day |
|---|
| 1010 | !Config is a good value. |
|---|
| 1011 | !Config Units = [seconds] |
|---|
| 1012 | ! |
|---|
| 1013 | dt_routing = one_day |
|---|
| 1014 | CALL getin_p('DT_ROUTING', dt_routing) |
|---|
| 1015 | ! |
|---|
| 1016 | !Config Key = ROUTING_RIVERS |
|---|
| 1017 | !Config If = RIVER_ROUTING |
|---|
| 1018 | !Config Desc = Number of rivers |
|---|
| 1019 | !Config Def = 50 |
|---|
| 1020 | !Config Help = This parameter chooses the number of largest river basins |
|---|
| 1021 | !Config which should be treated as independently as rivers and not |
|---|
| 1022 | !Config flow into the oceans as diffusion coastal flow. |
|---|
| 1023 | !Config Units = [-] |
|---|
| 1024 | num_largest = 50 |
|---|
| 1025 | CALL getin_p('ROUTING_RIVERS', num_largest) |
|---|
| 1026 | ! |
|---|
| 1027 | !Config Key = DO_FLOODINFILT |
|---|
| 1028 | !Config Desc = Should floodplains reinfiltrate into the soil |
|---|
| 1029 | !Config If = RIVER_ROUTING |
|---|
| 1030 | !Config Def = n |
|---|
| 1031 | !Config Help = This parameters allows the user to ask the model |
|---|
| 1032 | !Config to take into account the flood plains reinfiltration |
|---|
| 1033 | !Config into the soil moisture. It then can go |
|---|
| 1034 | !Config back to the slow and fast reservoirs |
|---|
| 1035 | !Config Units = [FLAG] |
|---|
| 1036 | ! |
|---|
| 1037 | dofloodinfilt = .FALSE. |
|---|
| 1038 | CALL getin_p('DO_FLOODINFILT', dofloodinfilt) |
|---|
| 1039 | ! |
|---|
| 1040 | !Config Key = DO_SWAMPS |
|---|
| 1041 | !Config Desc = Should we include swamp parameterization |
|---|
| 1042 | !Config If = RIVER_ROUTING |
|---|
| 1043 | !Config Def = n |
|---|
| 1044 | !Config Help = This parameters allows the user to ask the model |
|---|
| 1045 | !Config to take into account the swamps and return |
|---|
| 1046 | !Config the water into the bottom of the soil. It then can go |
|---|
| 1047 | !Config back to the atmopshere. This tried to simulate |
|---|
| 1048 | !Config internal deltas of rivers. |
|---|
| 1049 | !Config Units = [FLAG] |
|---|
| 1050 | ! |
|---|
| 1051 | doswamps = .FALSE. |
|---|
| 1052 | CALL getin_p('DO_SWAMPS', doswamps) |
|---|
| 1053 | ! |
|---|
| 1054 | !Config Key = DO_PONDS |
|---|
| 1055 | !Config Desc = Should we include ponds |
|---|
| 1056 | !Config If = RIVER_ROUTING |
|---|
| 1057 | !Config Def = n |
|---|
| 1058 | !Config Help = This parameters allows the user to ask the model |
|---|
| 1059 | !Config to take into account the ponds and return |
|---|
| 1060 | !Config the water into the soil moisture. It then can go |
|---|
| 1061 | !Config back to the atmopshere. This tried to simulate |
|---|
| 1062 | !Config little ponds especially in West Africa. |
|---|
| 1063 | !Config Units = [FLAG] |
|---|
| 1064 | ! |
|---|
| 1065 | doponds = .FALSE. |
|---|
| 1066 | CALL getin_p('DO_PONDS', doponds) |
|---|
| 1067 | ! |
|---|
| 1068 | ! Fix the time constants according to hydrol_cwrr flag |
|---|
| 1069 | ! |
|---|
| 1070 | ! |
|---|
| 1071 | !Config Key = SLOW_TCST |
|---|
| 1072 | !Config Desc = Time constant for the slow reservoir |
|---|
| 1073 | !Config If = RIVER_ROUTING |
|---|
| 1074 | !Config Def = n |
|---|
| 1075 | !Config Help = This parameters allows the user to fix the |
|---|
| 1076 | !Config time constant (in days) of the slow reservoir |
|---|
| 1077 | !Config in order to get better river flows for |
|---|
| 1078 | !Config particular regions. |
|---|
| 1079 | !Config Units = [days] |
|---|
| 1080 | ! |
|---|
| 1081 | !> A value for property of each reservoir (in day/m) is given to compute a time constant (in day) |
|---|
| 1082 | !> for each reservoir (product of tcst and topo_resid). |
|---|
| 1083 | !> The value of tcst has been calibrated for the three reservoirs over the Senegal river basin only, |
|---|
| 1084 | !> during the 1 degree NCEP Corrected by Cru (NCC) resolution simulations (Ngo-Duc et al., 2005, Ngo-Duc et al., 2006) and |
|---|
| 1085 | !> generalized for all the basins of the world. The "slow reservoir" and the "fast reservoir" |
|---|
| 1086 | !> have the highest value in order to simulate the groundwater. |
|---|
| 1087 | !> The "stream reservoir", which represents all the water of the stream, has the lowest value. |
|---|
| 1088 | !> Those figures are the same for all the basins of the world. |
|---|
| 1089 | !> The value of slow_tcst is equal to fast_tcst when CWRR is activated. |
|---|
| 1090 | !> This assumption should be re-discussed. |
|---|
| 1091 | ! |
|---|
| 1092 | IF ( hydrol_cwrr ) THEN |
|---|
| 1093 | slow_tcst = slow_tcst_cwrr |
|---|
| 1094 | ELSE |
|---|
| 1095 | slow_tcst = slow_tcst_chois |
|---|
| 1096 | ENDIF |
|---|
| 1097 | CALL getin_p('SLOW_TCST', slow_tcst) |
|---|
| 1098 | ! |
|---|
| 1099 | !Config Key = FAST_TCST |
|---|
| 1100 | !Config Desc = Time constant for the fast reservoir |
|---|
| 1101 | !Config If = RIVER_ROUTING |
|---|
| 1102 | !Config Def = fast_tcst_cwrr or fast_tcst_chois depending on flag HYDROL_CWRR |
|---|
| 1103 | !Config Help = This parameters allows the user to fix the |
|---|
| 1104 | !Config time constant (in days) of the fast reservoir |
|---|
| 1105 | !Config in order to get better river flows for |
|---|
| 1106 | !Config particular regions. |
|---|
| 1107 | !Config Units = [days] |
|---|
| 1108 | ! |
|---|
| 1109 | IF ( hydrol_cwrr ) THEN |
|---|
| 1110 | fast_tcst = fast_tcst_cwrr |
|---|
| 1111 | ELSE |
|---|
| 1112 | fast_tcst = fast_tcst_chois |
|---|
| 1113 | ENDIF |
|---|
| 1114 | CALL getin_p('FAST_TCST', fast_tcst) |
|---|
| 1115 | ! |
|---|
| 1116 | !Config Key = STREAM_TCST |
|---|
| 1117 | !Config Desc = Time constant for the stream reservoir |
|---|
| 1118 | !Config If = RIVER_ROUTING |
|---|
| 1119 | !Config Def = stream_tcst_cwrr or stream_tcst_chois depending on flag HYDROL_CWRR |
|---|
| 1120 | !Config Help = This parameters allows the user to fix the |
|---|
| 1121 | !Config time constant (in days) of the stream reservoir |
|---|
| 1122 | !Config in order to get better river flows for |
|---|
| 1123 | !Config particular regions. |
|---|
| 1124 | !Config Units = [days] |
|---|
| 1125 | ! |
|---|
| 1126 | IF ( hydrol_cwrr ) THEN |
|---|
| 1127 | stream_tcst = stream_tcst_cwrr |
|---|
| 1128 | ELSE |
|---|
| 1129 | stream_tcst = stream_tcst_chois |
|---|
| 1130 | ENDIF |
|---|
| 1131 | CALL getin_p('STREAM_TCST', stream_tcst) |
|---|
| 1132 | ! |
|---|
| 1133 | !Config Key = FLOOD_TCST |
|---|
| 1134 | !Config Desc = Time constant for the flood reservoir |
|---|
| 1135 | !Config If = RIVER_ROUTING |
|---|
| 1136 | !Config Def = 4.0 |
|---|
| 1137 | !Config Help = This parameters allows the user to fix the |
|---|
| 1138 | !Config time constant (in days) of the flood reservoir |
|---|
| 1139 | !Config in order to get better river flows for |
|---|
| 1140 | !Config particular regions. |
|---|
| 1141 | !Config Units = [days] |
|---|
| 1142 | ! |
|---|
| 1143 | IF ( hydrol_cwrr ) THEN |
|---|
| 1144 | flood_tcst = flood_tcst_cwrr |
|---|
| 1145 | ELSE |
|---|
| 1146 | flood_tcst = flood_tcst_chois |
|---|
| 1147 | ENDIF |
|---|
| 1148 | CALL getin_p('FLOOD_TCST', flood_tcst) |
|---|
| 1149 | ! |
|---|
| 1150 | !Config Key = SWAMP_CST |
|---|
| 1151 | !Config Desc = Fraction of the river that flows back to swamps |
|---|
| 1152 | !Config If = RIVER_ROUTING |
|---|
| 1153 | !Config Def = 0.2 |
|---|
| 1154 | !Config Help = This parameters allows the user to fix the |
|---|
| 1155 | !Config fraction of the river transport |
|---|
| 1156 | !Config that flows to swamps |
|---|
| 1157 | !Config Units = [-] |
|---|
| 1158 | ! |
|---|
| 1159 | IF ( hydrol_cwrr ) THEN |
|---|
| 1160 | swamp_cst = swamp_cst_cwrr |
|---|
| 1161 | ELSE |
|---|
| 1162 | swamp_cst = swamp_cst_chois |
|---|
| 1163 | ENDIF |
|---|
| 1164 | CALL getin_p('SWAMP_CST', swamp_cst) |
|---|
| 1165 | ! |
|---|
| 1166 | !Config Key = FLOOD_BETA |
|---|
| 1167 | !Config Desc = Parameter to fix the shape of the floodplain |
|---|
| 1168 | !Config If = RIVER_ROUTING |
|---|
| 1169 | !Config Def = 2.0 |
|---|
| 1170 | !Config Help = Parameter to fix the shape of the floodplain |
|---|
| 1171 | !Config (>1 for convex edges, <1 for concave edges) |
|---|
| 1172 | !Config Units = [-] |
|---|
| 1173 | CALL getin_p("FLOOD_BETA", beta) |
|---|
| 1174 | ! |
|---|
| 1175 | !Config Key = POND_BETAP |
|---|
| 1176 | !Config Desc = Ratio of the basin surface intercepted by ponds and the maximum surface of ponds |
|---|
| 1177 | !Config If = RIVER_ROUTING |
|---|
| 1178 | !Config Def = 0.5 |
|---|
| 1179 | !Config Help = |
|---|
| 1180 | !Config Units = [-] |
|---|
| 1181 | CALL getin_p("POND_BETAP", betap) |
|---|
| 1182 | ! |
|---|
| 1183 | !Config Key = FLOOD_CRI |
|---|
| 1184 | !Config Desc = Potential height for which all the basin is flooded |
|---|
| 1185 | !Config If = DO_FLOODPLAINS or DO_PONDS |
|---|
| 1186 | !Config Def = 2000. |
|---|
| 1187 | !Config Help = |
|---|
| 1188 | !Config Units = [mm] |
|---|
| 1189 | CALL getin_p("FLOOD_CRI", floodcri) |
|---|
| 1190 | ! |
|---|
| 1191 | !Config Key = POND_CRI |
|---|
| 1192 | !Config Desc = Potential height for which all the basin is a pond |
|---|
| 1193 | !Config If = DO_FLOODPLAINS or DO_PONDS |
|---|
| 1194 | !Config Def = 2000. |
|---|
| 1195 | !Config Help = |
|---|
| 1196 | !Config Units = [mm] |
|---|
| 1197 | CALL getin_p("POND_CRI", pondcri) |
|---|
| 1198 | |
|---|
| 1199 | !Config Key = MAX_LAKE_RESERVOIR |
|---|
| 1200 | !Config Desc = Maximum limit of water in lake_reservoir |
|---|
| 1201 | !Config If = RIVER_ROUTING |
|---|
| 1202 | !Config Def = 7000 |
|---|
| 1203 | !Config Help = |
|---|
| 1204 | !Config Units = [kg/m2(routing area)] |
|---|
| 1205 | max_lake_reservoir = 7000 |
|---|
| 1206 | CALL getin_p("MAX_LAKE_RESERVOIR", max_lake_reservoir) |
|---|
| 1207 | |
|---|
| 1208 | ! |
|---|
| 1209 | ! |
|---|
| 1210 | ! In order to simplify the time cascade check that dt_routing |
|---|
| 1211 | ! is a multiple of dt_sechiba |
|---|
| 1212 | ! |
|---|
| 1213 | ratio = dt_routing/dt_sechiba |
|---|
| 1214 | IF ( ABS(NINT(ratio) - ratio) .GT. 10*EPSILON(ratio)) THEN |
|---|
| 1215 | WRITE(numout,*) 'WARNING -- WARNING -- WARNING -- WARNING' |
|---|
| 1216 | WRITE(numout,*) "The chosen time step for the routing is not a multiple of the" |
|---|
| 1217 | WRITE(numout,*) "main time step of the model. We will change dt_routing so that" |
|---|
| 1218 | WRITE(numout,*) "this condition os fulfilled" |
|---|
| 1219 | dt_routing = NINT(ratio) * dt_sechiba |
|---|
| 1220 | WRITE(numout,*) 'THE NEW DT_ROUTING IS : ', dt_routing |
|---|
| 1221 | ENDIF |
|---|
| 1222 | ! |
|---|
| 1223 | IF ( dt_routing .LT. dt_sechiba) THEN |
|---|
| 1224 | WRITE(numout,*) 'WARNING -- WARNING -- WARNING -- WARNING' |
|---|
| 1225 | WRITE(numout,*) 'The routing timestep can not be smaller than the one' |
|---|
| 1226 | WRITE(numout,*) 'of the model. We reset its value to the model''s timestep.' |
|---|
| 1227 | WRITE(numout,*) 'The old DT_ROUTING is : ', dt_routing |
|---|
| 1228 | dt_routing = dt_sechiba |
|---|
| 1229 | WRITE(numout,*) 'THE NEW DT_ROUTING IS : ', dt_routing |
|---|
| 1230 | ENDIF |
|---|
| 1231 | ! |
|---|
| 1232 | var_name ="routingcounter" |
|---|
| 1233 | CALL ioconf_setatt_p('UNITS', 's') |
|---|
| 1234 | CALL ioconf_setatt_p('LONG_NAME','Time counter for the routing scheme') |
|---|
| 1235 | CALL restget_p (rest_id, var_name, kjit, .TRUE., zero, time_counter) |
|---|
| 1236 | CALL setvar_p (time_counter, val_exp, 'NO_KEYWORD', zero) |
|---|
| 1237 | |
|---|
| 1238 | ALLOCATE (routing_area_loc(nbpt,nbasmax), stat=ier) |
|---|
| 1239 | IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for routing_area_loc','','') |
|---|
| 1240 | |
|---|
| 1241 | ALLOCATE (routing_area_glo(nbp_glo,nbasmax)) |
|---|
| 1242 | IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for routing_area_glo','','') |
|---|
| 1243 | var_name = 'routingarea' |
|---|
| 1244 | IF (is_root_prc) THEN |
|---|
| 1245 | CALL ioconf_setatt('UNITS', 'm^2') |
|---|
| 1246 | CALL ioconf_setatt('LONG_NAME','Area of basin') |
|---|
| 1247 | CALL restget (rest_id, var_name, nbp_glo, nbasmax, 1, kjit, .TRUE., routing_area_glo, "gather", nbp_glo, index_g) |
|---|
| 1248 | ENDIF |
|---|
| 1249 | CALL scatter(routing_area_glo,routing_area_loc) |
|---|
| 1250 | routing_area=>routing_area_loc |
|---|
| 1251 | |
|---|
| 1252 | ALLOCATE (tmp_real_g(nbp_glo,nbasmax), stat=ier) |
|---|
| 1253 | IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for tmp_real_g','','') |
|---|
| 1254 | |
|---|
| 1255 | ALLOCATE (route_togrid_loc(nbpt,nbasmax), stat=ier) |
|---|
| 1256 | IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for route_togrid_loc','','') |
|---|
| 1257 | ALLOCATE (route_togrid_glo(nbp_glo,nbasmax), stat=ier) ! used in global in routing_flow |
|---|
| 1258 | IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for route_togrid_glo','','') |
|---|
| 1259 | |
|---|
| 1260 | IF (is_root_prc) THEN |
|---|
| 1261 | var_name = 'routetogrid' |
|---|
| 1262 | CALL ioconf_setatt('UNITS', '-') |
|---|
| 1263 | CALL ioconf_setatt('LONG_NAME','Grid into which the basin flows') |
|---|
| 1264 | CALL restget (rest_id, var_name, nbp_glo, nbasmax, 1, kjit, .TRUE., tmp_real_g, "gather", nbp_glo, index_g) |
|---|
| 1265 | route_togrid_glo(:,:) = undef_int |
|---|
| 1266 | WHERE ( tmp_real_g .LT. val_exp ) |
|---|
| 1267 | route_togrid_glo = NINT(tmp_real_g) |
|---|
| 1268 | ENDWHERE |
|---|
| 1269 | ENDIF |
|---|
| 1270 | CALL bcast(route_togrid_glo) ! used in global in routing_flow |
|---|
| 1271 | CALL scatter(route_togrid_glo,route_togrid_loc) |
|---|
| 1272 | route_togrid=>route_togrid_loc |
|---|
| 1273 | ! |
|---|
| 1274 | ALLOCATE (route_tobasin_loc(nbpt,nbasmax), stat=ier) |
|---|
| 1275 | IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for route_tobasin_loc','','') |
|---|
| 1276 | |
|---|
| 1277 | ALLOCATE (route_tobasin_glo(nbp_glo,nbasmax), stat=ier) |
|---|
| 1278 | IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for route_tobasin_glo','','') |
|---|
| 1279 | |
|---|
| 1280 | IF (is_root_prc) THEN |
|---|
| 1281 | var_name = 'routetobasin' |
|---|
| 1282 | CALL ioconf_setatt('UNITS', '-') |
|---|
| 1283 | CALL ioconf_setatt('LONG_NAME','Basin in to which the water goes') |
|---|
| 1284 | CALL restget (rest_id, var_name, nbp_glo, nbasmax, 1, kjit, .TRUE., tmp_real_g, "gather", nbp_glo, index_g) |
|---|
| 1285 | route_tobasin_glo = undef_int |
|---|
| 1286 | WHERE ( tmp_real_g .LT. val_exp ) |
|---|
| 1287 | route_tobasin_glo = NINT(tmp_real_g) |
|---|
| 1288 | ENDWHERE |
|---|
| 1289 | ENDIF |
|---|
| 1290 | CALL scatter(route_tobasin_glo,route_tobasin_loc) |
|---|
| 1291 | route_tobasin=>route_tobasin_loc |
|---|
| 1292 | ! |
|---|
| 1293 | ! nbintobasin |
|---|
| 1294 | ! |
|---|
| 1295 | ALLOCATE (route_nbintobas_loc(nbpt,nbasmax), stat=ier) |
|---|
| 1296 | IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for route_nbintobas_loc','','') |
|---|
| 1297 | ALLOCATE (route_nbintobas_glo(nbp_glo,nbasmax), stat=ier) |
|---|
| 1298 | IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for route_nbintobas_glo','','') |
|---|
| 1299 | |
|---|
| 1300 | IF (is_root_prc) THEN |
|---|
| 1301 | var_name = 'routenbintobas' |
|---|
| 1302 | CALL ioconf_setatt('UNITS', '-') |
|---|
| 1303 | CALL ioconf_setatt('LONG_NAME','Number of basin into current one') |
|---|
| 1304 | CALL restget (rest_id, var_name, nbp_glo, nbasmax, 1, kjit, .TRUE., tmp_real_g, "gather", nbp_glo, index_g) |
|---|
| 1305 | route_nbintobas_glo = undef_int |
|---|
| 1306 | WHERE ( tmp_real_g .LT. val_exp ) |
|---|
| 1307 | route_nbintobas_glo = NINT(tmp_real_g) |
|---|
| 1308 | ENDWHERE |
|---|
| 1309 | ENDIF |
|---|
| 1310 | CALL scatter(route_nbintobas_glo,route_nbintobas_loc) |
|---|
| 1311 | route_nbintobas=>route_nbintobas_loc |
|---|
| 1312 | ! |
|---|
| 1313 | ALLOCATE (global_basinid_loc(nbpt,nbasmax), stat=ier) |
|---|
| 1314 | IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for global_basinid_loc','','') |
|---|
| 1315 | ALLOCATE (global_basinid_glo(nbp_glo,nbasmax), stat=ier) |
|---|
| 1316 | IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for global_basinid_glo','','') |
|---|
| 1317 | |
|---|
| 1318 | IF (is_root_prc) THEN |
|---|
| 1319 | var_name = 'basinid' |
|---|
| 1320 | CALL ioconf_setatt('UNITS', '-') |
|---|
| 1321 | CALL ioconf_setatt('LONG_NAME','ID of basin') |
|---|
| 1322 | CALL restget (rest_id, var_name, nbp_glo, nbasmax, 1, kjit, .TRUE., tmp_real_g, "gather", nbp_glo, index_g) |
|---|
| 1323 | global_basinid_glo = undef_int |
|---|
| 1324 | WHERE ( tmp_real_g .LT. val_exp ) |
|---|
| 1325 | global_basinid_glo = NINT(tmp_real_g) |
|---|
| 1326 | ENDWHERE |
|---|
| 1327 | ENDIF |
|---|
| 1328 | CALL scatter(global_basinid_glo,global_basinid_loc) |
|---|
| 1329 | global_basinid=>global_basinid_loc |
|---|
| 1330 | ! |
|---|
| 1331 | ALLOCATE (topo_resid_loc(nbpt,nbasmax), stat=ier) |
|---|
| 1332 | IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for topo_resid_loc','','') |
|---|
| 1333 | ALLOCATE (topo_resid_glo(nbp_glo,nbasmax), stat=ier) |
|---|
| 1334 | IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for topo_resid_glo','','') |
|---|
| 1335 | |
|---|
| 1336 | IF (is_root_prc) THEN |
|---|
| 1337 | var_name = 'topoindex' |
|---|
| 1338 | CALL ioconf_setatt('UNITS', 'm') |
|---|
| 1339 | CALL ioconf_setatt('LONG_NAME','Topographic index of the residence time') |
|---|
| 1340 | CALL restget (rest_id, var_name, nbp_glo, nbasmax, 1, kjit, .TRUE., topo_resid_glo, "gather", nbp_glo, index_g) |
|---|
| 1341 | ENDIF |
|---|
| 1342 | CALL scatter(topo_resid_glo,topo_resid_loc) |
|---|
| 1343 | topo_resid=>topo_resid_loc |
|---|
| 1344 | |
|---|
| 1345 | ALLOCATE (fast_reservoir(nbpt,nbasmax), stat=ier) |
|---|
| 1346 | IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for fast_reservoir','','') |
|---|
| 1347 | var_name = 'fastres' |
|---|
| 1348 | CALL ioconf_setatt_p('UNITS', 'Kg') |
|---|
| 1349 | CALL ioconf_setatt_p('LONG_NAME','Water in the fast reservoir') |
|---|
| 1350 | CALL restget_p (rest_id, var_name, nbp_glo, nbasmax, 1, kjit, .TRUE., fast_reservoir, "gather", nbp_glo, index_g) |
|---|
| 1351 | CALL setvar_p (fast_reservoir, val_exp, 'NO_KEYWORD', zero) |
|---|
| 1352 | |
|---|
| 1353 | ALLOCATE (slow_reservoir(nbpt,nbasmax), stat=ier) |
|---|
| 1354 | IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for slow_reservoir','','') |
|---|
| 1355 | var_name = 'slowres' |
|---|
| 1356 | CALL ioconf_setatt_p('UNITS', 'Kg') |
|---|
| 1357 | CALL ioconf_setatt_p('LONG_NAME','Water in the slow reservoir') |
|---|
| 1358 | CALL restget_p (rest_id, var_name, nbp_glo, nbasmax, 1, kjit, .TRUE., slow_reservoir, "gather", nbp_glo, index_g) |
|---|
| 1359 | CALL setvar_p (slow_reservoir, val_exp, 'NO_KEYWORD', zero) |
|---|
| 1360 | |
|---|
| 1361 | ALLOCATE (stream_reservoir(nbpt,nbasmax), stat=ier) |
|---|
| 1362 | IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for stream_reservoir','','') |
|---|
| 1363 | var_name = 'streamres' |
|---|
| 1364 | CALL ioconf_setatt_p('UNITS', 'Kg') |
|---|
| 1365 | CALL ioconf_setatt_p('LONG_NAME','Water in the stream reservoir') |
|---|
| 1366 | CALL restget_p (rest_id, var_name, nbp_glo, nbasmax, 1, kjit, .TRUE., stream_reservoir, "gather", nbp_glo, index_g) |
|---|
| 1367 | CALL setvar_p (stream_reservoir, val_exp, 'NO_KEYWORD', zero) |
|---|
| 1368 | |
|---|
| 1369 | ALLOCATE (flood_reservoir(nbpt,nbasmax), stat=ier) |
|---|
| 1370 | IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for flood_reservoir','','') |
|---|
| 1371 | var_name = 'floodres' |
|---|
| 1372 | CALL ioconf_setatt_p('UNITS', 'Kg') |
|---|
| 1373 | CALL ioconf_setatt_p('LONG_NAME','Water in the flood reservoir') |
|---|
| 1374 | CALL restget_p (rest_id, var_name, nbp_glo, nbasmax, 1, kjit, .TRUE., flood_reservoir, "gather", nbp_glo, index_g) |
|---|
| 1375 | CALL setvar_p (flood_reservoir, val_exp, 'NO_KEYWORD', zero) |
|---|
| 1376 | |
|---|
| 1377 | ALLOCATE (flood_frac_bas(nbpt,nbasmax), stat=ier) |
|---|
| 1378 | IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for flood_frac_bas','','') |
|---|
| 1379 | var_name = 'flood_frac_bas' |
|---|
| 1380 | CALL ioconf_setatt_p('UNITS', '-') |
|---|
| 1381 | CALL ioconf_setatt_p('LONG_NAME','Flooded fraction per basin') |
|---|
| 1382 | CALL restget_p (rest_id, var_name, nbp_glo, nbasmax, 1, kjit, .TRUE., flood_frac_bas, "gather", nbp_glo, index_g) |
|---|
| 1383 | CALL setvar_p (flood_frac_bas, val_exp, 'NO_KEYWORD', zero) |
|---|
| 1384 | |
|---|
| 1385 | ALLOCATE (flood_height(nbpt), stat=ier) |
|---|
| 1386 | IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for flood_height','','') |
|---|
| 1387 | var_name = 'floodh' |
|---|
| 1388 | CALL ioconf_setatt_p('UNITS', '-') |
|---|
| 1389 | CALL ioconf_setatt_p('LONG_NAME','') |
|---|
| 1390 | CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., flood_height, "gather", nbp_glo, index_g) |
|---|
| 1391 | CALL setvar_p (flood_height, val_exp, 'NO_KEYWORD', zero) |
|---|
| 1392 | |
|---|
| 1393 | ALLOCATE (pond_frac(nbpt), stat=ier) |
|---|
| 1394 | IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for pond_frac','','') |
|---|
| 1395 | var_name = 'pond_frac' |
|---|
| 1396 | CALL ioconf_setatt_p('UNITS', '-') |
|---|
| 1397 | CALL ioconf_setatt_p('LONG_NAME','Pond fraction per grid box') |
|---|
| 1398 | CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., pond_frac, "gather", nbp_glo, index_g) |
|---|
| 1399 | CALL setvar_p (pond_frac, val_exp, 'NO_KEYWORD', zero) |
|---|
| 1400 | |
|---|
| 1401 | var_name = 'flood_frac' |
|---|
| 1402 | CALL ioconf_setatt_p('UNITS', '-') |
|---|
| 1403 | CALL ioconf_setatt_p('LONG_NAME','Flooded fraction per grid box') |
|---|
| 1404 | CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., flood_frac, "gather", nbp_glo, index_g) |
|---|
| 1405 | CALL setvar_p (flood_frac, val_exp, 'NO_KEYWORD', zero) |
|---|
| 1406 | |
|---|
| 1407 | var_name = 'flood_res' |
|---|
| 1408 | CALL ioconf_setatt_p('UNITS','mm') |
|---|
| 1409 | CALL ioconf_setatt_p('LONG_NAME','Flooded quantity (estimation)') |
|---|
| 1410 | CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., flood_res, "gather", nbp_glo, index_g) |
|---|
| 1411 | CALL setvar_p (flood_res, val_exp, 'NO_KEYWORD', zero) |
|---|
| 1412 | ! flood_res = zero |
|---|
| 1413 | |
|---|
| 1414 | ALLOCATE (lake_reservoir(nbpt), stat=ier) |
|---|
| 1415 | IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for lake_reservoir','','') |
|---|
| 1416 | var_name = 'lakeres' |
|---|
| 1417 | CALL ioconf_setatt_p('UNITS', 'Kg') |
|---|
| 1418 | CALL ioconf_setatt_p('LONG_NAME','Water in the lake reservoir') |
|---|
| 1419 | CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., lake_reservoir, "gather", nbp_glo, index_g) |
|---|
| 1420 | CALL setvar_p (lake_reservoir, val_exp, 'NO_KEYWORD', zero) |
|---|
| 1421 | |
|---|
| 1422 | ALLOCATE (pond_reservoir(nbpt), stat=ier) |
|---|
| 1423 | IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for pond_reservoir','','') |
|---|
| 1424 | var_name = 'pondres' |
|---|
| 1425 | CALL ioconf_setatt_p('UNITS', 'Kg') |
|---|
| 1426 | CALL ioconf_setatt_p('LONG_NAME','Water in the pond reservoir') |
|---|
| 1427 | CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., pond_reservoir, "gather", nbp_glo, index_g) |
|---|
| 1428 | CALL setvar_p (pond_reservoir, val_exp, 'NO_KEYWORD', zero) |
|---|
| 1429 | ! |
|---|
| 1430 | ! Map of irrigated areas |
|---|
| 1431 | ! |
|---|
| 1432 | IF ( do_irrigation ) THEN |
|---|
| 1433 | ALLOCATE (irrigated(nbpt), stat=ier) |
|---|
| 1434 | IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for irrigated','','') |
|---|
| 1435 | var_name = 'irrigated' |
|---|
| 1436 | CALL ioconf_setatt_p('UNITS', 'm^2') |
|---|
| 1437 | CALL ioconf_setatt_p('LONG_NAME','Surface of irrigated area') |
|---|
| 1438 | CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., irrigated, "gather", nbp_glo, index_g) |
|---|
| 1439 | CALL setvar_p (irrigated, val_exp, 'NO_KEYWORD', undef_sechiba) |
|---|
| 1440 | ENDIF |
|---|
| 1441 | |
|---|
| 1442 | IF ( do_floodplains ) THEN |
|---|
| 1443 | ALLOCATE (floodplains(nbpt), stat=ier) |
|---|
| 1444 | IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for floodplains','','') |
|---|
| 1445 | var_name = 'floodplains' |
|---|
| 1446 | CALL ioconf_setatt_p('UNITS', 'm^2') |
|---|
| 1447 | CALL ioconf_setatt_p('LONG_NAME','Surface which can be flooded') |
|---|
| 1448 | CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., floodplains, "gather", nbp_glo, index_g) |
|---|
| 1449 | CALL setvar_p (floodplains, val_exp, 'NO_KEYWORD', undef_sechiba) |
|---|
| 1450 | ENDIF |
|---|
| 1451 | IF ( doswamps ) THEN |
|---|
| 1452 | ALLOCATE (swamp(nbpt), stat=ier) |
|---|
| 1453 | IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for swamp','','') |
|---|
| 1454 | var_name = 'swamp' |
|---|
| 1455 | CALL ioconf_setatt_p('UNITS', 'm^2') |
|---|
| 1456 | CALL ioconf_setatt_p('LONG_NAME','Surface which can become swamp') |
|---|
| 1457 | CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., swamp, "gather", nbp_glo, index_g) |
|---|
| 1458 | CALL setvar_p (swamp, val_exp, 'NO_KEYWORD', undef_sechiba) |
|---|
| 1459 | ENDIF |
|---|
| 1460 | ! |
|---|
| 1461 | ! Put into the restart file the fluxes so that they can be regenerated at restart. |
|---|
| 1462 | ! |
|---|
| 1463 | ALLOCATE (lakeinflow_mean(nbpt), stat=ier) |
|---|
| 1464 | IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for lakeinflow_mean','','') |
|---|
| 1465 | var_name = 'lakeinflow' |
|---|
| 1466 | CALL ioconf_setatt_p('UNITS', 'Kg/dt') |
|---|
| 1467 | CALL ioconf_setatt_p('LONG_NAME','Lake inflow') |
|---|
| 1468 | CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., lakeinflow_mean, "gather", nbp_glo, index_g) |
|---|
| 1469 | CALL setvar_p (lakeinflow_mean, val_exp, 'NO_KEYWORD', zero) |
|---|
| 1470 | |
|---|
| 1471 | ALLOCATE (returnflow_mean(nbpt), stat=ier) |
|---|
| 1472 | IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for returnflow_mean','','') |
|---|
| 1473 | var_name = 'returnflow' |
|---|
| 1474 | CALL ioconf_setatt_p('UNITS', 'Kg/m^2/dt') |
|---|
| 1475 | CALL ioconf_setatt_p('LONG_NAME','Deep return flux') |
|---|
| 1476 | CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., returnflow_mean, "gather", nbp_glo, index_g) |
|---|
| 1477 | CALL setvar_p (returnflow_mean, val_exp, 'NO_KEYWORD', zero) |
|---|
| 1478 | returnflow(:) = returnflow_mean(:) |
|---|
| 1479 | |
|---|
| 1480 | ALLOCATE (reinfiltration_mean(nbpt), stat=ier) |
|---|
| 1481 | IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for reinfiltration_mean','','') |
|---|
| 1482 | var_name = 'reinfiltration' |
|---|
| 1483 | CALL ioconf_setatt_p('UNITS', 'Kg/m^2/dt') |
|---|
| 1484 | CALL ioconf_setatt_p('LONG_NAME','Top return flux') |
|---|
| 1485 | CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., reinfiltration_mean, "gather", nbp_glo, index_g) |
|---|
| 1486 | CALL setvar_p (reinfiltration_mean, val_exp, 'NO_KEYWORD', zero) |
|---|
| 1487 | reinfiltration(:) = reinfiltration_mean(:) |
|---|
| 1488 | |
|---|
| 1489 | ALLOCATE (irrigation_mean(nbpt), stat=ier) |
|---|
| 1490 | IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for irrigation_mean','','') |
|---|
| 1491 | ALLOCATE (irrig_netereq(nbpt), stat=ier) |
|---|
| 1492 | IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for irrig_netereq','','') |
|---|
| 1493 | irrig_netereq(:) = zero |
|---|
| 1494 | |
|---|
| 1495 | IF ( do_irrigation ) THEN |
|---|
| 1496 | var_name = 'irrigation' |
|---|
| 1497 | CALL ioconf_setatt_p('UNITS', 'Kg/dt') |
|---|
| 1498 | CALL ioconf_setatt_p('LONG_NAME','Artificial irrigation flux') |
|---|
| 1499 | CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., irrigation_mean, "gather", nbp_glo, index_g) |
|---|
| 1500 | CALL setvar_p (irrigation_mean, val_exp, 'NO_KEYWORD', zero) |
|---|
| 1501 | ELSE |
|---|
| 1502 | irrigation_mean(:) = zero |
|---|
| 1503 | ENDIF |
|---|
| 1504 | irrigation(:) = irrigation_mean(:) |
|---|
| 1505 | |
|---|
| 1506 | ALLOCATE (riverflow_mean(nbpt), stat=ier) |
|---|
| 1507 | IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for riverflow_mean','','') |
|---|
| 1508 | var_name = 'riverflow' |
|---|
| 1509 | CALL ioconf_setatt_p('UNITS', 'Kg/dt') |
|---|
| 1510 | CALL ioconf_setatt_p('LONG_NAME','River flux into the sea') |
|---|
| 1511 | CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., riverflow_mean, "gather", nbp_glo, index_g) |
|---|
| 1512 | CALL setvar_p (riverflow_mean, val_exp, 'NO_KEYWORD', zero) |
|---|
| 1513 | riverflow(:) = riverflow_mean(:) |
|---|
| 1514 | |
|---|
| 1515 | ALLOCATE (coastalflow_mean(nbpt), stat=ier) |
|---|
| 1516 | IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for coastalflow_mean','','') |
|---|
| 1517 | var_name = 'coastalflow' |
|---|
| 1518 | CALL ioconf_setatt_p('UNITS', 'Kg/dt') |
|---|
| 1519 | CALL ioconf_setatt_p('LONG_NAME','Diffuse flux into the sea') |
|---|
| 1520 | CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., coastalflow_mean, "gather", nbp_glo, index_g) |
|---|
| 1521 | CALL setvar_p (coastalflow_mean, val_exp, 'NO_KEYWORD', zero) |
|---|
| 1522 | coastalflow(:) = coastalflow_mean(:) |
|---|
| 1523 | |
|---|
| 1524 | ! Locate it at the 2m level |
|---|
| 1525 | ipn = MINLOC(ABS(diaglev-2)) |
|---|
| 1526 | floodtemp_lev = ipn(1) |
|---|
| 1527 | ALLOCATE (floodtemp(nbpt), stat=ier) |
|---|
| 1528 | IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for floodtemp','','') |
|---|
| 1529 | floodtemp(:) = stempdiag(:,floodtemp_lev) |
|---|
| 1530 | |
|---|
| 1531 | ALLOCATE(hydrographs(nbpt), stat=ier) |
|---|
| 1532 | IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for hydrographs','','') |
|---|
| 1533 | var_name = 'hydrographs' |
|---|
| 1534 | CALL ioconf_setatt_p('UNITS', 'kg/dt_sechiba') |
|---|
| 1535 | CALL ioconf_setatt_p('LONG_NAME','Hydrograph at outlow of grid') |
|---|
| 1536 | CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., hydrographs, "gather", nbp_glo, index_g) |
|---|
| 1537 | CALL setvar_p (hydrographs, val_exp, 'NO_KEYWORD', zero) |
|---|
| 1538 | |
|---|
| 1539 | ALLOCATE(slowflow_diag(nbpt), stat=ier) |
|---|
| 1540 | IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for slowflow_diag','','') |
|---|
| 1541 | var_name = 'slowflow_diag' |
|---|
| 1542 | CALL ioconf_setatt_p('UNITS', 'kg/dt_sechiba') |
|---|
| 1543 | CALL ioconf_setatt_p('LONG_NAME','Slowflow hydrograph at outlow of grid') |
|---|
| 1544 | CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE.,slowflow_diag, "gather", nbp_glo, index_g) |
|---|
| 1545 | CALL setvar_p (slowflow_diag, val_exp, 'NO_KEYWORD', zero) |
|---|
| 1546 | |
|---|
| 1547 | ! |
|---|
| 1548 | ! The diagnostic variables, they are initialized from the above restart variables. |
|---|
| 1549 | ! |
|---|
| 1550 | ALLOCATE(fast_diag(nbpt), slow_diag(nbpt), stream_diag(nbpt), flood_diag(nbpt), & |
|---|
| 1551 | & pond_diag(nbpt), lake_diag(nbpt), stat=ier) |
|---|
| 1552 | IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for fast_diag,..','','') |
|---|
| 1553 | |
|---|
| 1554 | fast_diag(:) = zero |
|---|
| 1555 | slow_diag(:) = zero |
|---|
| 1556 | stream_diag(:) = zero |
|---|
| 1557 | flood_diag(:) = zero |
|---|
| 1558 | pond_diag(:) = zero |
|---|
| 1559 | lake_diag(:) = zero |
|---|
| 1560 | |
|---|
| 1561 | DO ig=1,nbpt |
|---|
| 1562 | totarea = zero |
|---|
| 1563 | DO ib=1,nbasmax |
|---|
| 1564 | totarea = totarea + routing_area(ig,ib) |
|---|
| 1565 | fast_diag(ig) = fast_diag(ig) + fast_reservoir(ig,ib) |
|---|
| 1566 | slow_diag(ig) = slow_diag(ig) + slow_reservoir(ig,ib) |
|---|
| 1567 | stream_diag(ig) = stream_diag(ig) + stream_reservoir(ig,ib) |
|---|
| 1568 | flood_diag(ig) = flood_diag(ig) + flood_reservoir(ig,ib) |
|---|
| 1569 | ENDDO |
|---|
| 1570 | ! |
|---|
| 1571 | fast_diag(ig) = fast_diag(ig)/totarea |
|---|
| 1572 | slow_diag(ig) = slow_diag(ig)/totarea |
|---|
| 1573 | stream_diag(ig) = stream_diag(ig)/totarea |
|---|
| 1574 | flood_diag(ig) = flood_diag(ig)/totarea |
|---|
| 1575 | ! |
|---|
| 1576 | ! This is the volume of the lake scaled to the entire grid. |
|---|
| 1577 | ! It would be better to scale it to the size of the lake |
|---|
| 1578 | ! but this information is not yet available. |
|---|
| 1579 | ! |
|---|
| 1580 | lake_diag(ig) = lake_reservoir(ig)/totarea |
|---|
| 1581 | ! |
|---|
| 1582 | ENDDO |
|---|
| 1583 | ! |
|---|
| 1584 | ! Get from the restart the fluxes we accumulated. |
|---|
| 1585 | ! |
|---|
| 1586 | ALLOCATE (floodout_mean(nbpt), stat=ier) |
|---|
| 1587 | IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for floodout_mean','','') |
|---|
| 1588 | var_name = 'floodout_route' |
|---|
| 1589 | CALL ioconf_setatt_p('UNITS', 'Kg') |
|---|
| 1590 | CALL ioconf_setatt_p('LONG_NAME','Accumulated flow out of floodplains for routing') |
|---|
| 1591 | CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., floodout_mean, "gather", nbp_glo, index_g) |
|---|
| 1592 | CALL setvar_p (floodout_mean, val_exp, 'NO_KEYWORD', zero) |
|---|
| 1593 | |
|---|
| 1594 | ALLOCATE (runoff_mean(nbpt), stat=ier) |
|---|
| 1595 | IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for runoff_mean','','') |
|---|
| 1596 | var_name = 'runoff_route' |
|---|
| 1597 | CALL ioconf_setatt_p('UNITS', 'Kg') |
|---|
| 1598 | CALL ioconf_setatt_p('LONG_NAME','Accumulated runoff for routing') |
|---|
| 1599 | CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., runoff_mean, "gather", nbp_glo, index_g) |
|---|
| 1600 | CALL setvar_p (runoff_mean, val_exp, 'NO_KEYWORD', zero) |
|---|
| 1601 | |
|---|
| 1602 | ALLOCATE(drainage_mean(nbpt), stat=ier) |
|---|
| 1603 | IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for drainage_mean','','') |
|---|
| 1604 | var_name = 'drainage_route' |
|---|
| 1605 | CALL ioconf_setatt_p('UNITS', 'Kg') |
|---|
| 1606 | CALL ioconf_setatt_p('LONG_NAME','Accumulated drainage for routing') |
|---|
| 1607 | CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., drainage_mean, "gather", nbp_glo, index_g) |
|---|
| 1608 | CALL setvar_p (drainage_mean, val_exp, 'NO_KEYWORD', zero) |
|---|
| 1609 | |
|---|
| 1610 | ALLOCATE(transpot_mean(nbpt), stat=ier) |
|---|
| 1611 | IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for transpot_mean','','') |
|---|
| 1612 | var_name = 'transpot_route' |
|---|
| 1613 | CALL ioconf_setatt_p('UNITS', 'Kg/m^2') |
|---|
| 1614 | CALL ioconf_setatt_p('LONG_NAME','Accumulated potential transpiration for routing/irrigation') |
|---|
| 1615 | CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., transpot_mean, "gather", nbp_glo, index_g) |
|---|
| 1616 | CALL setvar_p (transpot_mean, val_exp, 'NO_KEYWORD', zero) |
|---|
| 1617 | |
|---|
| 1618 | ALLOCATE(precip_mean(nbpt), stat=ier) |
|---|
| 1619 | IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for precip_mean','','') |
|---|
| 1620 | var_name = 'precip_route' |
|---|
| 1621 | CALL ioconf_setatt_p('UNITS', 'Kg/m^2') |
|---|
| 1622 | CALL ioconf_setatt_p('LONG_NAME','Accumulated rain precipitation for irrigation') |
|---|
| 1623 | CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., precip_mean, "gather", nbp_glo, index_g) |
|---|
| 1624 | CALL setvar_p (precip_mean, val_exp, 'NO_KEYWORD', zero) |
|---|
| 1625 | |
|---|
| 1626 | ALLOCATE(humrel_mean(nbpt), stat=ier) |
|---|
| 1627 | IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for humrel_mean','','') |
|---|
| 1628 | var_name = 'humrel_route' |
|---|
| 1629 | CALL ioconf_setatt_p('UNITS', '-') |
|---|
| 1630 | CALL ioconf_setatt_p('LONG_NAME','Mean humrel for irrigation') |
|---|
| 1631 | CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., humrel_mean, "gather", nbp_glo, index_g) |
|---|
| 1632 | CALL setvar_p (humrel_mean, val_exp, 'NO_KEYWORD', un) |
|---|
| 1633 | |
|---|
| 1634 | ALLOCATE(k_litt_mean(nbpt), stat=ier) |
|---|
| 1635 | IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for k_litt_mean','','') |
|---|
| 1636 | var_name = 'k_litt_route' |
|---|
| 1637 | CALL ioconf_setatt_p('UNITS', '-') |
|---|
| 1638 | CALL ioconf_setatt_p('LONG_NAME','Mean cond. for litter') |
|---|
| 1639 | CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., k_litt_mean, "gather", nbp_glo, index_g) |
|---|
| 1640 | CALL setvar_p (k_litt_mean, val_exp, 'NO_KEYWORD', zero) |
|---|
| 1641 | |
|---|
| 1642 | ALLOCATE(totnobio_mean(nbpt), stat=ier) |
|---|
| 1643 | IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for totnobio_mean','','') |
|---|
| 1644 | var_name = 'totnobio_route' |
|---|
| 1645 | CALL ioconf_setatt_p('UNITS', '-') |
|---|
| 1646 | CALL ioconf_setatt_p('LONG_NAME','Last Total fraction of no bio for irrigation') |
|---|
| 1647 | CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., totnobio_mean, "gather", nbp_glo, index_g) |
|---|
| 1648 | CALL setvar_p (totnobio_mean, val_exp, 'NO_KEYWORD', zero) |
|---|
| 1649 | |
|---|
| 1650 | ALLOCATE(vegtot_mean(nbpt), stat=ier) |
|---|
| 1651 | IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for vegtot_mean','','') |
|---|
| 1652 | var_name = 'vegtot_route' |
|---|
| 1653 | CALL ioconf_setatt_p('UNITS', '-') |
|---|
| 1654 | CALL ioconf_setatt_p('LONG_NAME','Last Total fraction of vegetation') |
|---|
| 1655 | CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., vegtot_mean, "gather", nbp_glo, index_g) |
|---|
| 1656 | CALL setvar_p (vegtot_mean, val_exp, 'NO_KEYWORD', un) |
|---|
| 1657 | ! |
|---|
| 1658 | ! |
|---|
| 1659 | DEALLOCATE(tmp_real_g) |
|---|
| 1660 | ! |
|---|
| 1661 | ! Allocate diagnostic variables |
|---|
| 1662 | ! |
|---|
| 1663 | ALLOCATE(hydrodiag_loc(nbpt,nbasmax),hydrodiag_glo(nbp_glo,nbasmax),stat=ier) |
|---|
| 1664 | IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for hydrodiag_glo','','') |
|---|
| 1665 | hydrodiag=>hydrodiag_loc |
|---|
| 1666 | |
|---|
| 1667 | ALLOCATE(hydroupbasin_loc(nbpt),hydroupbasin_glo(nbp_glo), stat=ier) |
|---|
| 1668 | IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for hydroupbasin_glo','','') |
|---|
| 1669 | hydroupbasin=>hydroupbasin_loc |
|---|
| 1670 | |
|---|
| 1671 | END SUBROUTINE routing_init |
|---|
| 1672 | ! |
|---|
| 1673 | !! ================================================================================================================================ |
|---|
| 1674 | !! SUBROUTINE : routing_clear |
|---|
| 1675 | !! |
|---|
| 1676 | !>\BRIEF : This subroutine deallocates the block memory previously allocated. |
|---|
| 1677 | !! \n |
|---|
| 1678 | !_ ================================================================================================================================ |
|---|
| 1679 | |
|---|
| 1680 | SUBROUTINE routing_clear() |
|---|
| 1681 | |
|---|
| 1682 | IF (ALLOCATED(routing_area_loc)) DEALLOCATE(routing_area_loc) |
|---|
| 1683 | IF (ALLOCATED(route_togrid_loc)) DEALLOCATE(route_togrid_loc) |
|---|
| 1684 | IF (ALLOCATED(route_tobasin_loc)) DEALLOCATE(route_tobasin_loc) |
|---|
| 1685 | IF (ALLOCATED(route_nbintobas_loc)) DEALLOCATE(route_nbintobas_loc) |
|---|
| 1686 | IF (ALLOCATED(global_basinid_loc)) DEALLOCATE(global_basinid_loc) |
|---|
| 1687 | IF (ALLOCATED(topo_resid_loc)) DEALLOCATE(topo_resid_loc) |
|---|
| 1688 | IF (ALLOCATED(routing_area_glo)) DEALLOCATE(routing_area_glo) |
|---|
| 1689 | IF (ALLOCATED(route_togrid_glo)) DEALLOCATE(route_togrid_glo) |
|---|
| 1690 | IF (ALLOCATED(route_tobasin_glo)) DEALLOCATE(route_tobasin_glo) |
|---|
| 1691 | IF (ALLOCATED(route_nbintobas_glo)) DEALLOCATE(route_nbintobas_glo) |
|---|
| 1692 | IF (ALLOCATED(global_basinid_glo)) DEALLOCATE(global_basinid_glo) |
|---|
| 1693 | IF (ALLOCATED(topo_resid_glo)) DEALLOCATE(topo_resid_glo) |
|---|
| 1694 | IF (ALLOCATED(fast_reservoir)) DEALLOCATE(fast_reservoir) |
|---|
| 1695 | IF (ALLOCATED(slow_reservoir)) DEALLOCATE(slow_reservoir) |
|---|
| 1696 | IF (ALLOCATED(stream_reservoir)) DEALLOCATE(stream_reservoir) |
|---|
| 1697 | IF (ALLOCATED(flood_reservoir)) DEALLOCATE(flood_reservoir) |
|---|
| 1698 | IF (ALLOCATED(flood_frac_bas)) DEALLOCATE(flood_frac_bas) |
|---|
| 1699 | IF (ALLOCATED(flood_height)) DEALLOCATE(flood_height) |
|---|
| 1700 | IF (ALLOCATED(pond_frac)) DEALLOCATE(pond_frac) |
|---|
| 1701 | IF (ALLOCATED(lake_reservoir)) DEALLOCATE(lake_reservoir) |
|---|
| 1702 | IF (ALLOCATED(pond_reservoir)) DEALLOCATE(pond_reservoir) |
|---|
| 1703 | IF (ALLOCATED(returnflow_mean)) DEALLOCATE(returnflow_mean) |
|---|
| 1704 | IF (ALLOCATED(reinfiltration_mean)) DEALLOCATE(reinfiltration_mean) |
|---|
| 1705 | IF (ALLOCATED(riverflow_mean)) DEALLOCATE(riverflow_mean) |
|---|
| 1706 | IF (ALLOCATED(coastalflow_mean)) DEALLOCATE(coastalflow_mean) |
|---|
| 1707 | IF (ALLOCATED(lakeinflow_mean)) DEALLOCATE(lakeinflow_mean) |
|---|
| 1708 | IF (ALLOCATED(runoff_mean)) DEALLOCATE(runoff_mean) |
|---|
| 1709 | IF (ALLOCATED(floodout_mean)) DEALLOCATE(floodout_mean) |
|---|
| 1710 | IF (ALLOCATED(drainage_mean)) DEALLOCATE(drainage_mean) |
|---|
| 1711 | IF (ALLOCATED(transpot_mean)) DEALLOCATE(transpot_mean) |
|---|
| 1712 | IF (ALLOCATED(precip_mean)) DEALLOCATE(precip_mean) |
|---|
| 1713 | IF (ALLOCATED(humrel_mean)) DEALLOCATE(humrel_mean) |
|---|
| 1714 | IF (ALLOCATED(k_litt_mean)) DEALLOCATE(k_litt_mean) |
|---|
| 1715 | IF (ALLOCATED(totnobio_mean)) DEALLOCATE(totnobio_mean) |
|---|
| 1716 | IF (ALLOCATED(vegtot_mean)) DEALLOCATE(vegtot_mean) |
|---|
| 1717 | IF (ALLOCATED(floodtemp)) DEALLOCATE(floodtemp) |
|---|
| 1718 | IF (ALLOCATED(hydrodiag_loc)) DEALLOCATE(hydrodiag_loc) |
|---|
| 1719 | IF (ALLOCATED(hydrodiag_glo)) DEALLOCATE(hydrodiag_glo) |
|---|
| 1720 | IF (ALLOCATED(hydroupbasin_loc)) DEALLOCATE(hydroupbasin_loc) |
|---|
| 1721 | IF (ALLOCATED(hydroupbasin_glo)) DEALLOCATE(hydroupbasin_glo) |
|---|
| 1722 | IF (ALLOCATED(hydrographs)) DEALLOCATE(hydrographs) |
|---|
| 1723 | IF (ALLOCATED(slowflow_diag)) DEALLOCATE(slowflow_diag) |
|---|
| 1724 | IF (ALLOCATED(irrigation_mean)) DEALLOCATE(irrigation_mean) |
|---|
| 1725 | IF (ALLOCATED(irrigated)) DEALLOCATE(irrigated) |
|---|
| 1726 | IF (ALLOCATED(floodplains)) DEALLOCATE(floodplains) |
|---|
| 1727 | IF (ALLOCATED(swamp)) DEALLOCATE(swamp) |
|---|
| 1728 | IF (ALLOCATED(fast_diag)) DEALLOCATE(fast_diag) |
|---|
| 1729 | IF (ALLOCATED(slow_diag)) DEALLOCATE(slow_diag) |
|---|
| 1730 | IF (ALLOCATED(stream_diag)) DEALLOCATE(stream_diag) |
|---|
| 1731 | IF (ALLOCATED(flood_diag)) DEALLOCATE(flood_diag) |
|---|
| 1732 | IF (ALLOCATED(pond_diag)) DEALLOCATE(pond_diag) |
|---|
| 1733 | IF (ALLOCATED(lake_diag)) DEALLOCATE(lake_diag) |
|---|
| 1734 | |
|---|
| 1735 | END SUBROUTINE routing_clear |
|---|
| 1736 | ! |
|---|
| 1737 | |
|---|
| 1738 | !! ================================================================================================================================ |
|---|
| 1739 | !! SUBROUTINE : routing_flow |
|---|
| 1740 | !! |
|---|
| 1741 | !>\BRIEF This subroutine computes the transport of water in the various reservoirs |
|---|
| 1742 | !! (including ponds and floodplains) and the water withdrawals from the reservoirs for irrigation. |
|---|
| 1743 | !! |
|---|
| 1744 | !! DESCRIPTION (definitions, functional, design, flags) : |
|---|
| 1745 | !! This will first compute the amount of water which flows out of each of the 3 reservoirs using the assumption of an |
|---|
| 1746 | !! exponential decrease of water in the reservoir (see Hagemann S and Dumenil L. (1998)). Then we compute the fluxes |
|---|
| 1747 | !! for floodplains and ponds. All this will then be used in order to update each of the basins : taking water out of |
|---|
| 1748 | !! the up-stream basin and adding it to the down-stream one. |
|---|
| 1749 | !! As this step happens globaly we have to stop the parallel processing in order to exchange the information. Once |
|---|
| 1750 | !! all reservoirs are updated we deal with irrigation. The final step is to compute diagnostic fluxes. Among them |
|---|
| 1751 | !! the hydrographs of the largest rivers we have chosen to monitor. |
|---|
| 1752 | !! |
|---|
| 1753 | !! RECENT CHANGE(S): None |
|---|
| 1754 | !! |
|---|
| 1755 | !! MAIN OUTPUT VARIABLE(S): lakeinflow, returnflow, reinfiltration, irrigation, riverflow, coastalflow, hydrographs, flood_frac, flood_res |
|---|
| 1756 | !! |
|---|
| 1757 | !! REFERENCES : |
|---|
| 1758 | !! - Ngo-Duc, T., K. Laval, G. Ramillien, J. Polcher, and A. Cazenave (2007) |
|---|
| 1759 | !! Validation of the land water storage simulated by Organising Carbon and Hydrology in Dynamic Ecosystems (ORCHIDEE) with Gravity Recovery and Climate Experiment (GRACE) data. |
|---|
| 1760 | !! Water Resour. Res., 43, W04427, doi:10.1029/2006WR004941. |
|---|
| 1761 | !! * Irrigation: |
|---|
| 1762 | !! - de Rosnay, P., J. Polcher, K. Laval, and M. Sabre (2003) |
|---|
| 1763 | !! Integrated parameterization of irrigation in the land surface model ORCHIDEE. Validation over Indian Peninsula. |
|---|
| 1764 | !! Geophys. Res. Lett., 30(19), 1986, doi:10.1029/2003GL018024. |
|---|
| 1765 | !! - A.C. Vivant (2003) |
|---|
| 1766 | !! Les plaines d'inondations et l'irrigation dans ORCHIDEE, impacts de leur prise en compte. |
|---|
| 1767 | !! , , 51pp. |
|---|
| 1768 | !! - N. Culson (2004) |
|---|
| 1769 | !! Impact de l'irrigation sur le cycle de l'eau |
|---|
| 1770 | !! Master thesis, Paris VI University, 55pp. |
|---|
| 1771 | !! - X.-T. Nguyen-Vinh (2005) |
|---|
| 1772 | !! Analyse de l'impact de l'irrigation en Amerique du Nord - plaine du Mississippi - sur la climatologie regionale |
|---|
| 1773 | !! Master thesis, Paris VI University, 33pp. |
|---|
| 1774 | !! - M. Guimberteau (2006) |
|---|
| 1775 | !! Analyse et modifications proposees de la modelisation de l'irrigation dans un modele de surface. |
|---|
| 1776 | !! Master thesis, Paris VI University, 46pp. |
|---|
| 1777 | !! - Guimberteau M. (2010) |
|---|
| 1778 | !! Modelisation de l'hydrologie continentale et influences de l'irrigation sur le cycle de l'eau. |
|---|
| 1779 | !! Ph.D. thesis, Paris VI University, 195pp. |
|---|
| 1780 | !! - Guimberteau M., Laval K., Perrier A. and Polcher J. (2011). |
|---|
| 1781 | !! Global effect of irrigation and its impact on the onset of the Indian summer monsoon. |
|---|
| 1782 | !! In press, Climate Dynamics, doi: 10.1007/s00382-011-1252-5. |
|---|
| 1783 | !! * Floodplains: |
|---|
| 1784 | !! - A.C. Vivant (2002) |
|---|
| 1785 | !! L'ecoulement lateral de l'eau sur les surfaces continentales. Prise en compte des plaines d'inondations dans ORCHIDEE. |
|---|
| 1786 | !! Master thesis, Paris VI University, 46pp. |
|---|
| 1787 | !! - A.C. Vivant (2003) |
|---|
| 1788 | !! Les plaines d'inondations et l'irrigation dans ORCHIDEE, impacts de leur prise en compte. |
|---|
| 1789 | !! , , 51pp. |
|---|
| 1790 | !! - T. d'Orgeval (2006) |
|---|
| 1791 | !! Impact du changement climatique sur le cycle de l'eau en Afrique de l'Ouest: modelisation et incertitudes. |
|---|
| 1792 | !! Ph.D. thesis, Paris VI University, 188pp. |
|---|
| 1793 | !! - T. d'Orgeval, J. Polcher, and P. de Rosnay (2008) |
|---|
| 1794 | !! Sensitivity of the West African hydrological cycle in ORCHIDEE to infiltration processes. |
|---|
| 1795 | !! Hydrol. Earth Syst. Sci., 12, 1387-1401 |
|---|
| 1796 | !! - M. Guimberteau, G. Drapeau, J. Ronchail, B. Sultan, J. Polcher, J.-M. Martinez, C. Prigent, J.-L. Guyot, G. Cochonneau, |
|---|
| 1797 | !! J. C. Espinoza, N. Filizola, P. Fraizy, W. Lavado, E. De Oliveira, R. Pombosa, L. Noriega, and P. Vauchel (2011) |
|---|
| 1798 | !! Discharge simulation in the sub-basins of the Amazon using ORCHIDEE forced by new datasets. |
|---|
| 1799 | !! Hydrol. Earth Syst. Sci. Discuss., 8, 11171-11232, doi:10.5194/hessd-8-11171-2011 |
|---|
| 1800 | !! |
|---|
| 1801 | !! FLOWCHART :None |
|---|
| 1802 | !! \n |
|---|
| 1803 | !_ ================================================================================================================================ |
|---|
| 1804 | |
|---|
| 1805 | SUBROUTINE routing_flow(nbpt, dt_routing, lalo, floodout, runoff, drainage, & |
|---|
| 1806 | & vegtot, totnobio, transpot_mean, transpot, evapot_corr, veget, veget_max, soil_deficit, & |
|---|
| 1807 | & precip, humrel, k_litt, floodtemp, reinf_slope, & |
|---|
| 1808 | & lakeinflow, returnflow, reinfiltration, irrigation, riverflow, & |
|---|
| 1809 | & coastalflow, hydrographs, slowflow_diag, flood_frac, flood_res, vegstress, & |
|---|
| 1810 | netflow_stream_diag, netflow_fast_diag, netflow_slow_diag) |
|---|
| 1811 | ! |
|---|
| 1812 | IMPLICIT NONE |
|---|
| 1813 | ! |
|---|
| 1814 | !! INPUT VARIABLES |
|---|
| 1815 | INTEGER(i_std), INTENT(in) :: nbpt !! Domain size (unitless) |
|---|
| 1816 | REAL(r_std), INTENT (in) :: dt_routing !! Routing time step (s) |
|---|
| 1817 | REAL(r_std), INTENT(in) :: lalo(nbpt,2) !! Vector of latitude and longitudes |
|---|
| 1818 | REAL(r_std), INTENT(in) :: runoff(nbpt) !! Grid-point runoff (kg/m^2/dt) |
|---|
| 1819 | REAL(r_std), INTENT(in) :: floodout(nbpt) !! Grid-point flow out of floodplains (kg/m^2/dt) |
|---|
| 1820 | REAL(r_std), INTENT(in) :: drainage(nbpt) !! Grid-point drainage (kg/m^2/dt) |
|---|
| 1821 | REAL(r_std), INTENT(in) :: vegtot(nbpt) !! Potentially vegetated fraction (unitless;0-1) |
|---|
| 1822 | REAL(r_std), INTENT(in) :: totnobio(nbpt) !! Other areas which can not have vegetation |
|---|
| 1823 | REAL(r_std), INTENT(in) :: transpot_mean(nbpt) !! Mean potential transpiration of the vegetation (kg/m^2/dt) |
|---|
| 1824 | REAL(r_std), INTENT(in) :: transpot(nbpt,nvm) !! potential transpiration of each pft(kg/m^2/dt) |
|---|
| 1825 | REAL(r_std), INTENT(in) :: evapot_corr(nbpt) !! potential soil evaporation(kg/m^2/dt) |
|---|
| 1826 | REAL(r_std), INTENT(in) :: veget(nbpt,nvm) !! vegetation fraction of each pft (unitless;0-1) |
|---|
| 1827 | REAL(r_std), INTENT(in) :: veget_max(nbpt,nvm) !! maximum vegetation fraction of each pft (unitless;0-1) |
|---|
| 1828 | REAL(r_std), INTENT(in) :: soil_deficit(nbpt,nvm) !! |
|---|
| 1829 | REAL(r_std), INTENT(in) :: precip(nbpt) !! Rainfall (kg/m^2/dt) |
|---|
| 1830 | REAL(r_std), INTENT(in) :: humrel(nbpt) !! Soil moisture stress, root extraction potential (unitless) |
|---|
| 1831 | REAL(r_std), INTENT(in) :: k_litt(nbpt) !! Averaged conductivity for saturated infiltration in the 'litter' layer (kg/m^2/dt) |
|---|
| 1832 | REAL(r_std), INTENT(in) :: floodtemp(nbpt) !! Temperature to decide if floodplains work (K) |
|---|
| 1833 | REAL(r_std), INTENT(in) :: reinf_slope(nbpt) !! Coefficient which determines the reinfiltration ratio in the grid box due to flat areas (unitless;0-1) |
|---|
| 1834 | REAL(r_std), INTENT(out) :: lakeinflow(nbpt) !! Water inflow to the lakes (kg/dt) |
|---|
| 1835 | REAL(r_std), INTENT(in) :: vegstress(nbpt,nvm) !! vegetation growth stress |
|---|
| 1836 | ! |
|---|
| 1837 | !! OUTPUT VARIABLES |
|---|
| 1838 | REAL(r_std), INTENT(out) :: returnflow(nbpt) !! The water flow from lakes and swamps which returns into the grid box. |
|---|
| 1839 | !! This water will go back into the hydrol or hydrolc module to allow re-evaporation (kg/m^2/dt_routing) |
|---|
| 1840 | REAL(r_std), INTENT(out) :: reinfiltration(nbpt) !! Water flow from ponds and floodplains which returns to the grid box (kg/m^2/dt) |
|---|
| 1841 | REAL(r_std), INTENT(out) :: irrigation(nbpt) !! Irrigation flux. This is the water taken from the reservoirs and beeing put into the upper layers of the soil (kg/m^2/dt_routing) |
|---|
| 1842 | REAL(r_std), INTENT(out) :: riverflow(nbpt) !! Outflow of the major rivers. The flux will be located on the continental grid but this should be a coastal point (kg/dt_routing) |
|---|
| 1843 | REAL(r_std), INTENT(out) :: coastalflow(nbpt) !! Outflow on coastal points by small basins. This is the water which flows in a disperse way into the ocean (kg/dt_routing) |
|---|
| 1844 | REAL(r_std), INTENT(out) :: hydrographs(nbpt) !! Hydrographs at the outflow of the grid box for major basins (kg/dt) |
|---|
| 1845 | REAL(r_std), INTENT(out) :: slowflow_diag(nbpt) !! Hydrographs of slow_flow = routed slow_flow for major basins (kg/dt) |
|---|
| 1846 | REAL(r_std), INTENT(out) :: flood_frac(nbpt) !! Flooded fraction of the grid box (unitless;0-1) |
|---|
| 1847 | REAL(r_std), INTENT(out) :: flood_res(nbpt) !! Diagnostic of water amount in the floodplains reservoir (kg) |
|---|
| 1848 | |
|---|
| 1849 | REAL(r_std), INTENT(out) :: netflow_stream_diag(nbpt) !! Input - Output flow to stream reservoir |
|---|
| 1850 | REAL(r_std), INTENT(out) :: netflow_fast_diag(nbpt) !! Input - Output flow to fast reservoir |
|---|
| 1851 | REAL(r_std), INTENT(out) :: netflow_slow_diag(nbpt) !! Input - Output flow to slow reservoir |
|---|
| 1852 | ! |
|---|
| 1853 | !! LOCAL VARIABLES |
|---|
| 1854 | REAL(r_std), DIMENSION(nbpt, nbasmax) :: fast_flow !! Outflow from the fast reservoir (kg/dt) |
|---|
| 1855 | REAL(r_std), DIMENSION(nbpt, nbasmax) :: slow_flow !! Outflow from the slow reservoir (kg/dt) |
|---|
| 1856 | REAL(r_std), DIMENSION(nbpt, nbasmax) :: stream_flow !! Outflow from the stream reservoir (kg/dt) |
|---|
| 1857 | REAL(r_std), DIMENSION(nbpt, nbasmax) :: flood_flow !! Outflow from the floodplain reservoir (kg/dt) |
|---|
| 1858 | REAL(r_std), DIMENSION(nbpt, nbasmax) :: pond_inflow !! Inflow to the pond reservoir (kg/dt) |
|---|
| 1859 | REAL(r_std), DIMENSION(nbpt, nbasmax) :: pond_drainage !! Drainage from pond (kg/m^2/dt) |
|---|
| 1860 | REAL(r_std), DIMENSION(nbpt, nbasmax) :: flood_drainage !! Drainage from floodplains (kg/m^2/dt) |
|---|
| 1861 | REAL(r_std), DIMENSION(nbpt, nbasmax) :: return_swamp !! Inflow to the swamp (kg/dt) |
|---|
| 1862 | ! |
|---|
| 1863 | ! Irrigation per basin |
|---|
| 1864 | ! |
|---|
| 1865 | REAL(r_std), DIMENSION(nbpt, nbasmax) :: irrig_needs !! Total irrigation requirement (water requirements by the crop for its optimal growth) (kg) |
|---|
| 1866 | REAL(r_std), DIMENSION(nbpt, nbasmax) :: irrig_actual !! Possible irrigation according to the water availability in the reservoirs (kg) |
|---|
| 1867 | REAL(r_std), DIMENSION(nbpt, nbasmax) :: irrig_deficit !! Amount of water missing for irrigation (kg) |
|---|
| 1868 | REAL(r_std), DIMENSION(nbpt, nbasmax) :: irrig_adduct !! Amount of water carried over from other basins for irrigation (kg) |
|---|
| 1869 | ! |
|---|
| 1870 | REAL(r_std), DIMENSION(nbpt, 0:nbasmax+3) :: transport !! Water transport between basins (kg/dt) |
|---|
| 1871 | REAL(r_std), DIMENSION(nbp_glo, 0:nbasmax+3) :: transport_glo !! Water transport between basins (kg/dt) |
|---|
| 1872 | REAL(r_std), DIMENSION(nbpt, nbasmax) :: floods !! Water flow in to the floodplains (kg/dt) |
|---|
| 1873 | REAL(r_std), DIMENSION(nbpt, nbasmax) :: potflood !! Potential inflow to the swamps (kg/dt) |
|---|
| 1874 | REAL(r_std), DIMENSION(nbpt) :: tobeflooded !! Maximal surface which can be inundated in each grid box (m^2) |
|---|
| 1875 | REAL(r_std), DIMENSION(nbpt) :: totarea !! Total area of basin (m^2) |
|---|
| 1876 | REAL(r_std), DIMENSION(nbpt) :: totflood !! Total amount of water in the floodplains reservoir (kg) |
|---|
| 1877 | REAL(r_std), DIMENSION(nbasmax) :: pond_excessflow !! |
|---|
| 1878 | REAL(r_std) :: flow !! Outflow computation for the reservoirs (kg/dt) |
|---|
| 1879 | REAL(r_std) :: floodindex !! Fraction of grid box area inundated (unitless;0-1) |
|---|
| 1880 | REAL(r_std) :: pondex !! |
|---|
| 1881 | REAL(r_std) :: flood_frac_pot !! Total fraction of the grid box which is flooded at optimum repartition (unitless;0-1) |
|---|
| 1882 | REAL(r_std) :: stream_tot !! Total water amount in the stream reservoirs (kg) |
|---|
| 1883 | REAL(r_std) :: adduction !! Importation of water from a stream reservoir of a neighboring grid box (kg) |
|---|
| 1884 | REAL(r_std), DIMENSION(nbp_glo) :: lake_overflow_g !! Removed water from lake reservoir on global grid (kg/gridcell/dt_routing) |
|---|
| 1885 | REAL(r_std), DIMENSION(nbpt) :: lake_overflow !! Removed water from lake reservoir on local grid (kg/gridcell/dt_routing) |
|---|
| 1886 | REAL(r_std), DIMENSION(nbpt) :: lake_overflow_coast !! lake_overflow distributed on coast gridcells, only diag(kg/gridcell/dt_routing) |
|---|
| 1887 | REAL(r_std) :: total_lake_overflow !! Sum of lake_overflow over full grid (kg) |
|---|
| 1888 | REAL(r_std), DIMENSION(8,nbasmax) :: streams_around !! Stream reservoirs of the neighboring grid boxes (kg) |
|---|
| 1889 | INTEGER(i_std), DIMENSION(8) :: igrd !! |
|---|
| 1890 | INTEGER(i_std), DIMENSION(2) :: ff !! |
|---|
| 1891 | INTEGER(i_std), DIMENSION(1) :: fi !! |
|---|
| 1892 | INTEGER(i_std) :: ig, ib, ib2, ig2, jv !! Indices (unitless) |
|---|
| 1893 | INTEGER(i_std) :: rtg, rtb, in !! Indices (unitless) |
|---|
| 1894 | INTEGER(i_std) :: ier !! Error handling |
|---|
| 1895 | REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: fast_flow_g !! Outflow from the fast reservoir (kg/dt) |
|---|
| 1896 | REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: slow_flow_g !! Outflow from the slow reservoir (kg/dt) |
|---|
| 1897 | REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: stream_flow_g !! Outflow from the stream reservoir (kg/dt) |
|---|
| 1898 | REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: irrig_deficit_glo !! Amount of water missing for irrigation (kg) |
|---|
| 1899 | REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: stream_reservoir_glo !! Water amount in the stream reservoir (kg) |
|---|
| 1900 | REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: irrig_adduct_glo !! Amount of water carried over from other basins for irrigation (kg) |
|---|
| 1901 | |
|---|
| 1902 | REAL(r_std), DIMENSION(nbpt, nbasmax) :: netflow_stream !! Input - Output flow to stream reservoir |
|---|
| 1903 | REAL(r_std), DIMENSION(nbpt, nbasmax) :: netflow_fast !! Input - Output flow to fast reservoir |
|---|
| 1904 | REAL(r_std), DIMENSION(nbpt, nbasmax) :: netflow_slow !! Input - Output flow to slow reservoir |
|---|
| 1905 | |
|---|
| 1906 | |
|---|
| 1907 | !! PARAMETERS |
|---|
| 1908 | LOGICAL, PARAMETER :: check_reservoir = .FALSE. !! Logical to choose if we write informations when a negative amount of water is occurring in a reservoir (true/false) |
|---|
| 1909 | !_ ================================================================================================================================ |
|---|
| 1910 | ! |
|---|
| 1911 | transport(:,:) = zero |
|---|
| 1912 | transport_glo(:,:) = zero |
|---|
| 1913 | irrig_netereq(:) = zero |
|---|
| 1914 | irrig_needs(:,:) = zero |
|---|
| 1915 | irrig_actual(:,:) = zero |
|---|
| 1916 | irrig_deficit(:,:) = zero |
|---|
| 1917 | irrig_adduct(:,:) = zero |
|---|
| 1918 | totarea(:) = zero |
|---|
| 1919 | totflood(:) = zero |
|---|
| 1920 | ! |
|---|
| 1921 | ! Compute all the fluxes |
|---|
| 1922 | ! |
|---|
| 1923 | DO ib=1,nbasmax |
|---|
| 1924 | DO ig=1,nbpt |
|---|
| 1925 | ! |
|---|
| 1926 | totarea(ig) = totarea(ig) + routing_area(ig,ib) |
|---|
| 1927 | totflood(ig) = totflood(ig) + flood_reservoir(ig,ib) |
|---|
| 1928 | ENDDO |
|---|
| 1929 | ENDDO |
|---|
| 1930 | ! |
|---|
| 1931 | !> The outflow fluxes from the three reservoirs are computed. |
|---|
| 1932 | !> The outflow of volume of water Vi into the reservoir i is assumed to be linearly related to its volume. |
|---|
| 1933 | !> The water travel simulated by the routing scheme is dependent on the water retention index topo_resid |
|---|
| 1934 | !> given by a 0.5 degree resolution map for each pixel performed from a simplification of Manning's formula |
|---|
| 1935 | !> (Dingman, 1994; Ducharne et al., 2003). |
|---|
| 1936 | !> The resulting product of tcst (in day/m) and topo_resid (in m) represents the time constant (day) |
|---|
| 1937 | !> which is an e-folding time, the time necessary for the water amount |
|---|
| 1938 | !> in the stream reservoir to decrease by a factor e. Hence, it gives an order of |
|---|
| 1939 | !> magnitude of the travel time through this reservoir between |
|---|
| 1940 | !> the sub-basin considered and its downstream neighbor. |
|---|
| 1941 | |
|---|
| 1942 | DO ib=1,nbasmax |
|---|
| 1943 | DO ig=1,nbpt |
|---|
| 1944 | IF ( route_tobasin(ig,ib) .GT. 0 ) THEN |
|---|
| 1945 | ! |
|---|
| 1946 | ! Each of the fluxes is limited by the water in the reservoir and a small margin |
|---|
| 1947 | ! (min_reservoir) to avoid rounding errors. |
|---|
| 1948 | ! |
|---|
| 1949 | flow = MIN(fast_reservoir(ig,ib)/((topo_resid(ig,ib)/1000.)*fast_tcst*one_day/dt_routing),& |
|---|
| 1950 | & fast_reservoir(ig,ib)-min_sechiba) |
|---|
| 1951 | fast_flow(ig,ib) = MAX(flow, zero) |
|---|
| 1952 | |
|---|
| 1953 | flow = MIN(slow_reservoir(ig,ib)/((topo_resid(ig,ib)/1000.)*slow_tcst*one_day/dt_routing),& |
|---|
| 1954 | & slow_reservoir(ig,ib)-min_sechiba) |
|---|
| 1955 | slow_flow(ig,ib) = MAX(flow, zero) |
|---|
| 1956 | |
|---|
| 1957 | flow = MIN(stream_reservoir(ig,ib)/((topo_resid(ig,ib)/1000.)*stream_tcst* & |
|---|
| 1958 | & MAX(un-SQRT(flood_frac_bas(ig,ib)),min_sechiba)*one_day/dt_routing),& |
|---|
| 1959 | & stream_reservoir(ig,ib)-min_sechiba) |
|---|
| 1960 | stream_flow(ig,ib) = MAX(flow, zero) |
|---|
| 1961 | ! |
|---|
| 1962 | ELSE |
|---|
| 1963 | fast_flow(ig,ib) = zero |
|---|
| 1964 | slow_flow(ig,ib) = zero |
|---|
| 1965 | stream_flow(ig,ib) = zero |
|---|
| 1966 | ENDIF |
|---|
| 1967 | ENDDO |
|---|
| 1968 | ENDDO |
|---|
| 1969 | !- |
|---|
| 1970 | !- Compute the fluxes out of the floodplains and ponds if they exist. |
|---|
| 1971 | !- |
|---|
| 1972 | IF (do_floodplains .OR. doponds) THEN |
|---|
| 1973 | DO ig=1,nbpt |
|---|
| 1974 | IF (flood_frac(ig) .GT. min_sechiba) THEN |
|---|
| 1975 | ! |
|---|
| 1976 | flow = MIN(floodout(ig)*totarea(ig)*pond_frac(ig)/flood_frac(ig), pond_reservoir(ig)+totflood(ig)) |
|---|
| 1977 | pondex = MAX(flow - pond_reservoir(ig), zero) |
|---|
| 1978 | pond_reservoir(ig) = pond_reservoir(ig) - (flow - pondex) |
|---|
| 1979 | ! |
|---|
| 1980 | ! If demand was over reservoir size, we will take it out from floodplains |
|---|
| 1981 | ! |
|---|
| 1982 | pond_excessflow(:) = zero |
|---|
| 1983 | DO ib=1,nbasmax |
|---|
| 1984 | pond_excessflow(ib) = MIN(pondex*flood_frac_bas(ig,ib)/(flood_frac(ig)-pond_frac(ig)),& |
|---|
| 1985 | & flood_reservoir(ig,ib)) |
|---|
| 1986 | pondex = pondex - pond_excessflow(ib) |
|---|
| 1987 | ENDDO |
|---|
| 1988 | ! |
|---|
| 1989 | IF ( pondex .GT. min_sechiba) THEN |
|---|
| 1990 | WRITE(numout,*) "Unable to redistribute the excess pond outflow over the water available in the floodplain." |
|---|
| 1991 | WRITE(numout,*) "Pondex = ", pondex |
|---|
| 1992 | WRITE(numout,*) "pond_excessflow(:) = ", pond_excessflow(:) |
|---|
| 1993 | ENDIF |
|---|
| 1994 | ! |
|---|
| 1995 | DO ib=1,nbasmax |
|---|
| 1996 | ! |
|---|
| 1997 | flow = floodout(ig)*routing_area(ig,ib)*flood_frac_bas(ig,ib)/flood_frac(ig) + pond_excessflow(ib) |
|---|
| 1998 | ! |
|---|
| 1999 | flood_reservoir(ig,ib) = flood_reservoir(ig,ib) - flow |
|---|
| 2000 | ! |
|---|
| 2001 | ! |
|---|
| 2002 | IF (flood_reservoir(ig,ib) .LT. min_sechiba) THEN |
|---|
| 2003 | flood_reservoir(ig,ib) = zero |
|---|
| 2004 | ENDIF |
|---|
| 2005 | IF (pond_reservoir(ig) .LT. min_sechiba) THEN |
|---|
| 2006 | pond_reservoir(ig) = zero |
|---|
| 2007 | ENDIF |
|---|
| 2008 | ENDDO |
|---|
| 2009 | ENDIF |
|---|
| 2010 | ENDDO |
|---|
| 2011 | ENDIF |
|---|
| 2012 | |
|---|
| 2013 | !- |
|---|
| 2014 | !- Computing the drainage and outflow from floodplains |
|---|
| 2015 | !> Drainage from floodplains is depending on a averaged conductivity (k_litt) |
|---|
| 2016 | !> for saturated infiltration in the 'litter' layer. Flood_drainage will be |
|---|
| 2017 | !> a component of the total reinfiltration that leaves the routing scheme. |
|---|
| 2018 | !- |
|---|
| 2019 | IF (do_floodplains) THEN |
|---|
| 2020 | IF (dofloodinfilt) THEN |
|---|
| 2021 | DO ib=1,nbasmax |
|---|
| 2022 | DO ig=1,nbpt |
|---|
| 2023 | flood_drainage(ig,ib) = MAX(zero, MIN(flood_reservoir(ig,ib), & |
|---|
| 2024 | & flood_frac(ig)*routing_area(ig,ib)*k_litt(ig)*dt_routing/one_day)) |
|---|
| 2025 | flood_reservoir(ig,ib) = flood_reservoir(ig,ib) - flood_drainage(ig,ib) |
|---|
| 2026 | ENDDO |
|---|
| 2027 | ENDDO |
|---|
| 2028 | ELSE |
|---|
| 2029 | DO ib=1,nbasmax |
|---|
| 2030 | DO ig=1,nbpt |
|---|
| 2031 | flood_drainage(ig,ib) = zero |
|---|
| 2032 | ENDDO |
|---|
| 2033 | ENDDO |
|---|
| 2034 | ENDIF |
|---|
| 2035 | !> Outflow from floodplains is computed depending a delay. This delay is characterized by a time constant |
|---|
| 2036 | !> function of the surface of the floodplains and the product of topo_resid and flood_tcst. flood_tcst |
|---|
| 2037 | !> has been calibrated through observations in the Niger Inner Delta (D'Orgeval, 2006). |
|---|
| 2038 | ! |
|---|
| 2039 | DO ib=1,nbasmax |
|---|
| 2040 | DO ig=1,nbpt |
|---|
| 2041 | IF ( route_tobasin(ig,ib) .GT. 0 ) THEN |
|---|
| 2042 | IF (flood_frac_bas(ig,ib) .GT. min_sechiba) THEN |
|---|
| 2043 | flow = MIN(flood_reservoir(ig,ib) & |
|---|
| 2044 | & /((topo_resid(ig,ib)/1000.)*flood_tcst* & |
|---|
| 2045 | & flood_frac_bas(ig,ib)*one_day/dt_routing),& |
|---|
| 2046 | & flood_reservoir(ig,ib)) |
|---|
| 2047 | ELSE |
|---|
| 2048 | flow = zero |
|---|
| 2049 | ENDIF |
|---|
| 2050 | flood_flow(ig,ib) = flow |
|---|
| 2051 | ELSE |
|---|
| 2052 | flood_flow(ig,ib) = zero |
|---|
| 2053 | ENDIF |
|---|
| 2054 | ENDDO |
|---|
| 2055 | ENDDO |
|---|
| 2056 | ELSE |
|---|
| 2057 | DO ib=1,nbasmax |
|---|
| 2058 | DO ig=1,nbpt |
|---|
| 2059 | flood_drainage(ig,ib) = zero |
|---|
| 2060 | flood_flow(ig,ib) = zero |
|---|
| 2061 | flood_reservoir(ig,ib) = zero |
|---|
| 2062 | ENDDO |
|---|
| 2063 | ENDDO |
|---|
| 2064 | ENDIF |
|---|
| 2065 | |
|---|
| 2066 | !- |
|---|
| 2067 | !- Computing drainage and inflow for ponds |
|---|
| 2068 | !> Drainage from ponds is computed in the same way than for floodplains. |
|---|
| 2069 | !> Reinfiltrated fraction from the runoff (i.e. the outflow from the fast reservoir) |
|---|
| 2070 | !> is the inflow of the pond reservoir. |
|---|
| 2071 | !- |
|---|
| 2072 | IF (doponds) THEN |
|---|
| 2073 | ! If used, the slope coef is not used in hydrol for water2infilt |
|---|
| 2074 | DO ib=1,nbasmax |
|---|
| 2075 | DO ig=1,nbpt |
|---|
| 2076 | pond_inflow(ig,ib) = fast_flow(ig,ib) * reinf_slope(ig) |
|---|
| 2077 | pond_drainage(ig,ib) = MIN(pond_reservoir(ig)*routing_area(ig,ib)/totarea(ig), & |
|---|
| 2078 | & pond_frac(ig)*routing_area(ig,ib)*k_litt(ig)*dt_routing/one_day) |
|---|
| 2079 | fast_flow(ig,ib) = fast_flow(ig,ib) - pond_inflow(ig,ib) |
|---|
| 2080 | ENDDO |
|---|
| 2081 | ENDDO |
|---|
| 2082 | ELSE |
|---|
| 2083 | DO ib=1,nbasmax |
|---|
| 2084 | DO ig=1,nbpt |
|---|
| 2085 | pond_inflow(ig,ib) = zero |
|---|
| 2086 | pond_drainage(ig,ib) = zero |
|---|
| 2087 | pond_reservoir(ig) = zero |
|---|
| 2088 | ENDDO |
|---|
| 2089 | ENDDO |
|---|
| 2090 | ENDIF |
|---|
| 2091 | |
|---|
| 2092 | !ym cette methode conserve les erreurs d'arrondie |
|---|
| 2093 | !ym mais n'est pas la plus efficace |
|---|
| 2094 | |
|---|
| 2095 | !- |
|---|
| 2096 | !- Compute the transport from one basin to another |
|---|
| 2097 | !- |
|---|
| 2098 | |
|---|
| 2099 | IF (is_root_prc) THEN |
|---|
| 2100 | ALLOCATE( fast_flow_g(nbp_glo, nbasmax), slow_flow_g(nbp_glo, nbasmax), & |
|---|
| 2101 | stream_flow_g(nbp_glo, nbasmax), stat=ier) |
|---|
| 2102 | ELSE |
|---|
| 2103 | ALLOCATE( fast_flow_g(1,1), slow_flow_g(1,1), & |
|---|
| 2104 | stream_flow_g(1, 1), stat=ier) |
|---|
| 2105 | ENDIF |
|---|
| 2106 | IF (ier /= 0) CALL ipslerr_p(3,'routing_flow','Pb in allocate for fast_flow_g','','') |
|---|
| 2107 | |
|---|
| 2108 | CALL gather(fast_flow,fast_flow_g) |
|---|
| 2109 | CALL gather(slow_flow,slow_flow_g) |
|---|
| 2110 | CALL gather(stream_flow,stream_flow_g) |
|---|
| 2111 | |
|---|
| 2112 | IF (is_root_prc) THEN |
|---|
| 2113 | DO ib=1,nbasmax |
|---|
| 2114 | DO ig=1,nbp_glo |
|---|
| 2115 | ! |
|---|
| 2116 | rtg = route_togrid_glo(ig,ib) |
|---|
| 2117 | rtb = route_tobasin_glo(ig,ib) |
|---|
| 2118 | transport_glo(rtg,rtb) = transport_glo(rtg,rtb) + fast_flow_g(ig,ib) + slow_flow_g(ig,ib) + & |
|---|
| 2119 | & stream_flow_g(ig,ib) |
|---|
| 2120 | ! |
|---|
| 2121 | ENDDO |
|---|
| 2122 | ENDDO |
|---|
| 2123 | ENDIF |
|---|
| 2124 | |
|---|
| 2125 | DEALLOCATE( fast_flow_g, slow_flow_g, stream_flow_g ) |
|---|
| 2126 | |
|---|
| 2127 | CALL scatter(transport_glo,transport) |
|---|
| 2128 | |
|---|
| 2129 | !- |
|---|
| 2130 | !- Do the floodings - First initialize |
|---|
| 2131 | !- |
|---|
| 2132 | return_swamp(:,:)=zero |
|---|
| 2133 | floods(:,:)=zero |
|---|
| 2134 | !- |
|---|
| 2135 | !> Over swamp areas, a fraction of water (return_swamp) is withdrawn from the river depending on the |
|---|
| 2136 | !> parameter swamp_cst. |
|---|
| 2137 | !> It will be transferred into soil moisture and thus does not return directly to the river. |
|---|
| 2138 | ! |
|---|
| 2139 | !- 1. Swamps: Take out water from the river to put it to the swamps |
|---|
| 2140 | !- |
|---|
| 2141 | ! |
|---|
| 2142 | IF ( doswamps ) THEN |
|---|
| 2143 | tobeflooded(:) = swamp(:) |
|---|
| 2144 | DO ib=1,nbasmax |
|---|
| 2145 | DO ig=1,nbpt |
|---|
| 2146 | potflood(ig,ib) = transport(ig,ib) |
|---|
| 2147 | ! |
|---|
| 2148 | IF ( tobeflooded(ig) > 0. .AND. potflood(ig,ib) > 0. .AND. floodtemp(ig) > tp_00 ) THEN |
|---|
| 2149 | ! |
|---|
| 2150 | IF (routing_area(ig,ib) > tobeflooded(ig)) THEN |
|---|
| 2151 | floodindex = tobeflooded(ig) / routing_area(ig,ib) |
|---|
| 2152 | ELSE |
|---|
| 2153 | floodindex = 1.0 |
|---|
| 2154 | ENDIF |
|---|
| 2155 | return_swamp(ig,ib) = swamp_cst * potflood(ig,ib) * floodindex |
|---|
| 2156 | ! |
|---|
| 2157 | tobeflooded(ig) = tobeflooded(ig) - routing_area(ig,ib) |
|---|
| 2158 | ! |
|---|
| 2159 | ENDIF |
|---|
| 2160 | ENDDO |
|---|
| 2161 | ENDDO |
|---|
| 2162 | ENDIF |
|---|
| 2163 | !- |
|---|
| 2164 | !- 2. Floodplains: Update the reservoir with the flux computed above. |
|---|
| 2165 | !- |
|---|
| 2166 | IF ( do_floodplains ) THEN |
|---|
| 2167 | DO ig=1,nbpt |
|---|
| 2168 | IF (floodplains(ig) .GT. min_sechiba .AND. floodtemp(ig) .GT. tp_00) THEN |
|---|
| 2169 | DO ib=1,nbasmax |
|---|
| 2170 | floods(ig,ib) = transport(ig,ib) - return_swamp(ig,ib) |
|---|
| 2171 | ENDDO |
|---|
| 2172 | ENDIF |
|---|
| 2173 | ENDDO |
|---|
| 2174 | ENDIF |
|---|
| 2175 | ! |
|---|
| 2176 | ! Update all reservoirs |
|---|
| 2177 | !> The slow and deep reservoir (slow_reservoir) collect the deep drainage whereas the |
|---|
| 2178 | !> fast_reservoir collects the computed surface runoff. Both discharge into a third reservoir |
|---|
| 2179 | !> (stream_reservoir) of the next sub-basin downstream. |
|---|
| 2180 | !> Water from the floodplains reservoir (flood_reservoir) flows also into the stream_reservoir of the next sub-basin downstream. |
|---|
| 2181 | !> Water that flows into the pond_reservoir is withdrawn from the fast_reservoir. |
|---|
| 2182 | ! |
|---|
| 2183 | DO ig=1,nbpt |
|---|
| 2184 | DO ib=1,nbasmax |
|---|
| 2185 | ! |
|---|
| 2186 | fast_reservoir(ig,ib) = fast_reservoir(ig,ib) + runoff(ig)*routing_area(ig,ib) - & |
|---|
| 2187 | & fast_flow(ig,ib) - pond_inflow(ig,ib) |
|---|
| 2188 | ! |
|---|
| 2189 | slow_reservoir(ig,ib) = slow_reservoir(ig,ib) + drainage(ig)*routing_area(ig,ib) - & |
|---|
| 2190 | & slow_flow(ig,ib) |
|---|
| 2191 | ! |
|---|
| 2192 | stream_reservoir(ig,ib) = stream_reservoir(ig,ib) + flood_flow(ig,ib) + transport(ig,ib) - & |
|---|
| 2193 | & stream_flow(ig,ib) - return_swamp(ig,ib) - floods(ig,ib) |
|---|
| 2194 | ! |
|---|
| 2195 | flood_reservoir(ig,ib) = flood_reservoir(ig,ib) + floods(ig,ib) - & |
|---|
| 2196 | & flood_flow(ig,ib) |
|---|
| 2197 | ! |
|---|
| 2198 | pond_reservoir(ig) = pond_reservoir(ig) + pond_inflow(ig,ib) - pond_drainage(ig,ib) |
|---|
| 2199 | ! |
|---|
| 2200 | IF ( flood_reservoir(ig,ib) .LT. zero ) THEN |
|---|
| 2201 | IF ( check_reservoir ) THEN |
|---|
| 2202 | WRITE(numout,*) "WARNING : negative flood reservoir at :", ig, ib, ". Problem is being corrected." |
|---|
| 2203 | WRITE(numout,*) "flood_reservoir, floods, flood_flow : ", flood_reservoir(ig,ib), floods(ig,ib), & |
|---|
| 2204 | & flood_flow(ig,ib) |
|---|
| 2205 | ENDIF |
|---|
| 2206 | stream_reservoir(ig,ib) = stream_reservoir(ig,ib) + flood_reservoir(ig,ib) |
|---|
| 2207 | flood_reservoir(ig,ib) = zero |
|---|
| 2208 | ENDIF |
|---|
| 2209 | ! |
|---|
| 2210 | IF ( stream_reservoir(ig,ib) .LT. zero ) THEN |
|---|
| 2211 | IF ( check_reservoir ) THEN |
|---|
| 2212 | WRITE(numout,*) "WARNING : negative stream reservoir at :", ig, ib, ". Problem is being corrected." |
|---|
| 2213 | WRITE(numout,*) "stream_reservoir, flood_flow, transport : ", stream_reservoir(ig,ib), flood_flow(ig,ib), & |
|---|
| 2214 | & transport(ig,ib) |
|---|
| 2215 | WRITE(numout,*) "stream_flow, return_swamp, floods :", stream_flow(ig,ib), return_swamp(ig,ib), floods(ig,ib) |
|---|
| 2216 | ENDIF |
|---|
| 2217 | fast_reservoir(ig,ib) = fast_reservoir(ig,ib) + stream_reservoir(ig,ib) |
|---|
| 2218 | stream_reservoir(ig,ib) = zero |
|---|
| 2219 | ENDIF |
|---|
| 2220 | ! |
|---|
| 2221 | IF ( fast_reservoir(ig,ib) .LT. zero ) THEN |
|---|
| 2222 | IF ( check_reservoir ) THEN |
|---|
| 2223 | WRITE(numout,*) "WARNING : negative fast reservoir at :", ig, ib, ". Problem is being corrected." |
|---|
| 2224 | WRITE(numout,*) "fast_reservoir, runoff, fast_flow, ponf_inflow : ", fast_reservoir(ig,ib), & |
|---|
| 2225 | &runoff(ig), fast_flow(ig,ib), pond_inflow(ig,ib) |
|---|
| 2226 | ENDIF |
|---|
| 2227 | slow_reservoir(ig,ib) = slow_reservoir(ig,ib) + fast_reservoir(ig,ib) |
|---|
| 2228 | fast_reservoir(ig,ib) = zero |
|---|
| 2229 | ENDIF |
|---|
| 2230 | |
|---|
| 2231 | IF ( slow_reservoir(ig,ib) .LT. - min_sechiba ) THEN |
|---|
| 2232 | IF ( check_reservoir ) THEN |
|---|
| 2233 | WRITE(numout,*) 'WARNING : There is a negative reservoir at :', ig, ib,lalo(ig,:) |
|---|
| 2234 | WRITE(numout,*) 'WARNING : slowr, slow_flow, drainage', & |
|---|
| 2235 | & slow_reservoir(ig,ib), slow_flow(ig,ib), drainage(ig) |
|---|
| 2236 | WRITE(numout,*) 'WARNING : pondr, pond_inflow, pond_drainage', & |
|---|
| 2237 | & pond_reservoir(ig), pond_inflow(ig,ib), pond_drainage(ig,ib) |
|---|
| 2238 | ENDIF |
|---|
| 2239 | CALL ipslerr_p(2, 'routing_flow', 'WARNING negative slow_reservoir.','','') |
|---|
| 2240 | ENDIF |
|---|
| 2241 | |
|---|
| 2242 | ENDDO |
|---|
| 2243 | ENDDO |
|---|
| 2244 | |
|---|
| 2245 | |
|---|
| 2246 | totflood(:) = zero |
|---|
| 2247 | DO ig=1,nbpt |
|---|
| 2248 | DO ib=1,nbasmax |
|---|
| 2249 | totflood(ig) = totflood(ig) + flood_reservoir(ig,ib) |
|---|
| 2250 | ENDDO |
|---|
| 2251 | ENDDO |
|---|
| 2252 | |
|---|
| 2253 | !- |
|---|
| 2254 | !- Computes the fraction of floodplains and ponds according to their volume |
|---|
| 2255 | !- |
|---|
| 2256 | IF (do_floodplains .OR. doponds) THEN |
|---|
| 2257 | flood_frac(:) = zero |
|---|
| 2258 | flood_height(:) = zero |
|---|
| 2259 | flood_frac_bas(:,:) = zero |
|---|
| 2260 | DO ig=1, nbpt |
|---|
| 2261 | IF (totflood(ig) .GT. min_sechiba) THEN |
|---|
| 2262 | ! We first compute the total fraction of the grid box which is flooded at optimum repartition |
|---|
| 2263 | flood_frac_pot = (totflood(ig) / (totarea(ig)*floodcri/(beta+un)))**(beta/(beta+un)) |
|---|
| 2264 | flood_frac(ig) = MIN(floodplains(ig) / totarea(ig), flood_frac_pot) |
|---|
| 2265 | ! Then we diagnose the fraction for each basin with the size of its flood_reservoir |
|---|
| 2266 | ! (flood_frac_bas may be > 1) |
|---|
| 2267 | DO ib=1,nbasmax |
|---|
| 2268 | IF (routing_area(ig,ib) .GT. min_sechiba) THEN |
|---|
| 2269 | flood_frac_bas(ig,ib) = flood_frac(ig) * & |
|---|
| 2270 | & (flood_reservoir(ig,ib) / totflood(ig)) / (routing_area(ig,ib) / totarea(ig)) |
|---|
| 2271 | ENDIF |
|---|
| 2272 | ENDDO |
|---|
| 2273 | ! We diagnose the maximum height of floodplain |
|---|
| 2274 | flood_height(ig) = (beta/(beta+1))*floodcri*(flood_frac(ig))**(un/beta) + totflood(ig)/(totarea(ig)*flood_frac(ig)) |
|---|
| 2275 | ! And finally add the pond surface |
|---|
| 2276 | pond_frac(ig) = MIN(un-flood_frac(ig), ((betap+1)*pond_reservoir(ig) / (pondcri*totarea(ig)))**(betap/(betap+1)) ) |
|---|
| 2277 | flood_frac(ig) = flood_frac(ig) + pond_frac(ig) |
|---|
| 2278 | ! |
|---|
| 2279 | ENDIF |
|---|
| 2280 | ENDDO |
|---|
| 2281 | ELSE |
|---|
| 2282 | flood_frac(:) = zero |
|---|
| 2283 | flood_height(:) = zero |
|---|
| 2284 | flood_frac_bas(:,:) = zero |
|---|
| 2285 | ENDIF |
|---|
| 2286 | |
|---|
| 2287 | !- |
|---|
| 2288 | !- Compute the total reinfiltration and returnflow to the grid box |
|---|
| 2289 | !> A term of returnflow is computed including the water from the swamps that does not return directly to the river |
|---|
| 2290 | !> but will be put into soil moisture (see hydrol module). |
|---|
| 2291 | !> A term of reinfiltration is computed including the water that reinfiltrated from the ponds and floodplains areas. |
|---|
| 2292 | !> It will be put into soil moisture (see hydrol module). |
|---|
| 2293 | !- |
|---|
| 2294 | IF (do_floodplains .OR. doswamps .OR. doponds) THEN |
|---|
| 2295 | returnflow(:) = zero |
|---|
| 2296 | reinfiltration(:) = zero |
|---|
| 2297 | ! |
|---|
| 2298 | DO ib=1,nbasmax |
|---|
| 2299 | DO ig=1,nbpt |
|---|
| 2300 | returnflow(ig) = returnflow(ig) + return_swamp(ig,ib) |
|---|
| 2301 | reinfiltration(ig) = reinfiltration(ig) + pond_drainage(ig,ib) + flood_drainage(ig,ib) |
|---|
| 2302 | ENDDO |
|---|
| 2303 | ENDDO |
|---|
| 2304 | ! |
|---|
| 2305 | DO ig=1,nbpt |
|---|
| 2306 | returnflow(ig) = returnflow(ig)/totarea(ig) |
|---|
| 2307 | reinfiltration(ig) = reinfiltration(ig)/totarea(ig) |
|---|
| 2308 | ENDDO |
|---|
| 2309 | ELSE |
|---|
| 2310 | returnflow(:) = zero |
|---|
| 2311 | reinfiltration(:) = zero |
|---|
| 2312 | ENDIF |
|---|
| 2313 | |
|---|
| 2314 | ! |
|---|
| 2315 | ! Compute the net irrigation requirement from Univ of Kassel |
|---|
| 2316 | ! |
|---|
| 2317 | ! This is a very low priority process and thus only applies if |
|---|
| 2318 | ! there is some water left in the reservoirs after all other things. |
|---|
| 2319 | ! |
|---|
| 2320 | !> The computation of the irrigation is performed here. |
|---|
| 2321 | !> * First step |
|---|
| 2322 | !> In a first time, the water requirements (irrig_netereq) by the crops for their optimal growth are calculated |
|---|
| 2323 | !> over each irrigated fraction (irrigated(ig)/totarea(ig)). It is the difference |
|---|
| 2324 | !> between the maximal water loss by the crops (transpot_mean) and the net water amount kept by the soil |
|---|
| 2325 | !> (precipitation and reinfiltration). Transpot_mean is computed in the routines enerbil and diffuco. It |
|---|
| 2326 | !> is derived from the effective transpiration parametrization under stress-free conditions, called potential transpiration. |
|---|
| 2327 | !> Crop_coef was used by a previous parametrization of irrigation in the code. Here, its value is equal to one. |
|---|
| 2328 | !> The crop coefficient was constant in space and time to represent a mean resistance of the vegetation to the potential evaporation. |
|---|
| 2329 | !> Now, the term crop_coef*Epot is substituted by transpot_mean (see Guimberteau et al., 2011). |
|---|
| 2330 | !> * Second step |
|---|
| 2331 | !> We compute irrigation needs in order to supply Irrig_netereq. Water for irrigation (irrig_actual) is withdrawn |
|---|
| 2332 | !> from the reservoirs. The amount of water is withdrawn in priority from the stream reservoir. |
|---|
| 2333 | !> If the irrigation requirement is higher than the water availability of the reservoir, water is withdrawn |
|---|
| 2334 | !> from the fast reservoir or, in the extreme case, from the slow reservoir. |
|---|
| 2335 | !> * Third step |
|---|
| 2336 | !> We compute a deficit in water for irrigation. If it is positive, irrigation (depending on water availibility in the reservoirs) |
|---|
| 2337 | !> has not supplied the crops requirements. |
|---|
| 2338 | ! |
|---|
| 2339 | IF ( do_irrigation ) THEN |
|---|
| 2340 | DO ig=1,nbpt |
|---|
| 2341 | ! |
|---|
| 2342 | IF ((vegtot(ig) .GT. min_sechiba) .AND. (humrel(ig) .LT. un-min_sechiba) .AND. & |
|---|
| 2343 | & (runoff(ig) .LT. min_sechiba) ) THEN |
|---|
| 2344 | |
|---|
| 2345 | ! irrig_netereq(ig) = (irrigated(ig) / totarea(ig) ) * MAX(zero, transpot_mean(ig) - & |
|---|
| 2346 | ! & (precip(ig)+reinfiltration(ig)) ) |
|---|
| 2347 | ! irrig_netereq(ig) = (irrigated(ig) / tot_vegfrac_crop(ig) ) * MAX(zero, transpot_agr(ig) - & |
|---|
| 2348 | ! & (precip(ig)+reinfiltration(ig)) ) |
|---|
| 2349 | irrig_netereq(ig) = zero |
|---|
| 2350 | DO jv=2,nvm |
|---|
| 2351 | IF ( veget_max(ig,jv) .GT. 0 ) THEN |
|---|
| 2352 | IF ( ok_LAIdev(jv) .AND. (vegstress(ig,jv) .LT. irrig_threshold(jv)) ) THEN |
|---|
| 2353 | IF (irrig_drip) THEN |
|---|
| 2354 | irrig_netereq(ig) = irrig_netereq(ig) + MIN( irrig_dosmax, ( irrigated(ig) * irrig_fulfill(jv) * & |
|---|
| 2355 | & MAX(zero, transpot(ig,jv) * (veget(ig,jv)/veget_max(ig,jv)) + & |
|---|
| 2356 | & evapot_corr(ig) * (1-veget(ig,jv)/veget_max(ig,jv)) - & |
|---|
| 2357 | & (precip(ig)+reinfiltration(ig)) ) ) ) * veget_max(ig,jv) |
|---|
| 2358 | ELSE !flooding |
|---|
| 2359 | irrig_netereq(ig) = irrig_netereq(ig) + MIN( irrig_dosmax, irrigated(ig) * & |
|---|
| 2360 | & MAX(zero, soil_deficit(ig,jv)) ) * veget_max(ig,jv) |
|---|
| 2361 | ENDIF |
|---|
| 2362 | ! irrigated must be the percentage of croplands irrigated |
|---|
| 2363 | ENDIF |
|---|
| 2364 | ENDIF |
|---|
| 2365 | ENDDO |
|---|
| 2366 | ! irrig_netereq is the needs (mm) over the entire grid |
|---|
| 2367 | |
|---|
| 2368 | ENDIF |
|---|
| 2369 | ! |
|---|
| 2370 | DO ib=1,nbasmax |
|---|
| 2371 | IF ( routing_area(ig,ib) .GT. 0 ) THEN |
|---|
| 2372 | |
|---|
| 2373 | irrig_needs(ig,ib) = irrig_netereq(ig) * routing_area(ig,ib) |
|---|
| 2374 | ! irrig_needs(ig,ib) = irrig_netereq(ig) * tot_vegfrac_crop(ig) * routing_area(ig,ib) |
|---|
| 2375 | |
|---|
| 2376 | irrig_actual(ig,ib) = MIN(irrig_needs(ig,ib),& |
|---|
| 2377 | & stream_reservoir(ig,ib) + fast_reservoir(ig,ib) + slow_reservoir(ig,ib) ) |
|---|
| 2378 | |
|---|
| 2379 | slow_reservoir(ig,ib) = MAX(zero, slow_reservoir(ig,ib) + & |
|---|
| 2380 | & MIN(zero, fast_reservoir(ig,ib) + MIN(zero, stream_reservoir(ig,ib)-irrig_actual(ig,ib)))) |
|---|
| 2381 | |
|---|
| 2382 | fast_reservoir(ig,ib) = MAX( zero, & |
|---|
| 2383 | & fast_reservoir(ig,ib) + MIN(zero, stream_reservoir(ig,ib)-irrig_actual(ig,ib))) |
|---|
| 2384 | |
|---|
| 2385 | stream_reservoir(ig,ib) = MAX(zero, stream_reservoir(ig,ib)-irrig_actual(ig,ib) ) |
|---|
| 2386 | |
|---|
| 2387 | irrig_deficit(ig,ib) = irrig_needs(ig,ib)-irrig_actual(ig,ib) |
|---|
| 2388 | |
|---|
| 2389 | ENDIF |
|---|
| 2390 | ENDDO |
|---|
| 2391 | ! |
|---|
| 2392 | ! Check if we cannot find the missing water in another basin of the same grid (stream reservoir only). |
|---|
| 2393 | ! If we find that then we create some adduction from that subbasin to the one where we need it for |
|---|
| 2394 | ! irrigation. |
|---|
| 2395 | ! |
|---|
| 2396 | !> If crops water requirements have not been supplied (irrig_deficit>0), we check if we cannot find the missing water |
|---|
| 2397 | !> in another basin of the same grid. If there is water in the stream reservoir of this subbasin, we create some adduction |
|---|
| 2398 | !> from that subbasin to the one where we need it for irrigation. |
|---|
| 2399 | !> |
|---|
| 2400 | DO ib=1,nbasmax |
|---|
| 2401 | |
|---|
| 2402 | stream_tot = SUM(stream_reservoir(ig,:)) |
|---|
| 2403 | |
|---|
| 2404 | DO WHILE ( irrig_deficit(ig,ib) > min_sechiba .AND. stream_tot > min_sechiba) |
|---|
| 2405 | |
|---|
| 2406 | fi = MAXLOC(stream_reservoir(ig,:)) |
|---|
| 2407 | ib2 = fi(1) |
|---|
| 2408 | |
|---|
| 2409 | irrig_adduct(ig,ib) = MIN(irrig_deficit(ig,ib), stream_reservoir(ig,ib2)) |
|---|
| 2410 | stream_reservoir(ig,ib2) = stream_reservoir(ig,ib2)-irrig_adduct(ig,ib) |
|---|
| 2411 | irrig_deficit(ig,ib) = irrig_deficit(ig,ib)-irrig_adduct(ig,ib) |
|---|
| 2412 | |
|---|
| 2413 | stream_tot = SUM(stream_reservoir(ig,:)) |
|---|
| 2414 | |
|---|
| 2415 | ENDDO |
|---|
| 2416 | |
|---|
| 2417 | ENDDO |
|---|
| 2418 | ! |
|---|
| 2419 | ENDDO |
|---|
| 2420 | ! |
|---|
| 2421 | ! If we are at higher resolution we might need to look at neighboring grid boxes to find the streams |
|---|
| 2422 | ! which can feed irrigation |
|---|
| 2423 | ! |
|---|
| 2424 | !> At higher resolution (grid box smaller than 100x100km), we can import water from neighboring grid boxes |
|---|
| 2425 | !> to the one where we need it for irrigation. |
|---|
| 2426 | ! |
|---|
| 2427 | IF (is_root_prc) THEN |
|---|
| 2428 | ALLOCATE(irrig_deficit_glo(nbp_glo, nbasmax), stream_reservoir_glo(nbp_glo, nbasmax), & |
|---|
| 2429 | & irrig_adduct_glo(nbp_glo, nbasmax), stat=ier) |
|---|
| 2430 | ELSE |
|---|
| 2431 | ALLOCATE(irrig_deficit_glo(0, 0), stream_reservoir_glo(0, 0), & |
|---|
| 2432 | & irrig_adduct_glo(0, 0), stat=ier) |
|---|
| 2433 | ENDIF |
|---|
| 2434 | IF (ier /= 0) CALL ipslerr_p(3,'routing_flow','Pb in allocate for irrig_deficit_glo, stream_reservoir_glo,...','','') |
|---|
| 2435 | |
|---|
| 2436 | CALL gather(irrig_deficit, irrig_deficit_glo) |
|---|
| 2437 | CALL gather(stream_reservoir, stream_reservoir_glo) |
|---|
| 2438 | CALL gather(irrig_adduct, irrig_adduct_glo) |
|---|
| 2439 | |
|---|
| 2440 | IF (is_root_prc) THEN |
|---|
| 2441 | ! |
|---|
| 2442 | DO ig=1,nbp_glo |
|---|
| 2443 | ! Only work if the grid box is smaller than 100x100km. Else the piplines we build |
|---|
| 2444 | ! here would be too long to be reasonable. |
|---|
| 2445 | IF ( resolution_g(ig,1) < 100000. .AND. resolution_g(ig,2) < 100000. ) THEN |
|---|
| 2446 | DO ib=1,nbasmax |
|---|
| 2447 | ! |
|---|
| 2448 | IF ( irrig_deficit_glo(ig,ib) > min_sechiba ) THEN |
|---|
| 2449 | ! |
|---|
| 2450 | streams_around(:,:) = zero |
|---|
| 2451 | ! |
|---|
| 2452 | DO in=1,NbNeighb |
|---|
| 2453 | ig2 = neighbours_g(ig,in) |
|---|
| 2454 | IF (ig2 .GT. 0 ) THEN |
|---|
| 2455 | streams_around(in,:) = stream_reservoir_glo(ig2,:) |
|---|
| 2456 | igrd(in) = ig2 |
|---|
| 2457 | ENDIF |
|---|
| 2458 | ENDDO |
|---|
| 2459 | ! |
|---|
| 2460 | IF ( MAXVAL(streams_around) .GT. zero ) THEN |
|---|
| 2461 | ! |
|---|
| 2462 | ff=MAXLOC(streams_around) |
|---|
| 2463 | ig2=igrd(ff(1)) |
|---|
| 2464 | ib2=ff(2) |
|---|
| 2465 | ! |
|---|
| 2466 | IF ( routing_area_glo(ig2,ib2) .GT. 0 .AND. stream_reservoir_glo(ig2,ib2) > zero ) THEN |
|---|
| 2467 | adduction = MIN(irrig_deficit_glo(ig,ib), stream_reservoir_glo(ig2,ib2)) |
|---|
| 2468 | stream_reservoir_glo(ig2,ib2) = stream_reservoir_glo(ig2,ib2) - adduction |
|---|
| 2469 | irrig_deficit_glo(ig,ib) = irrig_deficit_glo(ig,ib) - adduction |
|---|
| 2470 | irrig_adduct_glo(ig,ib) = irrig_adduct_glo(ig,ib) + adduction |
|---|
| 2471 | ENDIF |
|---|
| 2472 | ! |
|---|
| 2473 | ENDIF |
|---|
| 2474 | ! |
|---|
| 2475 | ENDIF |
|---|
| 2476 | ! |
|---|
| 2477 | ENDDO |
|---|
| 2478 | ENDIF |
|---|
| 2479 | ENDDO |
|---|
| 2480 | ! |
|---|
| 2481 | ENDIF |
|---|
| 2482 | ! |
|---|
| 2483 | |
|---|
| 2484 | CALL scatter(irrig_deficit_glo, irrig_deficit) |
|---|
| 2485 | CALL scatter(stream_reservoir_glo, stream_reservoir) |
|---|
| 2486 | CALL scatter(irrig_adduct_glo, irrig_adduct) |
|---|
| 2487 | |
|---|
| 2488 | DEALLOCATE(irrig_deficit_glo, stream_reservoir_glo, irrig_adduct_glo) |
|---|
| 2489 | |
|---|
| 2490 | ENDIF |
|---|
| 2491 | |
|---|
| 2492 | !! Calculate the net water flow to each routing reservoir (in kg/dt) |
|---|
| 2493 | !! to further diagnose the corresponding water budget residu |
|---|
| 2494 | !! in routing_main |
|---|
| 2495 | |
|---|
| 2496 | netflow_fast_diag(:) = zero |
|---|
| 2497 | netflow_slow_diag(:) = zero |
|---|
| 2498 | netflow_stream_diag(:) = zero |
|---|
| 2499 | |
|---|
| 2500 | DO ib=1,nbasmax |
|---|
| 2501 | DO ig=1,nbpt |
|---|
| 2502 | netflow_fast_diag(ig) = netflow_fast_diag(ig) + runoff(ig)*routing_area(ig,ib) & |
|---|
| 2503 | - fast_flow(ig,ib) - pond_inflow(ig,ib) |
|---|
| 2504 | netflow_slow_diag(ig) = netflow_slow_diag(ig) + drainage(ig)*routing_area(ig,ib) & |
|---|
| 2505 | - slow_flow(ig,ib) |
|---|
| 2506 | netflow_stream_diag(ig) = netflow_stream_diag(ig) + flood_flow(ig,ib) + transport(ig,ib) & |
|---|
| 2507 | - stream_flow(ig,ib) - return_swamp(ig,ib) - floods(ig,ib) |
|---|
| 2508 | ENDDO |
|---|
| 2509 | ENDDO |
|---|
| 2510 | |
|---|
| 2511 | !! Grid cell averaging |
|---|
| 2512 | DO ig=1,nbpt |
|---|
| 2513 | netflow_fast_diag(ig) = netflow_fast_diag(ig)/totarea(ig) |
|---|
| 2514 | netflow_slow_diag(ig) = netflow_slow_diag(ig)/totarea(ig) |
|---|
| 2515 | netflow_stream_diag(ig) = netflow_stream_diag(ig)/totarea(ig) |
|---|
| 2516 | ENDDO |
|---|
| 2517 | |
|---|
| 2518 | ! |
|---|
| 2519 | ! |
|---|
| 2520 | ! Compute the fluxes which leave the routing scheme |
|---|
| 2521 | ! |
|---|
| 2522 | ! Lakeinflow is in Kg/dt |
|---|
| 2523 | ! returnflow is in Kg/m^2/dt |
|---|
| 2524 | ! |
|---|
| 2525 | hydrographs(:) = zero |
|---|
| 2526 | slowflow_diag(:) = zero |
|---|
| 2527 | fast_diag(:) = zero |
|---|
| 2528 | slow_diag(:) = zero |
|---|
| 2529 | stream_diag(:) = zero |
|---|
| 2530 | flood_diag(:) = zero |
|---|
| 2531 | pond_diag(:) = zero |
|---|
| 2532 | irrigation(:) = zero |
|---|
| 2533 | ! |
|---|
| 2534 | ! |
|---|
| 2535 | DO ib=1,nbasmax |
|---|
| 2536 | ! |
|---|
| 2537 | DO ig=1,nbpt |
|---|
| 2538 | IF (hydrodiag(ig,ib) > 0 ) THEN |
|---|
| 2539 | hydrographs(ig) = hydrographs(ig) + fast_flow(ig,ib) + slow_flow(ig,ib) + & |
|---|
| 2540 | & stream_flow(ig,ib) |
|---|
| 2541 | slowflow_diag(ig) = slowflow_diag(ig) + slow_flow(ig,ib) |
|---|
| 2542 | ENDIF |
|---|
| 2543 | fast_diag(ig) = fast_diag(ig) + fast_reservoir(ig,ib) |
|---|
| 2544 | slow_diag(ig) = slow_diag(ig) + slow_reservoir(ig,ib) |
|---|
| 2545 | stream_diag(ig) = stream_diag(ig) + stream_reservoir(ig,ib) |
|---|
| 2546 | flood_diag(ig) = flood_diag(ig) + flood_reservoir(ig,ib) |
|---|
| 2547 | IF (do_fullirr) THEN |
|---|
| 2548 | irrigation(ig) = irrigation(ig) + irrig_needs(ig,ib) |
|---|
| 2549 | ! when fully irrigated, we interrupt the water balance, and bring |
|---|
| 2550 | ! magic water |
|---|
| 2551 | ELSE |
|---|
| 2552 | irrigation (ig) = irrigation (ig) + irrig_actual(ig,ib) + irrig_adduct(ig,ib) |
|---|
| 2553 | ENDIF |
|---|
| 2554 | ENDDO |
|---|
| 2555 | ENDDO |
|---|
| 2556 | ! |
|---|
| 2557 | DO ig=1,nbpt |
|---|
| 2558 | fast_diag(ig) = fast_diag(ig)/totarea(ig) |
|---|
| 2559 | slow_diag(ig) = slow_diag(ig)/totarea(ig) |
|---|
| 2560 | stream_diag(ig) = stream_diag(ig)/totarea(ig) |
|---|
| 2561 | flood_diag(ig) = flood_diag(ig)/totarea(ig) |
|---|
| 2562 | pond_diag(ig) = pond_reservoir(ig)/totarea(ig) |
|---|
| 2563 | ! |
|---|
| 2564 | irrigation(ig) = irrigation(ig)/totarea(ig) |
|---|
| 2565 | ! |
|---|
| 2566 | ! The three output types for the routing : endoheric basins,, rivers and |
|---|
| 2567 | ! diffuse coastal flow. |
|---|
| 2568 | ! |
|---|
| 2569 | lakeinflow(ig) = transport(ig,nbasmax+1) |
|---|
| 2570 | coastalflow(ig) = transport(ig,nbasmax+2) |
|---|
| 2571 | riverflow(ig) = transport(ig,nbasmax+3) |
|---|
| 2572 | ! |
|---|
| 2573 | ENDDO |
|---|
| 2574 | ! |
|---|
| 2575 | flood_res = flood_diag + pond_diag |
|---|
| 2576 | |
|---|
| 2577 | |
|---|
| 2578 | !! Remove water from lake reservoir if it exceeds the maximum limit and distribute it |
|---|
| 2579 | !! uniformly over all possible the coastflow gridcells |
|---|
| 2580 | |
|---|
| 2581 | ! Calculate lake_overflow and remove it from lake_reservoir |
|---|
| 2582 | DO ig=1,nbpt |
|---|
| 2583 | lake_overflow(ig) = MAX(0., lake_reservoir(ig) - max_lake_reservoir*totarea(ig)) |
|---|
| 2584 | lake_reservoir(ig) = lake_reservoir(ig) - lake_overflow(ig) |
|---|
| 2585 | END DO |
|---|
| 2586 | ! Transform lake_overflow from kg/grid-cell/dt_routing into kg/m^2/s |
|---|
| 2587 | CALL xios_orchidee_send_field("lake_overflow",lake_overflow(:)/totarea(:)/dt_routing) |
|---|
| 2588 | |
|---|
| 2589 | ! Calculate the sum of the lake_overflow and distribute it uniformly over all gridboxes |
|---|
| 2590 | CALL gather(lake_overflow,lake_overflow_g) |
|---|
| 2591 | IF (is_root_prc) THEN |
|---|
| 2592 | total_lake_overflow=SUM(lake_overflow_g) |
|---|
| 2593 | END IF |
|---|
| 2594 | CALL bcast(total_lake_overflow) |
|---|
| 2595 | |
|---|
| 2596 | ! Distribute the lake_overflow uniformly over all coastal gridcells |
|---|
| 2597 | ! lake_overflow_coast is only calculated to be used as diagnostics if needed |
|---|
| 2598 | DO ig=1,nbpt |
|---|
| 2599 | coastalflow(ig) = coastalflow(ig) + total_lake_overflow/nb_coast_gridcells * mask_coast(ig) |
|---|
| 2600 | lake_overflow_coast(ig) = total_lake_overflow/nb_coast_gridcells * mask_coast(ig) |
|---|
| 2601 | END DO |
|---|
| 2602 | ! Transform from kg/grid-cell/dt_routing into m^3/grid-cell/s to match output unit of coastalflow |
|---|
| 2603 | CALL xios_orchidee_send_field("lake_overflow_coast",lake_overflow_coast/mille/dt_routing) |
|---|
| 2604 | |
|---|
| 2605 | |
|---|
| 2606 | END SUBROUTINE routing_flow |
|---|
| 2607 | ! |
|---|
| 2608 | !! ================================================================================================================================ |
|---|
| 2609 | !! SUBROUTINE : routing_lake |
|---|
| 2610 | !! |
|---|
| 2611 | !>\BRIEF : This subroutine stores water in lakes so that it does not cycle through the runoff. |
|---|
| 2612 | !! For the moment it only works for endoheric lakes but I can be extended in the future. |
|---|
| 2613 | !! |
|---|
| 2614 | !! DESCRIPTION (definitions, functional, design, flags): The return flow to the soil moisture reservoir |
|---|
| 2615 | !! is based on a maximum lake evaporation rate (maxevap_lake). \n |
|---|
| 2616 | !! |
|---|
| 2617 | !! RECENT CHANGE(S): None |
|---|
| 2618 | !! |
|---|
| 2619 | !! MAIN OUTPUT VARIABLE(S): |
|---|
| 2620 | !! |
|---|
| 2621 | !! REFERENCES : None |
|---|
| 2622 | !! |
|---|
| 2623 | !! FLOWCHART :None |
|---|
| 2624 | !! \n |
|---|
| 2625 | !_ ================================================================================================================================ |
|---|
| 2626 | |
|---|
| 2627 | SUBROUTINE routing_lake(nbpt, dt_routing, lakeinflow, humrel, return_lakes) |
|---|
| 2628 | ! |
|---|
| 2629 | IMPLICIT NONE |
|---|
| 2630 | ! |
|---|
| 2631 | !! INPUT VARIABLES |
|---|
| 2632 | INTEGER(i_std), INTENT(in) :: nbpt !! Domain size (unitless) |
|---|
| 2633 | REAL(r_std), INTENT (in) :: dt_routing !! Routing time step (s) |
|---|
| 2634 | REAL(r_std), INTENT(out) :: lakeinflow(nbpt) !! Water inflow to the lakes (kg/dt) |
|---|
| 2635 | REAL(r_std), INTENT(in) :: humrel(nbpt) !! Soil moisture stress, root extraction potential (unitless) |
|---|
| 2636 | ! |
|---|
| 2637 | !! OUTPUT VARIABLES |
|---|
| 2638 | REAL(r_std), INTENT(out) :: return_lakes(nbpt) !! Water from lakes flowing back into soil moisture (kg/m^2/dt) |
|---|
| 2639 | ! |
|---|
| 2640 | !! LOCAL VARIABLES |
|---|
| 2641 | INTEGER(i_std) :: ig !! Indices (unitless) |
|---|
| 2642 | REAL(r_std) :: refill !! |
|---|
| 2643 | REAL(r_std) :: total_area !! Sum of all the surfaces of the basins (m^2) |
|---|
| 2644 | |
|---|
| 2645 | !_ ================================================================================================================================ |
|---|
| 2646 | ! |
|---|
| 2647 | ! |
|---|
| 2648 | DO ig=1,nbpt |
|---|
| 2649 | ! |
|---|
| 2650 | total_area = SUM(routing_area(ig,:)) |
|---|
| 2651 | ! |
|---|
| 2652 | lake_reservoir(ig) = lake_reservoir(ig) + lakeinflow(ig) |
|---|
| 2653 | |
|---|
| 2654 | IF ( doswamps ) THEN |
|---|
| 2655 | ! Calculate a return flow that will be extracted from the lake reservoir and reinserted in the soil in hydrol |
|---|
| 2656 | ! Uptake in Kg/dt |
|---|
| 2657 | refill = MAX(zero, maxevap_lake * (un - humrel(ig)) * dt_routing * total_area) |
|---|
| 2658 | return_lakes(ig) = MIN(refill, lake_reservoir(ig)) |
|---|
| 2659 | lake_reservoir(ig) = lake_reservoir(ig) - return_lakes(ig) |
|---|
| 2660 | ! Return in Kg/m^2/dt |
|---|
| 2661 | return_lakes(ig) = return_lakes(ig)/total_area |
|---|
| 2662 | ELSE |
|---|
| 2663 | return_lakes(ig) = zero |
|---|
| 2664 | ENDIF |
|---|
| 2665 | |
|---|
| 2666 | ! This is the volume of the lake scaled to the entire grid. |
|---|
| 2667 | ! It would be better to scale it to the size of the lake |
|---|
| 2668 | ! but this information is not yet available. |
|---|
| 2669 | lake_diag(ig) = lake_reservoir(ig)/total_area |
|---|
| 2670 | |
|---|
| 2671 | lakeinflow(ig) = lakeinflow(ig)/total_area |
|---|
| 2672 | |
|---|
| 2673 | ENDDO |
|---|
| 2674 | ! |
|---|
| 2675 | END SUBROUTINE routing_lake |
|---|
| 2676 | ! |
|---|
| 2677 | |
|---|
| 2678 | !! ================================================================================================================================ |
|---|
| 2679 | !! SUBROUTINE : routing_diagnostic_p |
|---|
| 2680 | !! |
|---|
| 2681 | !>\BRIEF This parallelized subroutine gives a diagnostic of the basins used |
|---|
| 2682 | !! |
|---|
| 2683 | !! DESCRIPTION (definitions, functional, design, flags) : None |
|---|
| 2684 | !! |
|---|
| 2685 | !! RECENT CHANGE(S): None |
|---|
| 2686 | !! |
|---|
| 2687 | !! MAIN OUTPUT VARIABLE(S): |
|---|
| 2688 | !! |
|---|
| 2689 | !! REFERENCES : None |
|---|
| 2690 | !! |
|---|
| 2691 | !! FLOWCHART : None |
|---|
| 2692 | !! \n |
|---|
| 2693 | !_ ================================================================================================================================ |
|---|
| 2694 | |
|---|
| 2695 | SUBROUTINE routing_diagnostic_p(nbpt, index, lalo, resolution, contfrac, hist_id, hist2_id) |
|---|
| 2696 | ! |
|---|
| 2697 | IMPLICIT NONE |
|---|
| 2698 | |
|---|
| 2699 | !! INPUT VARIABLES |
|---|
| 2700 | INTEGER(i_std), INTENT(in) :: nbpt !! Domain size (unitless) |
|---|
| 2701 | INTEGER(i_std), INTENT(in) :: index(nbpt) !! Indices of the points on the map (unitless) |
|---|
| 2702 | REAL(r_std), INTENT(in) :: lalo(nbpt,2) !! Vector of latitude and longitudes (beware of the order !) |
|---|
| 2703 | REAL(r_std), INTENT(in) :: resolution(nbpt,2) !! The size of each grid box in X and Y (m) |
|---|
| 2704 | REAL(r_std), INTENT(in) :: contfrac(nbpt) !! Fraction of land in each grid box (unitless;0-1) |
|---|
| 2705 | INTEGER(i_std),INTENT (in) :: hist_id !! Access to history file (unitless) |
|---|
| 2706 | INTEGER(i_std),INTENT (in) :: hist2_id !! Access to history file 2 (unitless) |
|---|
| 2707 | ! |
|---|
| 2708 | !! LOCAL VARIABLES |
|---|
| 2709 | REAL(r_std), DIMENSION(nbpt) :: nbrivers !! Number of rivers in the grid (unitless) |
|---|
| 2710 | REAL(r_std), DIMENSION(nbpt) :: basinmap !! Map of basins (unitless) |
|---|
| 2711 | REAL(r_std), DIMENSION(nbp_glo) :: nbrivers_g !! Number of rivers in the grid (unitless) |
|---|
| 2712 | REAL(r_std), DIMENSION(nbp_glo) :: basinmap_g !! Map of basins (unitless) |
|---|
| 2713 | |
|---|
| 2714 | !_ ================================================================================================================================ |
|---|
| 2715 | routing_area => routing_area_glo |
|---|
| 2716 | topo_resid => topo_resid_glo |
|---|
| 2717 | route_togrid => route_togrid_glo |
|---|
| 2718 | route_tobasin => route_tobasin_glo |
|---|
| 2719 | route_nbintobas => route_nbintobas_glo |
|---|
| 2720 | global_basinid => global_basinid_glo |
|---|
| 2721 | hydrodiag=>hydrodiag_glo |
|---|
| 2722 | hydroupbasin=>hydroupbasin_glo |
|---|
| 2723 | |
|---|
| 2724 | IF (is_root_prc) CALL routing_diagnostic(nbp_glo, index_g, lalo_g, resolution_g, contfrac_g, nbrivers_g,basinmap_g) |
|---|
| 2725 | |
|---|
| 2726 | routing_area => routing_area_loc |
|---|
| 2727 | topo_resid => topo_resid_loc |
|---|
| 2728 | route_togrid => route_togrid_loc |
|---|
| 2729 | route_tobasin => route_tobasin_loc |
|---|
| 2730 | route_nbintobas => route_nbintobas_loc |
|---|
| 2731 | global_basinid => global_basinid_loc |
|---|
| 2732 | hydrodiag=>hydrodiag_loc |
|---|
| 2733 | hydroupbasin=>hydroupbasin_loc |
|---|
| 2734 | |
|---|
| 2735 | CALL scatter(nbrivers_g,nbrivers) |
|---|
| 2736 | CALL scatter(basinmap_g,basinmap) |
|---|
| 2737 | CALL scatter(hydrodiag_glo,hydrodiag_loc) |
|---|
| 2738 | CALL scatter(hydroupbasin_glo,hydroupbasin_loc) |
|---|
| 2739 | |
|---|
| 2740 | CALL xios_orchidee_send_field("basinmap",basinmap) |
|---|
| 2741 | CALL xios_orchidee_send_field("nbrivers",nbrivers) |
|---|
| 2742 | |
|---|
| 2743 | IF ( .NOT. almaoutput ) THEN |
|---|
| 2744 | CALL histwrite_p(hist_id, 'basinmap', 1, basinmap, nbpt, index) |
|---|
| 2745 | CALL histwrite_p(hist_id, 'nbrivers', 1, nbrivers, nbpt, index) |
|---|
| 2746 | ELSE |
|---|
| 2747 | ENDIF |
|---|
| 2748 | IF ( hist2_id > 0 ) THEN |
|---|
| 2749 | IF ( .NOT. almaoutput ) THEN |
|---|
| 2750 | CALL histwrite_p(hist2_id, 'basinmap', 1, basinmap, nbpt, index) |
|---|
| 2751 | CALL histwrite_p(hist2_id, 'nbrivers', 1, nbrivers, nbpt, index) |
|---|
| 2752 | ELSE |
|---|
| 2753 | ENDIF |
|---|
| 2754 | ENDIF |
|---|
| 2755 | |
|---|
| 2756 | |
|---|
| 2757 | END SUBROUTINE routing_diagnostic_p |
|---|
| 2758 | |
|---|
| 2759 | !! ================================================================================================================================ |
|---|
| 2760 | !! SUBROUTINE : routing_diagnostic |
|---|
| 2761 | !! |
|---|
| 2762 | !>\BRIEF This non-parallelized subroutine gives a diagnostic of the basins used. This produces some information |
|---|
| 2763 | !! on the rivers which are being diagnosed. |
|---|
| 2764 | !! |
|---|
| 2765 | !! DESCRIPTION (definitions, functional, design, flags) : As not all rivers can be monitored in the model, we will only |
|---|
| 2766 | !! archive num_largest rivers. In this routine we will diagnose the num_largest largest rivers and print to the standard |
|---|
| 2767 | !! output the names of these basins and their area. The list of names of these largest rivers are taken from a list coded in the |
|---|
| 2768 | !! routine routing_names. As this standard output is not sufficient, we will also write it to a netCDF file with the routine |
|---|
| 2769 | !! routing_diagncfile. It is important to keep for diagnostic the fraction of the largest basins in each grid box and keep information |
|---|
| 2770 | !! how they are linked one to the other. |
|---|
| 2771 | !! |
|---|
| 2772 | !! RECENT CHANGE(S): None |
|---|
| 2773 | !! |
|---|
| 2774 | !! MAIN OUTPUT VARIABLE(S): No output variables. |
|---|
| 2775 | !! |
|---|
| 2776 | !! REFERENCES : None |
|---|
| 2777 | !! |
|---|
| 2778 | !! FLOWCHART :None |
|---|
| 2779 | !! \n |
|---|
| 2780 | !_ ================================================================================================================================ |
|---|
| 2781 | |
|---|
| 2782 | SUBROUTINE routing_diagnostic(nbpt, l_index, lalo, resolution, contfrac, nbrivers, basinmap) |
|---|
| 2783 | ! |
|---|
| 2784 | IMPLICIT NONE |
|---|
| 2785 | ! |
|---|
| 2786 | !! INPUT VARIABLES |
|---|
| 2787 | INTEGER(i_std), INTENT(in) :: nbpt !! Domain size (unitless) |
|---|
| 2788 | INTEGER(i_std), INTENT(in) :: l_index(nbpt) !! Indices of the points on the map (unitless) |
|---|
| 2789 | REAL(r_std), INTENT(in) :: lalo(nbpt,2) !! Vector of latitude and longitudes (beware of the order !) |
|---|
| 2790 | REAL(r_std), INTENT(in) :: resolution(nbpt,2) !! The size of each grid box in X and Y (m) |
|---|
| 2791 | REAL(r_std), INTENT(in) :: contfrac(nbpt) !! Fraction of land in each grid box (unitless;0-1) |
|---|
| 2792 | ! |
|---|
| 2793 | !! OUTPUT VARIABLES |
|---|
| 2794 | REAL(r_std), DIMENSION(nbpt), INTENT(out) :: nbrivers !! Number of rivers in the grid (unitless) |
|---|
| 2795 | REAL(r_std), DIMENSION(nbpt), INTENT(out) :: basinmap !! Map of basins (unitless) |
|---|
| 2796 | ! |
|---|
| 2797 | !! LOCAL VARIABLES |
|---|
| 2798 | INTEGER(i_std), DIMENSION(nbpt,nbasmax) :: outids !! IDs of river to which this basin contributes (unitless) |
|---|
| 2799 | INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:) :: pts !! List the points belonging to the basin (unitless) |
|---|
| 2800 | INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:) :: ptbas !! List the basin number for this point (unitless) |
|---|
| 2801 | INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:) :: outpt !! Outflow point for each basin (unitless) |
|---|
| 2802 | INTEGER(i_std), ALLOCATABLE, DIMENSION(:) :: nb_pts !! Number of points in the basin (unitless) |
|---|
| 2803 | REAL(r_std), ALLOCATABLE, DIMENSION(:) :: totarea !! Total area of basin (m^2) |
|---|
| 2804 | REAL(r_std), ALLOCATABLE, DIMENSION(:) :: tmparea !! |
|---|
| 2805 | INTEGER(i_std), ALLOCATABLE, DIMENSION(:) :: topids !! The IDs of the first num_largest basins (unitless) |
|---|
| 2806 | CHARACTER(LEN=25), ALLOCATABLE, DIMENSION(:) :: basin_names !! Names of the rivers (unitless) |
|---|
| 2807 | CHARACTER(LEN=25) :: name_str !! |
|---|
| 2808 | ! |
|---|
| 2809 | LOGICAL :: river_file !! Choose to write a description of the rivers (true/false) |
|---|
| 2810 | CHARACTER(LEN=80) :: river_file_name !! Filename in which we write the description of the rivers (unitless) |
|---|
| 2811 | ! |
|---|
| 2812 | CHARACTER(LEN=25), ALLOCATABLE, DIMENSION(:) :: sorted_names !! |
|---|
| 2813 | INTEGER(i_std), ALLOCATABLE, DIMENSION(:) :: streams_nb !! Number of streams in basin (unitless) |
|---|
| 2814 | INTEGER(i_std), ALLOCATABLE, DIMENSION(:) :: streams_avehops !! Average number of hops in streams (unitless) |
|---|
| 2815 | INTEGER(i_std), ALLOCATABLE, DIMENSION(:) :: streams_minhops !! Minimum number of hops in streams (unitless) |
|---|
| 2816 | INTEGER(i_std), ALLOCATABLE, DIMENSION(:) :: streams_maxhops !! Minimum number of hops in streams (unitless) |
|---|
| 2817 | REAL(r_std), ALLOCATABLE, DIMENSION(:) :: streams_resid !! Average residence time |
|---|
| 2818 | ! |
|---|
| 2819 | REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: lbasin_area !! |
|---|
| 2820 | REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: lbasin_uparea !! |
|---|
| 2821 | INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:) :: lrivercode !! |
|---|
| 2822 | ! |
|---|
| 2823 | INTEGER(i_std) :: ig, ib, og, ob, ign, ibn, ff(1), ic, icc, nb_small, idbas, slen, ii !! Indices (unitless) |
|---|
| 2824 | INTEGER(i_std) :: ier !! Error handling |
|---|
| 2825 | CHARACTER(LEN=1) :: nn !! |
|---|
| 2826 | INTEGER(i_std) :: name_found !! |
|---|
| 2827 | ! |
|---|
| 2828 | REAL(r_std) :: averesid !! |
|---|
| 2829 | REAL(r_std), DIMENSION(nbasmax) :: tmpbas !! |
|---|
| 2830 | REAL(r_std), DIMENSION(nbpt,nbasmax) :: areaupbasin !! |
|---|
| 2831 | INTEGER(i_std), ALLOCATABLE, DIMENSION(:) :: sortedrivs !! |
|---|
| 2832 | ! |
|---|
| 2833 | ! Variables for the river coding |
|---|
| 2834 | ! |
|---|
| 2835 | INTEGER(i_std) :: longest_river !! |
|---|
| 2836 | INTEGER(i_std) :: nbmax !! |
|---|
| 2837 | INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:) :: allstreams !! |
|---|
| 2838 | REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: upstreamchange !! |
|---|
| 2839 | INTEGER(i_std), ALLOCATABLE, DIMENSION(:) :: tstreams, tslen, tpts, tptbas, tcode !! |
|---|
| 2840 | REAL(r_std), ALLOCATABLE, DIMENSION(:) :: tuparea !! |
|---|
| 2841 | REAL(r_std), ALLOCATABLE, DIMENSION(:) :: tupstreamchange !! |
|---|
| 2842 | ! |
|---|
| 2843 | LOGICAL :: err_nbpt_grid_basin !! (true/false) |
|---|
| 2844 | LOGICAL :: err_basin_number !! (true/false) |
|---|
| 2845 | |
|---|
| 2846 | !_ ================================================================================================================================ |
|---|
| 2847 | ! |
|---|
| 2848 | ! |
|---|
| 2849 | ALLOCATE(pts(num_largest, nbpt), stat=ier) |
|---|
| 2850 | IF (ier /= 0) CALL ipslerr_p(3,'routing_diagnostic','Pb in allocate for pts','','') |
|---|
| 2851 | |
|---|
| 2852 | ALLOCATE(ptbas(num_largest, nbpt), stat=ier) |
|---|
| 2853 | IF (ier /= 0) CALL ipslerr_p(3,'routing_diagnostic','Pb in allocate for ptbas','','') |
|---|
| 2854 | |
|---|
| 2855 | ALLOCATE(outpt(num_largest, 2), stat=ier) |
|---|
| 2856 | IF (ier /= 0) CALL ipslerr_p(3,'routing_diagnostic','Pb in allocate for outpt','','') |
|---|
| 2857 | |
|---|
| 2858 | ALLOCATE(nb_pts(num_largest), stat=ier) |
|---|
| 2859 | IF (ier /= 0) CALL ipslerr_p(3,'routing_diagnostic','Pb in allocate for nb_pts','','') |
|---|
| 2860 | |
|---|
| 2861 | ALLOCATE(totarea(num_largest), tmparea(num_largest), stat=ier) |
|---|
| 2862 | IF (ier /= 0) CALL ipslerr_p(3,'routing_diagnostic','Pb in allocate for totarea','','') |
|---|
| 2863 | |
|---|
| 2864 | ALLOCATE(topids(num_largest), stat=ier) |
|---|
| 2865 | IF (ier /= 0) CALL ipslerr_p(3,'routing_diagnostic','Pb in allocate for topids','','') |
|---|
| 2866 | |
|---|
| 2867 | ALLOCATE(sortedrivs(num_largest), stat=ier) |
|---|
| 2868 | IF (ier /= 0) CALL ipslerr_p(3,'routing_diagnostic','Pb in allocate for sortedrivs','','') |
|---|
| 2869 | |
|---|
| 2870 | ALLOCATE(sorted_names(num_largest), stat=ier) |
|---|
| 2871 | IF (ier /= 0) CALL ipslerr_p(3,'routing_diagnostic','Pb in allocate for sorted_names','','') |
|---|
| 2872 | |
|---|
| 2873 | ALLOCATE(streams_nb(num_largest), streams_avehops(num_largest), streams_minhops(num_largest), stat=ier) |
|---|
| 2874 | IF (ier /= 0) CALL ipslerr_p(3,'routing_diagnostic','Pb in allocate for streams_nb','','') |
|---|
| 2875 | |
|---|
| 2876 | ALLOCATE(streams_maxhops(num_largest), stat=ier) |
|---|
| 2877 | IF (ier /= 0) CALL ipslerr_p(3,'routing_diagnostic','Pb in allocate for streams_maxhops','','') |
|---|
| 2878 | |
|---|
| 2879 | ALLOCATE(streams_resid(num_largest), stat=ier) |
|---|
| 2880 | IF (ier /= 0) CALL ipslerr_p(3,'routing_diagnostic','Pb in allocate for streams_resid','','') |
|---|
| 2881 | |
|---|
| 2882 | ALLOCATE(lbasin_area(num_largest,nbpt), lbasin_uparea(num_largest,nbpt), lrivercode(num_largest,nbpt), stat=ier) |
|---|
| 2883 | IF (ier /= 0) CALL ipslerr_p(3,'routing_diagnostic','Pb in allocate for lbasin_area','','') |
|---|
| 2884 | |
|---|
| 2885 | IF ( .NOT. is_root_prc) THEN |
|---|
| 2886 | WRITE(numout,*) "routing_diagnostic is not suitable for running in parallel" |
|---|
| 2887 | WRITE(numout,*) "We are here on a non root processor. is_root_prc = ", is_root_prc |
|---|
| 2888 | WRITE(numout,*) "STOP from routing_diagnostic" |
|---|
| 2889 | CALL ipslerr_p(3,'routing_diagnostic','This routine is not suitable for running in parallel','','') |
|---|
| 2890 | ENDIF |
|---|
| 2891 | |
|---|
| 2892 | |
|---|
| 2893 | !Config Key = RIVER_DESC |
|---|
| 2894 | !Config Desc = Writes out a description of the rivers |
|---|
| 2895 | !Config If = RIVER_ROUTING |
|---|
| 2896 | !Config Def = n |
|---|
| 2897 | !Config Help = This flag allows to write out a file containing the list of |
|---|
| 2898 | !Config rivers which are beeing simulated. It provides location of outflow |
|---|
| 2899 | !Config drainage area, name and ID. |
|---|
| 2900 | !Config Units = [FLAG] |
|---|
| 2901 | ! |
|---|
| 2902 | river_file=.FALSE. |
|---|
| 2903 | CALL getin('RIVER_DESC', river_file) |
|---|
| 2904 | ! |
|---|
| 2905 | !Config Key = RIVER_DESC_FILE |
|---|
| 2906 | !Config Desc = Filename in which we write the description of the rivers. If suffix is ".nc" a netCDF file is created |
|---|
| 2907 | !Config If = RIVER_DESC |
|---|
| 2908 | !Config Def = river_desc.nc |
|---|
| 2909 | !Config Help = File name where we will write the information. If the suffix is ".nc" a netCDF file is generated. Else |
|---|
| 2910 | !Config a simple text file will contain some information. The netCDF file is valuable for post-processing the |
|---|
| 2911 | ! data as it will contain the fraction of the large basins in each grid box. |
|---|
| 2912 | !Config Units = [FILE] |
|---|
| 2913 | ! |
|---|
| 2914 | river_file_name="river_desc.nc" |
|---|
| 2915 | CALL getin('RIVER_DESC_FILE', river_file_name) |
|---|
| 2916 | ! |
|---|
| 2917 | ! |
|---|
| 2918 | ! First we get the list of all river outflow points |
|---|
| 2919 | ! We work under the assumption that we only have num_largest basins finishing with |
|---|
| 2920 | ! nbasmax+3. This is checked in routing_truncate. |
|---|
| 2921 | ! |
|---|
| 2922 | nb_small = 1 |
|---|
| 2923 | outpt(:,:) = -1 |
|---|
| 2924 | ic = 0 |
|---|
| 2925 | DO ig=1,nbpt |
|---|
| 2926 | DO ib=1,nbasmax |
|---|
| 2927 | ign = route_togrid(ig, ib) |
|---|
| 2928 | ibn = route_tobasin(ig, ib) |
|---|
| 2929 | IF ( ibn .EQ. nbasmax+3) THEN |
|---|
| 2930 | ic = ic + 1 |
|---|
| 2931 | outpt(ic,1) = ig |
|---|
| 2932 | outpt(ic,2) = ib |
|---|
| 2933 | ! |
|---|
| 2934 | ! Get the largest id of the basins we call a river. This is |
|---|
| 2935 | ! to extract the names of all rivers. |
|---|
| 2936 | ! |
|---|
| 2937 | IF ( global_basinid(ig,ib) > nb_small ) THEN |
|---|
| 2938 | nb_small = global_basinid(ig,ib) |
|---|
| 2939 | ENDIF |
|---|
| 2940 | ENDIF |
|---|
| 2941 | ENDDO |
|---|
| 2942 | ENDDO |
|---|
| 2943 | |
|---|
| 2944 | nb_small = MIN(nb_small, 349) |
|---|
| 2945 | |
|---|
| 2946 | ALLOCATE(basin_names(nb_small), stat=ier) |
|---|
| 2947 | IF (ier /= 0) CALL ipslerr_p(3,'routing_diagnostic','Pb in allocate for basins_names','','') |
|---|
| 2948 | |
|---|
| 2949 | CALL routing_names(nb_small, basin_names) |
|---|
| 2950 | ! |
|---|
| 2951 | ! Go through all points and basins to see if they outflow as a river and store the |
|---|
| 2952 | ! information needed in the various arrays. |
|---|
| 2953 | ! |
|---|
| 2954 | nb_pts(:) = 0 |
|---|
| 2955 | totarea(:) = zero |
|---|
| 2956 | hydrodiag(:,:) = 0 |
|---|
| 2957 | areaupbasin(:,:) = zero |
|---|
| 2958 | outids(:,:) = -1 |
|---|
| 2959 | ob = -1 |
|---|
| 2960 | og = -1 |
|---|
| 2961 | lbasin_area(:,:) = zero |
|---|
| 2962 | lbasin_uparea(:,:) = zero |
|---|
| 2963 | longest_river = 0 |
|---|
| 2964 | ! |
|---|
| 2965 | err_nbpt_grid_basin = .FALSE. |
|---|
| 2966 | loopgridbasin : DO ig=1,nbpt |
|---|
| 2967 | ! |
|---|
| 2968 | DO ib=1,nbasmax |
|---|
| 2969 | IF ( routing_area(ig,ib) .GT. zero ) THEN |
|---|
| 2970 | ic = 0 |
|---|
| 2971 | ign = ig |
|---|
| 2972 | ibn = ib |
|---|
| 2973 | ! Locate outflow point |
|---|
| 2974 | DO WHILE (ibn .GT. 0 .AND. ibn .LE. nbasmax .AND. ic .LT. nbasmax*nbpt) |
|---|
| 2975 | ic = ic + 1 |
|---|
| 2976 | og = ign |
|---|
| 2977 | ob = ibn |
|---|
| 2978 | ign = route_togrid(og, ob) |
|---|
| 2979 | ibn = route_tobasin(og, ob) |
|---|
| 2980 | areaupbasin(og, ob) = areaupbasin(og, ob) + routing_area(ig,ib) |
|---|
| 2981 | ENDDO |
|---|
| 2982 | ! |
|---|
| 2983 | longest_river = MAX(longest_river, ic) |
|---|
| 2984 | ! |
|---|
| 2985 | ! Now that we have an outflow check if it is one of the num_largest rivers. |
|---|
| 2986 | ! In this case we keeps the location so we diagnose it. |
|---|
| 2987 | ! |
|---|
| 2988 | IF ( ibn .EQ. nbasmax + 3) THEN |
|---|
| 2989 | DO icc = 1,num_largest |
|---|
| 2990 | IF ( outpt(icc,1) .EQ. og .AND. outpt(icc,2) .EQ. ob ) THEN |
|---|
| 2991 | ! |
|---|
| 2992 | ! We only keep this point for our map if it is large enough. |
|---|
| 2993 | ! |
|---|
| 2994 | nb_pts(icc) = nb_pts(icc) + 1 |
|---|
| 2995 | ! |
|---|
| 2996 | ! |
|---|
| 2997 | IF ( nb_pts(icc) > nbpt ) THEN |
|---|
| 2998 | err_nbpt_grid_basin = .TRUE. |
|---|
| 2999 | EXIT loopgridbasin |
|---|
| 3000 | ENDIF |
|---|
| 3001 | ! |
|---|
| 3002 | pts(icc, nb_pts(icc)) = ig |
|---|
| 3003 | ptbas(icc, nb_pts(icc)) = ib |
|---|
| 3004 | totarea(icc) = totarea(icc) + routing_area(ig,ib) |
|---|
| 3005 | ! |
|---|
| 3006 | lbasin_area(icc,nb_pts(icc)) = routing_area(ig,ib) |
|---|
| 3007 | ! |
|---|
| 3008 | ! ID of the river is taken from the last point before the outflow. |
|---|
| 3009 | topids(icc) = global_basinid(og,ob) |
|---|
| 3010 | outids(ig,ib) = global_basinid(og,ob) |
|---|
| 3011 | ! |
|---|
| 3012 | ! On this gridbox and basin we will diagnose the hydrograph |
|---|
| 3013 | ! |
|---|
| 3014 | hydrodiag(ig, ib) = 1 |
|---|
| 3015 | ! |
|---|
| 3016 | ENDIF |
|---|
| 3017 | ENDDO |
|---|
| 3018 | ENDIF |
|---|
| 3019 | ENDIF |
|---|
| 3020 | ! |
|---|
| 3021 | ENDDO |
|---|
| 3022 | ! |
|---|
| 3023 | ENDDO loopgridbasin |
|---|
| 3024 | ! |
|---|
| 3025 | IF ( err_nbpt_grid_basin ) THEN |
|---|
| 3026 | WRITE(numout, *) "routing_diagnostic : The number of grid points in basin ", icc |
|---|
| 3027 | WRITE(numout, *) "routing_diagnostic : is larger than anticiped. " |
|---|
| 3028 | CALL ipslerr_p(3, 'routing_diagnostic', 'We are heading for a out of bounds in arrays pts, ptsbas and lbasin_area.',& |
|---|
| 3029 | & 'Increase the last dimension of these arrays.','') |
|---|
| 3030 | ENDIF |
|---|
| 3031 | ! |
|---|
| 3032 | ! Now we decide which points we will keep from the largest basins |
|---|
| 3033 | ! |
|---|
| 3034 | ! Temporary fix |
|---|
| 3035 | route_nbintobas(:,:) = 0 |
|---|
| 3036 | ! |
|---|
| 3037 | basinmap(:) = zero |
|---|
| 3038 | DO ig=1,nbpt |
|---|
| 3039 | ! |
|---|
| 3040 | ! Look for the dominant basin in this grid. This information only affects some |
|---|
| 3041 | ! diagnostics : hydrographs and saved area upstream. |
|---|
| 3042 | ! |
|---|
| 3043 | icc = 0 |
|---|
| 3044 | idbas = -1 |
|---|
| 3045 | ! |
|---|
| 3046 | DO ib=1,nbasmax |
|---|
| 3047 | IF ( outids(ig,ib) > 0 ) THEN |
|---|
| 3048 | IF ( COUNT(outids(ig,:) == outids(ig,ib)) > icc ) THEN |
|---|
| 3049 | icc = COUNT(outids(ig,:) == outids(ig,ib)) |
|---|
| 3050 | idbas = outids(ig,ib) |
|---|
| 3051 | ENDIF |
|---|
| 3052 | ENDIF |
|---|
| 3053 | ENDDO |
|---|
| 3054 | ! |
|---|
| 3055 | ! If we have found a point from the large basins and decided which one |
|---|
| 3056 | ! takes over this grid then we note it on the map. |
|---|
| 3057 | ! Clean-up a little the hydrodiag array |
|---|
| 3058 | ! |
|---|
| 3059 | IF ( idbas > 0 ) THEN |
|---|
| 3060 | basinmap(ig) = REAL(idbas, r_std) |
|---|
| 3061 | ENDIF |
|---|
| 3062 | ! |
|---|
| 3063 | ! Now place the hydrograph diagnostic on the point closest to the |
|---|
| 3064 | ! ocean. |
|---|
| 3065 | ! |
|---|
| 3066 | tmpbas(:) = zero |
|---|
| 3067 | DO ib=1,nbasmax |
|---|
| 3068 | IF ( outids(ig,ib) .EQ. idbas) THEN |
|---|
| 3069 | tmpbas(ib) = areaupbasin(ig,ib) |
|---|
| 3070 | ENDIF |
|---|
| 3071 | ENDDO |
|---|
| 3072 | hydrodiag(ig,:) = 0 |
|---|
| 3073 | ff=MAXLOC(tmpbas) |
|---|
| 3074 | hydrodiag(ig,ff(1)) = 1 |
|---|
| 3075 | hydroupbasin(ig) = areaupbasin(ig,ff(1)) |
|---|
| 3076 | ! |
|---|
| 3077 | ENDDO |
|---|
| 3078 | ! |
|---|
| 3079 | ! |
|---|
| 3080 | ! |
|---|
| 3081 | tmparea(:) = totarea(:) |
|---|
| 3082 | DO icc = 1, num_largest |
|---|
| 3083 | ff = MAXLOC(tmparea) |
|---|
| 3084 | sortedrivs(icc) = ff(1) |
|---|
| 3085 | tmparea(ff(1)) = 0.0 |
|---|
| 3086 | ENDDO |
|---|
| 3087 | ! |
|---|
| 3088 | ! Diagnose the complexity of the basins obtained and determine their code in the Pfafstetter system |
|---|
| 3089 | ! |
|---|
| 3090 | nbmax=MAXVAL(nb_pts) |
|---|
| 3091 | ALLOCATE(allstreams(nbmax, longest_river), upstreamchange(nbmax, longest_river), stat=ier) |
|---|
| 3092 | IF (ier /= 0) CALL ipslerr_p(3,'routing_diagnostic','Pb in allocate for allstreams','','') |
|---|
| 3093 | |
|---|
| 3094 | ALLOCATE(tstreams(longest_river), tupstreamchange(longest_river), stat=ier) |
|---|
| 3095 | IF (ier /= 0) CALL ipslerr_p(3,'routing_diagnostic','Pb in allocate for tstreams','','') |
|---|
| 3096 | |
|---|
| 3097 | ALLOCATE(tslen(nbmax), tpts(nbmax), tptbas(nbmax), tuparea(nbmax), stat=ier) |
|---|
| 3098 | IF (ier /= 0) CALL ipslerr_p(3,'routing_diagnostic','Pb in allocate for tslen','','') |
|---|
| 3099 | |
|---|
| 3100 | ALLOCATE(tcode(nbmax), stat=ier) |
|---|
| 3101 | IF (ier /= 0) CALL ipslerr_p(3,'routing_diagnostic','Pb in allocate for tcode','','') |
|---|
| 3102 | |
|---|
| 3103 | DO icc = 1, num_largest |
|---|
| 3104 | ! |
|---|
| 3105 | ! Work through the largest basins |
|---|
| 3106 | ! |
|---|
| 3107 | idbas = sortedrivs(icc) |
|---|
| 3108 | ! |
|---|
| 3109 | streams_nb(idbas) = 0 |
|---|
| 3110 | streams_avehops(idbas) = 0 |
|---|
| 3111 | streams_minhops(idbas) = undef_int |
|---|
| 3112 | streams_maxhops(idbas) = 0 |
|---|
| 3113 | streams_resid(idbas) = zero |
|---|
| 3114 | tslen(:) = 0 |
|---|
| 3115 | ! |
|---|
| 3116 | allstreams(:,:) = 0 |
|---|
| 3117 | upstreamchange(:,:) = zero |
|---|
| 3118 | ! |
|---|
| 3119 | DO ii=1,nb_pts(idbas) |
|---|
| 3120 | ! |
|---|
| 3121 | ig = pts(idbas, ii) |
|---|
| 3122 | ib = ptbas(idbas, ii) |
|---|
| 3123 | ! |
|---|
| 3124 | lbasin_uparea(idbas,ii) = areaupbasin(ig,ib) |
|---|
| 3125 | ! |
|---|
| 3126 | slen = 0 |
|---|
| 3127 | ign = ig |
|---|
| 3128 | ibn = ib |
|---|
| 3129 | og = ig |
|---|
| 3130 | ob = ib |
|---|
| 3131 | ! |
|---|
| 3132 | averesid = zero |
|---|
| 3133 | tupstreamchange(:) = zero |
|---|
| 3134 | ! go to outflow point to count the number of hops |
|---|
| 3135 | DO WHILE (ibn .GT. 0 .AND. ibn .LE. nbasmax) |
|---|
| 3136 | ! Store data |
|---|
| 3137 | slen = slen + 1 |
|---|
| 3138 | tstreams(slen) = ign |
|---|
| 3139 | tupstreamchange(slen) = areaupbasin(ign,ibn)-areaupbasin(og,ob) |
|---|
| 3140 | ! Move to next point |
|---|
| 3141 | og = ign |
|---|
| 3142 | ob = ibn |
|---|
| 3143 | ign = route_togrid(og, ob) |
|---|
| 3144 | ibn = route_tobasin(og, ob) |
|---|
| 3145 | averesid = averesid + topo_resid(og, ob)**2 |
|---|
| 3146 | ENDDO |
|---|
| 3147 | ! |
|---|
| 3148 | allstreams(ii,1:slen) = tstreams(slen:1:-1) |
|---|
| 3149 | upstreamchange(ii,1:slen) = tupstreamchange(slen:1:-1) |
|---|
| 3150 | tslen(ii) = slen |
|---|
| 3151 | ! |
|---|
| 3152 | ! Save diagnostics |
|---|
| 3153 | ! |
|---|
| 3154 | streams_nb(idbas) = streams_nb(idbas) + 1 |
|---|
| 3155 | streams_avehops(idbas) = streams_avehops(idbas) + slen |
|---|
| 3156 | streams_resid(idbas) = streams_resid(idbas) + SQRT(averesid) |
|---|
| 3157 | IF ( slen < streams_minhops(idbas) ) THEN |
|---|
| 3158 | streams_minhops(idbas) = slen |
|---|
| 3159 | ENDIF |
|---|
| 3160 | IF ( slen > streams_maxhops(idbas) ) THEN |
|---|
| 3161 | streams_maxhops(idbas) = slen |
|---|
| 3162 | ENDIF |
|---|
| 3163 | ! |
|---|
| 3164 | ENDDO |
|---|
| 3165 | ! build the average |
|---|
| 3166 | IF ( streams_nb(idbas) > 0 ) THEN |
|---|
| 3167 | streams_avehops(idbas) = streams_avehops(idbas)/streams_nb(idbas) |
|---|
| 3168 | streams_resid(idbas) = streams_resid(idbas)/REAL(streams_nb(idbas), r_std) |
|---|
| 3169 | ELSE |
|---|
| 3170 | ! River without streams ... very rare but happens |
|---|
| 3171 | streams_avehops(idbas) = zero |
|---|
| 3172 | streams_resid(idbas) = zero |
|---|
| 3173 | streams_maxhops(idbas) = zero |
|---|
| 3174 | streams_minhops(idbas) = zero |
|---|
| 3175 | ENDIF |
|---|
| 3176 | ! |
|---|
| 3177 | ! |
|---|
| 3178 | ii=nb_pts(idbas) |
|---|
| 3179 | tpts(:) = 0 |
|---|
| 3180 | tpts(1:ii) = pts(idbas,1:ii) |
|---|
| 3181 | tptbas(:) = 0 |
|---|
| 3182 | tptbas(1:ii) = ptbas(idbas,1:ii) |
|---|
| 3183 | tuparea(:) = 0 |
|---|
| 3184 | tuparea(1:ii) = lbasin_uparea(idbas,1:ii) |
|---|
| 3185 | ! |
|---|
| 3186 | CALL routing_diagcode(ii, tpts, tptbas, tuparea, tslen, MAXVAL(tslen), allstreams, upstreamchange, tcode) |
|---|
| 3187 | ! |
|---|
| 3188 | lrivercode(idbas,:) = 0 |
|---|
| 3189 | lrivercode(idbas,1:ii) = tcode(1:ii) |
|---|
| 3190 | ! |
|---|
| 3191 | ENDDO |
|---|
| 3192 | ! |
|---|
| 3193 | ! Create the sorted list of names |
|---|
| 3194 | ! |
|---|
| 3195 | err_basin_number = .FALSE. |
|---|
| 3196 | DO icc = 1, num_largest |
|---|
| 3197 | ! |
|---|
| 3198 | ib=sortedrivs(icc) |
|---|
| 3199 | ! |
|---|
| 3200 | IF ( topids(ib) .GT. nb_small ) THEN |
|---|
| 3201 | IF (topids(ib) <= 99 ) THEN |
|---|
| 3202 | WRITE(sorted_names(icc), '("Nb_",I2.2)') topids(ib) |
|---|
| 3203 | ELSE IF (topids(ib) <= 999 ) THEN |
|---|
| 3204 | WRITE(sorted_names(icc), '("Nb_",I3.3)') topids(ib) |
|---|
| 3205 | ELSE IF (topids(ib) <= 9999 ) THEN |
|---|
| 3206 | WRITE(sorted_names(icc), '("Nb_",I4.4)') topids(ib) |
|---|
| 3207 | ELSE IF (topids(ib) <= 99999 ) THEN |
|---|
| 3208 | WRITE(sorted_names(icc), '("Nb_",I5.5)') topids(ib) |
|---|
| 3209 | ELSE IF (topids(ib) <= 999999 ) THEN |
|---|
| 3210 | WRITE(sorted_names(icc), '("Nb_",I6.6)') topids(ib) |
|---|
| 3211 | ELSE |
|---|
| 3212 | err_basin_number = .TRUE. |
|---|
| 3213 | EXIT |
|---|
| 3214 | ENDIF |
|---|
| 3215 | |
|---|
| 3216 | ELSE |
|---|
| 3217 | IF (topids(ib) <= -1 ) THEN |
|---|
| 3218 | WRITE(sorted_names(icc), '("Ne_",I2.2)') -1*topids(ib) |
|---|
| 3219 | ELSE |
|---|
| 3220 | IF (printlev >=6) WRITE(numout,*) ">>> nb_small, ib, topids :", nb_small, ib, topids(ib) |
|---|
| 3221 | sorted_names(icc) = basin_names(topids(ib)) |
|---|
| 3222 | ENDIF |
|---|
| 3223 | ENDIF |
|---|
| 3224 | ! |
|---|
| 3225 | ENDDO |
|---|
| 3226 | ! |
|---|
| 3227 | IF ( err_basin_number ) THEN |
|---|
| 3228 | CALL ipslerr_p(3, 'routing_diagnostic', 'We found a basin number larger than 999999.',& |
|---|
| 3229 | & 'This is impossible. Please verify your configuration.','') |
|---|
| 3230 | ENDIF |
|---|
| 3231 | ! |
|---|
| 3232 | ! Check for doubles and rename if needed |
|---|
| 3233 | ! |
|---|
| 3234 | DO icc = 1, num_largest |
|---|
| 3235 | name_found=0 |
|---|
| 3236 | DO ic=1, num_largest |
|---|
| 3237 | IF ( TRIM(sorted_names(icc)) == TRIM(sorted_names(ic)) ) THEN |
|---|
| 3238 | name_found = name_found + 1 |
|---|
| 3239 | ENDIF |
|---|
| 3240 | ENDDO |
|---|
| 3241 | ! |
|---|
| 3242 | IF ( name_found > 1 ) THEN |
|---|
| 3243 | DO ic=num_largest,1,-1 |
|---|
| 3244 | IF ( TRIM(sorted_names(icc)) == TRIM(sorted_names(ic)) ) THEN |
|---|
| 3245 | IF ( name_found > 1 ) THEN |
|---|
| 3246 | WRITE(nn,'(I1)') name_found |
|---|
| 3247 | sorted_names(ic) = TRIM(sorted_names(ic))//nn |
|---|
| 3248 | name_found = name_found - 1 |
|---|
| 3249 | ENDIF |
|---|
| 3250 | ENDIF |
|---|
| 3251 | ENDDO |
|---|
| 3252 | ENDIF |
|---|
| 3253 | ! |
|---|
| 3254 | ENDDO |
|---|
| 3255 | ! |
|---|
| 3256 | ! Print to stdout on ROOT_PROC the diagnostics for the largest basins we have found. |
|---|
| 3257 | ! |
|---|
| 3258 | IF (printlev>=1) THEN |
|---|
| 3259 | DO icc = 1, num_largest |
|---|
| 3260 | IF ( nb_pts(sortedrivs(icc)) .GT. 2 ) THEN |
|---|
| 3261 | name_str = sorted_names(icc) |
|---|
| 3262 | WRITE(numout,'("Basin ID ", I5," ", A15, " Area [km^2] : ", F13.4, " Nb points : ", I4)')& |
|---|
| 3263 | & topids(sortedrivs(icc)), name_str(1:15), totarea(sortedrivs(icc))/1.e6, nb_pts(sortedrivs(icc)) |
|---|
| 3264 | ENDIF |
|---|
| 3265 | ENDDO |
|---|
| 3266 | END IF |
|---|
| 3267 | ! |
|---|
| 3268 | ! Save some of the basin information into files. |
|---|
| 3269 | ! |
|---|
| 3270 | IF ( river_file ) THEN |
|---|
| 3271 | |
|---|
| 3272 | IF ( INDEX(river_file_name,".nc") > 1 ) THEN |
|---|
| 3273 | |
|---|
| 3274 | CALL routing_diagncfile(river_file_name, nbpt, lalo, nb_pts, topids, sorted_names, sortedrivs, & |
|---|
| 3275 | & pts, lbasin_area, lbasin_uparea, lrivercode, outpt, streams_nb, streams_avehops, & |
|---|
| 3276 | & streams_minhops, streams_maxhops, streams_resid) |
|---|
| 3277 | |
|---|
| 3278 | ELSE |
|---|
| 3279 | |
|---|
| 3280 | OPEN(diagunit, FILE=river_file_name) |
|---|
| 3281 | WRITE(diagunit,'(A)') "Basin ID, Area [km^2], Nb points, Lon and Lat of outflow" |
|---|
| 3282 | WRITE(diagunit,'(A)') "Nb streams, total number of hops, min, ave and max number of hops per stream" |
|---|
| 3283 | ! |
|---|
| 3284 | DO icc = 1, num_largest |
|---|
| 3285 | ! |
|---|
| 3286 | IF ( nb_pts(sortedrivs(icc)) .GT. 2 ) THEN |
|---|
| 3287 | ! |
|---|
| 3288 | name_str = sorted_names(icc) |
|---|
| 3289 | ! |
|---|
| 3290 | WRITE(diagunit,'(I5,A25,F14.5,I5,2F9.2)') topids(sortedrivs(icc)), name_str(1:15), totarea(sortedrivs(icc))/1.e6, & |
|---|
| 3291 | & nb_pts(sortedrivs(icc)), lalo(outpt(sortedrivs(icc),1),2), lalo(outpt(sortedrivs(icc),1),1) |
|---|
| 3292 | WRITE(diagunit,'(5I9,F16.4)') streams_nb(sortedrivs(icc)), & |
|---|
| 3293 | & streams_avehops(sortedrivs(icc))*streams_nb(sortedrivs(icc)), & |
|---|
| 3294 | & streams_minhops(sortedrivs(icc)), & |
|---|
| 3295 | & streams_avehops(sortedrivs(icc)), & |
|---|
| 3296 | & streams_maxhops(sortedrivs(icc)), streams_resid(sortedrivs(icc)) |
|---|
| 3297 | ! |
|---|
| 3298 | ENDIF |
|---|
| 3299 | ! |
|---|
| 3300 | ENDDO |
|---|
| 3301 | ! |
|---|
| 3302 | CLOSE(diagunit) |
|---|
| 3303 | ! |
|---|
| 3304 | ENDIF |
|---|
| 3305 | ! |
|---|
| 3306 | ENDIF |
|---|
| 3307 | ! |
|---|
| 3308 | ! |
|---|
| 3309 | nbrivers(:) = zero |
|---|
| 3310 | DO ig=1,nbpt |
|---|
| 3311 | nbrivers(ig) = COUNT(route_tobasin(ig,1:nbasmax) == nbasmax+3) |
|---|
| 3312 | ENDDO |
|---|
| 3313 | DO ig=1,nbpt |
|---|
| 3314 | IF ( nbrivers(ig) > 1 ) THEN |
|---|
| 3315 | WRITE(numout,*) 'Grid box ', ig, ' has ', NINT(nbrivers(ig)), ' outflow points.' |
|---|
| 3316 | WRITE(numout,*) 'The rivers which flow into the ocean at this point are :' |
|---|
| 3317 | DO icc=1,nbasmax |
|---|
| 3318 | IF ( route_tobasin(ig,icc) == nbasmax+3) THEN |
|---|
| 3319 | IF ( global_basinid(ig,icc) <= nb_small ) THEN |
|---|
| 3320 | WRITE(numout,*) 'ID = ',global_basinid(ig,icc), ' Name = ', basin_names(global_basinid(ig,icc)) |
|---|
| 3321 | ELSE |
|---|
| 3322 | WRITE(numout,*) 'ID = ',global_basinid(ig,icc), ' Problem ===== ID is larger than possible' |
|---|
| 3323 | ENDIF |
|---|
| 3324 | ENDIF |
|---|
| 3325 | ENDDO |
|---|
| 3326 | ENDIF |
|---|
| 3327 | ENDDO |
|---|
| 3328 | ! |
|---|
| 3329 | ic = COUNT(topo_resid .GT. 0.) |
|---|
| 3330 | IF (printlev>=1) THEN |
|---|
| 3331 | WRITE(numout,*) 'Maximum topographic index :', MAXVAL(topo_resid) |
|---|
| 3332 | WRITE(numout,*) 'Mean topographic index :', SUM(topo_resid, MASK=topo_resid .GT. zero)/ic |
|---|
| 3333 | WRITE(numout,*) 'Minimum topographic index :', MINVAL(topo_resid, MASK=topo_resid .GT. zero) |
|---|
| 3334 | END IF |
|---|
| 3335 | |
|---|
| 3336 | DEALLOCATE(pts) |
|---|
| 3337 | DEALLOCATE(outpt) |
|---|
| 3338 | DEALLOCATE(nb_pts) |
|---|
| 3339 | DEALLOCATE(totarea, tmparea) |
|---|
| 3340 | DEALLOCATE(streams_nb, streams_avehops, streams_minhops, streams_maxhops) |
|---|
| 3341 | ! |
|---|
| 3342 | DEALLOCATE(lbasin_area, lbasin_uparea, lrivercode) |
|---|
| 3343 | ! |
|---|
| 3344 | DEALLOCATE(allstreams) |
|---|
| 3345 | DEALLOCATE(tstreams) |
|---|
| 3346 | DEALLOCATE(tslen, tpts, tptbas, tuparea) |
|---|
| 3347 | DEALLOCATE(tcode) |
|---|
| 3348 | ! |
|---|
| 3349 | ic = COUNT(topo_resid .GT. 0.) |
|---|
| 3350 | IF (printlev>=1) THEN |
|---|
| 3351 | WRITE(numout,*) 'Maximum topographic index :', MAXVAL(topo_resid) |
|---|
| 3352 | WRITE(numout,*) 'Mean topographic index :', SUM(topo_resid, MASK=topo_resid .GT. 0.)/ic |
|---|
| 3353 | WRITE(numout,*) 'Minimum topographic index :', MINVAL(topo_resid, MASK=topo_resid .GT. 0.) |
|---|
| 3354 | END IF |
|---|
| 3355 | |
|---|
| 3356 | END SUBROUTINE routing_diagnostic |
|---|
| 3357 | ! |
|---|
| 3358 | !! ================================================================================================================================ |
|---|
| 3359 | !! SUBROUTINE : routing_diagcode |
|---|
| 3360 | !! |
|---|
| 3361 | !>\BRIEF This subroutine determines the code in the Pfafstetter system for all points |
|---|
| 3362 | !! within the given catchment. |
|---|
| 3363 | !! |
|---|
| 3364 | !! DESCRIPTION (definitions, functional, design, flags) : None |
|---|
| 3365 | !! |
|---|
| 3366 | !! RECENT CHANGE(S): None |
|---|
| 3367 | !! |
|---|
| 3368 | !! MAIN OUTPUT VARIABLE(S): streamcode |
|---|
| 3369 | !! |
|---|
| 3370 | !! REFERENCES : None |
|---|
| 3371 | !! |
|---|
| 3372 | !! FLOWCHART :None |
|---|
| 3373 | !! \n |
|---|
| 3374 | !_ ================================================================================================================================ |
|---|
| 3375 | |
|---|
| 3376 | SUBROUTINE routing_diagcode(ip, tpts, tpbas, tuparea, tslen, ls, allstreams, upstreamchange, streamcode) |
|---|
| 3377 | ! |
|---|
| 3378 | IMPLICIT NONE |
|---|
| 3379 | ! |
|---|
| 3380 | !! INPUT VARIABLES |
|---|
| 3381 | INTEGER(i_std), INTENT(in) :: ip !! |
|---|
| 3382 | INTEGER(i_std), INTENT(in) :: ls !! |
|---|
| 3383 | INTEGER(i_std), DIMENSION(ip), INTENT(in) :: tpts !! |
|---|
| 3384 | INTEGER(i_std), DIMENSION(ip), INTENT(in) :: tpbas !! |
|---|
| 3385 | REAL(r_std), DIMENSION(ip), INTENT(in) :: tuparea !! |
|---|
| 3386 | INTEGER(i_std), DIMENSION(ip), INTENT(in) :: tslen !! |
|---|
| 3387 | INTEGER(i_std), DIMENSION(ip,ls), INTENT(in) :: allstreams !! |
|---|
| 3388 | REAL(r_std), DIMENSION(ip,ls), INTENT(in) :: upstreamchange !! |
|---|
| 3389 | ! |
|---|
| 3390 | !! OUTPUT VARIABLES |
|---|
| 3391 | INTEGER(i_std), DIMENSION(ip), INTENT(out) :: streamcode !! |
|---|
| 3392 | ! |
|---|
| 3393 | !! LOCAL VARIABLES |
|---|
| 3394 | INTEGER(i_std) :: ilev, cntsubbas, ib, ic, i, it, ilevmax, imaxlen, nbzero !! |
|---|
| 3395 | INTEGER(i_std) :: tstreamcode(ip)!! |
|---|
| 3396 | INTEGER(i_std) :: indsubbas(ip) !! |
|---|
| 3397 | INTEGER(i_std) :: iw(ip) !! |
|---|
| 3398 | INTEGER(i_std) :: tdiff(ip) !! |
|---|
| 3399 | INTEGER(i_std) :: tmpjunc(4) !! |
|---|
| 3400 | INTEGER(i_std) :: junction(4) !! |
|---|
| 3401 | INTEGER(i_std) :: ff(1) !! |
|---|
| 3402 | INTEGER(i_std) :: ll !! |
|---|
| 3403 | REAL(r_std) :: chguparea(ip) !! |
|---|
| 3404 | REAL(r_std) :: largest !! |
|---|
| 3405 | |
|---|
| 3406 | !_ ================================================================================================================================ |
|---|
| 3407 | ! |
|---|
| 3408 | streamcode(:) = 0 |
|---|
| 3409 | ! |
|---|
| 3410 | ! If we accept 4 grid boxes per coded basin then per level we need at least |
|---|
| 3411 | ! 4*9=36 boxes. |
|---|
| 3412 | ! |
|---|
| 3413 | ilevmax = 0 |
|---|
| 3414 | it = ip |
|---|
| 3415 | DO WHILE (it >= 36) |
|---|
| 3416 | ilevmax = ilevmax+1 |
|---|
| 3417 | it = it/9 |
|---|
| 3418 | ENDDO |
|---|
| 3419 | ! |
|---|
| 3420 | DO ilev=1,ilevmax |
|---|
| 3421 | ! |
|---|
| 3422 | ! Count number of sub-basins we already have |
|---|
| 3423 | ! |
|---|
| 3424 | cntsubbas=0 |
|---|
| 3425 | tstreamcode(:) = streamcode(:) |
|---|
| 3426 | DO WHILE ( COUNT(tstreamcode(:) >= 0) > 0 ) |
|---|
| 3427 | cntsubbas=cntsubbas+1 |
|---|
| 3428 | indsubbas(cntsubbas) = MAXVAL(tstreamcode(:)) |
|---|
| 3429 | WHERE ( tstreamcode(:) == indsubbas(cntsubbas) ) tstreamcode = -1 |
|---|
| 3430 | ENDDO |
|---|
| 3431 | ! |
|---|
| 3432 | ! Go through all these basins in order to find the next Pfafstetter numbers |
|---|
| 3433 | ! |
|---|
| 3434 | DO ib=1,cntsubbas |
|---|
| 3435 | ! |
|---|
| 3436 | ! Get all the streams which have the current Pfadstetter number |
|---|
| 3437 | ! |
|---|
| 3438 | it=0 |
|---|
| 3439 | DO ic=1,ip |
|---|
| 3440 | IF ( streamcode(ic) == indsubbas(ib) ) THEN |
|---|
| 3441 | it =it+1 |
|---|
| 3442 | iw(it)=ic |
|---|
| 3443 | ENDIF |
|---|
| 3444 | ENDDO |
|---|
| 3445 | ! |
|---|
| 3446 | ! Which is the longest stream in this basin ? |
|---|
| 3447 | ! |
|---|
| 3448 | ff=MAXLOC(tslen(iw(1:it))) |
|---|
| 3449 | imaxlen=iw(ff(1)) |
|---|
| 3450 | chguparea(:) = zero |
|---|
| 3451 | chguparea(1:tslen(imaxlen)) = upstreamchange(imaxlen, 1:tslen(imaxlen)) |
|---|
| 3452 | ! |
|---|
| 3453 | IF ( COUNT(chguparea(1:tslen(imaxlen)) > 0) < 4 ) THEN |
|---|
| 3454 | ! |
|---|
| 3455 | ! If this subbasin is too small we just set all points to zero |
|---|
| 3456 | ! |
|---|
| 3457 | DO i=1,it |
|---|
| 3458 | streamcode(iw(i)) = streamcode(iw(i))*10 |
|---|
| 3459 | ENDDO |
|---|
| 3460 | ELSE |
|---|
| 3461 | ! |
|---|
| 3462 | ! Else do the Pfafstetter numbering |
|---|
| 3463 | ! |
|---|
| 3464 | ! |
|---|
| 3465 | ! Where do we have the 4 largest change in upstream area on this stream. |
|---|
| 3466 | ! This must be the confluence of 2 rivers and thus a junction point. |
|---|
| 3467 | ! |
|---|
| 3468 | largest=pi*R_Earth*R_Earth |
|---|
| 3469 | DO i=1,4 |
|---|
| 3470 | ff = MAXLOC(chguparea(1:tslen(imaxlen)), MASK = chguparea(1:tslen(imaxlen)) < largest) |
|---|
| 3471 | tmpjunc(i) = ff(1) |
|---|
| 3472 | largest=chguparea(tmpjunc(i)) |
|---|
| 3473 | ENDDO |
|---|
| 3474 | ! sort junctions to go from the outflow up-stream |
|---|
| 3475 | ff(1)=0 |
|---|
| 3476 | DO i=1,4 |
|---|
| 3477 | junction(i) = MINVAL(tmpjunc, MASK=tmpjunc > ff(1)) |
|---|
| 3478 | ff(1) = junction(i) |
|---|
| 3479 | ENDDO |
|---|
| 3480 | ! |
|---|
| 3481 | ! Find all streams which are identical up to that junction and increase their code accordingly |
|---|
| 3482 | ! |
|---|
| 3483 | DO i=1,it |
|---|
| 3484 | ll=MIN(tslen(imaxlen),tslen(iw(i))) |
|---|
| 3485 | tdiff(1:ll) = allstreams(imaxlen,1:ll)-allstreams(iw(i),1:ll) |
|---|
| 3486 | nbzero = COUNT(tdiff(1:ll) == 0) |
|---|
| 3487 | IF (nbzero < junction(1) ) THEN |
|---|
| 3488 | ! Before first of the 4 largest basins |
|---|
| 3489 | streamcode(iw(i)) = streamcode(iw(i))*10+1 |
|---|
| 3490 | ELSE IF (nbzero == junction(1) ) THEN |
|---|
| 3491 | ! Stream part of the first largest basin |
|---|
| 3492 | streamcode(iw(i)) = streamcode(iw(i))*10+2 |
|---|
| 3493 | ELSE IF (nbzero < junction(2) ) THEN |
|---|
| 3494 | ! Between first and second stream |
|---|
| 3495 | streamcode(iw(i)) = streamcode(iw(i))*10+3 |
|---|
| 3496 | ELSE IF (nbzero == junction(2) ) THEN |
|---|
| 3497 | ! Stream part of the second basin |
|---|
| 3498 | streamcode(iw(i)) = streamcode(iw(i))*10+4 |
|---|
| 3499 | ELSE IF (nbzero < junction(3) ) THEN |
|---|
| 3500 | ! In between stream 2 and 3 |
|---|
| 3501 | streamcode(iw(i)) = streamcode(iw(i))*10+5 |
|---|
| 3502 | ELSE IF (nbzero == junction(3) ) THEN |
|---|
| 3503 | ! Part of 3rd basin |
|---|
| 3504 | streamcode(iw(i)) = streamcode(iw(i))*10+6 |
|---|
| 3505 | ELSE IF (nbzero < junction(4) ) THEN |
|---|
| 3506 | ! In between 3 and 4th basins |
|---|
| 3507 | streamcode(iw(i)) = streamcode(iw(i))*10+7 |
|---|
| 3508 | ELSE IF (nbzero == junction(4) ) THEN |
|---|
| 3509 | ! Final of the 4 largest basins |
|---|
| 3510 | streamcode(iw(i)) = streamcode(iw(i))*10+8 |
|---|
| 3511 | ELSE |
|---|
| 3512 | ! The rest of the points and also the basin of the longest stream |
|---|
| 3513 | streamcode(iw(i)) = streamcode(iw(i))*10+9 |
|---|
| 3514 | ENDIF |
|---|
| 3515 | ENDDO |
|---|
| 3516 | ENDIF |
|---|
| 3517 | ENDDO |
|---|
| 3518 | ! |
|---|
| 3519 | ENDDO |
|---|
| 3520 | ! |
|---|
| 3521 | ! |
|---|
| 3522 | END SUBROUTINE routing_diagcode |
|---|
| 3523 | ! |
|---|
| 3524 | !! ================================================================================================================================ |
|---|
| 3525 | !! SUBROUTINE : routing_diagncfile |
|---|
| 3526 | !! |
|---|
| 3527 | !>\BRIEF This subroutine creates a netCDF file containing all the informations |
|---|
| 3528 | !! on the largest rivers which can be used for a refined analysis. |
|---|
| 3529 | !! |
|---|
| 3530 | !! DESCRIPTION (definitions, functional, design, flags) : None |
|---|
| 3531 | !! |
|---|
| 3532 | !! RECENT CHANGE(S): None |
|---|
| 3533 | !! |
|---|
| 3534 | !! MAIN OUTPUT VARIABLE(S): None |
|---|
| 3535 | !! |
|---|
| 3536 | !! REFERENCES : None |
|---|
| 3537 | !! |
|---|
| 3538 | !! FLOWCHART : None |
|---|
| 3539 | !! \n |
|---|
| 3540 | !_ ================================================================================================================================ |
|---|
| 3541 | |
|---|
| 3542 | SUBROUTINE routing_diagncfile(river_file_name, nbpt, lalo, nb_pts, topids, sorted_names, sortedrivs, & |
|---|
| 3543 | & lbasin_index, lbasin_area, lbasin_uparea, lrivercode, outpt, streams_nb, streams_avehops, & |
|---|
| 3544 | & streams_minhops, streams_maxhops, streams_resid) |
|---|
| 3545 | ! |
|---|
| 3546 | USE netcdf |
|---|
| 3547 | ! |
|---|
| 3548 | IMPLICIT NONE |
|---|
| 3549 | ! |
|---|
| 3550 | ! |
|---|
| 3551 | !! INPUT VARIABLES |
|---|
| 3552 | REAL(r_std), INTENT(in) :: lalo(nbpt,2) !! Vector of latitude and longitudes (beware of the order !) |
|---|
| 3553 | |
|---|
| 3554 | !! LOCAL VARIABLES |
|---|
| 3555 | CHARACTER(LEN=80) :: river_file_name !! Filename in which we write the description of the rivers (1) |
|---|
| 3556 | INTEGER(i_std) :: nbpt !! Domain size (unitless) |
|---|
| 3557 | INTEGER(i_std), DIMENSION(num_largest) :: nb_pts !! Number of points in the basin (unitless) |
|---|
| 3558 | INTEGER(i_std), DIMENSION(num_largest) :: topids !! The IDs of the first num_largest basins (unitless) |
|---|
| 3559 | CHARACTER(LEN=25), DIMENSION(num_largest) :: sorted_names !! Names of the basins to be put into the file (unitless) |
|---|
| 3560 | INTEGER(i_std), DIMENSION(num_largest) :: sortedrivs !! |
|---|
| 3561 | INTEGER(i_std), DIMENSION(num_largest,nbpt) :: lbasin_index !! |
|---|
| 3562 | REAL(r_std), DIMENSION(num_largest,nbpt) :: lbasin_area !! |
|---|
| 3563 | REAL(r_std), DIMENSION(num_largest,nbpt) :: lbasin_uparea !! |
|---|
| 3564 | INTEGER(i_std), DIMENSION(num_largest,nbpt) :: lrivercode !! |
|---|
| 3565 | ! |
|---|
| 3566 | INTEGER(i_std), DIMENSION(num_largest,2) :: outpt !! Outflow point for each basin (unitless) |
|---|
| 3567 | INTEGER(i_std), DIMENSION(num_largest) :: streams_nb !! Number of streams in basin (unitless) |
|---|
| 3568 | INTEGER(i_std), DIMENSION(num_largest) :: streams_avehops !! Average number of hops in streams (unitless) |
|---|
| 3569 | INTEGER(i_std), DIMENSION(num_largest) :: streams_minhops !! Minimum number of hops in streams (unitless) |
|---|
| 3570 | INTEGER(i_std), DIMENSION(num_largest) :: streams_maxhops !! Minimum number of hops in streams (unitless) |
|---|
| 3571 | REAL(r_std), DIMENSION(num_largest) :: streams_resid !! Average residence time |
|---|
| 3572 | ! |
|---|
| 3573 | INTEGER(i_std) :: icc, fid, iret, ierr_tot, ib, ij, ik, i, j, lcc !! Indices (unitless) |
|---|
| 3574 | INTEGER(i_std) :: nlonid, nlatid, varid, varid2, varid3 |
|---|
| 3575 | INTEGER(i_std) :: dims(2) !! |
|---|
| 3576 | REAL(r_std) :: lon_min, lon_max, lat_min, lat_max |
|---|
| 3577 | CHARACTER(LEN=80) :: lon_name, lat_name, var_name, long_name, nc_name, att_str |
|---|
| 3578 | CHARACTER(LEN=15) :: gridtype !! |
|---|
| 3579 | ! |
|---|
| 3580 | REAL(r_std) :: basinfrac(iim_g,jjm_g) !! |
|---|
| 3581 | REAL(r_std) :: basinuparea(iim_g,jjm_g) !! |
|---|
| 3582 | INTEGER(i_std) :: basincode(iim_g,jjm_g) !! |
|---|
| 3583 | ! |
|---|
| 3584 | LOGICAL :: check=.FALSE. !! (true/false) |
|---|
| 3585 | ! |
|---|
| 3586 | !! PARAMETERS |
|---|
| 3587 | INTEGER(i_std),PARAMETER :: kind_r_diag=NF90_REAL8 !! |
|---|
| 3588 | INTEGER(i_std),PARAMETER :: kind_i_diag=NF90_INT !! |
|---|
| 3589 | |
|---|
| 3590 | !_ ================================================================================================================================ |
|---|
| 3591 | ! |
|---|
| 3592 | ! |
|---|
| 3593 | ! 1.0 Create the NETCDF file and store the coordinates. |
|---|
| 3594 | ! |
|---|
| 3595 | ! This variable should be defined and computed in the module grid.f90. |
|---|
| 3596 | ! Jan |
|---|
| 3597 | gridtype="regular" |
|---|
| 3598 | ! |
|---|
| 3599 | iret = NF90_CREATE(TRIM(river_file_name), NF90_CLOBBER, fid) |
|---|
| 3600 | IF (iret /= NF90_NOERR) THEN |
|---|
| 3601 | CALL ipslerr_p (3,'routing_diagncfile', 'Could not create file :', & |
|---|
| 3602 | & TRIM(river_file_name), '(Problem with disk place or filename ?)') |
|---|
| 3603 | ENDIF |
|---|
| 3604 | ! |
|---|
| 3605 | ! 1.1 Define dimensions |
|---|
| 3606 | ! |
|---|
| 3607 | IF ( INDEX(gridtype, "regular") == 1 ) THEN |
|---|
| 3608 | ! |
|---|
| 3609 | ! 1.1.1 regular grid |
|---|
| 3610 | ! |
|---|
| 3611 | iret = NF90_DEF_DIM(fid, 'lon', iim_g, dims(1)) |
|---|
| 3612 | IF (iret /= NF90_NOERR) THEN |
|---|
| 3613 | CALL ipslerr_p (3,'routing_diagncfile', 'Dimension "x" can not be defined for the file : ', & |
|---|
| 3614 | & TRIM(river_file_name),'(Solution ?)') |
|---|
| 3615 | ENDIF |
|---|
| 3616 | iret = NF90_DEF_DIM(fid, 'lat', jjm_g, dims(2)) |
|---|
| 3617 | IF (iret /= NF90_NOERR) THEN |
|---|
| 3618 | CALL ipslerr_p (3,'routing_diagncfile', 'Dimension "y" can not be defined for the file : ', & |
|---|
| 3619 | & TRIM(river_file_name),'(Solution ?)') |
|---|
| 3620 | ENDIF |
|---|
| 3621 | ELSE |
|---|
| 3622 | ! |
|---|
| 3623 | ! 1.1.2 irregular grid |
|---|
| 3624 | ! |
|---|
| 3625 | iret = NF90_DEF_DIM(fid, 'x', iim_g, dims(1)) |
|---|
| 3626 | IF (iret /= NF90_NOERR) THEN |
|---|
| 3627 | CALL ipslerr_p (3,'routing_diagncfile', 'Dimension "x" can not be defined for the file : ', & |
|---|
| 3628 | & TRIM(river_file_name),'(Solution ?)') |
|---|
| 3629 | ENDIF |
|---|
| 3630 | |
|---|
| 3631 | iret = NF90_DEF_DIM(fid, 'y', jjm_g, dims(2)) |
|---|
| 3632 | IF (iret /= NF90_NOERR) THEN |
|---|
| 3633 | CALL ipslerr_p (3,'routing_diagncfile', 'Dimension "y" can not be defined for the file : ', & |
|---|
| 3634 | & TRIM(river_file_name),'(Solution ?)') |
|---|
| 3635 | ENDIF |
|---|
| 3636 | ENDIF |
|---|
| 3637 | ! |
|---|
| 3638 | ! |
|---|
| 3639 | ! 1.2 Define variables and attributes |
|---|
| 3640 | ! |
|---|
| 3641 | IF ( INDEX(gridtype, "regular") == 1 ) THEN |
|---|
| 3642 | ! |
|---|
| 3643 | ! 1.2.1 regular grid |
|---|
| 3644 | ! |
|---|
| 3645 | lon_name = 'lon' |
|---|
| 3646 | ! |
|---|
| 3647 | iret = NF90_DEF_VAR(fid, lon_name, kind_r_diag, dims(1), nlonid) |
|---|
| 3648 | IF (iret /= NF90_NOERR) THEN |
|---|
| 3649 | CALL ipslerr_p (3,'routing_diagncfile', 'Variable '//lon_name//' can not be defined for the file : ', & |
|---|
| 3650 | & TRIM(river_file_name),'(Solution ?)') |
|---|
| 3651 | ENDIF |
|---|
| 3652 | ! |
|---|
| 3653 | lat_name = 'lat' |
|---|
| 3654 | iret = NF90_DEF_VAR(fid, lat_name, kind_r_diag, dims(2), nlatid) |
|---|
| 3655 | IF (iret /= NF90_NOERR) THEN |
|---|
| 3656 | CALL ipslerr_p (3,'routing_diagncfile', 'Variable '//lat_name//' can not be defined for the file : ', & |
|---|
| 3657 | & TRIM(river_file_name),'(Solution ?)') |
|---|
| 3658 | ENDIF |
|---|
| 3659 | ! |
|---|
| 3660 | ELSE |
|---|
| 3661 | ! |
|---|
| 3662 | ! 1.2.2 irregular grid |
|---|
| 3663 | ! |
|---|
| 3664 | lon_name = 'nav_lon' |
|---|
| 3665 | ! |
|---|
| 3666 | iret = NF90_DEF_VAR(fid, lon_name, kind_r_diag, dims, nlonid) |
|---|
| 3667 | IF (iret /= NF90_NOERR) THEN |
|---|
| 3668 | CALL ipslerr_p (3,'routing_diagncfile', 'Variable '//lon_name//' can not be defined for the file : ', & |
|---|
| 3669 | & TRIM(river_file_name),'(Solution ?)') |
|---|
| 3670 | ENDIF |
|---|
| 3671 | ! |
|---|
| 3672 | lat_name = 'nav_lat' |
|---|
| 3673 | iret = NF90_DEF_VAR(fid, lat_name, kind_r_diag, dims, nlatid) |
|---|
| 3674 | IF (iret /= NF90_NOERR) THEN |
|---|
| 3675 | CALL ipslerr_p (3,'routing_diagncfile', 'Variable '//lat_name//' can not be defined for the file : ', & |
|---|
| 3676 | & TRIM(river_file_name),'(Solution ?)') |
|---|
| 3677 | ENDIF |
|---|
| 3678 | ! |
|---|
| 3679 | ENDIF |
|---|
| 3680 | ! |
|---|
| 3681 | ! 1.3 Add attributes to the coordinate variables |
|---|
| 3682 | ! |
|---|
| 3683 | iret = NF90_PUT_ATT(fid, nlonid, 'units', "degrees_east") |
|---|
| 3684 | IF (iret /= NF90_NOERR) THEN |
|---|
| 3685 | CALL ipslerr_p (3,'routing_diagncfile', 'Could not add attribut to variable '//lon_name//' for the file :', & |
|---|
| 3686 | & TRIM(river_file_name),'(Solution ?)') |
|---|
| 3687 | ENDIF |
|---|
| 3688 | ! |
|---|
| 3689 | lon_min = -180. |
|---|
| 3690 | lon_max = 180. |
|---|
| 3691 | ! |
|---|
| 3692 | iret = NF90_PUT_ATT(fid, nlonid, 'valid_min', lon_min) |
|---|
| 3693 | IF (iret /= NF90_NOERR) THEN |
|---|
| 3694 | CALL ipslerr_p (3,'routing_diagncfile', 'Could not add attribut to variable '//lon_name//' for the file :', & |
|---|
| 3695 | & TRIM(river_file_name),'(Solution ?)') |
|---|
| 3696 | ENDIF |
|---|
| 3697 | iret = NF90_PUT_ATT(fid, nlonid, 'valid_max', lon_max) |
|---|
| 3698 | IF (iret /= NF90_NOERR) THEN |
|---|
| 3699 | CALL ipslerr_p (3,'routing_diagncfile', 'Could not add attribut to variable '//lon_name//' for the file :', & |
|---|
| 3700 | & TRIM(river_file_name),'(Solution ?)') |
|---|
| 3701 | ENDIF |
|---|
| 3702 | ! |
|---|
| 3703 | iret = NF90_PUT_ATT(fid, nlonid, 'long_name', "Longitude") |
|---|
| 3704 | IF (iret /= NF90_NOERR) THEN |
|---|
| 3705 | CALL ipslerr_p (3,'routing_diagncfile', 'Could not add attribut to variable '//lon_name//' for the file :', & |
|---|
| 3706 | & TRIM(river_file_name),'(Solution ?)') |
|---|
| 3707 | ENDIF |
|---|
| 3708 | iret = NF90_PUT_ATT(fid, nlatid, 'units', "degrees_north") |
|---|
| 3709 | IF (iret /= NF90_NOERR) THEN |
|---|
| 3710 | CALL ipslerr_p (3,'routing_diagncfile', 'Could not add attribut to variable '//lat_name//' for the file :', & |
|---|
| 3711 | & TRIM(river_file_name),'(Solution ?)') |
|---|
| 3712 | ENDIF |
|---|
| 3713 | ! |
|---|
| 3714 | lat_max = 90. |
|---|
| 3715 | lat_min = -90. |
|---|
| 3716 | ! |
|---|
| 3717 | iret = NF90_PUT_ATT(fid, nlatid, 'valid_min', lat_min) |
|---|
| 3718 | IF (iret /= NF90_NOERR) THEN |
|---|
| 3719 | CALL ipslerr_p (3,'routing_diagncfile', 'Could not add attribut to variable '//lat_name//' for the file :', & |
|---|
| 3720 | & TRIM(river_file_name),'(Solution ?)') |
|---|
| 3721 | ENDIF |
|---|
| 3722 | iret = NF90_PUT_ATT(fid, nlatid, 'valid_max', lat_max) |
|---|
| 3723 | IF (iret /= NF90_NOERR) THEN |
|---|
| 3724 | CALL ipslerr_p (3,'routing_diagncfile', 'Could not add attribut to variable '//lat_name//' for the file :', & |
|---|
| 3725 | & TRIM(river_file_name),'(Solution ?)') |
|---|
| 3726 | ENDIF |
|---|
| 3727 | iret = NF90_PUT_ATT(fid, nlatid, 'long_name', "Latitude") |
|---|
| 3728 | IF (iret /= NF90_NOERR) THEN |
|---|
| 3729 | CALL ipslerr_p (3,'routing_diagncfile', 'Could not add attribut to variable '//lat_name//' for the file :', & |
|---|
| 3730 | & TRIM(river_file_name),'(Solution ?)') |
|---|
| 3731 | ENDIF |
|---|
| 3732 | ! |
|---|
| 3733 | iret = NF90_ENDDEF(fid) |
|---|
| 3734 | IF (iret /= NF90_NOERR) THEN |
|---|
| 3735 | CALL ipslerr_p (3,'routing_diagncfile', 'Could not end definitions in the file : ', & |
|---|
| 3736 | & TRIM(river_file_name),'(Solution ?)') |
|---|
| 3737 | ENDIF |
|---|
| 3738 | ! |
|---|
| 3739 | ! 1.4 Write coordinates |
|---|
| 3740 | ! |
|---|
| 3741 | IF ( INDEX(gridtype, "regular") == 1 ) THEN |
|---|
| 3742 | ! |
|---|
| 3743 | ! 1.4.1 regular grid |
|---|
| 3744 | ! |
|---|
| 3745 | iret = NF90_PUT_VAR(fid, nlonid, lon_g(1:iim_g,1)) |
|---|
| 3746 | IF (iret /= NF90_NOERR) THEN |
|---|
| 3747 | CALL ipslerr_p (3,'routing_diagncfile', 'Could not put variable nav_lon in the file : ', & |
|---|
| 3748 | & TRIM(river_file_name),'(Solution ?)') |
|---|
| 3749 | ENDIF |
|---|
| 3750 | ! |
|---|
| 3751 | iret = NF90_PUT_VAR(fid, nlatid, lat_g(1,1:jjm_g)) |
|---|
| 3752 | IF (iret /= NF90_NOERR) THEN |
|---|
| 3753 | CALL ipslerr_p (3,'routing_diagncfile', 'Could not put variable nav_lat in the file : ', & |
|---|
| 3754 | & TRIM(river_file_name),'(Solution ?)') |
|---|
| 3755 | ENDIF |
|---|
| 3756 | ELSE |
|---|
| 3757 | ! |
|---|
| 3758 | ! 1.4.2 irregular grid |
|---|
| 3759 | ! |
|---|
| 3760 | iret = NF90_PUT_VAR(fid, nlonid, lon_g) |
|---|
| 3761 | IF (iret /= NF90_NOERR) THEN |
|---|
| 3762 | CALL ipslerr_p (3,'routing_diagncfile', 'Could not put variable nav_lon in the file : ', & |
|---|
| 3763 | & TRIM(river_file_name),'(Solution ?)') |
|---|
| 3764 | ENDIF |
|---|
| 3765 | ! |
|---|
| 3766 | iret = NF90_PUT_VAR(fid, nlatid, lat_g) |
|---|
| 3767 | IF (iret /= NF90_NOERR) THEN |
|---|
| 3768 | CALL ipslerr_p (3,'routing_diagncfile', 'Could not put variable nav_lat in the file : ', & |
|---|
| 3769 | & TRIM(river_file_name),'(Solution ?)') |
|---|
| 3770 | ENDIF |
|---|
| 3771 | ENDIF |
|---|
| 3772 | ! |
|---|
| 3773 | ! 2.0 Go through all basins and wirte the information into the netCDF file. |
|---|
| 3774 | ! |
|---|
| 3775 | DO icc = 1, num_largest |
|---|
| 3776 | ! |
|---|
| 3777 | ! 2.1 Compute the fields to be saved in the file |
|---|
| 3778 | ! |
|---|
| 3779 | ib=sortedrivs(icc) |
|---|
| 3780 | ! |
|---|
| 3781 | ! |
|---|
| 3782 | IF ( nb_pts(ib) > 2 ) THEN |
|---|
| 3783 | ! |
|---|
| 3784 | basinfrac(:,:) = zero |
|---|
| 3785 | basinuparea(:,:) = zero |
|---|
| 3786 | basincode(:,:) = zero |
|---|
| 3787 | ! |
|---|
| 3788 | DO ij=1, nb_pts(ib) |
|---|
| 3789 | |
|---|
| 3790 | ik=lbasin_index(ib,ij) |
|---|
| 3791 | |
|---|
| 3792 | j = ((index_g(ik)-1)/iim_g) + 1 |
|---|
| 3793 | i = (index_g(ik)-(j-1)*iim_g) |
|---|
| 3794 | |
|---|
| 3795 | basinfrac(i,j) = basinfrac(i,j) + lbasin_area(ib,ij)/(resolution_g(ik,1)*resolution_g(ik,2)) |
|---|
| 3796 | basinuparea(i,j) = MAX(basinuparea(i,j), lbasin_uparea(ib,ij)) |
|---|
| 3797 | basincode(i,j) = lrivercode(ib,ij) |
|---|
| 3798 | |
|---|
| 3799 | ENDDO |
|---|
| 3800 | ! |
|---|
| 3801 | DO i=1,iim_g |
|---|
| 3802 | DO j=1,jjm_g |
|---|
| 3803 | IF ( basinfrac(i,j) <= EPSILON(zero) ) THEN |
|---|
| 3804 | basinfrac(i,j) = undef_sechiba |
|---|
| 3805 | basinuparea(i,j) = undef_sechiba |
|---|
| 3806 | basincode(i,j) = undef_int |
|---|
| 3807 | ELSE |
|---|
| 3808 | basinfrac(i,j) = MIN(basinfrac(i,j), un) |
|---|
| 3809 | ENDIF |
|---|
| 3810 | ENDDO |
|---|
| 3811 | ENDDO |
|---|
| 3812 | ! |
|---|
| 3813 | ! |
|---|
| 3814 | ! 2.2 Define the variables in the netCDF file |
|---|
| 3815 | ! |
|---|
| 3816 | iret = NF90_REDEF(fid) |
|---|
| 3817 | IF (iret /= NF90_NOERR) THEN |
|---|
| 3818 | CALL ipslerr_p (3,'routing_diagncfile', & |
|---|
| 3819 | & 'Could not restart definitions in the file : ', & |
|---|
| 3820 | & TRIM(river_file_name),'(Solution ?)') |
|---|
| 3821 | ENDIF |
|---|
| 3822 | ! |
|---|
| 3823 | ! Create a name more suitable for a variable in a netCDF file |
|---|
| 3824 | ! |
|---|
| 3825 | nc_name = TRIM(sorted_names(icc)) |
|---|
| 3826 | ! Take out all character which could cause problems |
|---|
| 3827 | lcc=LEN_TRIM(nc_name) |
|---|
| 3828 | DO ij=1,lcc |
|---|
| 3829 | IF ( nc_name(ij:ij) == " " ) nc_name(ij:ij) = "_" |
|---|
| 3830 | IF ( nc_name(ij:ij) == "(" ) nc_name(ij:ij) = "_" |
|---|
| 3831 | IF ( nc_name(ij:ij) == ")" ) nc_name(ij:ij) = "_" |
|---|
| 3832 | ENDDO |
|---|
| 3833 | ! reduce redundant "__" |
|---|
| 3834 | DO ij=1,lcc |
|---|
| 3835 | IF ( nc_name(ij:ij+1) == "__" ) nc_name(ij+1:)=nc_name(ij+2:lcc) |
|---|
| 3836 | ENDDO |
|---|
| 3837 | lcc=LEN_TRIM(nc_name) |
|---|
| 3838 | IF ( nc_name(lcc:lcc) == "_" ) nc_name(lcc:lcc) = " " |
|---|
| 3839 | ! |
|---|
| 3840 | ! |
|---|
| 3841 | ! 2.3 Fraction variable |
|---|
| 3842 | ! |
|---|
| 3843 | IF (check) WRITE(numout,*) "Define Fraction variable and add attributes" |
|---|
| 3844 | ! |
|---|
| 3845 | var_name = TRIM(nc_name)//"_frac" |
|---|
| 3846 | ! |
|---|
| 3847 | iret = NF90_DEF_VAR(fid, TRIM(var_name), kind_r_diag, dims, varid) |
|---|
| 3848 | IF (iret /= NF90_NOERR) THEN |
|---|
| 3849 | CALL ipslerr_p (3,'routing_diagncfile', 'Variable '//TRIM(var_name)//' can not be defined for the file : ', & |
|---|
| 3850 | & TRIM(river_file_name),'(Solution ?)') |
|---|
| 3851 | ENDIF |
|---|
| 3852 | ! |
|---|
| 3853 | ierr_tot = 0 |
|---|
| 3854 | ! Units |
|---|
| 3855 | iret = NF90_PUT_ATT(fid, varid, 'units', "-") |
|---|
| 3856 | IF (iret /= NF90_NOERR) THEN |
|---|
| 3857 | WRITE(numout,*) 'Units', iret |
|---|
| 3858 | WRITE(numout,*) TRIM(NF90_STRERROR(iret)) |
|---|
| 3859 | ierr_tot = ierr_tot + 1 |
|---|
| 3860 | ENDIF |
|---|
| 3861 | ! Long name |
|---|
| 3862 | long_name = "Fraction of basin "//TRIM(sorted_names(icc))//" per grid box" |
|---|
| 3863 | iret = NF90_PUT_ATT(fid, varid, 'long_name', long_name) |
|---|
| 3864 | IF (iret /= NF90_NOERR) THEN |
|---|
| 3865 | WRITE(numout,*) 'Long_Name', long_name, iret |
|---|
| 3866 | WRITE(numout,*) TRIM(NF90_STRERROR(iret)) |
|---|
| 3867 | ierr_tot = ierr_tot + 1 |
|---|
| 3868 | ENDIF |
|---|
| 3869 | ! Missing value |
|---|
| 3870 | iret = NF90_PUT_ATT(fid, varid, 'missing_value', undef_sechiba) |
|---|
| 3871 | IF (iret /= NF90_NOERR) THEN |
|---|
| 3872 | WRITE(numout,*) 'Missing value', undef_sechiba, iret |
|---|
| 3873 | WRITE(numout,*) TRIM(NF90_STRERROR(iret)) |
|---|
| 3874 | ierr_tot = ierr_tot + 1 |
|---|
| 3875 | ENDIF |
|---|
| 3876 | ! |
|---|
| 3877 | ib=sortedrivs(icc) |
|---|
| 3878 | IF ( check ) WRITE(numout,*) "Doing basin ", icc," corrsdponding to index = ", ib, "num_largest : ", num_largest |
|---|
| 3879 | ! |
|---|
| 3880 | ! Nb of grid points in basin |
|---|
| 3881 | att_str='Nb_of_grid_points_in_basin' |
|---|
| 3882 | iret = NF90_PUT_ATT(fid, varid, att_str, nb_pts(ib)) |
|---|
| 3883 | IF (iret /= NF90_NOERR) THEN |
|---|
| 3884 | WRITE(numout,*) 'Nb of grid points in basin', nb_pts(ib), iret |
|---|
| 3885 | WRITE(numout,*) TRIM(NF90_STRERROR(iret)) |
|---|
| 3886 | ierr_tot = ierr_tot + 1 |
|---|
| 3887 | ENDIF |
|---|
| 3888 | ! |
|---|
| 3889 | ! Longitude of outflow point |
|---|
| 3890 | att_str='Longitude_of_outflow_point' |
|---|
| 3891 | iret = NF90_PUT_ATT(fid, varid, att_str, lalo(outpt(ib,1),2)) |
|---|
| 3892 | IF (iret /= NF90_NOERR) THEN |
|---|
| 3893 | WRITE(numout,*) 'Longitude of outflow point', lalo(outpt(ib,1),2), iret |
|---|
| 3894 | WRITE(numout,*) TRIM(NF90_STRERROR(iret)) |
|---|
| 3895 | ierr_tot = ierr_tot + 1 |
|---|
| 3896 | ENDIF |
|---|
| 3897 | ! |
|---|
| 3898 | ! Latitide of outflow point |
|---|
| 3899 | att_str='Latitude_of_outflow_point' |
|---|
| 3900 | iret = NF90_PUT_ATT(fid, varid, att_str, lalo(outpt(ib,1),1)) |
|---|
| 3901 | IF (iret /= NF90_NOERR) THEN |
|---|
| 3902 | WRITE(numout,*) 'Latitude of outflow point', lalo(outpt(ib,1),1), iret |
|---|
| 3903 | WRITE(numout,*) TRIM(NF90_STRERROR(iret)) |
|---|
| 3904 | ierr_tot = ierr_tot + 1 |
|---|
| 3905 | ENDIF |
|---|
| 3906 | ! |
|---|
| 3907 | ! Number of streams |
|---|
| 3908 | att_str= 'Number_of_streams' |
|---|
| 3909 | iret = NF90_PUT_ATT(fid, varid, att_str, streams_nb(ib)) |
|---|
| 3910 | IF (iret /= NF90_NOERR) THEN |
|---|
| 3911 | WRITE(numout,*) 'Number of streams', streams_nb(ib), iret |
|---|
| 3912 | WRITE(numout,*) TRIM(NF90_STRERROR(iret)) |
|---|
| 3913 | ierr_tot = ierr_tot + 1 |
|---|
| 3914 | ENDIF |
|---|
| 3915 | ! |
|---|
| 3916 | ! Total number of hops to go to the oceans |
|---|
| 3917 | att_str='Total_number_of_hops_to_ocean' |
|---|
| 3918 | iret = NF90_PUT_ATT(fid, varid, att_str, streams_avehops(ib)*streams_nb(ib)) |
|---|
| 3919 | IF (iret /= NF90_NOERR) THEN |
|---|
| 3920 | WRITE(numout,*) 'Total number of hops to go to the oceans ', streams_avehops(ib)*streams_nb(ib), iret |
|---|
| 3921 | ierr_tot = ierr_tot + 1 |
|---|
| 3922 | ENDIF |
|---|
| 3923 | ! |
|---|
| 3924 | ! Minimum number of hops to go to the ocean for any stream |
|---|
| 3925 | att_str='Minimum_number_of_hops_to_ocean_for_any_stream' |
|---|
| 3926 | iret = NF90_PUT_ATT(fid, varid, att_str, streams_minhops(ib)) |
|---|
| 3927 | IF (iret /= NF90_NOERR) THEN |
|---|
| 3928 | WRITE(numout,*) 'Minimum number of hops to go tp the ocean for any stream', streams_minhops(ib), iret |
|---|
| 3929 | ierr_tot = ierr_tot + 1 |
|---|
| 3930 | ENDIF |
|---|
| 3931 | ! |
|---|
| 3932 | ! Average number of hops to go to the ocean for any stream |
|---|
| 3933 | att_str='Average_number_of_hops_to_ocean_for_any_stream' |
|---|
| 3934 | iret = NF90_PUT_ATT(fid, varid, att_str, streams_avehops(ib)) |
|---|
| 3935 | IF (iret /= NF90_NOERR) THEN |
|---|
| 3936 | WRITE(numout,*) 'Average number of hops to go tp the ocean for any stream', streams_avehops(ib), iret |
|---|
| 3937 | ierr_tot = ierr_tot + 1 |
|---|
| 3938 | ENDIF |
|---|
| 3939 | ! |
|---|
| 3940 | ! Maximum number of hops to go to the ocean for any stream |
|---|
| 3941 | att_str='Maximum_number_of_hops_to_ocean_for_any_stream' |
|---|
| 3942 | iret = NF90_PUT_ATT(fid, varid, att_str, streams_maxhops(ib)) |
|---|
| 3943 | IF (iret /= NF90_NOERR) THEN |
|---|
| 3944 | WRITE(numout,*) 'Maximum number of hops to go tp the ocean for any stream', streams_maxhops(ib), iret |
|---|
| 3945 | ierr_tot = ierr_tot + 1 |
|---|
| 3946 | ENDIF |
|---|
| 3947 | ! |
|---|
| 3948 | ! Average residence time in the basin |
|---|
| 3949 | att_str='Average_residence_time_in_basin' |
|---|
| 3950 | iret = NF90_PUT_ATT(fid, varid, att_str, streams_resid(ib)) |
|---|
| 3951 | IF (iret /= NF90_NOERR) THEN |
|---|
| 3952 | WRITE(numout,*) 'Average residence time in the basin', streams_resid(ib), iret |
|---|
| 3953 | ierr_tot = ierr_tot + 1 |
|---|
| 3954 | ENDIF |
|---|
| 3955 | ! |
|---|
| 3956 | IF (ierr_tot > 0 ) THEN |
|---|
| 3957 | CALL ipslerr_p (3,'routing_diagncfile', 'Could not add some attributes to variable '//var_name//' for the file :', & |
|---|
| 3958 | & TRIM(river_file_name),'(Solution ?)') |
|---|
| 3959 | ENDIF |
|---|
| 3960 | ! |
|---|
| 3961 | ! 2.4 Upstream area variable variable |
|---|
| 3962 | ! |
|---|
| 3963 | IF (check) WRITE(numout,*) "Define Upstream variable and add attributes" |
|---|
| 3964 | ! |
|---|
| 3965 | ! Create a name more suitable for a variable in a netCDF file |
|---|
| 3966 | ! |
|---|
| 3967 | var_name = TRIM(nc_name)//"_upstream" |
|---|
| 3968 | DO ij=1,LEN_TRIM(var_name) |
|---|
| 3969 | IF ( var_name(ij:ij) == " " ) var_name(ij:ij) = "_" |
|---|
| 3970 | ENDDO |
|---|
| 3971 | ! |
|---|
| 3972 | iret = NF90_DEF_VAR(fid, TRIM(var_name), kind_r_diag, dims, varid2) |
|---|
| 3973 | IF (iret /= NF90_NOERR) THEN |
|---|
| 3974 | CALL ipslerr_p (3,'routing_diagncfile', 'Variable '//TRIM(var_name)//' can not be defined for the file : ', & |
|---|
| 3975 | & TRIM(river_file_name),'(Solution ?)') |
|---|
| 3976 | ENDIF |
|---|
| 3977 | ! |
|---|
| 3978 | ierr_tot = 0 |
|---|
| 3979 | ! Units |
|---|
| 3980 | iret = NF90_PUT_ATT(fid, varid2, 'units', "m^2") |
|---|
| 3981 | IF (iret /= NF90_NOERR) ierr_tot = ierr_tot + 1 |
|---|
| 3982 | ! Long name |
|---|
| 3983 | long_name = "Upstream area of basin "//TRIM(sorted_names(icc))//" in the grid box" |
|---|
| 3984 | iret = NF90_PUT_ATT(fid, varid2, 'long_name', long_name) |
|---|
| 3985 | IF (iret /= NF90_NOERR) ierr_tot = ierr_tot + 1 |
|---|
| 3986 | ! Missing value |
|---|
| 3987 | iret = NF90_PUT_ATT(fid, varid2, 'missing_value', undef_sechiba) |
|---|
| 3988 | IF (iret /= NF90_NOERR) ierr_tot = ierr_tot + 1 |
|---|
| 3989 | ! |
|---|
| 3990 | IF (ierr_tot > 0 ) THEN |
|---|
| 3991 | CALL ipslerr_p (3,'routing_diagncfile', 'Could not add some attributes to variable '//var_name//' for the file :', & |
|---|
| 3992 | & TRIM(river_file_name),'(Solution ?)') |
|---|
| 3993 | ENDIF |
|---|
| 3994 | ! |
|---|
| 3995 | ! 2.5 Pfafstetter codes for basins |
|---|
| 3996 | ! |
|---|
| 3997 | IF (check) WRITE(numout,*) "Define Pfafstetter codes variable and add attributes" |
|---|
| 3998 | ! |
|---|
| 3999 | var_name = TRIM(nc_name)//"_coding" |
|---|
| 4000 | DO ij=1,LEN_TRIM(var_name) |
|---|
| 4001 | IF ( var_name(ij:ij) == " " ) var_name(ij:ij) = "_" |
|---|
| 4002 | ENDDO |
|---|
| 4003 | ! |
|---|
| 4004 | iret = NF90_DEF_VAR(fid, TRIM(var_name), kind_i_diag, dims, varid3) |
|---|
| 4005 | IF (iret /= NF90_NOERR) THEN |
|---|
| 4006 | CALL ipslerr_p (3,'routing_diagncfile', 'Variable '//TRIM(var_name)//' can not be defined for the file : ', & |
|---|
| 4007 | & TRIM(river_file_name),'(Solution ?)') |
|---|
| 4008 | ENDIF |
|---|
| 4009 | ! |
|---|
| 4010 | ierr_tot = 0 |
|---|
| 4011 | ! Units |
|---|
| 4012 | iret = NF90_PUT_ATT(fid, varid3, 'units', "-") |
|---|
| 4013 | IF (iret /= NF90_NOERR) ierr_tot = ierr_tot + 1 |
|---|
| 4014 | ! Long name |
|---|
| 4015 | long_name = "Pfafstetter codes of grid boxes in basin "//TRIM(sorted_names(icc)) |
|---|
| 4016 | iret = NF90_PUT_ATT(fid, varid3, 'long_name', long_name) |
|---|
| 4017 | IF (iret /= NF90_NOERR) ierr_tot = ierr_tot + 1 |
|---|
| 4018 | ! Missing value |
|---|
| 4019 | iret = NF90_PUT_ATT(fid, varid3, 'missing_value', undef_int) |
|---|
| 4020 | IF (iret /= NF90_NOERR) ierr_tot = ierr_tot + 1 |
|---|
| 4021 | ! |
|---|
| 4022 | IF (ierr_tot > 0 ) THEN |
|---|
| 4023 | CALL ipslerr_p (3,'routing_diagncfile', 'Could not add some attributes to variable '//var_name//' for the file :', & |
|---|
| 4024 | & TRIM(river_file_name),'(Solution ?)') |
|---|
| 4025 | ENDIF |
|---|
| 4026 | ! |
|---|
| 4027 | ! 2.6 ENDDEF of netCDF file |
|---|
| 4028 | ! |
|---|
| 4029 | IF (check) WRITE(numout,*) "END define" |
|---|
| 4030 | ! |
|---|
| 4031 | iret = NF90_ENDDEF(fid) |
|---|
| 4032 | IF (iret /= NF90_NOERR) THEN |
|---|
| 4033 | CALL ipslerr_p (3,'routing_diagncfile', & |
|---|
| 4034 | & 'Could not end definitions in the file : ', & |
|---|
| 4035 | & TRIM(river_file_name),'(Solution ?)') |
|---|
| 4036 | ENDIF |
|---|
| 4037 | ! |
|---|
| 4038 | ! 2.7 Write the data to the file |
|---|
| 4039 | ! |
|---|
| 4040 | IF (check) WRITE(numout,*) "Put basinfrac" |
|---|
| 4041 | iret = NF90_PUT_VAR(fid, varid, basinfrac) |
|---|
| 4042 | IF (iret /= NF90_NOERR) THEN |
|---|
| 4043 | CALL ipslerr_p (3,'routing_diagncfile', 'Could not put variable basinfrac in the file : ', & |
|---|
| 4044 | & TRIM(river_file_name),'(Solution ?)') |
|---|
| 4045 | ENDIF |
|---|
| 4046 | |
|---|
| 4047 | IF (check) WRITE(numout,*) "Put basinuparea" |
|---|
| 4048 | iret = NF90_PUT_VAR(fid, varid2, basinuparea) |
|---|
| 4049 | IF (iret /= NF90_NOERR) THEN |
|---|
| 4050 | CALL ipslerr_p (3,'routing_diagncfile', 'Could not put variable basinuparea in the file : ', & |
|---|
| 4051 | & TRIM(river_file_name),'(Solution ?)') |
|---|
| 4052 | ENDIF |
|---|
| 4053 | |
|---|
| 4054 | IF (check) WRITE(numout,*) "Put basincode" |
|---|
| 4055 | iret = NF90_PUT_VAR(fid, varid3, basincode) |
|---|
| 4056 | IF (iret /= NF90_NOERR) THEN |
|---|
| 4057 | CALL ipslerr_p (3,'routing_diagfile', 'Could not put variable basincode in the file : ', & |
|---|
| 4058 | & TRIM(river_file_name),'(Solution ?)') |
|---|
| 4059 | ENDIF |
|---|
| 4060 | ! |
|---|
| 4061 | ENDIF |
|---|
| 4062 | ! |
|---|
| 4063 | ENDDO |
|---|
| 4064 | ! |
|---|
| 4065 | IF (check) WRITE(numout,*) "Close file" |
|---|
| 4066 | ! |
|---|
| 4067 | ! Close netCDF file and do some memory management. |
|---|
| 4068 | ! |
|---|
| 4069 | iret = NF90_CLOSE(fid) |
|---|
| 4070 | IF (iret /= NF90_NOERR) THEN |
|---|
| 4071 | CALL ipslerr_p (3,'routing_diagncfile', & |
|---|
| 4072 | & 'Could not end definitions in the file : ', & |
|---|
| 4073 | & TRIM(river_file_name),'(Solution ?)') |
|---|
| 4074 | ENDIF |
|---|
| 4075 | ! |
|---|
| 4076 | ! |
|---|
| 4077 | END SUBROUTINE routing_diagncfile |
|---|
| 4078 | ! |
|---|
| 4079 | !! ================================================================================================================================ |
|---|
| 4080 | !! SUBROUTINE : routing_basins_p |
|---|
| 4081 | !! |
|---|
| 4082 | !>\BRIEF This parallelized subroutine computes the routing map if needed. |
|---|
| 4083 | !! |
|---|
| 4084 | !! DESCRIPTION (definitions, functional, design, flags) : None |
|---|
| 4085 | !! |
|---|
| 4086 | !! RECENT CHANGE(S): None |
|---|
| 4087 | !! |
|---|
| 4088 | !! MAIN OUTPUT VARIABLE(S): |
|---|
| 4089 | !! |
|---|
| 4090 | !! REFERENCES : None |
|---|
| 4091 | !! |
|---|
| 4092 | !! FLOWCHART : None |
|---|
| 4093 | !! \n |
|---|
| 4094 | !_ ================================================================================================================================ |
|---|
| 4095 | |
|---|
| 4096 | SUBROUTINE routing_basins_p(nbpt, lalo, neighbours, resolution, contfrac) |
|---|
| 4097 | ! |
|---|
| 4098 | IMPLICIT NONE |
|---|
| 4099 | ! |
|---|
| 4100 | !! INPUT VARIABLES |
|---|
| 4101 | INTEGER(i_std), INTENT(in) :: nbpt !! Domain size (unitless) |
|---|
| 4102 | REAL(r_std), INTENT(in) :: lalo(nbpt,2) !! Vector of latitude and longitudes (beware of the order !) |
|---|
| 4103 | INTEGER(i_std), INTENT(in) :: neighbours(nbpt,NbNeighb) !! Vector of neighbours for each grid point (1=North and then clockwise) (unitless) |
|---|
| 4104 | REAL(r_std), INTENT(in) :: resolution(nbpt,2) !! The size of each grid box in X and Y (m) |
|---|
| 4105 | REAL(r_std), INTENT(in) :: contfrac(nbpt) !! Fraction of land in each grid box (unitless;0-1) |
|---|
| 4106 | |
|---|
| 4107 | !_ ================================================================================================================================ |
|---|
| 4108 | |
|---|
| 4109 | ! INTEGER(i_std) :: neighbours_tmp(nbpt,8) |
|---|
| 4110 | ! INTEGER(i_std) :: i,j |
|---|
| 4111 | |
|---|
| 4112 | ! DO i=1,nbp_loc |
|---|
| 4113 | ! DO j=1,NbNeighb |
|---|
| 4114 | ! IF (neighbours(i,j)==-1) THEN |
|---|
| 4115 | ! neighbours_tmp(i,j)=neighbours(i,j) |
|---|
| 4116 | ! ELSE |
|---|
| 4117 | ! neighbours_tmp(i,j)=neighbours(i,j)+nbp_para_begin(mpi_rank)-1 |
|---|
| 4118 | ! ENDIF |
|---|
| 4119 | ! ENDDO |
|---|
| 4120 | ! ENDDO |
|---|
| 4121 | |
|---|
| 4122 | routing_area => routing_area_glo |
|---|
| 4123 | topo_resid => topo_resid_glo |
|---|
| 4124 | route_togrid => route_togrid_glo |
|---|
| 4125 | route_tobasin => route_tobasin_glo |
|---|
| 4126 | route_nbintobas => route_nbintobas_glo |
|---|
| 4127 | global_basinid => global_basinid_glo |
|---|
| 4128 | |
|---|
| 4129 | IF (is_root_prc) CALL routing_basins(nbp_glo,lalo_g, neighbours_g, resolution_g, contfrac_g) |
|---|
| 4130 | |
|---|
| 4131 | routing_area => routing_area_loc |
|---|
| 4132 | topo_resid => topo_resid_loc |
|---|
| 4133 | route_togrid => route_togrid_loc |
|---|
| 4134 | route_tobasin => route_tobasin_loc |
|---|
| 4135 | route_nbintobas => route_nbintobas_loc |
|---|
| 4136 | global_basinid => global_basinid_loc |
|---|
| 4137 | |
|---|
| 4138 | CALL scatter(routing_area_glo,routing_area_loc) |
|---|
| 4139 | CALL scatter(topo_resid_glo,topo_resid_loc) |
|---|
| 4140 | CALL scatter(route_togrid_glo,route_togrid_loc) |
|---|
| 4141 | CALL scatter(route_tobasin_glo,route_tobasin_loc) |
|---|
| 4142 | CALL scatter(route_nbintobas_glo,route_nbintobas_loc) |
|---|
| 4143 | CALL scatter(global_basinid_glo,global_basinid_loc) |
|---|
| 4144 | |
|---|
| 4145 | END SUBROUTINE routing_basins_p |
|---|
| 4146 | ! |
|---|
| 4147 | |
|---|
| 4148 | !! ================================================================================================================================ |
|---|
| 4149 | !! SUBROUTINE : routing_basins |
|---|
| 4150 | !! |
|---|
| 4151 | !>\BRIEF This non-parallelized subroutine reads in the map of basins and flow direction to construct |
|---|
| 4152 | !! the catchments of each grid box. |
|---|
| 4153 | !! |
|---|
| 4154 | !! DESCRIPTION (definitions, functional, design, flags) : |
|---|
| 4155 | !! The work is done in a number of steps which are performed locally on the |
|---|
| 4156 | !! GCM grid: |
|---|
| 4157 | !! 1) First we find the grid-points of the high resolution routing grid which are |
|---|
| 4158 | !! within the coarser grid of the GCM. |
|---|
| 4159 | !! 2) When we have these grid points we decompose them into basins in the routine |
|---|
| 4160 | !! routing_findbasins. A number of simplifications are done if needed. |
|---|
| 4161 | !! 3) In the routine routing_globalize we put the basin information of this grid |
|---|
| 4162 | !! into the global fields. |
|---|
| 4163 | !! Then we work on the global grid to perform the following tasks : |
|---|
| 4164 | !! 1) We link up the basins of the various grid points and check the global consistency. |
|---|
| 4165 | !! 2) The area of each outflow point is computed. |
|---|
| 4166 | !! 3) The final step is to reduce the number of basins in order to fit into the truncation.\n |
|---|
| 4167 | !! |
|---|
| 4168 | !! RECENT CHANGE(S): None |
|---|
| 4169 | !! |
|---|
| 4170 | !! MAIN OUTPUT VARIABLE(S): None, as the routine puts information into the global variables of the module. |
|---|
| 4171 | !! |
|---|
| 4172 | !! REFERENCES : None |
|---|
| 4173 | !! |
|---|
| 4174 | !! FLOWCHART : None |
|---|
| 4175 | !! \n |
|---|
| 4176 | !_ ================================================================================================================================ |
|---|
| 4177 | |
|---|
| 4178 | SUBROUTINE routing_basins(nbpt, lalo, neighbours, resolution, contfrac) |
|---|
| 4179 | ! |
|---|
| 4180 | IMPLICIT NONE |
|---|
| 4181 | ! |
|---|
| 4182 | !! INPUT VARIABLES |
|---|
| 4183 | INTEGER(i_std), INTENT(in) :: nbpt !! Domain size (unitless) |
|---|
| 4184 | REAL(r_std), INTENT(in) :: lalo(nbpt,2) !! Vector of latitude and longitudes (beware of the order !) |
|---|
| 4185 | INTEGER(i_std), INTENT(in) :: neighbours(nbpt,NbNeighb)!! Vector of neighbours for each grid point |
|---|
| 4186 | !! (1=North and then cloxkwise) |
|---|
| 4187 | REAL(r_std), INTENT(in) :: resolution(nbpt,2) !! The size of each grid box in X and Y (m) |
|---|
| 4188 | REAL(r_std), INTENT(in) :: contfrac(nbpt) !! Fraction of land in each grid box (unitless;0-1) |
|---|
| 4189 | ! |
|---|
| 4190 | !! LOCAL VARIABLES |
|---|
| 4191 | CHARACTER(LEN=80) :: filename !! Name of the netcdf file (unitless) |
|---|
| 4192 | INTEGER(i_std) :: iml, jml, lml, tml, fid, ib, ip, jp, fopt !! Indices (unitless) |
|---|
| 4193 | REAL(r_std) :: lev(1), date, dt, coslat |
|---|
| 4194 | INTEGER(i_std) :: itau(1) !! |
|---|
| 4195 | REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: trip !! The trip field (unitless) |
|---|
| 4196 | REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: basins !! The basin field (unitless) |
|---|
| 4197 | REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: topoindex !! Topographic index of the residence time (m) |
|---|
| 4198 | REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: hierarchy !! |
|---|
| 4199 | REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: lat_rel !! |
|---|
| 4200 | REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: lon_rel !! |
|---|
| 4201 | ! |
|---|
| 4202 | INTEGER(i_std) :: nbi, nbj !! Number of point in x and y within the grid (unitless) |
|---|
| 4203 | REAL(r_std) :: min_topoind !! The current minimum of topographic index (m) |
|---|
| 4204 | REAL(r_std) :: max_basins !! |
|---|
| 4205 | REAL(r_std) :: invented_basins !! |
|---|
| 4206 | ! |
|---|
| 4207 | REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: area_bx !! Area of each small box in the grid box (m^2) |
|---|
| 4208 | REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: hierarchy_bx !! Level in the basin of the point |
|---|
| 4209 | REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: lon_bx !! |
|---|
| 4210 | REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: lat_bx !! |
|---|
| 4211 | REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: topoind_bx !! Topographic index of the residence time for each of the smaller boxes (m) |
|---|
| 4212 | INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:) :: trip_bx !! The trip field for each of the smaller boxes (unitless) |
|---|
| 4213 | INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:) :: basin_bx !! |
|---|
| 4214 | INTEGER(i_std), ALLOCATABLE, DIMENSION(:) :: coast_pts !! The coastal flow points (unitless) |
|---|
| 4215 | ! |
|---|
| 4216 | INTEGER(i_std), ALLOCATABLE, DIMENSION(:) :: basin_count !! |
|---|
| 4217 | INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:) :: basin_id !! |
|---|
| 4218 | REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: basin_area !! |
|---|
| 4219 | REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: basin_hierarchy !! |
|---|
| 4220 | REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: basin_topoind !! Topographic index of the residence time for a basin (m) |
|---|
| 4221 | REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: fetch_basin !! |
|---|
| 4222 | INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:) :: basin_flowdir !! Water flow directions in the basin (unitless) |
|---|
| 4223 | INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:) :: outflow_grid !! Type of outflow on the grid box (unitless) |
|---|
| 4224 | INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:) :: outflow_basin !! |
|---|
| 4225 | INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:) :: inflow_number !! |
|---|
| 4226 | INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:,:) :: inflow_basin !! |
|---|
| 4227 | INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:,:) :: inflow_grid !! |
|---|
| 4228 | INTEGER(i_std), ALLOCATABLE, DIMENSION(:) :: nbcoastal !! |
|---|
| 4229 | INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:) :: coastal_basin !! |
|---|
| 4230 | ! |
|---|
| 4231 | ! Interpolation help variables |
|---|
| 4232 | ! |
|---|
| 4233 | INTEGER(i_std) :: nix, njx !! |
|---|
| 4234 | CHARACTER(LEN=30) :: callsign !! |
|---|
| 4235 | REAL(r_std), ALLOCATABLE, DIMENSION(:,:,:) :: resol_lu !! Resolution |
|---|
| 4236 | INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:) :: mask !! Mask to exclude some points (unitless) |
|---|
| 4237 | REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: sub_area !! Area on the fine grid (m^2) |
|---|
| 4238 | INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:,:) :: sub_index !! Indices of the points we need on the fine grid (unitless) |
|---|
| 4239 | INTEGER(i_std), ALLOCATABLE, DIMENSION(:) :: sub_pts !! Number of high resolution points on this grid (unitless) |
|---|
| 4240 | INTEGER :: ALLOC_ERR !! |
|---|
| 4241 | LOGICAL :: ok_interpol = .FALSE. !! Flag for interpolation (true/false) |
|---|
| 4242 | ! |
|---|
| 4243 | INTEGER(i_std) :: nb_basin !! Number of sub-basins (unitless) |
|---|
| 4244 | INTEGER(i_std) :: nwbas !! |
|---|
| 4245 | INTEGER(i_std), ALLOCATABLE, DIMENSION(:) :: basin_inbxid !! |
|---|
| 4246 | INTEGER(i_std), ALLOCATABLE, DIMENSION(:) :: basin_sz !! |
|---|
| 4247 | INTEGER(i_std), ALLOCATABLE, DIMENSION(:) :: basin_bxout !! |
|---|
| 4248 | INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:,:) :: basin_pts !! |
|---|
| 4249 | CHARACTER(LEN=7) :: fmt !! |
|---|
| 4250 | LOGICAL :: debug = .FALSE. !! (true/false) |
|---|
| 4251 | ! |
|---|
| 4252 | INTEGER(i_std), DIMENSION(2) :: diagbox = (/ 1, 2 /) !! |
|---|
| 4253 | |
|---|
| 4254 | !_ ================================================================================================================================ |
|---|
| 4255 | ! |
|---|
| 4256 | ! |
|---|
| 4257 | IF ( .NOT. is_root_prc) THEN |
|---|
| 4258 | WRITE(numout,*) "is_root_prc = ", is_root_prc |
|---|
| 4259 | CALL ipslerr_p (3,'routing_basins', & |
|---|
| 4260 | & 'routing_basins is not suitable for running in parallel', & |
|---|
| 4261 | & 'We are here on a non root processor. ','(STOP from routing_basins)') |
|---|
| 4262 | ENDIF |
|---|
| 4263 | ! |
|---|
| 4264 | ! Test on diagbox and nbpt |
|---|
| 4265 | ! |
|---|
| 4266 | IF (debug) THEN |
|---|
| 4267 | IF (ANY(diagbox .GT. nbpt)) THEN |
|---|
| 4268 | WRITE(numout,*) "Debug diganostics : nbpt, diagbox", nbpt, diagbox |
|---|
| 4269 | call ipslerr_p(3,'routing_basin', & |
|---|
| 4270 | & 'Problem with diagbox in debug mode.', & |
|---|
| 4271 | & 'diagbox values can''t be greater than land points number.', & |
|---|
| 4272 | & '(decrease diagbox wrong value)') |
|---|
| 4273 | ENDIF |
|---|
| 4274 | ENDIF |
|---|
| 4275 | ! |
|---|
| 4276 | ! |
|---|
| 4277 | ! Needs to be a configurable variable |
|---|
| 4278 | ! |
|---|
| 4279 | ! |
|---|
| 4280 | !Config Key = ROUTING_FILE |
|---|
| 4281 | !Config Desc = Name of file which contains the routing information |
|---|
| 4282 | !Config If = RIVER_ROUTING |
|---|
| 4283 | !Config Def = routing.nc |
|---|
| 4284 | !Config Help = The file provided here should alow the routing module to |
|---|
| 4285 | !Config read the high resolution grid of basins and the flow direction |
|---|
| 4286 | !Config from one mesh to the other. |
|---|
| 4287 | !Config Units = [FILE] |
|---|
| 4288 | ! |
|---|
| 4289 | filename = 'routing.nc' |
|---|
| 4290 | CALL getin('ROUTING_FILE',filename) |
|---|
| 4291 | ! |
|---|
| 4292 | CALL flininfo(filename,iml, jml, lml, tml, fid) |
|---|
| 4293 | CALL flinclo(fid) |
|---|
| 4294 | ! |
|---|
| 4295 | ! soils_param.nc file is 1° soit texture file. |
|---|
| 4296 | ! |
|---|
| 4297 | ALLOCATE(lat_rel(iml,jml), STAT=ALLOC_ERR) |
|---|
| 4298 | IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for lat_rel','','') |
|---|
| 4299 | |
|---|
| 4300 | ALLOCATE(lon_rel(iml,jml), STAT=ALLOC_ERR) |
|---|
| 4301 | IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for lon_rel','','') |
|---|
| 4302 | |
|---|
| 4303 | ALLOCATE (trip(iml,jml), STAT=ALLOC_ERR) |
|---|
| 4304 | IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for trip','','') |
|---|
| 4305 | |
|---|
| 4306 | ALLOCATE (basins(iml,jml), STAT=ALLOC_ERR) |
|---|
| 4307 | IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for basins','','') |
|---|
| 4308 | |
|---|
| 4309 | ALLOCATE (topoindex(iml,jml), STAT=ALLOC_ERR) |
|---|
| 4310 | IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for topoindex','','') |
|---|
| 4311 | |
|---|
| 4312 | ALLOCATE (hierarchy(iml,jml), STAT=ALLOC_ERR) |
|---|
| 4313 | IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for hierarchy','','') |
|---|
| 4314 | |
|---|
| 4315 | ! |
|---|
| 4316 | CALL flinopen(filename, .FALSE., iml, jml, lml, lon_rel, lat_rel, lev, tml, itau, date, dt, fid) |
|---|
| 4317 | !! |
|---|
| 4318 | !! From the basin description data we will read the following variables : |
|---|
| 4319 | !! |
|---|
| 4320 | !! Trip : Provides the flow direction following the convention : |
|---|
| 4321 | !! trip = 1 : flow = N |
|---|
| 4322 | !! trip = 2 : flow = NE |
|---|
| 4323 | !! trip = 3 : flow = E |
|---|
| 4324 | !! trip = 4 : flow = SE |
|---|
| 4325 | !! trip = 5 : flow = S |
|---|
| 4326 | !! trip = 6 : flow = SW |
|---|
| 4327 | !! trip = 7 : flow = W |
|---|
| 4328 | !! trip = 8 : flow = NW |
|---|
| 4329 | !! trip = 97 : return flow into the ground |
|---|
| 4330 | !! trip = 98 : coastal flow (diffuse flow into the oceans) |
|---|
| 4331 | !! trip = 99 : river flow into the oceans |
|---|
| 4332 | !! |
|---|
| 4333 | !! Basins : Provides a uniqe ID for each basin. These IDs are also used to get |
|---|
| 4334 | !! the name of the basin from the table in routine routing_names. |
|---|
| 4335 | !! |
|---|
| 4336 | !! Topoind : is the topographic index for the retention time of the water in the |
|---|
| 4337 | !! grid box. It has been computed with the following formula : 1000 x sqrt(d^3/Dz) |
|---|
| 4338 | !! where d is the distance of the river from the current grid box to the next one |
|---|
| 4339 | !! as indicated by the variable trip. |
|---|
| 4340 | !! Dz the hight difference between between the two grid boxes. |
|---|
| 4341 | !! All these variables are in meters. |
|---|
| 4342 | !! Furthermore we have to limit the height difference to 5m in order to avoid any unpleasant |
|---|
| 4343 | !! surprises. If dz < 5m then dz=5. |
|---|
| 4344 | !! |
|---|
| 4345 | ! |
|---|
| 4346 | CALL flinget(fid, 'trip', iml, jml, lml, tml, 1, 1, trip) |
|---|
| 4347 | ! |
|---|
| 4348 | CALL flinget(fid, 'basins', iml, jml, lml, tml, 1, 1, basins) |
|---|
| 4349 | ! |
|---|
| 4350 | CALL flinget(fid, 'topoind', iml, jml, lml, tml, 1, 1, topoindex) |
|---|
| 4351 | ! |
|---|
| 4352 | CALL flinclo(fid) |
|---|
| 4353 | ! |
|---|
| 4354 | min_topoind = MINVAL(topoindex, MASK=topoindex .LT. undef_sechiba-un) |
|---|
| 4355 | ! |
|---|
| 4356 | DO ip=1,iml |
|---|
| 4357 | DO jp=1,jml |
|---|
| 4358 | IF ( trip(ip,jp) < 1.e10 .AND. topoindex(ip,jp) > 1.e10) THEN |
|---|
| 4359 | WRITE(numout,*) 'trip exists but not topoind :' |
|---|
| 4360 | WRITE(numout,*) 'ip, jp :', ip, jp |
|---|
| 4361 | WRITE(numout,*) 'trip, topoind : ', trip(ip,jp), topoindex(ip,jp) |
|---|
| 4362 | CALL ipslerr_p(3,'routing_basins','trip exists but not topoind','','') |
|---|
| 4363 | ENDIF |
|---|
| 4364 | ENDDO |
|---|
| 4365 | ENDDO |
|---|
| 4366 | |
|---|
| 4367 | ALLOCATE(resol_lu(iml,jml,2), STAT=ALLOC_ERR) |
|---|
| 4368 | IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for resol_lu','','') |
|---|
| 4369 | |
|---|
| 4370 | ALLOCATE(mask(iml,jml), STAT=ALLOC_ERR) |
|---|
| 4371 | IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for mask','','') |
|---|
| 4372 | ! |
|---|
| 4373 | ! Consider all points a priori |
|---|
| 4374 | ! |
|---|
| 4375 | mask(:,:) = 0 |
|---|
| 4376 | ! |
|---|
| 4377 | DO ip=1,iml |
|---|
| 4378 | DO jp=1,jml |
|---|
| 4379 | ! |
|---|
| 4380 | ! Determine the land mask of the basin map read from the file ROUTING_FILE |
|---|
| 4381 | ! |
|---|
| 4382 | IF ( trip(ip,jp) < 1.e10 ) THEN |
|---|
| 4383 | mask(ip,jp) = 1 |
|---|
| 4384 | ENDIF |
|---|
| 4385 | ! |
|---|
| 4386 | ! Resolution in longitude |
|---|
| 4387 | ! |
|---|
| 4388 | coslat = MAX( COS( lat_rel(ip,jp) * pi/180. ), mincos ) |
|---|
| 4389 | IF ( ip .EQ. 1 ) THEN |
|---|
| 4390 | resol_lu(ip,jp,1) = ABS( lon_rel(ip+1,jp) - lon_rel(ip,jp) ) * pi/180. * R_Earth * coslat |
|---|
| 4391 | ELSEIF ( ip .EQ. iml ) THEN |
|---|
| 4392 | resol_lu(ip,jp,1) = ABS( lon_rel(ip,jp) - lon_rel(ip-1,jp) ) * pi/180. * R_Earth * coslat |
|---|
| 4393 | ELSE |
|---|
| 4394 | resol_lu(ip,jp,1) = ABS( lon_rel(ip+1,jp) - lon_rel(ip-1,jp) )/2. * pi/180. * R_Earth * coslat |
|---|
| 4395 | ENDIF |
|---|
| 4396 | ! |
|---|
| 4397 | ! Resolution in latitude |
|---|
| 4398 | ! |
|---|
| 4399 | IF ( jp .EQ. 1 ) THEN |
|---|
| 4400 | resol_lu(ip,jp,2) = ABS( lat_rel(ip,jp) - lat_rel(ip,jp+1) ) * pi/180. * R_Earth |
|---|
| 4401 | ELSEIF ( jp .EQ. jml ) THEN |
|---|
| 4402 | resol_lu(ip,jp,2) = ABS( lat_rel(ip,jp-1) - lat_rel(ip,jp) ) * pi/180. * R_Earth |
|---|
| 4403 | ELSE |
|---|
| 4404 | resol_lu(ip,jp,2) = ABS( lat_rel(ip,jp-1) - lat_rel(ip,jp+1) )/2. * pi/180. * R_Earth |
|---|
| 4405 | ENDIF |
|---|
| 4406 | ! |
|---|
| 4407 | ENDDO |
|---|
| 4408 | ENDDO |
|---|
| 4409 | ! |
|---|
| 4410 | ! The maximum number of points of the source map (basin description here) which can fit into |
|---|
| 4411 | ! any grid point of the ORCHIDEE grid is stimated here. |
|---|
| 4412 | ! Some margin is taken. |
|---|
| 4413 | ! |
|---|
| 4414 | callsign = "routing_basins" |
|---|
| 4415 | ok_interpol = .FALSE. |
|---|
| 4416 | ! |
|---|
| 4417 | nix=INT(MAXVAL(resolution_g(:,1))/MAXVAL(resol_lu(:,:,1)))+2 |
|---|
| 4418 | njx=INT(MAXVAL(resolution_g(:,2))/MAXVAL(resol_lu(:,:,2)))+2 |
|---|
| 4419 | nbvmax = nix*njx*2 |
|---|
| 4420 | ! |
|---|
| 4421 | ! We are on the root processor here as this routine is not in parallel. So no need to broadcast. |
|---|
| 4422 | ! |
|---|
| 4423 | IF (printlev >=1) THEN |
|---|
| 4424 | WRITE(numout,*) "Projection arrays for ",callsign," : " |
|---|
| 4425 | WRITE(numout,*) "Routing : nbvmax = ", nbvmax |
|---|
| 4426 | END IF |
|---|
| 4427 | |
|---|
| 4428 | ALLOCATE (sub_area(nbpt,nbvmax), STAT=ALLOC_ERR) |
|---|
| 4429 | IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for sub_area','','') |
|---|
| 4430 | sub_area(:,:)=zero |
|---|
| 4431 | |
|---|
| 4432 | ALLOCATE (sub_index(nbpt,nbvmax,2), STAT=ALLOC_ERR) |
|---|
| 4433 | IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for sub_index','','') |
|---|
| 4434 | sub_index(:,:,:)=0 |
|---|
| 4435 | |
|---|
| 4436 | ALLOCATE (sub_pts(nbpt), STAT=ALLOC_ERR) |
|---|
| 4437 | IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for sub_pts','','') |
|---|
| 4438 | sub_pts(:)=0 |
|---|
| 4439 | ! |
|---|
| 4440 | ! routine aggregate will for each point of the ORCHIDEE grid determine which points |
|---|
| 4441 | ! of the source grid (basin definitions here) fit in there and which fraction of |
|---|
| 4442 | ! of the ORCHIDEE grid it represents. |
|---|
| 4443 | ! |
|---|
| 4444 | CALL aggregate(nbpt, lalo, neighbours, resolution, contfrac, & |
|---|
| 4445 | & iml, jml, lon_rel, lat_rel, mask, callsign, & |
|---|
| 4446 | & nbvmax, sub_index, sub_area, ok_interpol) |
|---|
| 4447 | ! |
|---|
| 4448 | WHERE (sub_area < 0) sub_area=zero |
|---|
| 4449 | ! |
|---|
| 4450 | ! Some verifications |
|---|
| 4451 | ! |
|---|
| 4452 | DO ib=1,nbpt |
|---|
| 4453 | sub_pts(ib) = COUNT(sub_area(ib,:) > zero) |
|---|
| 4454 | DO fopt=1,sub_pts(ib) |
|---|
| 4455 | IF (sub_area(ib, fopt) == 0 ) THEN |
|---|
| 4456 | WRITE(numout,*) "Zero Area - Sub_area > 0 : ", ib, fopt |
|---|
| 4457 | WRITE(numout,*) "Zero Area - lon : ",lalo(ib,2) |
|---|
| 4458 | WRITE(numout,*) "Zero Area - lon_rel : ", lon_rel(sub_index(ib, fopt, 1),sub_index(ib, fopt, 2)) |
|---|
| 4459 | WRITE(numout,*) "Zero Area - lat : ",lalo(ib,1) |
|---|
| 4460 | WRITE(numout,*) "Zero Area - lat_rel : ", lat_rel(sub_index(ib, fopt, 1),sub_index(ib, fopt, 2)) |
|---|
| 4461 | ENDIF |
|---|
| 4462 | ENDDO |
|---|
| 4463 | ENDDO |
|---|
| 4464 | ! |
|---|
| 4465 | ! Do some memory management. |
|---|
| 4466 | ! |
|---|
| 4467 | nwbas = MAX(MAXVAL(sub_pts), NbNeighb+1) |
|---|
| 4468 | ! |
|---|
| 4469 | ALLOCATE (area_bx(nbvmax,nbvmax), stat=ALLOC_ERR) |
|---|
| 4470 | IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for area_bx','','') |
|---|
| 4471 | ALLOCATE (hierarchy_bx(nbvmax,nbvmax), stat=ALLOC_ERR) |
|---|
| 4472 | IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for hierarchy_bx','','') |
|---|
| 4473 | ALLOCATE (lon_bx(nbvmax,nbvmax), stat=ALLOC_ERR) |
|---|
| 4474 | IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for lon_bx','','') |
|---|
| 4475 | ALLOCATE (lat_bx(nbvmax,nbvmax), stat=ALLOC_ERR) |
|---|
| 4476 | IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for lat_bx','','') |
|---|
| 4477 | ALLOCATE (topoind_bx(nbvmax,nbvmax), stat=ALLOC_ERR) |
|---|
| 4478 | IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for topoind_bx','','') |
|---|
| 4479 | ALLOCATE (trip_bx(nbvmax,nbvmax), stat=ALLOC_ERR) |
|---|
| 4480 | IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for trip_bx','','') |
|---|
| 4481 | ALLOCATE (basin_bx(nbvmax,nbvmax), stat=ALLOC_ERR) |
|---|
| 4482 | IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for basin_bx','','') |
|---|
| 4483 | ALLOCATE (coast_pts(nbvmax), stat=ALLOC_ERR) |
|---|
| 4484 | IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for coast_pts','','') |
|---|
| 4485 | ALLOCATE (basin_inbxid(nbvmax), stat=ALLOC_ERR) |
|---|
| 4486 | IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for basin_inbxid','','') |
|---|
| 4487 | ALLOCATE (basin_sz(nbvmax), stat=ALLOC_ERR) |
|---|
| 4488 | IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for basin_sz','','') |
|---|
| 4489 | ALLOCATE (basin_pts(nbvmax,nbvmax,2), stat=ALLOC_ERR) |
|---|
| 4490 | IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for basin_pts','','') |
|---|
| 4491 | ALLOCATE (basin_bxout(nbvmax), stat=ALLOC_ERR) |
|---|
| 4492 | IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for basin_bxout','','') |
|---|
| 4493 | ALLOCATE (basin_count(nbpt), stat=ALLOC_ERR) |
|---|
| 4494 | IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for basin_count','','') |
|---|
| 4495 | ALLOCATE (basin_area(nbpt,nwbas), basin_hierarchy(nbpt,nwbas), basin_topoind(nbpt,nwbas), stat=ALLOC_ERR) |
|---|
| 4496 | IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for basin_area','','') |
|---|
| 4497 | ALLOCATE (fetch_basin(nbpt,nwbas), stat=ALLOC_ERR) |
|---|
| 4498 | IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for fetch_basin','','') |
|---|
| 4499 | ALLOCATE (basin_id(nbpt,nwbas), basin_flowdir(nbpt,nwbas), stat=ALLOC_ERR) |
|---|
| 4500 | IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for basin_id','','') |
|---|
| 4501 | ALLOCATE (outflow_grid(nbpt,nwbas),outflow_basin(nbpt,nwbas), stat=ALLOC_ERR) |
|---|
| 4502 | IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for outflow_grid','','') |
|---|
| 4503 | ALLOCATE (inflow_number(nbpt,nwbas), stat=ALLOC_ERR) |
|---|
| 4504 | IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for inflow_number','','') |
|---|
| 4505 | ALLOCATE (inflow_basin(nbpt,nwbas,nbvmax), inflow_grid(nbpt,nwbas,nbvmax), stat=ALLOC_ERR) |
|---|
| 4506 | IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for inflow_basin','','') |
|---|
| 4507 | ALLOCATE (nbcoastal(nbpt), coastal_basin(nbpt,nwbas), stat=ALLOC_ERR) |
|---|
| 4508 | IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for nbcoastal','','') |
|---|
| 4509 | |
|---|
| 4510 | ! Order all sub points in each grid_box and find the sub basins |
|---|
| 4511 | ! |
|---|
| 4512 | ! before we start we set the maps to empty |
|---|
| 4513 | ! |
|---|
| 4514 | basin_id(:,:) = undef_int |
|---|
| 4515 | basin_count(:) = 0 |
|---|
| 4516 | hierarchy(:,:) = undef_sechiba |
|---|
| 4517 | max_basins = MAXVAL(basins, MASK=basins .LT. 1.e10) |
|---|
| 4518 | invented_basins = max_basins |
|---|
| 4519 | nbcoastal(:) = 0 |
|---|
| 4520 | ! |
|---|
| 4521 | !! Finds,in each grid box, the distance to the outflow point ... this defines the order in which |
|---|
| 4522 | !! the water will go through the sub-basins and grid boxes. |
|---|
| 4523 | ! |
|---|
| 4524 | CALL routing_hierarchy(iml, jml, trip, topoindex, hierarchy) |
|---|
| 4525 | ! |
|---|
| 4526 | ! |
|---|
| 4527 | DO ib =1, nbpt |
|---|
| 4528 | ! |
|---|
| 4529 | ! |
|---|
| 4530 | ! extract the information for this grid box |
|---|
| 4531 | ! |
|---|
| 4532 | !! Extracts from the global high resolution fields the data for the current grid box. |
|---|
| 4533 | ! |
|---|
| 4534 | CALL routing_getgrid(nbpt, iml, jml, ib, sub_pts, sub_index, sub_area, max_basins, min_topoind, & |
|---|
| 4535 | & lon_rel, lat_rel, lalo, resolution, contfrac, trip, basins, topoindex, hierarchy, & |
|---|
| 4536 | & nbi, nbj, area_bx, trip_bx, basin_bx, topoind_bx, hierarchy_bx, lon_bx, lat_bx) |
|---|
| 4537 | ! |
|---|
| 4538 | !! Finds the basins: returns the list of all points which are within the same basin of the grid box. |
|---|
| 4539 | ! |
|---|
| 4540 | CALL routing_findbasins(nbi, nbj, trip_bx, basin_bx, hierarchy_bx, topoind_bx,& |
|---|
| 4541 | & nb_basin, basin_inbxid, basin_sz, basin_bxout, basin_pts, coast_pts) |
|---|
| 4542 | |
|---|
| 4543 | #ifdef STRICT_CHECK |
|---|
| 4544 | IF (ANY(basin_inbxid(1:nb_basin) < 0)) THEN |
|---|
| 4545 | CALL ipslerr_p(3, 'routing_basins', 'basin_inbxid cannot have negative values.', 'Those will be later used as index in an array.', '') |
|---|
| 4546 | ENDIF |
|---|
| 4547 | #endif |
|---|
| 4548 | |
|---|
| 4549 | ! |
|---|
| 4550 | ! Deal with the case where nb_basin=0 for this grid box. In this case all goes into coastal flow. |
|---|
| 4551 | ! |
|---|
| 4552 | IF ( debug .AND. (COUNT(diagbox .EQ. ib) .GT. 0) ) THEN |
|---|
| 4553 | WRITE(numout,*) '===================== IB = :', ib |
|---|
| 4554 | WRITE(numout,*) "sub_pts(ib) :", sub_pts(ib), "sub_area(ib,:) :",sub_area(ib,1:2) |
|---|
| 4555 | WRITE(numout,*) 'LON LAT of GCM :', lalo(ib,2), lalo(ib,1) |
|---|
| 4556 | WRITE(numout,*) 'Neighbor options :', neighbours(ib,1:NbNeighb) |
|---|
| 4557 | WRITE(numout,*) 'Resolution :', resolution(ib,1:2) |
|---|
| 4558 | WRITE(fmt,"('(',I3,'I6)')") nbi |
|---|
| 4559 | WRITE(numout,*) '-------------> trip ', trip_bx(1,1) |
|---|
| 4560 | DO jp=1,nbj |
|---|
| 4561 | WRITE(numout,fmt) trip_bx(1:nbi,jp) |
|---|
| 4562 | ENDDO |
|---|
| 4563 | WRITE(numout,*) '-------------> basin ',basin_bx(1,1) |
|---|
| 4564 | DO jp=1,nbj |
|---|
| 4565 | WRITE(numout,fmt) basin_bx(1:nbi,jp) |
|---|
| 4566 | ENDDO |
|---|
| 4567 | WRITE(numout,*) '-------------> hierarchy ',hierarchy_bx(1,1) |
|---|
| 4568 | DO jp=1,nbj |
|---|
| 4569 | WRITE(numout,fmt) INT(hierarchy_bx(1:nbi,jp)/1000.) |
|---|
| 4570 | ENDDO |
|---|
| 4571 | WRITE(numout,*) '-------------> topoindex ',topoind_bx(1,1) |
|---|
| 4572 | DO jp=1,nbj |
|---|
| 4573 | WRITE(numout,fmt) INT(topoind_bx(1:nbi,jp)/1000.) |
|---|
| 4574 | ENDDO |
|---|
| 4575 | ! |
|---|
| 4576 | WRITE(numout,*) '------------> The basins we retain' |
|---|
| 4577 | DO jp=1,nb_basin |
|---|
| 4578 | WRITE(numout,*) 'index, size, bxout, coast :', basin_inbxid(jp), basin_sz(jp),& |
|---|
| 4579 | & basin_bxout(jp), coast_pts(jp) |
|---|
| 4580 | ENDDO |
|---|
| 4581 | ! |
|---|
| 4582 | ENDIF |
|---|
| 4583 | ! |
|---|
| 4584 | !! Puts the basins found for the current grid box in the context of the global map. |
|---|
| 4585 | ! |
|---|
| 4586 | CALL routing_globalize(nbpt, ib, neighbours, area_bx, trip_bx, hierarchy_bx, topoind_bx, min_topoind,& |
|---|
| 4587 | & nb_basin, basin_inbxid, basin_sz, basin_pts, basin_bxout, coast_pts, nwbas, basin_count,& |
|---|
| 4588 | & basin_area, basin_hierarchy, basin_topoind, basin_id, basin_flowdir, outflow_grid,& |
|---|
| 4589 | & nbcoastal, coastal_basin) |
|---|
| 4590 | ! |
|---|
| 4591 | ! |
|---|
| 4592 | IF ( debug .AND. (COUNT(diagbox .EQ. ib) .GT. 0) ) THEN |
|---|
| 4593 | WRITE(numout,*) 'GLOBAL information after routing_globalize for grid ', ib |
|---|
| 4594 | DO jp=1,basin_count(ib) |
|---|
| 4595 | WRITE(numout,*) 'Basin ID : ', basin_id(ib, jp) |
|---|
| 4596 | WRITE(numout,*) 'Basin flowdir :', basin_flowdir(ib, jp) |
|---|
| 4597 | WRITE(numout,*) 'Basin hierarchy :', basin_hierarchy(ib, jp) |
|---|
| 4598 | WRITE(numout,*) 'Basin topoindex :', basin_topoind(ib, jp) |
|---|
| 4599 | WRITE(numout,*) 'Basin outflow grid :', outflow_grid(ib,jp) |
|---|
| 4600 | ENDDO |
|---|
| 4601 | ENDIF |
|---|
| 4602 | ! |
|---|
| 4603 | ENDDO |
|---|
| 4604 | ! |
|---|
| 4605 | !! Makes the connections between the bains and ensures global coherence. |
|---|
| 4606 | ! |
|---|
| 4607 | CALL routing_linkup(nbpt, contfrac, neighbours, nwbas, basin_count, basin_area, basin_id, basin_flowdir, & |
|---|
| 4608 | & basin_hierarchy, outflow_grid, outflow_basin, inflow_number, inflow_grid, inflow_basin, & |
|---|
| 4609 | & nbcoastal, coastal_basin, invented_basins) |
|---|
| 4610 | ! |
|---|
| 4611 | ! |
|---|
| 4612 | IF (printlev>=1) WRITE(numout,*) 'The maximum number of basins in any grid :', MAXVAL(basin_count) |
|---|
| 4613 | ! |
|---|
| 4614 | IF ( debug ) THEN |
|---|
| 4615 | DO ib=1,SIZE(diagbox) |
|---|
| 4616 | IF ( diagbox(ib) .GT. 0 ) THEN |
|---|
| 4617 | WRITE(numout,*) 'After routing_linkup information for grid ', diagbox(ib) |
|---|
| 4618 | DO jp=1,basin_count(diagbox(ib)) |
|---|
| 4619 | WRITE(numout,*) 'Basin ID : ', basin_id(diagbox(ib), jp) |
|---|
| 4620 | WRITE(numout,*) 'Basin outflow_grid :', outflow_grid(diagbox(ib), jp) |
|---|
| 4621 | WRITE(numout,*) 'Basin outflow_basin:', outflow_basin(diagbox(ib), jp) |
|---|
| 4622 | WRITE(numout,*) 'Basin hierarchy :', basin_hierarchy(diagbox(ib), jp) |
|---|
| 4623 | ENDDO |
|---|
| 4624 | ENDIF |
|---|
| 4625 | ENDDO |
|---|
| 4626 | ENDIF |
|---|
| 4627 | ! |
|---|
| 4628 | !! Computes the fetch of each basin, upstream area in known. |
|---|
| 4629 | ! |
|---|
| 4630 | CALL routing_fetch(nbpt, resolution, contfrac, nwbas, basin_count, basin_area, basin_id, outflow_grid, & |
|---|
| 4631 | & outflow_basin, fetch_basin) |
|---|
| 4632 | ! |
|---|
| 4633 | ! |
|---|
| 4634 | IF (printlev >=3) WRITE(numout,*) "Start reducing the number of basins per grid to meet the required truncation." |
|---|
| 4635 | ! |
|---|
| 4636 | !! Reduces the number of basins per grid to the value chosen by the user. |
|---|
| 4637 | ! |
|---|
| 4638 | CALL routing_truncate(nbpt, resolution, contfrac, nwbas, basin_count, basin_area, basin_topoind,& |
|---|
| 4639 | & fetch_basin, basin_id, basin_flowdir, outflow_grid, outflow_basin, inflow_number,& |
|---|
| 4640 | & inflow_grid, inflow_basin) |
|---|
| 4641 | ! |
|---|
| 4642 | DEALLOCATE (lat_rel) |
|---|
| 4643 | DEALLOCATE (lon_rel) |
|---|
| 4644 | ! |
|---|
| 4645 | DEALLOCATE (trip) |
|---|
| 4646 | DEALLOCATE (basins) |
|---|
| 4647 | DEALLOCATE (topoindex) |
|---|
| 4648 | DEALLOCATE (hierarchy) |
|---|
| 4649 | ! |
|---|
| 4650 | DEALLOCATE (sub_area) |
|---|
| 4651 | DEALLOCATE (sub_index) |
|---|
| 4652 | DEALLOCATE (sub_pts) |
|---|
| 4653 | ! |
|---|
| 4654 | DEALLOCATE (mask) |
|---|
| 4655 | DEALLOCATE (resol_lu) |
|---|
| 4656 | ! |
|---|
| 4657 | DEALLOCATE (basin_count) |
|---|
| 4658 | DEALLOCATE (basin_area, basin_hierarchy, basin_topoind, fetch_basin) |
|---|
| 4659 | DEALLOCATE (basin_id, basin_flowdir) |
|---|
| 4660 | DEALLOCATE (outflow_grid,outflow_basin) |
|---|
| 4661 | DEALLOCATE (inflow_number) |
|---|
| 4662 | DEALLOCATE (inflow_basin, inflow_grid) |
|---|
| 4663 | DEALLOCATE (nbcoastal, coastal_basin) |
|---|
| 4664 | |
|---|
| 4665 | END SUBROUTINE routing_basins |
|---|
| 4666 | |
|---|
| 4667 | |
|---|
| 4668 | !! ================================================================================================================================ |
|---|
| 4669 | !! SUBROUTINE : routing_getgrid |
|---|
| 4670 | !! |
|---|
| 4671 | !>\BRIEF This subroutine extracts from the global high resolution fields |
|---|
| 4672 | !! the data for the current grid box we are dealing with. |
|---|
| 4673 | !! |
|---|
| 4674 | !! DESCRIPTION (definitions, functional, design, flags) : |
|---|
| 4675 | !! Convention for trip on the input : |
|---|
| 4676 | !! The trip field follows the following convention for the flow of the water : |
|---|
| 4677 | !! trip = 1 : flow = N |
|---|
| 4678 | !! trip = 2 : flow = NE |
|---|
| 4679 | !! trip = 3 : flow = E |
|---|
| 4680 | !! trip = 4 : flow = SE |
|---|
| 4681 | !! trip = 5 : flow = S |
|---|
| 4682 | !! trip = 6 : flow = SW |
|---|
| 4683 | !! trip = 7 : flow = W |
|---|
| 4684 | !! trip = 8 : flow = NW |
|---|
| 4685 | !! trip = 97 : return flow into the ground |
|---|
| 4686 | !! trip = 98 : coastal flow (diffuse flow into the oceans) These values are created here |
|---|
| 4687 | !! trip = 99 : river flow into the oceans |
|---|
| 4688 | !! |
|---|
| 4689 | !! On output, the grid boxes of the basin map which flow out of the GCM grid are identified |
|---|
| 4690 | !! by numbers larger than 100 : |
|---|
| 4691 | !! trip = 101 : flow = N out of the coarse grid |
|---|
| 4692 | !! trip = 102 : flow = NE out of the coarse grid |
|---|
| 4693 | !! trip = 103 : flow = E out of the coarse grid |
|---|
| 4694 | !! trip = 104 : flow = SE out of the coarse grid |
|---|
| 4695 | !! trip = 105 : flow = S out of the coarse grid |
|---|
| 4696 | !! trip = 106 : flow = SW out of the coarse grid |
|---|
| 4697 | !! trip = 107 : flow = W out of the coarse grid |
|---|
| 4698 | !! trip = 108 : flow = NW out of the coarse grid |
|---|
| 4699 | !! Inside the grid the convention remains the same as above (ie between 1 and 99).:\n |
|---|
| 4700 | !! |
|---|
| 4701 | !! RECENT CHANGE(S): None |
|---|
| 4702 | !! |
|---|
| 4703 | !! MAIN OUTPUT VARIABLE(S): |
|---|
| 4704 | !! |
|---|
| 4705 | !! REFERENCES : None |
|---|
| 4706 | !! |
|---|
| 4707 | !! FLOWCHART : None |
|---|
| 4708 | !! \n |
|---|
| 4709 | !_ ================================================================================================================================ |
|---|
| 4710 | |
|---|
| 4711 | SUBROUTINE routing_getgrid(nbpt, iml, jml, ib, sub_pts, sub_index, sub_area, max_basins, min_topoind, & |
|---|
| 4712 | & lon_rel, lat_rel, lalo, resolution, contfrac, trip, basins, topoindex, hierarchy, & |
|---|
| 4713 | & nbi, nbj, area_bx, trip_bx, basin_bx, topoind_bx, hierarchy_bx, lon_bx, lat_bx) |
|---|
| 4714 | ! |
|---|
| 4715 | IMPLICIT NONE |
|---|
| 4716 | ! |
|---|
| 4717 | !! INPUT VARIABLES |
|---|
| 4718 | INTEGER(i_std), INTENT(in) :: nbpt !! Domain size (unitless) |
|---|
| 4719 | INTEGER(i_std), INTENT(in) :: iml !! X resolution of the high resolution grid |
|---|
| 4720 | INTEGER(i_std), INTENT(in) :: jml !! Y resolution of the high resolution grid |
|---|
| 4721 | INTEGER(i_std), INTENT(in) :: ib !! Current basin (unitless) |
|---|
| 4722 | INTEGER(i_std), INTENT(in) :: sub_pts(nbpt) !! Number of high resolution points on this grid (unitless) |
|---|
| 4723 | INTEGER(i_std), INTENT(in) :: sub_index(nbpt,nbvmax,2) !! Indices of the points we need on the fine grid (unitless) |
|---|
| 4724 | REAL(r_std), INTENT(inout) :: max_basins !! The current maximum of basins |
|---|
| 4725 | REAL(r_std), INTENT(in) :: min_topoind !! The current minimum of topographic index (m) |
|---|
| 4726 | REAL(r_std), INTENT(in) :: sub_area(nbpt,nbvmax) !! Area on the fine grid (m^2) |
|---|
| 4727 | REAL(r_std), INTENT(in) :: lon_rel(iml,jml) !! |
|---|
| 4728 | REAL(r_std), INTENT(in) :: lat_rel(iml,jml) !! coordinates of the fine grid |
|---|
| 4729 | REAL(r_std), INTENT(in) :: lalo(nbpt,2) !! Vector of latitude and longitudes (beware of the order !) |
|---|
| 4730 | REAL(r_std), INTENT(in) :: resolution(nbpt,2) !! The size of each grid box in X and Y (m) |
|---|
| 4731 | REAL(r_std), INTENT(in) :: contfrac(nbpt) !! Fraction of land in each grid box (unitless;0-1) |
|---|
| 4732 | REAL(r_std), INTENT(inout) :: trip(iml,jml) !! The trip field (unitless) |
|---|
| 4733 | REAL(r_std), INTENT(inout) :: basins(iml,jml) !! data on the fine grid |
|---|
| 4734 | REAL(r_std), INTENT(inout) :: topoindex(iml,jml) !! Topographic index of the residence time (m) |
|---|
| 4735 | REAL(r_std), INTENT(inout) :: hierarchy(iml, jml) !! data on the fine grid |
|---|
| 4736 | ! |
|---|
| 4737 | !! OUTPUT VARIABLES |
|---|
| 4738 | INTEGER(i_std), INTENT(out) :: nbi, nbj !! Number of point in x and y within the grid (unitless) |
|---|
| 4739 | REAL(r_std), INTENT(out) :: area_bx(nbvmax,nbvmax) !! Area of each small box in the grid box (m^2) |
|---|
| 4740 | REAL(r_std), INTENT(out) :: hierarchy_bx(nbvmax,nbvmax) !! Level in the basin of the point |
|---|
| 4741 | REAL(r_std), INTENT(out) :: lon_bx(nbvmax,nbvmax) !! |
|---|
| 4742 | REAL(r_std), INTENT(out) :: lat_bx(nbvmax,nbvmax) !! |
|---|
| 4743 | REAL(r_std), INTENT(out) :: topoind_bx(nbvmax,nbvmax) !! Topographic index of the residence time for each of the smaller boxes (m) |
|---|
| 4744 | INTEGER(i_std), INTENT(out) :: trip_bx(nbvmax,nbvmax) !! The trip field for each of the smaller boxes (unitless) |
|---|
| 4745 | INTEGER(i_std), INTENT(out) :: basin_bx(nbvmax,nbvmax) !! |
|---|
| 4746 | ! |
|---|
| 4747 | !! LOCAL VARIABLES |
|---|
| 4748 | INTEGER(i_std) :: ip, jp, ll(1), iloc, jloc !! Indices (unitless) |
|---|
| 4749 | REAL(r_std) :: lonstr(nbvmax*nbvmax) !! |
|---|
| 4750 | REAL(r_std) :: latstr(nbvmax*nbvmax) !! |
|---|
| 4751 | |
|---|
| 4752 | !_ ================================================================================================================================ |
|---|
| 4753 | |
|---|
| 4754 | ! |
|---|
| 4755 | ! Set everything to undef to locate easily empty points |
|---|
| 4756 | ! |
|---|
| 4757 | trip_bx(:,:) = undef_int |
|---|
| 4758 | basin_bx(:,:) = undef_int |
|---|
| 4759 | topoind_bx(:,:) = undef_sechiba |
|---|
| 4760 | area_bx(:,:) = undef_sechiba |
|---|
| 4761 | hierarchy_bx(:,:) = undef_sechiba |
|---|
| 4762 | ! |
|---|
| 4763 | IF ( sub_pts(ib) > 0 ) THEN |
|---|
| 4764 | ! |
|---|
| 4765 | DO ip=1,sub_pts(ib) |
|---|
| 4766 | lonstr(ip) = lon_rel(sub_index(ib, ip, 1), sub_index(ib, ip, 2)) |
|---|
| 4767 | latstr(ip) = lat_rel(sub_index(ib, ip, 1), sub_index(ib, ip, 2)) |
|---|
| 4768 | ENDDO |
|---|
| 4769 | ! |
|---|
| 4770 | ! Get the size of the area and order the coordinates to go from North to South and West to East |
|---|
| 4771 | ! |
|---|
| 4772 | CALL routing_sortcoord(sub_pts(ib), lonstr, 'WE', nbi) |
|---|
| 4773 | CALL routing_sortcoord(sub_pts(ib), latstr, 'NS', nbj) |
|---|
| 4774 | ! |
|---|
| 4775 | ! Transfer the data in such a way that (1,1) is the North Western corner and |
|---|
| 4776 | ! (nbi, nbj) the South Eastern. |
|---|
| 4777 | ! |
|---|
| 4778 | DO ip=1,sub_pts(ib) |
|---|
| 4779 | ll = MINLOC(ABS(lonstr(1:nbi) - lon_rel(sub_index(ib, ip, 1), sub_index(ib, ip, 2)))) |
|---|
| 4780 | iloc = ll(1) |
|---|
| 4781 | ll = MINLOC(ABS(latstr(1:nbj) - lat_rel(sub_index(ib, ip, 1), sub_index(ib, ip, 2)))) |
|---|
| 4782 | jloc = ll(1) |
|---|
| 4783 | trip_bx(iloc, jloc) = NINT(trip(sub_index(ib, ip, 1), sub_index(ib, ip, 2))) |
|---|
| 4784 | basin_bx(iloc, jloc) = NINT(basins(sub_index(ib, ip, 1), sub_index(ib, ip, 2))) |
|---|
| 4785 | area_bx(iloc, jloc) = sub_area(ib, ip) |
|---|
| 4786 | topoind_bx(iloc, jloc) = topoindex(sub_index(ib, ip, 1), sub_index(ib, ip, 2)) |
|---|
| 4787 | hierarchy_bx(iloc, jloc) = hierarchy(sub_index(ib, ip, 1), sub_index(ib, ip, 2)) |
|---|
| 4788 | lon_bx(iloc, jloc) = lon_rel(sub_index(ib, ip, 1), sub_index(ib, ip, 2)) |
|---|
| 4789 | lat_bx(iloc, jloc) = lat_rel(sub_index(ib, ip, 1), sub_index(ib, ip, 2)) |
|---|
| 4790 | ENDDO |
|---|
| 4791 | ELSE |
|---|
| 4792 | ! |
|---|
| 4793 | ! This is the case where the model invented a continental point |
|---|
| 4794 | ! |
|---|
| 4795 | nbi = 1 |
|---|
| 4796 | nbj = 1 |
|---|
| 4797 | iloc = 1 |
|---|
| 4798 | jloc = 1 |
|---|
| 4799 | trip_bx(iloc, jloc) = 98 |
|---|
| 4800 | basin_bx(iloc, jloc) = NINT(max_basins + 1) |
|---|
| 4801 | max_basins = max_basins + 1 |
|---|
| 4802 | area_bx(iloc, jloc) = resolution(ib,1)*resolution(ib,2)*contfrac(ib) |
|---|
| 4803 | topoind_bx(iloc, jloc) = min_topoind |
|---|
| 4804 | hierarchy_bx(iloc, jloc) = min_topoind |
|---|
| 4805 | lon_bx(iloc, jloc) = lalo(ib,2) |
|---|
| 4806 | lat_bx(iloc, jloc) = lalo(ib,1) |
|---|
| 4807 | ! |
|---|
| 4808 | ENDIF |
|---|
| 4809 | ! |
|---|
| 4810 | ! Tag in trip all the outflow conditions. The table is thus : |
|---|
| 4811 | ! trip = 100+n : Outflow into another grid box |
|---|
| 4812 | ! trip = 99 : River outflow into the ocean |
|---|
| 4813 | ! trip = 98 : This will be coastal flow (not organized as a basin) |
|---|
| 4814 | ! trip = 97 : return flow into the soil (local) |
|---|
| 4815 | ! |
|---|
| 4816 | DO jp=1,nbj |
|---|
| 4817 | IF ( trip_bx(1,jp) .EQ. 8 .OR. trip_bx(1,jp) .EQ. 7 .OR. trip_bx(1,jp) .EQ. 6) THEN |
|---|
| 4818 | trip_bx(1,jp) = trip_bx(1,jp) + 100 |
|---|
| 4819 | ENDIF |
|---|
| 4820 | IF ( trip_bx(nbi,jp) .EQ. 2 .OR. trip_bx(nbi,jp) .EQ. 3 .OR. trip_bx(nbi,jp) .EQ. 4) THEN |
|---|
| 4821 | trip_bx(nbi,jp) = trip_bx(nbi,jp) + 100 |
|---|
| 4822 | ENDIF |
|---|
| 4823 | ENDDO |
|---|
| 4824 | DO ip=1,nbi |
|---|
| 4825 | IF ( trip_bx(ip,1) .EQ. 8 .OR. trip_bx(ip,1) .EQ. 1 .OR. trip_bx(ip,1) .EQ. 2) THEN |
|---|
| 4826 | trip_bx(ip,1) = trip_bx(ip,1) + 100 |
|---|
| 4827 | ENDIF |
|---|
| 4828 | IF ( trip_bx(ip,nbj) .EQ. 6 .OR. trip_bx(ip,nbj) .EQ. 5 .OR. trip_bx(ip,nbj) .EQ. 4) THEN |
|---|
| 4829 | trip_bx(ip,nbj) = trip_bx(ip,nbj) + 100 |
|---|
| 4830 | ENDIF |
|---|
| 4831 | ENDDO |
|---|
| 4832 | ! |
|---|
| 4833 | ! |
|---|
| 4834 | ! We simplify the outflow. We only need the direction normal to the |
|---|
| 4835 | ! box boundary and the 4 corners. |
|---|
| 4836 | ! |
|---|
| 4837 | ! Northern border |
|---|
| 4838 | IF ( trip_bx(1,1) .EQ. 102 ) trip_bx(1,1) = 101 |
|---|
| 4839 | IF ( trip_bx(nbi,1) .EQ. 108 ) trip_bx(nbi,1) = 101 |
|---|
| 4840 | DO ip=2,nbi-1 |
|---|
| 4841 | IF ( trip_bx(ip,1) .EQ. 108 .OR. trip_bx(ip,1) .EQ. 102 ) trip_bx(ip,1) = 101 |
|---|
| 4842 | ENDDO |
|---|
| 4843 | ! Southern border |
|---|
| 4844 | IF ( trip_bx(1,nbj) .EQ. 104 ) trip_bx(1,nbj) = 105 |
|---|
| 4845 | IF ( trip_bx(nbi,nbj) .EQ. 106 ) trip_bx(nbi,nbj) = 105 |
|---|
| 4846 | DO ip=2,nbi-1 |
|---|
| 4847 | IF ( trip_bx(ip,nbj) .EQ. 104 .OR. trip_bx(ip,nbj) .EQ. 106 ) trip_bx(ip,nbj) = 105 |
|---|
| 4848 | ENDDO |
|---|
| 4849 | ! Eastern border |
|---|
| 4850 | IF ( trip_bx(nbi,1) .EQ. 104) trip_bx(nbi,1) = 103 |
|---|
| 4851 | IF ( trip_bx(nbi,nbj) .EQ. 102) trip_bx(nbi,nbj) = 103 |
|---|
| 4852 | DO jp=2,nbj-1 |
|---|
| 4853 | IF ( trip_bx(nbi,jp) .EQ. 104 .OR. trip_bx(nbi,jp) .EQ. 102 ) trip_bx(nbi,jp) = 103 |
|---|
| 4854 | ENDDO |
|---|
| 4855 | ! Western border |
|---|
| 4856 | IF ( trip_bx(1,1) .EQ. 106) trip_bx(1,1) = 107 |
|---|
| 4857 | IF ( trip_bx(1,nbj) .EQ. 108) trip_bx(1,nbj) = 107 |
|---|
| 4858 | DO jp=2,nbj-1 |
|---|
| 4859 | IF ( trip_bx(1,jp) .EQ. 106 .OR. trip_bx(1,jp) .EQ. 108 ) trip_bx(1,jp) = 107 |
|---|
| 4860 | ENDDO |
|---|
| 4861 | ! |
|---|
| 4862 | ! |
|---|
| 4863 | END SUBROUTINE routing_getgrid |
|---|
| 4864 | ! |
|---|
| 4865 | !! ================================================================================================================================ |
|---|
| 4866 | !! SUBROUTINE : routing_sortcoord |
|---|
| 4867 | !! |
|---|
| 4868 | !>\BRIEF This subroutines orders the coordinates to go from North to South and West to East. |
|---|
| 4869 | !! |
|---|
| 4870 | !! DESCRIPTION (definitions, functional, design, flags) : None |
|---|
| 4871 | !! |
|---|
| 4872 | !! RECENT CHANGE(S): None |
|---|
| 4873 | !! |
|---|
| 4874 | !! MAIN OUTPUT VARIABLE(S): |
|---|
| 4875 | !! |
|---|
| 4876 | !! REFERENCES : None |
|---|
| 4877 | !! |
|---|
| 4878 | !! FLOWCHART : None |
|---|
| 4879 | !! \n |
|---|
| 4880 | !_ ================================================================================================================================ |
|---|
| 4881 | |
|---|
| 4882 | SUBROUTINE routing_sortcoord(nb_in, coords, direction, nb_out) |
|---|
| 4883 | ! |
|---|
| 4884 | IMPLICIT NONE |
|---|
| 4885 | ! |
|---|
| 4886 | !! INPUT VARIABLES |
|---|
| 4887 | INTEGER(i_std), INTENT(in) :: nb_in !! |
|---|
| 4888 | REAL(r_std), INTENT(inout) :: coords(nb_in) !! |
|---|
| 4889 | ! |
|---|
| 4890 | !! OUTPUT VARIABLES |
|---|
| 4891 | INTEGER(i_std), INTENT(out) :: nb_out !! |
|---|
| 4892 | ! |
|---|
| 4893 | !! LOCAL VARIABLES |
|---|
| 4894 | CHARACTER(LEN=2) :: direction !! |
|---|
| 4895 | INTEGER(i_std) :: ipos !! |
|---|
| 4896 | REAL(r_std) :: coords_tmp(nb_in) !! |
|---|
| 4897 | INTEGER(i_std), DIMENSION(1) :: ll !! |
|---|
| 4898 | INTEGER(i_std) :: ind(nb_in) !! |
|---|
| 4899 | |
|---|
| 4900 | !_ ================================================================================================================================ |
|---|
| 4901 | ! |
|---|
| 4902 | ipos = 1 |
|---|
| 4903 | nb_out = nb_in |
|---|
| 4904 | ! |
|---|
| 4905 | ! Compress the coordinates array |
|---|
| 4906 | ! |
|---|
| 4907 | DO WHILE ( ipos < nb_in ) |
|---|
| 4908 | IF ( coords(ipos+1) /= undef_sechiba) THEN |
|---|
| 4909 | IF ( COUNT(coords(ipos:nb_out) == coords(ipos)) > 1 ) THEN |
|---|
| 4910 | coords(ipos:nb_out-1) = coords(ipos+1:nb_out) |
|---|
| 4911 | coords(nb_out:nb_in) = undef_sechiba |
|---|
| 4912 | nb_out = nb_out - 1 |
|---|
| 4913 | ELSE |
|---|
| 4914 | ipos = ipos + 1 |
|---|
| 4915 | ENDIF |
|---|
| 4916 | ELSE |
|---|
| 4917 | EXIT |
|---|
| 4918 | ENDIF |
|---|
| 4919 | ENDDO |
|---|
| 4920 | ! |
|---|
| 4921 | ! Sort it now |
|---|
| 4922 | ! |
|---|
| 4923 | ! First we get ready and adjust for the periodicity in longitude |
|---|
| 4924 | ! |
|---|
| 4925 | coords_tmp(:) = undef_sechiba |
|---|
| 4926 | IF ( INDEX(direction, 'WE') == 1 .OR. INDEX(direction, 'EW') == 1) THEN |
|---|
| 4927 | IF ( MAXVAL(ABS(coords(1:nb_out))) .GT. 160 ) THEN |
|---|
| 4928 | coords_tmp(1:nb_out) = MOD(coords(1:nb_out) + 360.0, 360.0) |
|---|
| 4929 | ELSE |
|---|
| 4930 | coords_tmp(1:nb_out) = coords(1:nb_out) |
|---|
| 4931 | ENDIF |
|---|
| 4932 | ELSE IF ( INDEX(direction, 'NS') == 1 .OR. INDEX(direction, 'SN') == 1) THEN |
|---|
| 4933 | coords_tmp(1:nb_out) = coords(1:nb_out) |
|---|
| 4934 | ELSE |
|---|
| 4935 | WRITE(numout,*) 'The chosen direction (', direction,') is not recognized' |
|---|
| 4936 | CALL ipslerr_p(3,'routing_sortcoord','The chosen direction is not recognized','First section','') |
|---|
| 4937 | ENDIF |
|---|
| 4938 | ! |
|---|
| 4939 | ! Get it sorted out now |
|---|
| 4940 | ! |
|---|
| 4941 | ipos = 1 |
|---|
| 4942 | ! |
|---|
| 4943 | IF ( INDEX(direction, 'WE') == 1 .OR. INDEX(direction, 'SN') == 1) THEN |
|---|
| 4944 | DO WHILE (COUNT(ABS(coords_tmp(:)-undef_sechiba) > EPSILON(undef_sechiba)*10.) >= 1) |
|---|
| 4945 | ll = MINLOC(coords_tmp(:), coords_tmp /= undef_sechiba) |
|---|
| 4946 | ind(ipos) = ll(1) |
|---|
| 4947 | coords_tmp(ll(1)) = undef_sechiba |
|---|
| 4948 | ipos = ipos + 1 |
|---|
| 4949 | ENDDO |
|---|
| 4950 | ELSE IF ( INDEX(direction, 'EW') == 1 .OR. INDEX(direction, 'NS') == 1) THEN |
|---|
| 4951 | DO WHILE (COUNT(ABS(coords_tmp(:)-undef_sechiba) > EPSILON(undef_sechiba)*10.) >= 1) |
|---|
| 4952 | ll = MAXLOC(coords_tmp(:), coords_tmp /= undef_sechiba) |
|---|
| 4953 | ind(ipos) = ll(1) |
|---|
| 4954 | coords_tmp(ll(1)) = undef_sechiba |
|---|
| 4955 | ipos = ipos + 1 |
|---|
| 4956 | ENDDO |
|---|
| 4957 | ELSE |
|---|
| 4958 | WRITE(numout,*) 'The chosen direction (', direction,') is not recognized (second)' |
|---|
| 4959 | CALL ipslerr_p(3,'routing_sortcoord','The chosen direction is not recognized','Second section','') |
|---|
| 4960 | ENDIF |
|---|
| 4961 | ! |
|---|
| 4962 | coords(1:nb_out) = coords(ind(1:nb_out)) |
|---|
| 4963 | IF (nb_out < nb_in) THEN |
|---|
| 4964 | coords(nb_out+1:nb_in) = zero |
|---|
| 4965 | ENDIF |
|---|
| 4966 | ! |
|---|
| 4967 | END SUBROUTINE routing_sortcoord |
|---|
| 4968 | ! |
|---|
| 4969 | |
|---|
| 4970 | !! ================================================================================================================================ |
|---|
| 4971 | !! SUBROUTINE : routing_findbasins |
|---|
| 4972 | !! |
|---|
| 4973 | !>\BRIEF This subroutine finds the basins and does some clean up. |
|---|
| 4974 | !! The aim is to return the list off all points which are within the |
|---|
| 4975 | !! same basin of the grid box. |
|---|
| 4976 | !! |
|---|
| 4977 | !! DESCRIPTION (definitions, functional, design, flags) : |
|---|
| 4978 | !! We will also collect all points which directly flow into the ocean in one basin |
|---|
| 4979 | !! Make sure that we do not have a basin with two outflows and other exceptions. |
|---|
| 4980 | !! At this stage no effort is made to come down to the truncation of the model. |
|---|
| 4981 | !! |
|---|
| 4982 | !! Convention for trip \n |
|---|
| 4983 | !! ------------------- \n |
|---|
| 4984 | !! Inside of the box : \n |
|---|
| 4985 | !! trip = 1 : flow = N \n |
|---|
| 4986 | !! trip = 2 : flow = NE \n |
|---|
| 4987 | !! trip = 3 : flow = E \n |
|---|
| 4988 | !! trip = 4 : flow = SE \n |
|---|
| 4989 | !! trip = 5 : flow = S \n |
|---|
| 4990 | !! trip = 6 : flow = SW \n |
|---|
| 4991 | !! trip = 7 : flow = W \n |
|---|
| 4992 | !! trip = 8 : flow = NW \n |
|---|
| 4993 | !! trip = 97 : return flow into the ground \n |
|---|
| 4994 | !! trip = 98 : coastal flow (diffuse flow into the oceans) These values are created here \n |
|---|
| 4995 | !! trip = 99 : river flow into the oceans \n |
|---|
| 4996 | !! |
|---|
| 4997 | !! Out flow from the grid : \n |
|---|
| 4998 | !! trip = 101 : flow = N out of the coarse grid \n |
|---|
| 4999 | !! trip = 102 : flow = NE out of the coarse grid \n |
|---|
| 5000 | !! trip = 103 : flow = E out of the coarse grid \n |
|---|
| 5001 | !! trip = 104 : flow = SE out of the coarse grid \n |
|---|
| 5002 | !! trip = 105 : flow = S out of the coarse grid \n |
|---|
| 5003 | !! trip = 106 : flow = SW out of the coarse grid \n |
|---|
| 5004 | !! trip = 107 : flow = W out of the coarse grid \n |
|---|
| 5005 | !! trip = 108 : flow = NW out of the coarse grid! \n |
|---|
| 5006 | !! RECENT CHANGE(S): None |
|---|
| 5007 | !! |
|---|
| 5008 | !! MAIN OUTPUT VARIABLE(S): |
|---|
| 5009 | !! |
|---|
| 5010 | !! REFERENCES : None |
|---|
| 5011 | !! |
|---|
| 5012 | !! FLOWCHART : None |
|---|
| 5013 | !! \n |
|---|
| 5014 | !_ ================================================================================================================================ |
|---|
| 5015 | |
|---|
| 5016 | SUBROUTINE routing_findbasins(nbi, nbj, trip, basin, hierarchy, topoind, nb_basin, basin_inbxid, basin_sz,& |
|---|
| 5017 | & basin_bxout, basin_pts, coast_pts) |
|---|
| 5018 | ! |
|---|
| 5019 | IMPLICIT NONE |
|---|
| 5020 | ! |
|---|
| 5021 | !! INPUT VARIABLES |
|---|
| 5022 | INTEGER(i_std), INTENT(in) :: nbi !! Number of point in x within the grid (unitless) |
|---|
| 5023 | INTEGER(i_std), INTENT(in) :: nbj !! Number of point in y within the grid (unitless) |
|---|
| 5024 | REAL(r_std), INTENT(in) :: hierarchy(:,:) !! |
|---|
| 5025 | REAL(r_std), INTENT(in) :: topoind(:,:) !! Topographic index of the residence time (m) |
|---|
| 5026 | ! |
|---|
| 5027 | ! Modified |
|---|
| 5028 | INTEGER(i_std), INTENT(inout) :: trip(:,:) !! The trip field (unitless) |
|---|
| 5029 | INTEGER(i_std), INTENT(inout) :: basin(:,:) !! |
|---|
| 5030 | ! |
|---|
| 5031 | !! OUTPUT VARIABLES |
|---|
| 5032 | INTEGER(i_std), INTENT(out) :: nb_basin !! Number of sub-basins (unitless) |
|---|
| 5033 | INTEGER(i_std), INTENT(out) :: basin_inbxid(nbvmax) !! |
|---|
| 5034 | INTEGER(i_std), INTENT(out) :: basin_sz(nbvmax) !! |
|---|
| 5035 | INTEGER(i_std), INTENT(out) :: basin_bxout(nbvmax) !! |
|---|
| 5036 | INTEGER(i_std), INTENT(out) :: basin_pts(nbvmax, nbvmax, 2) !! |
|---|
| 5037 | INTEGER(i_std), INTENT(out) :: coast_pts(nbvmax) !! The coastal flow points (unitless) |
|---|
| 5038 | ! |
|---|
| 5039 | !! LOCAL VARIABLES |
|---|
| 5040 | INTEGER(i_std) :: ibas, ilf, nbb, nb_in !! |
|---|
| 5041 | INTEGER(i_std) :: bname(nbvmax) !! |
|---|
| 5042 | INTEGER(i_std) :: sz(nbvmax) !! |
|---|
| 5043 | INTEGER(i_std) :: pts(nbvmax,nbvmax,2) !! |
|---|
| 5044 | INTEGER(i_std) :: nbout(nbvmax) !! |
|---|
| 5045 | INTEGER(i_std) :: new_nb !! |
|---|
| 5046 | INTEGER(i_std) :: new_bname(nbvmax) !! |
|---|
| 5047 | INTEGER(i_std) :: new_sz(nbvmax) !! |
|---|
| 5048 | INTEGER(i_std) :: new_pts(nbvmax,nbvmax,2) !! |
|---|
| 5049 | INTEGER(i_std) :: itrans !! |
|---|
| 5050 | INTEGER(i_std) :: trans(nbvmax) !! |
|---|
| 5051 | INTEGER(i_std) :: outdir(nbvmax) !! |
|---|
| 5052 | INTEGER(i_std) :: tmpsz(nbvmax) !! |
|---|
| 5053 | INTEGER(i_std) :: ip, jp, jpp(1), ipb !! |
|---|
| 5054 | INTEGER(i_std) :: sortind(nbvmax) !! |
|---|
| 5055 | CHARACTER(LEN=7) :: fmt !! |
|---|
| 5056 | |
|---|
| 5057 | !_ ================================================================================================================================ |
|---|
| 5058 | ! |
|---|
| 5059 | nbb = 0 |
|---|
| 5060 | ibas = -1 |
|---|
| 5061 | bname(:) = undef_int |
|---|
| 5062 | sz(:) = 0 |
|---|
| 5063 | nbout(:) = 0 |
|---|
| 5064 | new_pts(:,:,:) = 0 |
|---|
| 5065 | ! |
|---|
| 5066 | ! 1.0 Find all basins within this grid box |
|---|
| 5067 | ! Sort the variables per basin so that we can more easily |
|---|
| 5068 | ! access data from the same basin (The variables are : |
|---|
| 5069 | ! bname, sz, pts, nbout) |
|---|
| 5070 | ! |
|---|
| 5071 | DO ip=1,nbi |
|---|
| 5072 | DO jp=1,nbj |
|---|
| 5073 | IF ( basin(ip,jp) .LT. undef_int) THEN |
|---|
| 5074 | IF ( COUNT(basin(ip,jp) .EQ. bname(:)) .EQ. 0 ) THEN |
|---|
| 5075 | nbb = nbb + 1 |
|---|
| 5076 | IF ( nbb .GT. nbvmax ) CALL ipslerr_p(3,'routing_findbasins','nbvmax too small','first section','') |
|---|
| 5077 | bname(nbb) = basin(ip,jp) |
|---|
| 5078 | sz(nbb) = 0 |
|---|
| 5079 | ENDIF |
|---|
| 5080 | ! |
|---|
| 5081 | DO ilf=1,nbb |
|---|
| 5082 | IF ( basin(ip,jp) .EQ. bname(ilf) ) THEN |
|---|
| 5083 | ibas = ilf |
|---|
| 5084 | ENDIF |
|---|
| 5085 | ENDDO |
|---|
| 5086 | ! |
|---|
| 5087 | sz(ibas) = sz(ibas) + 1 |
|---|
| 5088 | IF ( sz(ibas) .GT. nbvmax ) CALL ipslerr_p(3,'routing_findbasins','nbvmax too small','second section','') |
|---|
| 5089 | pts(ibas, sz(ibas), 1) = ip |
|---|
| 5090 | pts(ibas, sz(ibas), 2) = jp |
|---|
| 5091 | ! We deal only with outflow and leave flow back into the grid box for later. |
|---|
| 5092 | IF ( trip(ip,jp) .GE. 97 ) THEN |
|---|
| 5093 | nbout(ibas) = nbout(ibas) + 1 |
|---|
| 5094 | ENDIF |
|---|
| 5095 | ! |
|---|
| 5096 | ENDIF |
|---|
| 5097 | ! |
|---|
| 5098 | ENDDO |
|---|
| 5099 | ENDDO |
|---|
| 5100 | ! |
|---|
| 5101 | ! 2.0 All basins which have size 1 and flow to the ocean are put together. |
|---|
| 5102 | ! |
|---|
| 5103 | itrans = 0 |
|---|
| 5104 | coast_pts(:) = undef_int |
|---|
| 5105 | ! Get all the points we can collect |
|---|
| 5106 | DO ip=1,nbb |
|---|
| 5107 | IF ( sz(ip) .EQ. 1 .AND. trip(pts(ip,1,1),pts(ip,1,2)) .EQ. 99) THEN |
|---|
| 5108 | itrans = itrans + 1 |
|---|
| 5109 | trans(itrans) = ip |
|---|
| 5110 | trip(pts(ip,1,1),pts(ip,1,2)) = 98 |
|---|
| 5111 | ENDIF |
|---|
| 5112 | ENDDO |
|---|
| 5113 | ! put everything in the first basin |
|---|
| 5114 | IF ( itrans .GT. 1) THEN |
|---|
| 5115 | ipb = trans(1) |
|---|
| 5116 | coast_pts(sz(ipb)) = bname(ipb) |
|---|
| 5117 | bname(ipb) = -1 |
|---|
| 5118 | DO ip=2,itrans |
|---|
| 5119 | sz(ipb) = sz(ipb) + 1 |
|---|
| 5120 | coast_pts(sz(ipb)) = bname(trans(ip)) |
|---|
| 5121 | sz(trans(ip)) = 0 |
|---|
| 5122 | pts(ipb, sz(ipb), 1) = pts(trans(ip), 1, 1) |
|---|
| 5123 | pts(ipb, sz(ipb), 2) = pts(trans(ip), 1, 2) |
|---|
| 5124 | ENDDO |
|---|
| 5125 | ENDIF |
|---|
| 5126 | ! |
|---|
| 5127 | ! 3.0 Make sure that we have only one outflow point in each basin |
|---|
| 5128 | ! |
|---|
| 5129 | ! nbb is the number of basins on this grid box. |
|---|
| 5130 | new_nb = 0 |
|---|
| 5131 | DO ip=1,nbb |
|---|
| 5132 | ! We only do this for grid-points which have more than one outflow |
|---|
| 5133 | IF ( sz(ip) .GT. 1 .AND. nbout(ip) .GT. 1) THEN |
|---|
| 5134 | ! |
|---|
| 5135 | ! Pick up all points needed and store them in trans |
|---|
| 5136 | ! |
|---|
| 5137 | itrans = 0 |
|---|
| 5138 | DO jp=1,sz(ip) |
|---|
| 5139 | IF ( trip(pts(ip,jp,1),pts(ip,jp,2)) .GE. 97) THEN |
|---|
| 5140 | itrans = itrans + 1 |
|---|
| 5141 | trans(itrans) = trip(pts(ip,jp,1),pts(ip,jp,2)) |
|---|
| 5142 | ENDIF |
|---|
| 5143 | ENDDO |
|---|
| 5144 | ! |
|---|
| 5145 | ! First issue : We have more than one point of the basin which flows into |
|---|
| 5146 | ! the ocean. In this case we put everything into coastal flow. It will go into |
|---|
| 5147 | ! a separate basin in the routing_globalize routine. |
|---|
| 5148 | ! |
|---|
| 5149 | IF ( (COUNT(trans(1:itrans) .EQ. 99) + COUNT(trans(1:itrans) .EQ. 98)) .GT. 1) THEN |
|---|
| 5150 | DO jp=1,sz(ip) |
|---|
| 5151 | IF ( trip(pts(ip,jp,1),pts(ip,jp,2)) .EQ. 99 ) THEN |
|---|
| 5152 | trip(pts(ip,jp,1),pts(ip,jp,2)) = 98 |
|---|
| 5153 | trans(itrans) = trip(pts(ip,jp,1),pts(ip,jp,2)) |
|---|
| 5154 | ENDIF |
|---|
| 5155 | ENDDO |
|---|
| 5156 | ENDIF |
|---|
| 5157 | ! |
|---|
| 5158 | ! Second issue : We have redundant outflows at the boundaries. That is two small grid |
|---|
| 5159 | ! boxes flowing into the same GCM grid box. |
|---|
| 5160 | ! |
|---|
| 5161 | IF ( COUNT(trans(1:itrans) .GT. 100) .GE. 1) THEN |
|---|
| 5162 | CALL routing_simplify(nbi, nbj, trip, basin, hierarchy, bname(ip)) |
|---|
| 5163 | itrans = 0 |
|---|
| 5164 | DO jp=1,sz(ip) |
|---|
| 5165 | IF ( trip(pts(ip,jp,1),pts(ip,jp,2)) .GE. 9) THEN |
|---|
| 5166 | itrans = itrans + 1 |
|---|
| 5167 | trans(itrans) = trip(pts(ip,jp,1),pts(ip,jp,2)) |
|---|
| 5168 | ENDIF |
|---|
| 5169 | ENDDO |
|---|
| 5170 | ENDIF |
|---|
| 5171 | ! |
|---|
| 5172 | ! Third issue : we have more than one outflow from the boxes. This could be |
|---|
| 5173 | ! - flow into 2 or more neighboring GCM grids |
|---|
| 5174 | ! - flow into a neighboring GCM grids and into the ocean or be a return flow (=97. =98, =99) |
|---|
| 5175 | ! - flow into a neighboring GCM grids or ocean and back into the same GCM grid box |
|---|
| 5176 | ! The only solution is to cut the basin up in as many parts. |
|---|
| 5177 | ! |
|---|
| 5178 | IF ( COUNT(trans(1:itrans) .GE. 97) .GT. 1) THEN |
|---|
| 5179 | ! |
|---|
| 5180 | nb_in = new_nb |
|---|
| 5181 | CALL routing_cutbasin(nbi, nbj, nbb, trip, basin, bname(ip), new_nb, new_bname, new_sz, new_pts) |
|---|
| 5182 | ! |
|---|
| 5183 | ! If we have split the basin then we need to cancel the old one |
|---|
| 5184 | ! |
|---|
| 5185 | IF ( nb_in .NE. new_nb) THEN |
|---|
| 5186 | sz(ip) = 0 |
|---|
| 5187 | ENDIF |
|---|
| 5188 | ! |
|---|
| 5189 | ENDIF |
|---|
| 5190 | ! |
|---|
| 5191 | ENDIF |
|---|
| 5192 | ENDDO |
|---|
| 5193 | ! |
|---|
| 5194 | ! Add the new basins to the end of the list |
|---|
| 5195 | ! |
|---|
| 5196 | If ( nbb+new_nb .LE. nbvmax) THEN |
|---|
| 5197 | DO ip=1,new_nb |
|---|
| 5198 | bname(nbb+ip) = new_bname(ip) |
|---|
| 5199 | sz(nbb+ip) = new_sz(ip) |
|---|
| 5200 | pts(nbb+ip,:,:) = new_pts(ip,:,:) |
|---|
| 5201 | ENDDO |
|---|
| 5202 | nbb = nbb+new_nb |
|---|
| 5203 | ELSE |
|---|
| 5204 | WRITE(numout,*) 'Increase nbvmax. It is too small to contain all the basins (routing_findbasins)' |
|---|
| 5205 | CALL ipslerr_p(3,'routing_findbasins','Increase nbvmax.','It is too small to contain all the basins','') |
|---|
| 5206 | ENDIF |
|---|
| 5207 | ! |
|---|
| 5208 | ! Keep the output direction |
|---|
| 5209 | ! |
|---|
| 5210 | DO ip=1,nbb |
|---|
| 5211 | IF ( sz(ip) .GT. 0 ) THEN |
|---|
| 5212 | trans(:) = 0 |
|---|
| 5213 | DO jp=1,sz(ip) |
|---|
| 5214 | trans(jp) = trip(pts(ip,jp,1),pts(ip,jp,2)) |
|---|
| 5215 | ENDDO |
|---|
| 5216 | outdir(ip) = MAXVAL(trans(1:sz(ip))) |
|---|
| 5217 | IF ( outdir(ip) .GE. 97 ) THEN |
|---|
| 5218 | outdir(ip) = outdir(ip) - 100 |
|---|
| 5219 | ELSE |
|---|
| 5220 | WRITE(numout,*) 'Why are we here and can not find a trip larger than 96' |
|---|
| 5221 | WRITE(numout,*) 'Does this mean that the basin does not have any outflow ', ip, bname(ip) |
|---|
| 5222 | WRITE(fmt,"('(',I3,'I9)')") nbi |
|---|
| 5223 | WRITE(numout,*) '-----------------------> trip' |
|---|
| 5224 | DO jp=1,nbj |
|---|
| 5225 | WRITE(numout,fmt) trip(1:nbi,jp) |
|---|
| 5226 | ENDDO |
|---|
| 5227 | WRITE(numout,*) '-----------------------> basin' |
|---|
| 5228 | DO jp=1,nbj |
|---|
| 5229 | WRITE(numout,fmt) basin(1:nbi,jp) |
|---|
| 5230 | ENDDO |
|---|
| 5231 | CALL ipslerr_p(3,'routing_findbasins','Probleme finding trip','','') |
|---|
| 5232 | ENDIF |
|---|
| 5233 | ENDIF |
|---|
| 5234 | ENDDO |
|---|
| 5235 | ! |
|---|
| 5236 | ! |
|---|
| 5237 | ! Sort the output by size of the various basins. |
|---|
| 5238 | ! |
|---|
| 5239 | nb_basin = COUNT(sz(1:nbb) .GT. 0) |
|---|
| 5240 | tmpsz(:) = -1 |
|---|
| 5241 | tmpsz(1:nbb) = sz(1:nbb) |
|---|
| 5242 | DO ip=1,nbb |
|---|
| 5243 | jpp = MAXLOC(tmpsz(:)) |
|---|
| 5244 | IF ( sz(jpp(1)) .GT. 0) THEN |
|---|
| 5245 | sortind(ip) = jpp(1) |
|---|
| 5246 | tmpsz(jpp(1)) = -1 |
|---|
| 5247 | ENDIF |
|---|
| 5248 | ENDDO |
|---|
| 5249 | basin_inbxid(1:nb_basin) = bname(sortind(1:nb_basin)) |
|---|
| 5250 | basin_sz(1:nb_basin) = sz(sortind(1:nb_basin)) |
|---|
| 5251 | basin_pts(1:nb_basin,:,:) = pts(sortind(1:nb_basin),:,:) |
|---|
| 5252 | basin_bxout(1:nb_basin) = outdir(sortind(1:nb_basin)) |
|---|
| 5253 | ! |
|---|
| 5254 | ! We can only check if we have at least as many outflows as basins |
|---|
| 5255 | ! |
|---|
| 5256 | ip = COUNT(trip(1:nbi,1:nbj) .GE. 97 .AND. trip(1:nbi,1:nbj) .LT. undef_int) |
|---|
| 5257 | !! ip = ip + COUNT(trip(1:nbi,1:nbj) .EQ. 97) |
|---|
| 5258 | !! IF ( COUNT(trip(1:nbi,1:nbj) .EQ. 98) .GT. 0) ip = ip + 1 |
|---|
| 5259 | IF ( ip .LT. nb_basin ) THEN |
|---|
| 5260 | WRITE(numout,*) 'We have less outflow points than basins :', ip |
|---|
| 5261 | WRITE(fmt,"('(',I3,'I9)')") nbi |
|---|
| 5262 | WRITE(numout,*) '-----------------------> trip' |
|---|
| 5263 | DO jp=1,nbj |
|---|
| 5264 | WRITE(numout,fmt) trip(1:nbi,jp) |
|---|
| 5265 | ENDDO |
|---|
| 5266 | WRITE(numout,*) '-----------------------> basin' |
|---|
| 5267 | DO jp=1,nbj |
|---|
| 5268 | WRITE(numout,fmt) basin(1:nbi,jp) |
|---|
| 5269 | ENDDO |
|---|
| 5270 | WRITE(numout,*) 'nb_basin :', nb_basin |
|---|
| 5271 | WRITE(numout,*) 'Basin sized :', basin_sz(1:nb_basin) |
|---|
| 5272 | CALL ipslerr_p(3,'routing_findbasins','Probleme less outflow points than basins','','') |
|---|
| 5273 | ENDIF |
|---|
| 5274 | |
|---|
| 5275 | END SUBROUTINE routing_findbasins |
|---|
| 5276 | ! |
|---|
| 5277 | !! ================================================================================================================================ |
|---|
| 5278 | !! SUBROUTINE : routing_simplify |
|---|
| 5279 | !! |
|---|
| 5280 | !>\BRIEF This subroutine symplifies the routing out of each basin by taking |
|---|
| 5281 | !! out redundancies at the borders of the GCM box. |
|---|
| 5282 | !! The aim is to have only one outflow point per basin and grid box. |
|---|
| 5283 | !! But here we will not change the direction of the outflow. |
|---|
| 5284 | !! |
|---|
| 5285 | !! DESCRIPTION (definitions, functional, design, flags) : None |
|---|
| 5286 | !! |
|---|
| 5287 | !! RECENT CHANGE(S): None |
|---|
| 5288 | !! |
|---|
| 5289 | !! MAIN OUTPUT VARIABLE(S): |
|---|
| 5290 | !! |
|---|
| 5291 | !! REFERENCES : None |
|---|
| 5292 | !! |
|---|
| 5293 | !! FLOWCHART : None |
|---|
| 5294 | !! \n |
|---|
| 5295 | !_ ================================================================================================================================ |
|---|
| 5296 | |
|---|
| 5297 | SUBROUTINE routing_simplify(nbi, nbj, trip, basin, hierarchy, basin_inbxid) |
|---|
| 5298 | ! |
|---|
| 5299 | IMPLICIT NONE |
|---|
| 5300 | ! |
|---|
| 5301 | !! LOCAL VARIABLES |
|---|
| 5302 | INTEGER(i_std) :: nbi !! Number of point in x within the grid (unitless) |
|---|
| 5303 | INTEGER(i_std) :: nbj !! Number of point in y within the grid (unitless) |
|---|
| 5304 | INTEGER(i_std) :: trip(:,:) !! The trip field (unitless) |
|---|
| 5305 | INTEGER(i_std) :: basin(:,:) !! |
|---|
| 5306 | REAL(r_std) :: hierarchy(:,:) !! |
|---|
| 5307 | INTEGER(i_std) :: basin_inbxid !! |
|---|
| 5308 | ! |
|---|
| 5309 | INTEGER(i_std) :: ip, jp, nbout, basin_sz, iborder !! |
|---|
| 5310 | 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) |
|---|
| 5311 | INTEGER(i_std), DIMENSION(nbvmax,nbvmax,2) :: trip_flow !! |
|---|
| 5312 | INTEGER(i_std), DIMENSION(nbvmax,2) :: outflow !! |
|---|
| 5313 | INTEGER(i_std), DIMENSION(nbvmax) :: outsz !! |
|---|
| 5314 | CHARACTER(LEN=7) :: fmt !! |
|---|
| 5315 | ! |
|---|
| 5316 | INTEGER(i_std), DIMENSION(8,2) :: inc !! |
|---|
| 5317 | INTEGER(i_std) :: itodo, ill(1), icc, ismall, ibas, iip, jjp, ib, id !! Indices (unitless) |
|---|
| 5318 | INTEGER(i_std), DIMENSION(nbvmax) :: todopt !! |
|---|
| 5319 | !!$, todosz |
|---|
| 5320 | REAL(r_std), DIMENSION(nbvmax) :: todohi !! |
|---|
| 5321 | LOGICAL :: not_found, debug = .FALSE. !! (true/false) |
|---|
| 5322 | |
|---|
| 5323 | !_ ================================================================================================================================ |
|---|
| 5324 | ! |
|---|
| 5325 | ! |
|---|
| 5326 | ! The routing code (i=1, j=2) |
|---|
| 5327 | ! |
|---|
| 5328 | inc(1,1) = 0 |
|---|
| 5329 | inc(1,2) = -1 |
|---|
| 5330 | inc(2,1) = 1 |
|---|
| 5331 | inc(2,2) = -1 |
|---|
| 5332 | inc(3,1) = 1 |
|---|
| 5333 | inc(3,2) = 0 |
|---|
| 5334 | inc(4,1) = 1 |
|---|
| 5335 | inc(4,2) = 1 |
|---|
| 5336 | inc(5,1) = 0 |
|---|
| 5337 | inc(5,2) = 1 |
|---|
| 5338 | inc(6,1) = -1 |
|---|
| 5339 | inc(6,2) = 1 |
|---|
| 5340 | inc(7,1) = -1 |
|---|
| 5341 | inc(7,2) = 0 |
|---|
| 5342 | inc(8,1) = -1 |
|---|
| 5343 | inc(8,2) = -1 |
|---|
| 5344 | ! |
|---|
| 5345 | ! |
|---|
| 5346 | ! Symplify the outflow conditions first. We are only interested in the |
|---|
| 5347 | ! outflows which go to different GCM grid boxes. |
|---|
| 5348 | ! |
|---|
| 5349 | IF ( debug ) THEN |
|---|
| 5350 | WRITE(numout,*) '+++++++++++++++++++ BEFORE ANYTHING ++++++++++++++++++++' |
|---|
| 5351 | WRITE(fmt,"('(',I3,'I6)')") nbi |
|---|
| 5352 | DO jp=1,nbj |
|---|
| 5353 | WRITE(numout,fmt) trip_tmp(1:nbi,jp) |
|---|
| 5354 | ENDDO |
|---|
| 5355 | ENDIF |
|---|
| 5356 | ! |
|---|
| 5357 | ! transfer the trips into an array which only contains the basin we are interested in |
|---|
| 5358 | ! |
|---|
| 5359 | trip_tmp(:,:) = -1 |
|---|
| 5360 | basin_sz = 0 |
|---|
| 5361 | DO ip=1,nbi |
|---|
| 5362 | DO jp=1,nbj |
|---|
| 5363 | IF ( basin(ip,jp) .EQ. basin_inbxid) THEN |
|---|
| 5364 | trip_tmp(ip,jp) = trip(ip,jp) |
|---|
| 5365 | basin_sz = basin_sz + 1 |
|---|
| 5366 | ENDIF |
|---|
| 5367 | ENDDO |
|---|
| 5368 | ENDDO |
|---|
| 5369 | ! |
|---|
| 5370 | ! Determine for each point where it flows to |
|---|
| 5371 | ! |
|---|
| 5372 | CALL routing_findrout(nbi, nbj, trip_tmp, basin_sz, basin_inbxid, nbout, outflow, trip_flow, outsz) |
|---|
| 5373 | ! |
|---|
| 5374 | ! |
|---|
| 5375 | ! |
|---|
| 5376 | ! |
|---|
| 5377 | ! Over the width of a GCM grid box we can have many outflows but we are interested |
|---|
| 5378 | ! in only one for each basin. Thus we wish to collect them all to form only one outflow |
|---|
| 5379 | ! to the neighboring grid box. |
|---|
| 5380 | ! |
|---|
| 5381 | DO iborder = 101,107,2 |
|---|
| 5382 | ! |
|---|
| 5383 | ! If we have more than one of these outflows then we need to merge the sub-basins |
|---|
| 5384 | ! |
|---|
| 5385 | icc = COUNT(trip_tmp .EQ. iborder)-1 |
|---|
| 5386 | DO WHILE ( icc .GT. 0) |
|---|
| 5387 | ! Pick out all the points we will have to do |
|---|
| 5388 | itodo = 0 |
|---|
| 5389 | DO ip=1,nbout |
|---|
| 5390 | IF (trip_tmp(outflow(ip,1),outflow(ip,2)) .EQ. iborder) THEN |
|---|
| 5391 | itodo = itodo + 1 |
|---|
| 5392 | todopt(itodo) = ip |
|---|
| 5393 | !!$ todosz(itodo) = outsz(ip) |
|---|
| 5394 | ! We take the hierarchy of the outflow point as we will try to |
|---|
| 5395 | ! minimize if for the outflow of the entire basin. |
|---|
| 5396 | todohi(itodo) = hierarchy(outflow(ip,1),outflow(ip,2)) |
|---|
| 5397 | ENDIF |
|---|
| 5398 | ENDDO |
|---|
| 5399 | ! |
|---|
| 5400 | ! We change the direction of the smallest basin. |
|---|
| 5401 | ! |
|---|
| 5402 | ill=MAXLOC(todohi(1:itodo)) |
|---|
| 5403 | ismall = todopt(ill(1)) |
|---|
| 5404 | ! |
|---|
| 5405 | DO ip=1,nbi |
|---|
| 5406 | DO jp=1,nbj |
|---|
| 5407 | IF ( trip_flow(ip,jp,1) .EQ. outflow(ismall,1) .AND.& |
|---|
| 5408 | & trip_flow(ip,jp,2) .EQ. outflow(ismall,2) ) THEN |
|---|
| 5409 | ! Now that we have found a point of the smallest sub-basin we |
|---|
| 5410 | ! look around for another sub-basin |
|---|
| 5411 | ib = 1 |
|---|
| 5412 | not_found = .TRUE. |
|---|
| 5413 | DO WHILE ( not_found .AND. ib .LE. itodo ) |
|---|
| 5414 | IF ( ib .NE. ill(1) ) THEN |
|---|
| 5415 | ibas = todopt(ib) |
|---|
| 5416 | DO id=1,8 |
|---|
| 5417 | iip = ip + inc(id,1) |
|---|
| 5418 | jjp = jp + inc(id,2) |
|---|
| 5419 | ! Can we look at this points or is there any need to ? |
|---|
| 5420 | IF ( iip .GE. 1 .AND. iip .LE. nbi .AND. & |
|---|
| 5421 | & jjp .GE. 1 .AND. jjp .LE. nbj .AND. not_found) THEN |
|---|
| 5422 | ! Is this point the one we look for ? |
|---|
| 5423 | IF ( trip_flow(iip,jjp,1) .EQ. outflow(ibas,1) .AND. & |
|---|
| 5424 | & trip_flow(iip,jjp,2) .EQ. outflow(ibas,2)) THEN |
|---|
| 5425 | trip_flow(ip,jp,1) = outflow(ibas,1) |
|---|
| 5426 | trip_flow(ip,jp,2) = outflow(ibas,2) |
|---|
| 5427 | trip_tmp(ip,jp) = id |
|---|
| 5428 | ! This last line ensures that we do not come back to this point |
|---|
| 5429 | ! and that in the end the outer while will stop |
|---|
| 5430 | not_found = .FALSE. |
|---|
| 5431 | ENDIF |
|---|
| 5432 | ENDIF |
|---|
| 5433 | ENDDO |
|---|
| 5434 | ENDIF |
|---|
| 5435 | ib = ib + 1 |
|---|
| 5436 | ENDDO |
|---|
| 5437 | ENDIF |
|---|
| 5438 | ENDDO |
|---|
| 5439 | ENDDO |
|---|
| 5440 | ! |
|---|
| 5441 | icc = icc - 1 |
|---|
| 5442 | ENDDO |
|---|
| 5443 | ! |
|---|
| 5444 | ! |
|---|
| 5445 | ENDDO |
|---|
| 5446 | ! |
|---|
| 5447 | IF ( debug ) THEN |
|---|
| 5448 | WRITE(numout,*) '+++++++++++++++++++ AFTER +++++++++++++++++++++++++++++' |
|---|
| 5449 | WRITE(fmt,"('(',I3,'I6)')") nbi |
|---|
| 5450 | DO jp=1,nbj |
|---|
| 5451 | WRITE(numout,fmt) trip_tmp(1:nbi,jp) |
|---|
| 5452 | ENDDO |
|---|
| 5453 | ENDIF |
|---|
| 5454 | ! |
|---|
| 5455 | ! Put trip_tmp back into trip |
|---|
| 5456 | ! |
|---|
| 5457 | DO ip=1,nbi |
|---|
| 5458 | DO jp=1,nbj |
|---|
| 5459 | IF ( trip_tmp(ip,jp) .GT. 0) THEN |
|---|
| 5460 | trip(ip,jp) = trip_tmp(ip,jp) |
|---|
| 5461 | ENDIF |
|---|
| 5462 | ENDDO |
|---|
| 5463 | ENDDO |
|---|
| 5464 | ! |
|---|
| 5465 | END SUBROUTINE routing_simplify |
|---|
| 5466 | ! |
|---|
| 5467 | !! ================================================================================================================================ |
|---|
| 5468 | !! SUBROUTINE : routing_cutbasin |
|---|
| 5469 | !! |
|---|
| 5470 | !>\BRIEF This subroutine cuts the original basin which has more than one outflow |
|---|
| 5471 | !! into as many subbasins as outflow directions. |
|---|
| 5472 | !! |
|---|
| 5473 | !! DESCRIPTION (definitions, functional, design, flags) : None |
|---|
| 5474 | !! |
|---|
| 5475 | !! RECENT CHANGE(S): None |
|---|
| 5476 | !! |
|---|
| 5477 | !! MAIN OUTPUT VARIABLE(S): |
|---|
| 5478 | !! |
|---|
| 5479 | !! REFERENCES : None |
|---|
| 5480 | !! |
|---|
| 5481 | !! FLOWCHART : None |
|---|
| 5482 | !! \n |
|---|
| 5483 | !_ ================================================================================================================================ |
|---|
| 5484 | |
|---|
| 5485 | SUBROUTINE routing_cutbasin (nbi, nbj, nbbasins, trip, basin, basin_inbxid, nb, bname, sz, pts) |
|---|
| 5486 | ! |
|---|
| 5487 | IMPLICIT NONE |
|---|
| 5488 | ! |
|---|
| 5489 | !! INPUT VARIABLES |
|---|
| 5490 | INTEGER(i_std), INTENT(in) :: nbi, nbj !! Number of point in x and y within the grid (unitless) |
|---|
| 5491 | INTEGER(i_std), INTENT(in) :: nbbasins !! |
|---|
| 5492 | INTEGER(i_std), INTENT(in) :: basin_inbxid !! |
|---|
| 5493 | ! |
|---|
| 5494 | ! Modified |
|---|
| 5495 | INTEGER(i_std), INTENT(inout) :: trip(:,:) !! The trip field (unitless) |
|---|
| 5496 | INTEGER(i_std), INTENT(inout) :: basin(:,:) !! |
|---|
| 5497 | ! |
|---|
| 5498 | !! OUTPUT VARIABLES |
|---|
| 5499 | INTEGER(i_std), INTENT(out) :: nb !! |
|---|
| 5500 | INTEGER(i_std), INTENT(out) :: bname(nbvmax) !! |
|---|
| 5501 | INTEGER(i_std), INTENT(out) :: sz(nbvmax) !! |
|---|
| 5502 | INTEGER(i_std), INTENT(out) :: pts(nbvmax,nbvmax,2) !! |
|---|
| 5503 | ! |
|---|
| 5504 | !! LOCAL VARIABLES |
|---|
| 5505 | INTEGER(i_std) :: ip, jp, iip, jjp, ib, ibb, id, nbout !! Indices (unitless) |
|---|
| 5506 | INTEGER(i_std) :: basin_sz !! |
|---|
| 5507 | INTEGER(i_std) :: nb_in !! |
|---|
| 5508 | 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) |
|---|
| 5509 | INTEGER(i_std), DIMENSION(nbvmax,nbvmax,2) :: trip_flow !! |
|---|
| 5510 | INTEGER(i_std), DIMENSION(nbvmax,2) :: outflow !! |
|---|
| 5511 | INTEGER(i_std), DIMENSION(nbvmax) :: outsz !! |
|---|
| 5512 | CHARACTER(LEN=7) :: fmt !! |
|---|
| 5513 | LOGICAL :: not_found !! (true/false) |
|---|
| 5514 | LOGICAL :: debug=.FALSE. !! (true/false) |
|---|
| 5515 | ! |
|---|
| 5516 | INTEGER(i_std), DIMENSION(8,2) :: inc !! |
|---|
| 5517 | |
|---|
| 5518 | !_ ================================================================================================================================ |
|---|
| 5519 | ! |
|---|
| 5520 | ! |
|---|
| 5521 | ! The routing code (i=1, j=2) |
|---|
| 5522 | ! |
|---|
| 5523 | inc(1,1) = 0 |
|---|
| 5524 | inc(1,2) = -1 |
|---|
| 5525 | inc(2,1) = 1 |
|---|
| 5526 | inc(2,2) = -1 |
|---|
| 5527 | inc(3,1) = 1 |
|---|
| 5528 | inc(3,2) = 0 |
|---|
| 5529 | inc(4,1) = 1 |
|---|
| 5530 | inc(4,2) = 1 |
|---|
| 5531 | inc(5,1) = 0 |
|---|
| 5532 | inc(5,2) = 1 |
|---|
| 5533 | inc(6,1) = -1 |
|---|
| 5534 | inc(6,2) = 1 |
|---|
| 5535 | inc(7,1) = -1 |
|---|
| 5536 | inc(7,2) = 0 |
|---|
| 5537 | inc(8,1) = -1 |
|---|
| 5538 | inc(8,2) = -1 |
|---|
| 5539 | ! |
|---|
| 5540 | ! Set up a temporary trip field which only contains the values |
|---|
| 5541 | ! for the basin on which we currently work. |
|---|
| 5542 | ! |
|---|
| 5543 | trip_tmp(:,:) = -1 |
|---|
| 5544 | basin_sz = 0 |
|---|
| 5545 | DO ip=1,nbi |
|---|
| 5546 | DO jp=1,nbj |
|---|
| 5547 | IF ( basin(ip,jp) .EQ. basin_inbxid) THEN |
|---|
| 5548 | trip_tmp(ip,jp) = trip(ip,jp) |
|---|
| 5549 | basin_sz = basin_sz + 1 |
|---|
| 5550 | ENDIF |
|---|
| 5551 | ENDDO |
|---|
| 5552 | ENDDO |
|---|
| 5553 | ! |
|---|
| 5554 | CALL routing_findrout(nbi, nbj, trip_tmp, basin_sz, basin_inbxid, nbout, outflow, trip_flow, outsz) |
|---|
| 5555 | ! |
|---|
| 5556 | ! IF ( debug ) THEN |
|---|
| 5557 | ! DO ib = nb_in+1,nb |
|---|
| 5558 | ! DO ip=1,sz(ib) |
|---|
| 5559 | ! trip_tmp(pts(ib, ip, 1),pts(ib, ip, 2)) = ib*(-1)-900 |
|---|
| 5560 | ! ENDDO |
|---|
| 5561 | ! ENDDO |
|---|
| 5562 | ! WRITE(fmt,"('(',I3,'I6)')") nbi |
|---|
| 5563 | ! WRITE(numout,*) 'BEFORE ------------> New basins ' |
|---|
| 5564 | ! WRITE(numout,*) nb, ' sz :', sz(1:nb) |
|---|
| 5565 | ! DO jp=1,nbj |
|---|
| 5566 | ! WRITE(numout,fmt) trip_tmp(1:nbi,jp) |
|---|
| 5567 | ! ENDDO |
|---|
| 5568 | ! ENDIF |
|---|
| 5569 | ! |
|---|
| 5570 | ! Take out the small sub-basins. That is those which have only one grid box |
|---|
| 5571 | ! This is only done if we need to save space in the number of basins. Else we |
|---|
| 5572 | ! can take it easy and keep diverging sub-basins for the moment. |
|---|
| 5573 | ! |
|---|
| 5574 | IF ( nbbasins .GE. nbasmax ) THEN |
|---|
| 5575 | DO ib=1,nbout |
|---|
| 5576 | ! If the sub-basin is of size one and its larger neighbor is flowing into another |
|---|
| 5577 | ! direction then we put them together. |
|---|
| 5578 | IF ( outsz(ib) .EQ. 1 .AND. trip(outflow(ib,1), outflow(ib,2)) .GT. 99 ) THEN |
|---|
| 5579 | ! |
|---|
| 5580 | not_found = .TRUE. |
|---|
| 5581 | DO id=1,8 |
|---|
| 5582 | ip = outflow(ib,1) |
|---|
| 5583 | jp = outflow(ib,2) |
|---|
| 5584 | iip = ip + inc(id,1) |
|---|
| 5585 | jjp = jp + inc(id,2) |
|---|
| 5586 | ! Can we look at this points ? |
|---|
| 5587 | IF ( iip .GE. 1 .AND. iip .LE. nbi .AND. & |
|---|
| 5588 | & jjp .GE. 1 .AND. jjp .LE. nbj .AND. not_found) THEN |
|---|
| 5589 | ! Did we find a direct neighbor which is an outflow point ? |
|---|
| 5590 | IF ( trip_tmp(iip,jjp) .GT. 100 ) THEN |
|---|
| 5591 | ! IF so direct the flow towards it and update the tables. |
|---|
| 5592 | not_found = .FALSE. |
|---|
| 5593 | trip(ip,jp) = id |
|---|
| 5594 | trip_tmp(ip,jp) = id |
|---|
| 5595 | outsz(ib) = 0 |
|---|
| 5596 | ! update the table of this basin |
|---|
| 5597 | DO ibb=1,nbout |
|---|
| 5598 | IF ( iip .EQ. outflow(ibb,1) .AND. jjp .EQ. outflow(ibb,2) ) THEN |
|---|
| 5599 | outsz(ibb) = outsz(ibb)+1 |
|---|
| 5600 | trip_flow(ip,jp,1) = outflow(ibb,1) |
|---|
| 5601 | trip_flow(ip,jp,2) = outflow(ibb,2) |
|---|
| 5602 | ENDIF |
|---|
| 5603 | ENDDO |
|---|
| 5604 | ENDIF |
|---|
| 5605 | ENDIF |
|---|
| 5606 | ENDDO |
|---|
| 5607 | ENDIF |
|---|
| 5608 | ENDDO |
|---|
| 5609 | ENDIF |
|---|
| 5610 | ! |
|---|
| 5611 | ! |
|---|
| 5612 | ! Cut the basin if we have more than 1 left. |
|---|
| 5613 | ! |
|---|
| 5614 | ! |
|---|
| 5615 | IF ( COUNT(outsz(1:nbout) .GT. 0) .GT. 1 ) THEN |
|---|
| 5616 | ! |
|---|
| 5617 | nb_in = nb |
|---|
| 5618 | ! |
|---|
| 5619 | DO ib = 1,nbout |
|---|
| 5620 | IF ( outsz(ib) .GT. 0) THEN |
|---|
| 5621 | nb = nb+1 |
|---|
| 5622 | IF ( nb .GT. nbvmax) THEN |
|---|
| 5623 | WRITE(numout,*) 'nbvmax too small, increase it (routing_cutbasin)' |
|---|
| 5624 | ENDIF |
|---|
| 5625 | bname(nb) = basin_inbxid |
|---|
| 5626 | sz(nb) = 0 |
|---|
| 5627 | DO ip=1,nbi |
|---|
| 5628 | DO jp=1,nbj |
|---|
| 5629 | IF ( (trip_flow(ip,jp,1) + trip_flow(ip,jp,1)) .GT. 0 .AND. & |
|---|
| 5630 | & trip_flow(ip,jp,1) .EQ. outflow(ib,1) .AND. & |
|---|
| 5631 | & trip_flow(ip,jp,2) .EQ. outflow(ib,2) ) THEN |
|---|
| 5632 | sz(nb) = sz(nb) + 1 |
|---|
| 5633 | pts(nb, sz(nb), 1) = ip |
|---|
| 5634 | pts(nb, sz(nb), 2) = jp |
|---|
| 5635 | ENDIF |
|---|
| 5636 | ENDDO |
|---|
| 5637 | ENDDO |
|---|
| 5638 | ENDIF |
|---|
| 5639 | ENDDO |
|---|
| 5640 | ! A short verification |
|---|
| 5641 | IF ( SUM(sz(nb_in+1:nb)) .NE. basin_sz) THEN |
|---|
| 5642 | WRITE(numout,*) 'Lost some points while spliting the basin' |
|---|
| 5643 | WRITE(numout,*) 'nbout :', nbout |
|---|
| 5644 | DO ib = nb_in+1,nb |
|---|
| 5645 | WRITE(numout,*) 'ib, SZ :', ib, sz(ib) |
|---|
| 5646 | ENDDO |
|---|
| 5647 | WRITE(fmt,"('(',I3,'I6)')") nbi |
|---|
| 5648 | WRITE(numout,*) '-------------> trip ' |
|---|
| 5649 | DO jp=1,nbj |
|---|
| 5650 | WRITE(numout,fmt) trip_tmp(1:nbi,jp) |
|---|
| 5651 | ENDDO |
|---|
| 5652 | CALL ipslerr_p(3,'routing_cutbasin','Lost some points while spliting the basin','','') |
|---|
| 5653 | ENDIF |
|---|
| 5654 | |
|---|
| 5655 | IF ( debug ) THEN |
|---|
| 5656 | DO ib = nb_in+1,nb |
|---|
| 5657 | DO ip=1,sz(ib) |
|---|
| 5658 | trip_tmp(pts(ib, ip, 1),pts(ib, ip, 2)) = ib*(-1)-900 |
|---|
| 5659 | ENDDO |
|---|
| 5660 | ENDDO |
|---|
| 5661 | WRITE(fmt,"('(',I3,'I6)')") nbi |
|---|
| 5662 | WRITE(numout,*) 'AFTER-------------> New basins ' |
|---|
| 5663 | WRITE(numout,*) nb, ' sz :', sz(1:nb) |
|---|
| 5664 | DO jp=1,nbj |
|---|
| 5665 | WRITE(numout,fmt) trip_tmp(1:nbi,jp) |
|---|
| 5666 | ENDDO |
|---|
| 5667 | IF ( MAXVAl(trip_tmp(1:nbi,1:nbj)) .GT. 0) THEN |
|---|
| 5668 | CALL ipslerr_p(3,'routing_cutbasin','Error in debug checking','','') |
|---|
| 5669 | ENDIF |
|---|
| 5670 | ENDIF |
|---|
| 5671 | ENDIF |
|---|
| 5672 | ! |
|---|
| 5673 | END SUBROUTINE routing_cutbasin |
|---|
| 5674 | ! |
|---|
| 5675 | !! ================================================================================================================================ |
|---|
| 5676 | !! SUBROUTINE : routing_hierarchy |
|---|
| 5677 | !! |
|---|
| 5678 | !>\BRIEF This subroutine finds, for each point, the distance to the outflow |
|---|
| 5679 | !! point along the flowlines of the basin. |
|---|
| 5680 | !! |
|---|
| 5681 | !! DESCRIPTION (definitions, functional, design, flags) : None |
|---|
| 5682 | !! |
|---|
| 5683 | !! RECENT CHANGE(S): None |
|---|
| 5684 | !! |
|---|
| 5685 | !! MAIN OUTPUT VARIABLE(S): |
|---|
| 5686 | !! |
|---|
| 5687 | !! REFERENCES : None |
|---|
| 5688 | !! |
|---|
| 5689 | !! FLOWCHART : None |
|---|
| 5690 | !! \n |
|---|
| 5691 | !_ ================================================================================================================================ |
|---|
| 5692 | |
|---|
| 5693 | SUBROUTINE routing_hierarchy(iml, jml, trip, topoindex, hierarchy) |
|---|
| 5694 | ! |
|---|
| 5695 | IMPLICIT NONE |
|---|
| 5696 | ! |
|---|
| 5697 | !! LOCAL VARIABLES |
|---|
| 5698 | INTEGER(i_std) :: iml !! X resolution of the high resolution grid |
|---|
| 5699 | INTEGER(i_std) :: jml !! Y resolution of the high resolution grid |
|---|
| 5700 | REAL(r_std), DIMENSION(iml,jml) :: trip !! The trip field (unitless) |
|---|
| 5701 | REAL(r_std), DIMENSION(iml,jml) :: hierarchy !! |
|---|
| 5702 | REAL(r_std), DIMENSION(iml,jml) :: topoindex !! Topographic index of the residence time (m) |
|---|
| 5703 | ! |
|---|
| 5704 | INTEGER(i_std), DIMENSION(8,2) :: inc !! |
|---|
| 5705 | INTEGER(i_std) :: ip, jp, ib, ntripi, ntripj, cnt, trp !! |
|---|
| 5706 | REAL(r_std) :: topohier !! The new value of topographically weighted hierarchy (m) |
|---|
| 5707 | REAL(r_std) :: topohier_old !! The old value of topographically weighted hierarchy (m) |
|---|
| 5708 | CHARACTER(LEN=7) :: fmt !! |
|---|
| 5709 | |
|---|
| 5710 | !_ ================================================================================================================================ |
|---|
| 5711 | ! |
|---|
| 5712 | ! The routing code (i=1, j=2) |
|---|
| 5713 | ! |
|---|
| 5714 | inc(1,1) = 0 |
|---|
| 5715 | inc(1,2) = -1 |
|---|
| 5716 | inc(2,1) = 1 |
|---|
| 5717 | inc(2,2) = -1 |
|---|
| 5718 | inc(3,1) = 1 |
|---|
| 5719 | inc(3,2) = 0 |
|---|
| 5720 | inc(4,1) = 1 |
|---|
| 5721 | inc(4,2) = 1 |
|---|
| 5722 | inc(5,1) = 0 |
|---|
| 5723 | inc(5,2) = 1 |
|---|
| 5724 | inc(6,1) = -1 |
|---|
| 5725 | inc(6,2) = 1 |
|---|
| 5726 | inc(7,1) = -1 |
|---|
| 5727 | inc(7,2) = 0 |
|---|
| 5728 | inc(8,1) = -1 |
|---|
| 5729 | inc(8,2) = -1 |
|---|
| 5730 | ! |
|---|
| 5731 | DO ip=1,iml |
|---|
| 5732 | DO jp=1,jml |
|---|
| 5733 | IF ( trip(ip,jp) .LT. undef_sechiba ) THEN |
|---|
| 5734 | ntripi = ip |
|---|
| 5735 | ntripj = jp |
|---|
| 5736 | trp = NINT(trip(ip,jp)) |
|---|
| 5737 | cnt = 1 |
|---|
| 5738 | ! Warn for extreme numbers |
|---|
| 5739 | IF ( topoindex(ip,jp) .GT. 1.e10 ) THEN |
|---|
| 5740 | WRITE(numout,*) 'We have a very large topographic index for point ', ip, jp |
|---|
| 5741 | WRITE(numout,*) 'This can not be right :', topoindex(ip,jp) |
|---|
| 5742 | CALL ipslerr_p(3,'routing_hierarchy','Too large topographic index','','') |
|---|
| 5743 | ELSE |
|---|
| 5744 | topohier = topoindex(ip,jp) |
|---|
| 5745 | ENDIF |
|---|
| 5746 | ! |
|---|
| 5747 | DO WHILE ( trp .GT. 0 .AND. trp .LT. 9 .AND. cnt .LT. iml*jml) |
|---|
| 5748 | cnt = cnt + 1 |
|---|
| 5749 | ntripi = ntripi + inc(trp,1) |
|---|
| 5750 | IF ( ntripi .LT. 1) ntripi = iml |
|---|
| 5751 | IF ( ntripi .GT. iml) ntripi = 1 |
|---|
| 5752 | ntripj = ntripj + inc(trp,2) |
|---|
| 5753 | topohier_old = topohier |
|---|
| 5754 | topohier = topohier + topoindex(ntripi, ntripj) |
|---|
| 5755 | IF ( topohier_old .GT. topohier) THEN |
|---|
| 5756 | WRITE(numout,*) 'Big Problem, how comes we climb up a hill ?' |
|---|
| 5757 | WRITE(numout,*) 'The old value of topographicaly weighted hierarchy was : ', topohier_old |
|---|
| 5758 | WRITE(numout,*) 'The new one is :', topohier |
|---|
| 5759 | CALL ipslerr_p(3,'routing_hierarchy','Big Problem, how comes we climb up a hill ?','','') |
|---|
| 5760 | ENDIF |
|---|
| 5761 | trp = NINT(trip(ntripi, ntripj)) |
|---|
| 5762 | ENDDO |
|---|
| 5763 | |
|---|
| 5764 | IF ( cnt .EQ. iml*jml) THEN |
|---|
| 5765 | WRITE(numout,*) 'We could not route point (routing_findrout) :', ip, jp |
|---|
| 5766 | WRITE(numout,*) '-------------> trip ' |
|---|
| 5767 | WRITE(fmt,"('(',I3,'I6)')") iml |
|---|
| 5768 | DO ib=1,jml |
|---|
| 5769 | WRITE(numout,fmt) trip(1:iml,ib) |
|---|
| 5770 | ENDDO |
|---|
| 5771 | CALL ipslerr_p(3,'routing_hierarchy','We could not route point','','') |
|---|
| 5772 | ENDIF |
|---|
| 5773 | |
|---|
| 5774 | hierarchy(ip,jp) = topohier |
|---|
| 5775 | |
|---|
| 5776 | ENDIF |
|---|
| 5777 | ENDDO |
|---|
| 5778 | ENDDO |
|---|
| 5779 | ! |
|---|
| 5780 | ! |
|---|
| 5781 | END SUBROUTINE routing_hierarchy |
|---|
| 5782 | ! |
|---|
| 5783 | !! ================================================================================================================================ |
|---|
| 5784 | !! SUBROUTINE : routing_findrout |
|---|
| 5785 | !! |
|---|
| 5786 | !>\BRIEF This subroutine simply computes the route to each outflow point |
|---|
| 5787 | !! and returns the outflow point for each point in the basin. |
|---|
| 5788 | !! |
|---|
| 5789 | !! DESCRIPTION (definitions, functional, design, flags) : None |
|---|
| 5790 | !! |
|---|
| 5791 | !! RECENT CHANGE(S): None |
|---|
| 5792 | !! |
|---|
| 5793 | !! MAIN OUTPUT VARIABLE(S): |
|---|
| 5794 | !! |
|---|
| 5795 | !! REFERENCES : None |
|---|
| 5796 | !! |
|---|
| 5797 | !! FLOWCHART : None |
|---|
| 5798 | !! \n |
|---|
| 5799 | !_ ================================================================================================================================ |
|---|
| 5800 | |
|---|
| 5801 | SUBROUTINE routing_findrout(nbi, nbj, trip, basin_sz, basinid, nbout, outflow, trip_flow, outsz) |
|---|
| 5802 | ! |
|---|
| 5803 | IMPLICIT NONE |
|---|
| 5804 | ! |
|---|
| 5805 | !! INPUT VARIABLES |
|---|
| 5806 | INTEGER(i_std) :: nbi !! Number of point in x within the grid (unitless) |
|---|
| 5807 | INTEGER(i_std) :: nbj !! Number of point in y within the grid (unitless) |
|---|
| 5808 | INTEGER(i_std), DIMENSION(nbvmax,nbvmax) :: trip !! The trip field (unitless) |
|---|
| 5809 | INTEGER(i_std) :: basin_sz !! |
|---|
| 5810 | INTEGER(i_std) :: basinid !! |
|---|
| 5811 | ! |
|---|
| 5812 | !! OUTPUT VARIABLES |
|---|
| 5813 | INTEGER(i_std), DIMENSION(nbvmax,2), INTENT(out) :: outflow !! |
|---|
| 5814 | INTEGER(i_std), DIMENSION(nbvmax,nbvmax,2), INTENT(out) :: trip_flow !! |
|---|
| 5815 | INTEGER(i_std), INTENT(out) :: nbout !! |
|---|
| 5816 | INTEGER(i_std), DIMENSION(nbvmax), INTENT(out) :: outsz !! |
|---|
| 5817 | ! |
|---|
| 5818 | !! LOCAL VARIABLES |
|---|
| 5819 | INTEGER(i_std), DIMENSION(8,2) :: inc !! |
|---|
| 5820 | INTEGER(i_std) :: ip, jp, ib, cnt, trp, totsz !! Indices (unitless) |
|---|
| 5821 | CHARACTER(LEN=7) :: fmt !! |
|---|
| 5822 | |
|---|
| 5823 | !_ ================================================================================================================================ |
|---|
| 5824 | ! |
|---|
| 5825 | ! |
|---|
| 5826 | ! The routing code (i=1, j=2) |
|---|
| 5827 | ! |
|---|
| 5828 | inc(1,1) = 0 |
|---|
| 5829 | inc(1,2) = -1 |
|---|
| 5830 | inc(2,1) = 1 |
|---|
| 5831 | inc(2,2) = -1 |
|---|
| 5832 | inc(3,1) = 1 |
|---|
| 5833 | inc(3,2) = 0 |
|---|
| 5834 | inc(4,1) = 1 |
|---|
| 5835 | inc(4,2) = 1 |
|---|
| 5836 | inc(5,1) = 0 |
|---|
| 5837 | inc(5,2) = 1 |
|---|
| 5838 | inc(6,1) = -1 |
|---|
| 5839 | inc(6,2) = 1 |
|---|
| 5840 | inc(7,1) = -1 |
|---|
| 5841 | inc(7,2) = 0 |
|---|
| 5842 | inc(8,1) = -1 |
|---|
| 5843 | inc(8,2) = -1 |
|---|
| 5844 | ! |
|---|
| 5845 | ! |
|---|
| 5846 | ! Get the outflows and determine for each point to which outflow point it belong |
|---|
| 5847 | ! |
|---|
| 5848 | nbout = 0 |
|---|
| 5849 | trip_flow(:,:,:) = 0 |
|---|
| 5850 | DO ip=1,nbi |
|---|
| 5851 | DO jp=1,nbj |
|---|
| 5852 | IF ( trip(ip,jp) .GT. 9) THEN |
|---|
| 5853 | nbout = nbout + 1 |
|---|
| 5854 | outflow(nbout,1) = ip |
|---|
| 5855 | outflow(nbout,2) = jp |
|---|
| 5856 | ENDIF |
|---|
| 5857 | IF ( trip(ip,jp) .GT. 0) THEN |
|---|
| 5858 | trip_flow(ip,jp,1) = ip |
|---|
| 5859 | trip_flow(ip,jp,2) = jp |
|---|
| 5860 | ENDIF |
|---|
| 5861 | ENDDO |
|---|
| 5862 | ENDDO |
|---|
| 5863 | ! |
|---|
| 5864 | ! Follow the flow of the water |
|---|
| 5865 | ! |
|---|
| 5866 | DO ip=1,nbi |
|---|
| 5867 | DO jp=1,nbj |
|---|
| 5868 | IF ( (trip_flow(ip,jp,1) + trip_flow(ip,jp,2)) .GT. 0) THEN |
|---|
| 5869 | trp = trip(trip_flow(ip,jp,1), trip_flow(ip,jp,2)) |
|---|
| 5870 | cnt = 0 |
|---|
| 5871 | DO WHILE ( trp .GT. 0 .AND. trp .LT. 9 .AND. cnt .LT. nbi*nbj) |
|---|
| 5872 | cnt = cnt + 1 |
|---|
| 5873 | trip_flow(ip,jp,1) = trip_flow(ip,jp,1) + inc(trp,1) |
|---|
| 5874 | trip_flow(ip,jp,2) = trip_flow(ip,jp,2) + inc(trp,2) |
|---|
| 5875 | trp = trip(trip_flow(ip,jp,1), trip_flow(ip,jp,2)) |
|---|
| 5876 | ENDDO |
|---|
| 5877 | IF ( cnt .EQ. nbi*nbj) THEN |
|---|
| 5878 | WRITE(numout,*) 'We could not route point (routing_findrout) :', ip, jp |
|---|
| 5879 | WRITE(numout,*) '-------------> trip ' |
|---|
| 5880 | WRITE(fmt,"('(',I3,'I6)')") nbi |
|---|
| 5881 | DO ib=1,nbj |
|---|
| 5882 | WRITE(numout,fmt) trip(1:nbi,ib) |
|---|
| 5883 | ENDDO |
|---|
| 5884 | CALL ipslerr_p(3,'routing_findrout','We could not route point','','') |
|---|
| 5885 | ENDIF |
|---|
| 5886 | ENDIF |
|---|
| 5887 | ENDDO |
|---|
| 5888 | ENDDO |
|---|
| 5889 | ! |
|---|
| 5890 | ! What is the size of the region behind each outflow point ? |
|---|
| 5891 | ! |
|---|
| 5892 | totsz = 0 |
|---|
| 5893 | DO ip=1,nbout |
|---|
| 5894 | outsz(ip) = COUNT(trip_flow(:,:,1) .EQ. outflow(ip,1) .AND. trip_flow(:,:,2) .EQ. outflow(ip,2)) |
|---|
| 5895 | totsz = totsz + outsz(ip) |
|---|
| 5896 | ENDDO |
|---|
| 5897 | IF ( basin_sz .NE. totsz) THEN |
|---|
| 5898 | WRITE(numout,*) 'Water got lost while I tried to follow it ' |
|---|
| 5899 | WRITE(numout,*) basin_sz, totsz |
|---|
| 5900 | WRITE(numout,*) 'Basin id :', basinid |
|---|
| 5901 | DO ip=1,nbout |
|---|
| 5902 | WRITE(numout,*) 'ip :', ip, ' outsz :', outsz(ip), ' outflow :', outflow(ip,1), outflow(ip,2) |
|---|
| 5903 | ENDDO |
|---|
| 5904 | WRITE(numout,*) '-------------> trip ' |
|---|
| 5905 | WRITE(fmt,"('(',I3,'I6)')") nbi |
|---|
| 5906 | DO jp=1,nbj |
|---|
| 5907 | WRITE(numout,fmt) trip(1:nbi,jp) |
|---|
| 5908 | ENDDO |
|---|
| 5909 | CALL ipslerr_p(3,'routing_findrout','Water got lost while I tried to follow it','','') |
|---|
| 5910 | ENDIF |
|---|
| 5911 | ! |
|---|
| 5912 | END SUBROUTINE routing_findrout |
|---|
| 5913 | ! |
|---|
| 5914 | !! ================================================================================================================================ |
|---|
| 5915 | !! SUBROUTINE : routing_globalize |
|---|
| 5916 | !! |
|---|
| 5917 | !>\BRIEF This subroutine puts the basins found for grid box in the global map. |
|---|
| 5918 | !! Connection can only be made later when all information is together. |
|---|
| 5919 | !! |
|---|
| 5920 | !! DESCRIPTION (definitions, functional, design, flags) : None |
|---|
| 5921 | !! |
|---|
| 5922 | !! RECENT CHANGE(S): None |
|---|
| 5923 | !! |
|---|
| 5924 | !! MAIN OUTPUT VARIABLE(S): |
|---|
| 5925 | !! One of the outputs is basin_flowdir. Its convention is 1-8 for the directions from North to North |
|---|
| 5926 | !! West going through South. The negative values will be -3 for return flow, -2 for coastal flow |
|---|
| 5927 | !! |
|---|
| 5928 | !! REFERENCES : None |
|---|
| 5929 | !! |
|---|
| 5930 | !! FLOWCHART : None |
|---|
| 5931 | !! \n |
|---|
| 5932 | !_ ================================================================================================================================ |
|---|
| 5933 | |
|---|
| 5934 | SUBROUTINE routing_globalize(nbpt, ib, neighbours, area_bx, trip_bx, hierarchy_bx, topoind_bx, min_topoind,& |
|---|
| 5935 | & nb_basin, basin_inbxid, basin_sz, basin_pts, basin_bxout, coast_pts, nwbas, basin_count,& |
|---|
| 5936 | & basin_area, basin_hierarchy, basin_topoind, basin_id, basin_flowdir, outflow_grid,& |
|---|
| 5937 | & nbcoastal, coastal_basin) |
|---|
| 5938 | ! |
|---|
| 5939 | IMPLICIT NONE |
|---|
| 5940 | ! |
|---|
| 5941 | !! INPUT VARIABLES |
|---|
| 5942 | INTEGER(i_std), INTENT (in) :: nbpt !! Domain size (unitless) |
|---|
| 5943 | INTEGER(i_std), INTENT (in) :: ib !! Current basin (unitless) |
|---|
| 5944 | INTEGER(i_std), INTENT(in) :: neighbours(nbpt,NbNeighb)!! Vector of neighbours for each grid point |
|---|
| 5945 | !! (1=North and then clockwise) |
|---|
| 5946 | !! LOCAL VARIABLES |
|---|
| 5947 | REAL(r_std), DIMENSION(nbvmax,nbvmax) :: area_bx !! Area of each small box in the grid box (m^2) |
|---|
| 5948 | INTEGER(i_std), DIMENSION(nbvmax,nbvmax) :: trip_bx !! The trip field for each of the smaller boxes (unitless) |
|---|
| 5949 | REAL(r_std), DIMENSION(nbvmax,nbvmax) :: hierarchy_bx !! Level in the basin of the point |
|---|
| 5950 | REAL(r_std), DIMENSION(nbvmax,nbvmax) :: topoind_bx !! Topographic index of the residence time for each of the smaller boxes (m) |
|---|
| 5951 | REAL(r_std) :: min_topoind !! The current minimum of topographic index (m) |
|---|
| 5952 | INTEGER(i_std) :: nb_basin !! Number of sub-basins (unitless) |
|---|
| 5953 | INTEGER(i_std), DIMENSION(nbvmax) :: basin_inbxid, basin_sz !! ID of basin, number of points in the basin |
|---|
| 5954 | INTEGER(i_std), DIMENSION(nbvmax,nbvmax,2) :: basin_pts !! Points in each basin |
|---|
| 5955 | INTEGER(i_std), DIMENSION(nbvmax) :: basin_bxout !! outflow direction |
|---|
| 5956 | INTEGER(i_std) :: coast_pts(nbvmax) !! The coastal flow points (unitless) |
|---|
| 5957 | ! global maps |
|---|
| 5958 | INTEGER(i_std) :: nwbas !! |
|---|
| 5959 | INTEGER(i_std), DIMENSION(nbpt) :: basin_count !! |
|---|
| 5960 | INTEGER(i_std), DIMENSION(nbpt,nwbas) :: basin_id !! |
|---|
| 5961 | INTEGER(i_std), DIMENSION(nbpt,nwbas) :: basin_flowdir !! Water flow directions in the basin (unitless) |
|---|
| 5962 | REAL(r_std), DIMENSION(nbpt,nwbas) :: basin_area !! |
|---|
| 5963 | REAL(r_std), DIMENSION(nbpt,nwbas) :: basin_hierarchy !! |
|---|
| 5964 | REAL(r_std), DIMENSION(nbpt,nwbas) :: basin_topoind !! Topographic index of the residence time for a basin (m) |
|---|
| 5965 | INTEGER(i_std), DIMENSION(nbpt,nwbas) :: outflow_grid !! Type of outflow on the grid box (unitless) |
|---|
| 5966 | INTEGER(i_std), DIMENSION(nbpt) :: nbcoastal !! |
|---|
| 5967 | INTEGER(i_std), DIMENSION(nbpt,nwbas) :: coastal_basin !! |
|---|
| 5968 | ! |
|---|
| 5969 | INTEGER(i_std) :: ij, iz !! Indices (unitless) |
|---|
| 5970 | CHARACTER(LEN=4) :: hierar_method = 'OUTP' !! |
|---|
| 5971 | |
|---|
| 5972 | !_ ================================================================================================================================ |
|---|
| 5973 | ! |
|---|
| 5974 | ! |
|---|
| 5975 | DO ij=1, nb_basin |
|---|
| 5976 | ! |
|---|
| 5977 | ! Count the basins and keep their ID |
|---|
| 5978 | ! |
|---|
| 5979 | basin_count(ib) = basin_count(ib)+1 |
|---|
| 5980 | if (basin_count(ib) > nwbas) then |
|---|
| 5981 | WRITE(numout,*) 'ib=',ib |
|---|
| 5982 | call ipslerr_p(3,'routing_globalize', & |
|---|
| 5983 | & 'Problem with basin_count : ', & |
|---|
| 5984 | & 'It is greater than number of allocated basin nwbas.', & |
|---|
| 5985 | & '(stop to count basins)') |
|---|
| 5986 | endif |
|---|
| 5987 | basin_id(ib,basin_count(ib)) = basin_inbxid(ij) |
|---|
| 5988 | ! |
|---|
| 5989 | ! Transfer the list of basins which flow into the ocean as coastal flow. |
|---|
| 5990 | ! |
|---|
| 5991 | IF ( basin_id(ib,basin_count(ib)) .LT. 0) THEN |
|---|
| 5992 | nbcoastal(ib) = basin_sz(ij) |
|---|
| 5993 | coastal_basin(ib,1:nbcoastal(ib)) = coast_pts(1:nbcoastal(ib)) |
|---|
| 5994 | ENDIF |
|---|
| 5995 | ! |
|---|
| 5996 | ! |
|---|
| 5997 | ! Compute the area of the basin |
|---|
| 5998 | ! |
|---|
| 5999 | basin_area(ib,ij) = zero |
|---|
| 6000 | basin_hierarchy(ib,ij) = zero |
|---|
| 6001 | ! |
|---|
| 6002 | SELECT CASE (hierar_method) |
|---|
| 6003 | ! |
|---|
| 6004 | CASE("MINI") |
|---|
| 6005 | basin_hierarchy(ib,ij) = undef_sechiba |
|---|
| 6006 | ! |
|---|
| 6007 | END SELECT |
|---|
| 6008 | basin_topoind(ib,ij) = zero |
|---|
| 6009 | ! |
|---|
| 6010 | DO iz=1,basin_sz(ij) |
|---|
| 6011 | ! |
|---|
| 6012 | basin_area(ib,ij) = basin_area(ib,ij) + area_bx(basin_pts(ij,iz,1),basin_pts(ij,iz,2)) |
|---|
| 6013 | basin_topoind(ib,ij) = basin_topoind(ib,ij) + topoind_bx(basin_pts(ij,iz,1),basin_pts(ij,iz,2)) |
|---|
| 6014 | ! |
|---|
| 6015 | ! There are a number of ways to determine the hierarchy of the entire basin. |
|---|
| 6016 | ! We allow for three here : |
|---|
| 6017 | ! - Take the mean value |
|---|
| 6018 | ! - Take the minimum value within the basin |
|---|
| 6019 | ! - Take the value at the outflow point |
|---|
| 6020 | ! Probably taking the value of the outflow point is the best solution. |
|---|
| 6021 | ! |
|---|
| 6022 | SELECT CASE (hierar_method) |
|---|
| 6023 | ! |
|---|
| 6024 | CASE("MEAN") |
|---|
| 6025 | ! Mean hierarchy of the basin |
|---|
| 6026 | basin_hierarchy(ib,ij) = basin_hierarchy(ib,ij) + & |
|---|
| 6027 | & hierarchy_bx(basin_pts(ij,iz,1),basin_pts(ij,iz,2)) |
|---|
| 6028 | CASE("MINI") |
|---|
| 6029 | ! The smallest value of the basin |
|---|
| 6030 | IF ( hierarchy_bx(basin_pts(ij,iz,1),basin_pts(ij,iz,2)) .LT. basin_hierarchy(ib,ij)) THEN |
|---|
| 6031 | basin_hierarchy(ib,ij) = hierarchy_bx(basin_pts(ij,iz,1),basin_pts(ij,iz,2)) |
|---|
| 6032 | ENDIF |
|---|
| 6033 | CASE("OUTP") |
|---|
| 6034 | ! Value at the outflow point |
|---|
| 6035 | IF ( trip_bx(basin_pts(ij,iz,1),basin_pts(ij,iz,2)) .GT. 100 ) THEN |
|---|
| 6036 | basin_hierarchy(ib,ij) = hierarchy_bx(basin_pts(ij,iz,1),basin_pts(ij,iz,2)) |
|---|
| 6037 | ENDIF |
|---|
| 6038 | CASE DEFAULT |
|---|
| 6039 | WRITE(numout,*) 'Unknown method for computing the hierarchy of the basin' |
|---|
| 6040 | CALL ipslerr_p(3,'routing_globalize','Unknown method for computing the hierarchy of the basin','','') |
|---|
| 6041 | END SELECT |
|---|
| 6042 | ! |
|---|
| 6043 | ENDDO |
|---|
| 6044 | ! |
|---|
| 6045 | basin_topoind(ib,ij) = basin_topoind(ib,ij)/REAL(basin_sz(ij),r_std) |
|---|
| 6046 | ! |
|---|
| 6047 | SELECT CASE (hierar_method) |
|---|
| 6048 | ! |
|---|
| 6049 | CASE("MEAN") |
|---|
| 6050 | basin_hierarchy(ib,ij) = basin_hierarchy(ib,ij)/REAL(basin_sz(ij),r_std) |
|---|
| 6051 | ! |
|---|
| 6052 | END SELECT |
|---|
| 6053 | ! |
|---|
| 6054 | ! To make sure that it has the lowest number if this is an outflow point we reset basin_hierarchy |
|---|
| 6055 | ! |
|---|
| 6056 | IF (basin_bxout(ij) .LT. 0) THEN |
|---|
| 6057 | basin_hierarchy(ib,ij) = min_topoind |
|---|
| 6058 | basin_topoind(ib,ij) = min_topoind |
|---|
| 6059 | ENDIF |
|---|
| 6060 | ! |
|---|
| 6061 | ! |
|---|
| 6062 | ! Keep the outflow boxes and basin |
|---|
| 6063 | ! |
|---|
| 6064 | basin_flowdir(ib,ij) = basin_bxout(ij) |
|---|
| 6065 | IF (basin_bxout(ij) .GT. 0) THEN |
|---|
| 6066 | outflow_grid(ib,ij) = neighbours(ib,basin_bxout(ij)) |
|---|
| 6067 | ELSE |
|---|
| 6068 | outflow_grid(ib,ij) = basin_bxout(ij) |
|---|
| 6069 | ENDIF |
|---|
| 6070 | ! |
|---|
| 6071 | ! |
|---|
| 6072 | ENDDO |
|---|
| 6073 | ! |
|---|
| 6074 | |
|---|
| 6075 | ! |
|---|
| 6076 | END SUBROUTINE routing_globalize |
|---|
| 6077 | ! |
|---|
| 6078 | !! ================================================================================================================================ |
|---|
| 6079 | !! SUBROUTINE : routing_linkup |
|---|
| 6080 | !! |
|---|
| 6081 | !>\BRIEF This subroutine makes the connections between the basins and ensure global coherence. |
|---|
| 6082 | !! |
|---|
| 6083 | !! DESCRIPTION (definitions, functional, design, flags) : |
|---|
| 6084 | !! The convention for outflow_grid is : |
|---|
| 6085 | !! outflow_grid = -1 : River flow |
|---|
| 6086 | !! outflow_grid = -2 : Coastal flow |
|---|
| 6087 | !! outflow_grid = -3 : Return flow\n |
|---|
| 6088 | !! |
|---|
| 6089 | !! RECENT CHANGE(S): None |
|---|
| 6090 | !! |
|---|
| 6091 | !! MAIN OUTPUT VARIABLE(S): |
|---|
| 6092 | !! |
|---|
| 6093 | !! REFERENCES : None |
|---|
| 6094 | !! |
|---|
| 6095 | !! FLOWCHART : None |
|---|
| 6096 | !! \n |
|---|
| 6097 | !_ ================================================================================================================================ |
|---|
| 6098 | |
|---|
| 6099 | SUBROUTINE routing_linkup(nbpt, contfrac, neighbours, nwbas, basin_count, basin_area, basin_id, basin_flowdir, & |
|---|
| 6100 | & basin_hierarchy, outflow_grid, outflow_basin, inflow_number, inflow_grid, inflow_basin, nbcoastal,& |
|---|
| 6101 | & coastal_basin, invented_basins) |
|---|
| 6102 | ! |
|---|
| 6103 | IMPLICIT NONE |
|---|
| 6104 | ! |
|---|
| 6105 | !! INPUT VARIABLES |
|---|
| 6106 | INTEGER(i_std), INTENT (in) :: nbpt !! Domain size (unitless) |
|---|
| 6107 | REAL(r_std), DIMENSION(nbpt) :: contfrac |
|---|
| 6108 | INTEGER(i_std), DIMENSION(nbpt,NbNeighb), INTENT (in) :: neighbours !! |
|---|
| 6109 | REAL(r_std), INTENT(in) :: invented_basins !! |
|---|
| 6110 | ! |
|---|
| 6111 | INTEGER(i_std) :: nwbas !! |
|---|
| 6112 | INTEGER(i_std), DIMENSION(nbpt) :: basin_count !! |
|---|
| 6113 | INTEGER(i_std), DIMENSION(nbpt,nwbas) :: basin_id !! |
|---|
| 6114 | INTEGER(i_std), DIMENSION(nbpt,nwbas) :: basin_flowdir !! Water flow directions in the basin (unitless) |
|---|
| 6115 | REAL(r_std), DIMENSION(nbpt,nwbas) :: basin_area !! |
|---|
| 6116 | REAL(r_std), DIMENSION(nbpt,nwbas) :: basin_hierarchy !! |
|---|
| 6117 | INTEGER(i_std), DIMENSION(nbpt,nwbas) :: outflow_grid !! Type of outflow on the grid box (unitless) |
|---|
| 6118 | INTEGER(i_std), DIMENSION(nbpt,nwbas) :: outflow_basin !! |
|---|
| 6119 | INTEGER(i_std), DIMENSION(nbpt,nwbas) :: inflow_number !! |
|---|
| 6120 | INTEGER(i_std), DIMENSION(nbpt,nwbas,nbvmax) :: inflow_basin !! |
|---|
| 6121 | INTEGER(i_std), DIMENSION(nbpt,nwbas,nbvmax) :: inflow_grid !! |
|---|
| 6122 | INTEGER(i_std), DIMENSION(nbpt) :: nbcoastal !! |
|---|
| 6123 | INTEGER(i_std), DIMENSION(nbpt,nwbas) :: coastal_basin !! |
|---|
| 6124 | ! |
|---|
| 6125 | !! LOCAL VARIABLES |
|---|
| 6126 | INTEGER(i_std) :: sp, sb, sbl, inp, bid, outdm1, outdp1 !! Indices (unitless) |
|---|
| 6127 | INTEGER(i_std) :: dp1, dm1, dm1i, dp1i, bp1, bm1 !! Indices (unitless) |
|---|
| 6128 | INTEGER(i_std) :: dop, bop !! |
|---|
| 6129 | INTEGER(i_std) :: fbas(nwbas), nbfbas !! |
|---|
| 6130 | REAL(r_std) :: fbas_hierarchy(nwbas) !! |
|---|
| 6131 | REAL(r_std) :: angle |
|---|
| 6132 | INTEGER(i_std) :: ff(1) !! |
|---|
| 6133 | ! |
|---|
| 6134 | ! ERRORS |
|---|
| 6135 | LOGICAL :: error1, error2, error3, error4, error5 !! (true/false) |
|---|
| 6136 | ! |
|---|
| 6137 | !! PARAMETERS |
|---|
| 6138 | LOGICAL, PARAMETER :: check = .TRUE. !! (true/false) |
|---|
| 6139 | |
|---|
| 6140 | !_ ================================================================================================================================ |
|---|
| 6141 | error1=.FALSE. |
|---|
| 6142 | error2=.FALSE. |
|---|
| 6143 | error3=.FALSE. |
|---|
| 6144 | error4=.FALSE. |
|---|
| 6145 | error5=.FALSE. |
|---|
| 6146 | |
|---|
| 6147 | outflow_basin(:,:) = undef_int |
|---|
| 6148 | inflow_number(:,:) = 0 |
|---|
| 6149 | ! |
|---|
| 6150 | DO sp=1,nbpt |
|---|
| 6151 | DO sb=1,basin_count(sp) |
|---|
| 6152 | ! |
|---|
| 6153 | inp = outflow_grid(sp,sb) |
|---|
| 6154 | bid = basin_id(sp,sb) |
|---|
| 6155 | ! |
|---|
| 6156 | ! We only work on this point if it does not flow into the ocean |
|---|
| 6157 | ! At this point any of the outflows is designated by a negative values in |
|---|
| 6158 | ! outflow_grid |
|---|
| 6159 | ! |
|---|
| 6160 | IF ( inp .GT. 0 ) THEN |
|---|
| 6161 | ! |
|---|
| 6162 | ! Now find the basin in the onflow point (inp) |
|---|
| 6163 | ! |
|---|
| 6164 | nbfbas = 0 |
|---|
| 6165 | ! |
|---|
| 6166 | ! |
|---|
| 6167 | DO sbl=1,basin_count(inp) |
|---|
| 6168 | ! |
|---|
| 6169 | ! Either it is a standard basin or one aggregated from ocean flow points. |
|---|
| 6170 | ! If we flow into a another grid box we have to make sure that its hierarchy in the |
|---|
| 6171 | ! basin is lower. |
|---|
| 6172 | ! |
|---|
| 6173 | ! |
|---|
| 6174 | IF ( basin_id(inp,sbl) .GT. 0 ) THEN |
|---|
| 6175 | IF ( basin_id(inp,sbl) .EQ. bid .OR. basin_id(inp,sbl) .GT. invented_basins) THEN |
|---|
| 6176 | nbfbas =nbfbas + 1 |
|---|
| 6177 | fbas(nbfbas) = sbl |
|---|
| 6178 | fbas_hierarchy(nbfbas) = basin_hierarchy(inp,sbl) |
|---|
| 6179 | ENDIF |
|---|
| 6180 | ELSE |
|---|
| 6181 | IF ( COUNT(coastal_basin(inp,1:nbcoastal(inp)) .EQ. bid) .GT. 0 ) THEN |
|---|
| 6182 | nbfbas =nbfbas + 1 |
|---|
| 6183 | fbas(nbfbas) = sbl |
|---|
| 6184 | fbas_hierarchy(nbfbas) = basin_hierarchy(inp,sbl) |
|---|
| 6185 | ENDIF |
|---|
| 6186 | ENDIF |
|---|
| 6187 | ! |
|---|
| 6188 | ENDDO |
|---|
| 6189 | ! |
|---|
| 6190 | ! If we have more than one basin we will take the one which is lowest |
|---|
| 6191 | ! in the hierarchy. |
|---|
| 6192 | ! |
|---|
| 6193 | IF (nbfbas .GE. 1) THEN |
|---|
| 6194 | ff = MINLOC(fbas_hierarchy(1:nbfbas)) |
|---|
| 6195 | sbl = fbas(ff(1)) |
|---|
| 6196 | ! |
|---|
| 6197 | bop = undef_int |
|---|
| 6198 | IF ( basin_hierarchy(inp,sbl) .LE. basin_hierarchy(sp,sb) ) THEN |
|---|
| 6199 | IF ( basin_hierarchy(inp,sbl) .LT. basin_hierarchy(sp,sb) ) THEN |
|---|
| 6200 | bop = sbl |
|---|
| 6201 | ELSE |
|---|
| 6202 | ! The same hierarchy is allowed if both grids flow in about |
|---|
| 6203 | ! the same direction : |
|---|
| 6204 | IF ( ( MOD(basin_flowdir(inp,sbl)+1-1, 8)+1 .EQ. basin_flowdir(sp,sb)).OR. & |
|---|
| 6205 | & ( basin_flowdir(inp,sbl) .EQ. basin_flowdir(sp,sb)).OR. & |
|---|
| 6206 | & ( MOD(basin_flowdir(inp,sbl)+7-1, 8)+1 .EQ. basin_flowdir(sp,sb)) ) THEN |
|---|
| 6207 | bop = sbl |
|---|
| 6208 | ENDIF |
|---|
| 6209 | ENDIF |
|---|
| 6210 | ENDIF |
|---|
| 6211 | ! |
|---|
| 6212 | ! If the basin is suitable (bop < undef_int) then take it |
|---|
| 6213 | ! |
|---|
| 6214 | IF ( bop .LT. undef_int ) THEN |
|---|
| 6215 | outflow_basin(sp,sb) = bop |
|---|
| 6216 | inflow_number(inp,bop) = inflow_number(inp,bop) + 1 |
|---|
| 6217 | IF ( inflow_number(inp,bop) .LE. nbvmax ) THEN |
|---|
| 6218 | inflow_grid(inp, bop, inflow_number(inp,bop)) = sp |
|---|
| 6219 | inflow_basin(inp, bop, inflow_number(inp,bop)) = sb |
|---|
| 6220 | ELSE |
|---|
| 6221 | error1=.TRUE. |
|---|
| 6222 | EXIT |
|---|
| 6223 | ENDIF |
|---|
| 6224 | ENDIF |
|---|
| 6225 | ENDIF |
|---|
| 6226 | ! |
|---|
| 6227 | ! |
|---|
| 6228 | ENDIF |
|---|
| 6229 | ! |
|---|
| 6230 | ! |
|---|
| 6231 | ! |
|---|
| 6232 | ! Did we find it ? |
|---|
| 6233 | ! |
|---|
| 6234 | ! In case the outflow point was ocean or we did not find the correct basin we start to look |
|---|
| 6235 | ! around. We find two options for the outflow direction (dp1 & dm1) and the corresponding |
|---|
| 6236 | ! basin index (bp1 & bm1). |
|---|
| 6237 | ! |
|---|
| 6238 | ! |
|---|
| 6239 | IF ( outflow_basin(sp,sb) .EQ. undef_int & |
|---|
| 6240 | & .AND. basin_flowdir(sp,sb) .GT. 0) THEN |
|---|
| 6241 | ! |
|---|
| 6242 | dp1i = MOD(basin_flowdir(sp,sb)+1-1, NbNeighb)+1 |
|---|
| 6243 | dp1 = neighbours(sp,dp1i) |
|---|
| 6244 | dm1i = MOD(basin_flowdir(sp,sb)+7-1, NbNeighb)+1 |
|---|
| 6245 | IF ( dm1i .LT. 1 ) dm1i = 8 |
|---|
| 6246 | dm1 = neighbours(sp,dm1i) |
|---|
| 6247 | ! |
|---|
| 6248 | ! |
|---|
| 6249 | bp1 = -1 |
|---|
| 6250 | IF ( dp1 .GT. 0 ) THEN |
|---|
| 6251 | DO sbl=1,basin_count(dp1) |
|---|
| 6252 | IF (basin_id(dp1,sbl) .EQ. bid .AND.& |
|---|
| 6253 | & basin_hierarchy(sp,sb) .GE. basin_hierarchy(dp1,sbl) .AND. & |
|---|
| 6254 | & bp1 .LT. 0) THEN |
|---|
| 6255 | IF ( basin_hierarchy(sp,sb) .GT. basin_hierarchy(dp1,sbl) ) THEN |
|---|
| 6256 | bp1 = sbl |
|---|
| 6257 | ELSE |
|---|
| 6258 | ! The same hierarchy is allowed if both grids flow in about |
|---|
| 6259 | ! the same direction : |
|---|
| 6260 | angle=MODULO(basin_flowdir(dp1,sbl)-basin_flowdir(sp,sb)+8,8) |
|---|
| 6261 | IF ( angle >= 4 ) angle = angle-8 |
|---|
| 6262 | ! |
|---|
| 6263 | IF ( ABS(angle) <= 1 ) THEN |
|---|
| 6264 | bp1 = sbl |
|---|
| 6265 | ENDIF |
|---|
| 6266 | ENDIF |
|---|
| 6267 | ENDIF |
|---|
| 6268 | ENDDO |
|---|
| 6269 | ENDIF |
|---|
| 6270 | ! |
|---|
| 6271 | bm1 = -1 |
|---|
| 6272 | IF ( dm1 .GT. 0 ) THEN |
|---|
| 6273 | DO sbl=1,basin_count(dm1) |
|---|
| 6274 | IF (basin_id(dm1,sbl) .EQ. bid .AND.& |
|---|
| 6275 | & basin_hierarchy(sp,sb) .GE. basin_hierarchy(dm1,sbl) .AND. & |
|---|
| 6276 | & bm1 .LT. 0) THEN |
|---|
| 6277 | IF ( basin_hierarchy(sp,sb) .GT. basin_hierarchy(dm1,sbl) ) THEN |
|---|
| 6278 | bm1 = sbl |
|---|
| 6279 | ELSE |
|---|
| 6280 | ! The same hierarchy is allowed if both grids flow in about |
|---|
| 6281 | ! the same direction : |
|---|
| 6282 | angle=MODULO(basin_flowdir(dm1,sbl)-basin_flowdir(sp,sb)+8,8) |
|---|
| 6283 | IF ( angle >= 4 ) angle = angle-8 |
|---|
| 6284 | ! |
|---|
| 6285 | IF ( ABS(angle) <= 1 ) THEN |
|---|
| 6286 | bm1 = sbl |
|---|
| 6287 | ENDIF |
|---|
| 6288 | ENDIF |
|---|
| 6289 | ENDIF |
|---|
| 6290 | ENDDO |
|---|
| 6291 | ENDIF |
|---|
| 6292 | ! |
|---|
| 6293 | ! |
|---|
| 6294 | ! First deal with the case on land. |
|---|
| 6295 | ! |
|---|
| 6296 | ! For that we need to check if the water will be able to flow out of the grid dp1 or dm1 |
|---|
| 6297 | ! and not return to our current grid. If it is the current grid |
|---|
| 6298 | ! then we can not do anything with that neighbour. Thus we set the |
|---|
| 6299 | ! value of outdm1 and outdp1 back to -1 |
|---|
| 6300 | ! |
|---|
| 6301 | outdp1 = undef_int |
|---|
| 6302 | IF ( dp1 .GT. 0 .AND. bp1 .GT. 0 ) THEN |
|---|
| 6303 | ! if the outflow is into the ocean then we put something less than undef_int in outdp1! |
|---|
| 6304 | IF (basin_flowdir(dp1,bp1) .GT. 0) THEN |
|---|
| 6305 | outdp1 = neighbours(dp1,basin_flowdir(dp1,bp1)) |
|---|
| 6306 | IF ( outdp1 .EQ. sp ) outdp1 = undef_int |
|---|
| 6307 | ELSE |
|---|
| 6308 | outdp1 = nbpt + 1 |
|---|
| 6309 | ENDIF |
|---|
| 6310 | ENDIF |
|---|
| 6311 | outdm1 = undef_int |
|---|
| 6312 | IF ( dm1 .GT. 0 .AND. bm1 .GT. 0 ) THEN |
|---|
| 6313 | IF (basin_flowdir(dm1,bm1) .GT. 0) THEN |
|---|
| 6314 | outdm1 = neighbours(dm1,basin_flowdir(dm1,bm1)) |
|---|
| 6315 | IF ( outdm1 .EQ. sp ) outdm1 = undef_int |
|---|
| 6316 | ELSE |
|---|
| 6317 | outdm1 = nbpt + 1 |
|---|
| 6318 | ENDIF |
|---|
| 6319 | ENDIF |
|---|
| 6320 | ! |
|---|
| 6321 | ! Now that we know our options we need go through them. |
|---|
| 6322 | ! |
|---|
| 6323 | dop = undef_int |
|---|
| 6324 | bop = undef_int |
|---|
| 6325 | IF ( outdp1 .LT. undef_int .AND. outdm1 .LT. undef_int) THEN |
|---|
| 6326 | ! |
|---|
| 6327 | ! In this case we let the current basin flow into the smaller one |
|---|
| 6328 | ! |
|---|
| 6329 | IF ( basin_area(dp1,bp1) .LT. basin_area(dm1,bm1) ) THEN |
|---|
| 6330 | dop = dp1 |
|---|
| 6331 | bop = bp1 |
|---|
| 6332 | ELSE |
|---|
| 6333 | dop = dm1 |
|---|
| 6334 | bop = bm1 |
|---|
| 6335 | ENDIF |
|---|
| 6336 | ! |
|---|
| 6337 | ! |
|---|
| 6338 | ELSE IF ( outdp1 .LT. undef_int ) THEN |
|---|
| 6339 | ! If only the first one is possible |
|---|
| 6340 | dop = dp1 |
|---|
| 6341 | bop = bp1 |
|---|
| 6342 | ELSE IF ( outdm1 .LT. undef_int ) THEN |
|---|
| 6343 | ! If only the second one is possible |
|---|
| 6344 | dop = dm1 |
|---|
| 6345 | bop = bm1 |
|---|
| 6346 | ELSE |
|---|
| 6347 | ! |
|---|
| 6348 | ! Now we are at the point where none of the neighboring points is suitable |
|---|
| 6349 | ! or we have a coastal point. |
|---|
| 6350 | ! |
|---|
| 6351 | ! If there is an option to put the water into the ocean go for it. |
|---|
| 6352 | ! |
|---|
| 6353 | IF ( outflow_grid(sp,sb) .LT. 0 .OR. dm1 .LT. 0 .OR. dp1 .LT. 0 ) THEN |
|---|
| 6354 | dop = -1 |
|---|
| 6355 | ELSE |
|---|
| 6356 | ! |
|---|
| 6357 | ! If we are on a land point with only land neighbors but no one suitable to let the |
|---|
| 6358 | ! water flow into we have to look for a solution in the current grid box. |
|---|
| 6359 | ! |
|---|
| 6360 | ! |
|---|
| 6361 | IF ( bp1 .LT. 0 .AND. bm1 .LT. 0 ) THEN |
|---|
| 6362 | ! |
|---|
| 6363 | ! Do we have more than one basin with the same ID ? |
|---|
| 6364 | ! |
|---|
| 6365 | IF ( COUNT(basin_id(sp,1:basin_count(sp)) .EQ. bid) .GE. 2) THEN |
|---|
| 6366 | ! |
|---|
| 6367 | ! Now we can try the option of flowing into the basin of the same grid box. |
|---|
| 6368 | ! |
|---|
| 6369 | DO sbl=1,basin_count(sp) |
|---|
| 6370 | IF (sbl .NE. sb .AND. basin_id(sp,sbl) .EQ. bid) THEN |
|---|
| 6371 | ! In case this basin has a lower hierarchy or flows into a totaly |
|---|
| 6372 | ! different direction we go for it. |
|---|
| 6373 | IF ( (basin_hierarchy(sp,sb) .GE. basin_hierarchy(sp,sbl)) .OR. & |
|---|
| 6374 | & (basin_flowdir(sp,sbl) .LT. dm1i .AND.& |
|---|
| 6375 | & basin_flowdir(sp,sbl) .GT. dp1i) ) THEN |
|---|
| 6376 | dop = sp |
|---|
| 6377 | bop = sbl |
|---|
| 6378 | IF (check) THEN |
|---|
| 6379 | IF (basin_hierarchy(sp,sb) .LT. basin_hierarchy(sp,sbl)) THEN |
|---|
| 6380 | WRITE(numout,*) '>>>>>>> POINT CORRECTED against hierarchy :',& |
|---|
| 6381 | & sp, sb, 'into', sbl |
|---|
| 6382 | ENDIF |
|---|
| 6383 | ENDIF |
|---|
| 6384 | ENDIF |
|---|
| 6385 | ! |
|---|
| 6386 | ENDIF |
|---|
| 6387 | ENDDO |
|---|
| 6388 | ! |
|---|
| 6389 | ENDIF |
|---|
| 6390 | ENDIF |
|---|
| 6391 | ENDIF |
|---|
| 6392 | ! |
|---|
| 6393 | IF ( dop .EQ. undef_int .AND. bop .EQ. undef_int ) THEN |
|---|
| 6394 | IF (check) THEN |
|---|
| 6395 | WRITE(numout,*) 'Why are we here with point ', sp, sb |
|---|
| 6396 | WRITE(numout,*) 'Coordinates : (lon,lat) = ', lalo_g(sp,2), lalo_g(sp,1) |
|---|
| 6397 | WRITE(numout,*) 'neighbours :', neighbours_g(sp,:) |
|---|
| 6398 | WRITE(numout,*) 'Contfrac : = ', contfrac(sp) |
|---|
| 6399 | WRITE(numout,*) 'Local Basin ID :', basin_id(sp,1:basin_count(sp)) |
|---|
| 6400 | WRITE(numout,*) 'Local hierarchies :', basin_hierarchy(sp,1:basin_count(sp)) |
|---|
| 6401 | WRITE(numout,*) 'Local basin_flowdir :', basin_flowdir(sp,1:basin_count(sp)) |
|---|
| 6402 | WRITE(numout,*) 'Local outflowgrid :', outflow_grid(sp,1:basin_count(sp)) |
|---|
| 6403 | WRITE(numout,*) 'outflow_grid :', inp |
|---|
| 6404 | WRITE(numout,*) 'Coodinates outflow : (lon,lat) = ', lalo_g(inp,2), lalo_g(inp,1) |
|---|
| 6405 | WRITE(numout,*) 'Contfrac : = ', contfrac(inp) |
|---|
| 6406 | WRITE(numout,*) 'Outflow Basin ID :', basin_id(inp,1:basin_count(inp)) |
|---|
| 6407 | WRITE(numout,*) 'Outflow hierarchies :', basin_hierarchy(inp,1:basin_count(inp)) |
|---|
| 6408 | WRITE(numout,*) 'Outflow basin_flowdir :', basin_flowdir(inp,1:basin_count(inp)) |
|---|
| 6409 | WRITE(numout,*) 'Explored options +1 :', dp1, bp1, outdp1 |
|---|
| 6410 | WRITE(numout,*) 'Explored +1 Basin ID :', basin_id(dp1,1:basin_count(dp1)) |
|---|
| 6411 | WRITE(numout,*) 'Explored +1 hierarchies :', basin_hierarchy(dp1,1:basin_count(dp1)) |
|---|
| 6412 | WRITE(numout,*) 'Explored +1 basin_flowdir :', basin_flowdir(dp1,1:basin_count(dp1)) |
|---|
| 6413 | WRITE(numout,*) 'Explored options -1 :', dm1, bm1, outdm1 |
|---|
| 6414 | WRITE(numout,*) 'Explored -1 Basin ID :', basin_id(dm1,1:basin_count(dm1)) |
|---|
| 6415 | WRITE(numout,*) 'Explored -1 hierarchies :', basin_hierarchy(dm1,1:basin_count(dm1)) |
|---|
| 6416 | WRITE(numout,*) 'Explored -1 basin_flowdir :', basin_flowdir(dm1,1:basin_count(dm1)) |
|---|
| 6417 | WRITE(numout,*) '****************************' |
|---|
| 6418 | CALL FLUSH(numout) |
|---|
| 6419 | ENDIF |
|---|
| 6420 | IF ( contfrac(sp) > 0.01 ) THEN |
|---|
| 6421 | error2=.TRUE. |
|---|
| 6422 | EXIT |
|---|
| 6423 | ENDIF |
|---|
| 6424 | ENDIF |
|---|
| 6425 | ! |
|---|
| 6426 | ENDIF |
|---|
| 6427 | ! |
|---|
| 6428 | ! Now that we know where we want the water to flow to we write the |
|---|
| 6429 | ! the information in the right fields. |
|---|
| 6430 | ! |
|---|
| 6431 | IF ( dop .GT. 0 .AND. dop .NE. undef_int ) THEN |
|---|
| 6432 | outflow_grid(sp,sb) = dop |
|---|
| 6433 | outflow_basin(sp,sb) = bop |
|---|
| 6434 | inflow_number(dop,bop) = inflow_number(dop,bop) + 1 |
|---|
| 6435 | IF ( inflow_number(dop,bop) .LE. nbvmax ) THEN |
|---|
| 6436 | inflow_grid(dop, bop, inflow_number(dop,bop)) = sp |
|---|
| 6437 | inflow_basin(dop, bop, inflow_number(dop,bop)) = sb |
|---|
| 6438 | ELSE |
|---|
| 6439 | error3=.TRUE. |
|---|
| 6440 | EXIT |
|---|
| 6441 | ENDIF |
|---|
| 6442 | ! |
|---|
| 6443 | ELSE |
|---|
| 6444 | outflow_grid(sp,sb) = -2 |
|---|
| 6445 | outflow_basin(sp,sb) = undef_int |
|---|
| 6446 | ENDIF |
|---|
| 6447 | ! |
|---|
| 6448 | ENDIF |
|---|
| 6449 | ! |
|---|
| 6450 | ! |
|---|
| 6451 | ! If we still have not found anything then we have to check that there is not a basin |
|---|
| 6452 | ! within the same grid box which has a lower hierarchy. |
|---|
| 6453 | ! |
|---|
| 6454 | ! |
|---|
| 6455 | IF ( outflow_grid(sp,sb) .GT. 0 .AND. outflow_basin(sp,sb) .EQ. undef_int & |
|---|
| 6456 | & .AND. basin_flowdir(sp,sb) .GT. 0) THEN |
|---|
| 6457 | ! |
|---|
| 6458 | |
|---|
| 6459 | IF (check) & |
|---|
| 6460 | WRITE(numout,*) 'There is no reason to here, this part of the code should be dead :', sp,sb |
|---|
| 6461 | ! |
|---|
| 6462 | DO sbl=1,basin_count(sp) |
|---|
| 6463 | ! |
|---|
| 6464 | ! Three conditions are needed to let the water flow into another basin of the |
|---|
| 6465 | ! same grid : |
|---|
| 6466 | ! - another basin than the current one |
|---|
| 6467 | ! - same ID |
|---|
| 6468 | ! - of lower hierarchy. |
|---|
| 6469 | ! |
|---|
| 6470 | IF ( (sbl .NE. sb) .AND. (basin_id(sp,sbl) .EQ. bid)& |
|---|
| 6471 | & .AND. (basin_hierarchy(sp,sb) .GT. basin_hierarchy(sp,sbl)) ) THEN |
|---|
| 6472 | outflow_basin(sp,sb) = sbl |
|---|
| 6473 | inflow_number(sp,sbl) = inflow_number(sp,sbl) + 1 |
|---|
| 6474 | IF ( inflow_number(sp,sbl) .LE. nbvmax ) THEN |
|---|
| 6475 | IF ( sp .EQ. 42 .AND. sbl .EQ. 1) THEN |
|---|
| 6476 | IF (check) & |
|---|
| 6477 | WRITE(numout,*) 'ADD INFLOW (3):', sp, sb |
|---|
| 6478 | ENDIF |
|---|
| 6479 | inflow_grid(sp, sbl, inflow_number(sp,sbl)) = sp |
|---|
| 6480 | inflow_basin(sp, sbl, inflow_number(sp,sbl)) = sb |
|---|
| 6481 | ELSE |
|---|
| 6482 | error4=.TRUE. |
|---|
| 6483 | EXIT |
|---|
| 6484 | ENDIF |
|---|
| 6485 | ENDIF |
|---|
| 6486 | ENDDO |
|---|
| 6487 | ENDIF |
|---|
| 6488 | ! |
|---|
| 6489 | ! Ok that is it, we give up :-) |
|---|
| 6490 | ! |
|---|
| 6491 | IF ( outflow_grid(sp,sb) .GT. 0 .AND. outflow_basin(sp,sb) .EQ. undef_int & |
|---|
| 6492 | & .AND. basin_flowdir(sp,sb) .GT. 0) THEN |
|---|
| 6493 | ! |
|---|
| 6494 | error5=.TRUE. |
|---|
| 6495 | EXIT |
|---|
| 6496 | ENDIF |
|---|
| 6497 | ENDDO |
|---|
| 6498 | ! |
|---|
| 6499 | ENDDO |
|---|
| 6500 | IF (error1) THEN |
|---|
| 6501 | WRITE(numout,*) " routing_linkup : bop .LT. undef_int",bop |
|---|
| 6502 | CALL ipslerr_p(3,'routing_linkup', & |
|---|
| 6503 | "bop .LT. undef_int",'Increase nbvmax','stop routing_linkup') |
|---|
| 6504 | ENDIF |
|---|
| 6505 | IF (error2) THEN |
|---|
| 6506 | CALL ipslerr_p(3,'routing_linkup', & |
|---|
| 6507 | & 'In the routine which make connections between the basins and ensure global coherence,', & |
|---|
| 6508 | & 'there is a problem with outflow linkup without any valid direction. Try with check=.TRUE.', & |
|---|
| 6509 | & '(Perhaps there is a problem with the grid.)') |
|---|
| 6510 | ENDIF |
|---|
| 6511 | IF (error3) THEN |
|---|
| 6512 | WRITE(numout,*) " routing_linkup : dop .GT. 0 .AND. dop .NE. undef_int",dop |
|---|
| 6513 | CALL ipslerr_p(3,'routing_linkup', & |
|---|
| 6514 | "dop .GT. 0 .AND. dop .NE. undef_int",'Increase nbvmax. Try with check=.TRUE.','stop routing_linkup') |
|---|
| 6515 | ENDIF |
|---|
| 6516 | IF (error4) THEN |
|---|
| 6517 | WRITE(numout,*) " routing_linkup : (sbl .NE. sb) .AND. (basin_id(sp,sbl) .EQ. bid) ", & |
|---|
| 6518 | & " .AND. (basin_hierarchy(sp,sb) .GT. basin_hierarchy(sp,sbl))",sbl,sb,basin_id(sp,sbl),bid, & |
|---|
| 6519 | & basin_hierarchy(sp,sb),basin_hierarchy(sp,sbl) |
|---|
| 6520 | CALL ipslerr_p(3,'routing_linkup', & |
|---|
| 6521 | "(sbl .NE. sb) .AND. (basin_id(sp,sbl) .EQ. bid) .AND. (basin_hierarchy(sp,sb) .GT. basin_hierarchy(sp,sbl))" & |
|---|
| 6522 | ,'Increase nbvmax. Try with check=.TRUE.','stop routing_linkup') |
|---|
| 6523 | ENDIF |
|---|
| 6524 | IF (error5) THEN |
|---|
| 6525 | WRITE(numout,*) 'We could not find the basin into which we need to flow' |
|---|
| 6526 | WRITE(numout,*) 'Grid point ', sp, ' and basin ', sb |
|---|
| 6527 | WRITE(numout,*) 'Explored neighbours :', dm1, dp1 |
|---|
| 6528 | WRITE(numout,*) 'Outflow direction :', basin_flowdir(sp,sb) |
|---|
| 6529 | WRITE(numout,*) 'Outlfow grid :', outflow_grid(sp,sb) |
|---|
| 6530 | WRITE(numout,*) 'Outlfow basin :',outflow_basin(sp,sb) |
|---|
| 6531 | WRITE(numout,*) 'basin ID:',basin_id(sp,sb) |
|---|
| 6532 | WRITE(numout,*) 'Hierarchy :', basin_hierarchy(sp,sb) |
|---|
| 6533 | CALL ipslerr_p(3,'routing_linkup', & |
|---|
| 6534 | "We could not find the basin into which we need to flow",'Try with check=.TRUE.','stop routing_linkup') |
|---|
| 6535 | ENDIF |
|---|
| 6536 | ! |
|---|
| 6537 | ! Check for each outflow basin that it exists |
|---|
| 6538 | ! |
|---|
| 6539 | DO sp=1,nbpt |
|---|
| 6540 | DO sb=1,basin_count(sp) |
|---|
| 6541 | ! |
|---|
| 6542 | inp = outflow_grid(sp,sb) |
|---|
| 6543 | sbl = outflow_basin(sp,sb) |
|---|
| 6544 | IF ( inp .GE. 0 ) THEN |
|---|
| 6545 | IF ( basin_count(inp) .LT. sbl ) THEN |
|---|
| 6546 | WRITE(numout,*) 'point :', sp, ' basin :', sb |
|---|
| 6547 | WRITE(numout,*) 'Flows into point :', inp, ' basin :', sbl |
|---|
| 6548 | WRITE(numout,*) 'But it flows into now here as basin count = ', basin_count(inp) |
|---|
| 6549 | CALL ipslerr_p(3,'routing_linkup','Problem with outflow','','') |
|---|
| 6550 | ENDIF |
|---|
| 6551 | ENDIF |
|---|
| 6552 | ENDDO |
|---|
| 6553 | ENDDO |
|---|
| 6554 | ! |
|---|
| 6555 | END SUBROUTINE routing_linkup |
|---|
| 6556 | ! |
|---|
| 6557 | !! ================================================================================================================================ |
|---|
| 6558 | !! SUBROUTINE : routing_fetch |
|---|
| 6559 | !! |
|---|
| 6560 | !>\BRIEF This subroutine computes the fetch of each basin. This means that for each basin we |
|---|
| 6561 | !! will know how much area is upstream. It will help decide how to procede with the |
|---|
| 6562 | !! the truncation later and allow to set correctly in outflow_grid the distinction |
|---|
| 6563 | !! between coastal and river flow. |
|---|
| 6564 | !! |
|---|
| 6565 | !! DESCRIPTION (definitions, functional, design, flags) : None |
|---|
| 6566 | !! |
|---|
| 6567 | !! RECENT CHANGE(S): None |
|---|
| 6568 | !! |
|---|
| 6569 | !! MAIN OUTPUT VARIABLE(S): |
|---|
| 6570 | !! |
|---|
| 6571 | !! REFERENCES : None |
|---|
| 6572 | !! |
|---|
| 6573 | !! FLOWCHART : None |
|---|
| 6574 | !! \n |
|---|
| 6575 | !_ ================================================================================================================================ |
|---|
| 6576 | |
|---|
| 6577 | SUBROUTINE routing_fetch(nbpt, resolution, contfrac, nwbas, basin_count, basin_area, basin_id,& |
|---|
| 6578 | & outflow_grid, outflow_basin, fetch_basin) |
|---|
| 6579 | ! |
|---|
| 6580 | IMPLICIT NONE |
|---|
| 6581 | ! |
|---|
| 6582 | !! INPUT VARIABLES |
|---|
| 6583 | INTEGER(i_std), INTENT(in) :: nbpt !! Domain size (unitless) |
|---|
| 6584 | ! |
|---|
| 6585 | REAL(r_std), DIMENSION(nbpt,2), INTENT(in) :: resolution !! The size of each grid box in X and Y (m) |
|---|
| 6586 | REAL(r_std), DIMENSION(nbpt), INTENT(in) :: contfrac !! Fraction of land in each grid box (unitless;0-1) |
|---|
| 6587 | ! |
|---|
| 6588 | INTEGER(i_std) :: nwbas !! |
|---|
| 6589 | INTEGER(i_std), DIMENSION(nbpt), INTENT(in) :: basin_count !! |
|---|
| 6590 | REAL(r_std), DIMENSION(nbpt,nwbas), INTENT(inout) :: basin_area !! |
|---|
| 6591 | INTEGER(i_std), DIMENSION(nbpt,nwbas), INTENT(in) :: basin_id !! |
|---|
| 6592 | INTEGER(i_std), DIMENSION(nbpt,nwbas), INTENT(inout) :: outflow_grid !! Type of outflow on the grid box (unitless) |
|---|
| 6593 | INTEGER(i_std), DIMENSION(nbpt,nwbas), INTENT(in) :: outflow_basin !! |
|---|
| 6594 | ! |
|---|
| 6595 | !! OUTPUT VARIABLES |
|---|
| 6596 | REAL(r_std), DIMENSION(nbpt,nwbas), INTENT(out) :: fetch_basin !! |
|---|
| 6597 | ! |
|---|
| 6598 | !! LOCAL VARIABLES |
|---|
| 6599 | INTEGER(i_std) :: ib, ij, ff(1), it, itt, igrif, ibasf, nboutflow !! Indices (unitless) |
|---|
| 6600 | REAL(r_std) :: contarea !! |
|---|
| 6601 | REAL(r_std) :: totbasins !! |
|---|
| 6602 | REAL(r_std), DIMENSION(nbpt*nbvmax) :: tmp_area !! |
|---|
| 6603 | INTEGER(i_std), DIMENSION(nbpt*nbvmax,2) :: tmpindex !! |
|---|
| 6604 | |
|---|
| 6605 | !_ ================================================================================================================================ |
|---|
| 6606 | ! |
|---|
| 6607 | ! |
|---|
| 6608 | ! Normalize the area of all basins |
|---|
| 6609 | ! |
|---|
| 6610 | DO ib=1,nbpt |
|---|
| 6611 | ! |
|---|
| 6612 | totbasins = SUM(basin_area(ib,1:basin_count(ib))) |
|---|
| 6613 | contarea = resolution(ib,1)*resolution(ib,2)*contfrac(ib) |
|---|
| 6614 | ! |
|---|
| 6615 | DO ij=1,basin_count(ib) |
|---|
| 6616 | basin_area(ib,ij) = basin_area(ib,ij)/totbasins*contarea |
|---|
| 6617 | ENDDO |
|---|
| 6618 | ! |
|---|
| 6619 | ENDDO |
|---|
| 6620 | WRITE(numout,*) 'Normalization done' |
|---|
| 6621 | ! |
|---|
| 6622 | ! Compute the area upstream of each basin |
|---|
| 6623 | ! |
|---|
| 6624 | fetch_basin(:,:) = zero |
|---|
| 6625 | ! |
|---|
| 6626 | ! |
|---|
| 6627 | DO ib=1,nbpt |
|---|
| 6628 | ! |
|---|
| 6629 | DO ij=1,basin_count(ib) |
|---|
| 6630 | ! |
|---|
| 6631 | fetch_basin(ib, ij) = fetch_basin(ib, ij) + basin_area(ib,ij) |
|---|
| 6632 | ! |
|---|
| 6633 | igrif = outflow_grid(ib,ij) |
|---|
| 6634 | ibasf = outflow_basin(ib,ij) |
|---|
| 6635 | ! |
|---|
| 6636 | itt = 0 |
|---|
| 6637 | DO WHILE (igrif .GT. 0) |
|---|
| 6638 | fetch_basin(igrif,ibasf) = fetch_basin(igrif,ibasf) + basin_area(ib, ij) |
|---|
| 6639 | it = outflow_grid(igrif, ibasf) |
|---|
| 6640 | ibasf = outflow_basin(igrif, ibasf) |
|---|
| 6641 | igrif = it |
|---|
| 6642 | itt = itt + 1 |
|---|
| 6643 | IF ( itt .GT. 500) THEN |
|---|
| 6644 | WRITE(numout,& |
|---|
| 6645 | "('Grid ',I5, ' and basin ',I5, 'did not converge after iteration ',I5)") ib, ij, itt |
|---|
| 6646 | WRITE(numout,*) 'Basin ID :', basin_id(igrif,ibasf) |
|---|
| 6647 | WRITE(numout,& |
|---|
| 6648 | "('We are stuck with the flow into grid ',I5,' and basin ',I5)") igrif, ibasf |
|---|
| 6649 | WRITE(numout,*) "Coordinates : ", lalo_g(igrif,2), lalo_g(igrif,1) |
|---|
| 6650 | IF ( itt .GT. 510) THEN |
|---|
| 6651 | CALL ipslerr_p(3,'routing_fetch','Problem...','','') |
|---|
| 6652 | ENDIF |
|---|
| 6653 | ENDIF |
|---|
| 6654 | ENDDO |
|---|
| 6655 | ! |
|---|
| 6656 | ENDDO |
|---|
| 6657 | ! |
|---|
| 6658 | ENDDO |
|---|
| 6659 | ! |
|---|
| 6660 | WRITE(numout,*) 'The smallest FETCH :', MINVAL(fetch_basin) |
|---|
| 6661 | WRITE(numout,*) 'The largest FETCH :', MAXVAL(fetch_basin) |
|---|
| 6662 | ! |
|---|
| 6663 | ! Now we set for the 'num_largest' largest basins the outflow condition as stream flow |
|---|
| 6664 | ! (i.e. outflow_grid = -1) and all other outflow basins are set to coastal flow |
|---|
| 6665 | ! (i.e. outflow_grid = -2). The return flow is not touched. |
|---|
| 6666 | ! |
|---|
| 6667 | nboutflow = 0 |
|---|
| 6668 | ! |
|---|
| 6669 | DO ib=1,nbpt |
|---|
| 6670 | ! |
|---|
| 6671 | DO ij=1,basin_count(ib) |
|---|
| 6672 | ! |
|---|
| 6673 | ! We do not need any more the river flow flag as we are going to reset it. |
|---|
| 6674 | ! |
|---|
| 6675 | IF ( outflow_grid(ib,ij) .EQ. -1) THEN |
|---|
| 6676 | outflow_grid(ib,ij) = -2 |
|---|
| 6677 | ENDIF |
|---|
| 6678 | ! |
|---|
| 6679 | IF ( outflow_grid(ib,ij) .EQ. -2) THEN |
|---|
| 6680 | ! |
|---|
| 6681 | nboutflow = nboutflow + 1 |
|---|
| 6682 | tmp_area(nboutflow) = fetch_basin(ib,ij) |
|---|
| 6683 | tmpindex(nboutflow,1) = ib |
|---|
| 6684 | tmpindex(nboutflow,2) = ij |
|---|
| 6685 | ! |
|---|
| 6686 | ENDIF |
|---|
| 6687 | ! |
|---|
| 6688 | ENDDO |
|---|
| 6689 | ENDDO |
|---|
| 6690 | ! |
|---|
| 6691 | DO ib=1, num_largest |
|---|
| 6692 | ff = MAXLOC(tmp_area(1:nboutflow)) |
|---|
| 6693 | outflow_grid(tmpindex(ff(1),1), tmpindex(ff(1),2)) = -1 |
|---|
| 6694 | tmp_area(ff(1)) = zero |
|---|
| 6695 | ENDDO |
|---|
| 6696 | ! |
|---|
| 6697 | END SUBROUTINE routing_fetch |
|---|
| 6698 | ! |
|---|
| 6699 | !! ================================================================================================================================ |
|---|
| 6700 | !! SUBROUTINE : routing_truncate |
|---|
| 6701 | !! |
|---|
| 6702 | !>\BRIEF This subroutine reduces the number of basins per grid to the value chosen by the user. |
|---|
| 6703 | !! It also computes the final field which will be used to route the water at the |
|---|
| 6704 | !! requested truncation. |
|---|
| 6705 | !! |
|---|
| 6706 | !! DESCRIPTION (definitions, functional, design, flags) : |
|---|
| 6707 | !! Truncate if needed and find the path closest to the high resolution data. |
|---|
| 6708 | !! |
|---|
| 6709 | !! The algorithm : |
|---|
| 6710 | !! |
|---|
| 6711 | !! We only go through this procedure only as many times as there are basins to take out at most. |
|---|
| 6712 | !! This is important as it allows the simplifications to spread from one grid to the other. |
|---|
| 6713 | !! The for each step of the iteration and at each grid point we check the following options for |
|---|
| 6714 | !! simplifying the pathways of water : |
|---|
| 6715 | !! 1) If the basin of a grid flows into another basin of the same grid. Kill the one which only |
|---|
| 6716 | !! served as a transition |
|---|
| 6717 | !! 2) If in one grid box we have a number of basins which flow into the ocean as coastal flow. |
|---|
| 6718 | !! We kill the smallest one and put into the largest basin. There is no need to manage many |
|---|
| 6719 | !! basins going into the ocean as coastal flows. |
|---|
| 6720 | !! 3) If we have streams run in parallel from one gird box to the others (that is these are |
|---|
| 6721 | !! different basins) we will put the smaller one in the larger one. This may hapen at any |
|---|
| 6722 | !! level of the flow but in theory it should propagate downstream. |
|---|
| 6723 | !! 4) If we have two basins with the same ID but flow into different grid boxes we sacrifice |
|---|
| 6724 | !! the smallest one and route it through the largest. |
|---|
| 6725 | !! |
|---|
| 6726 | !! Obviously if any of the options find something then we skip the rest and take out the basin.:\n |
|---|
| 6727 | !! |
|---|
| 6728 | !! RECENT CHANGE(S): None |
|---|
| 6729 | !! |
|---|
| 6730 | !! MAIN OUTPUT VARIABLE(S): |
|---|
| 6731 | !! |
|---|
| 6732 | !! REFERENCES : None |
|---|
| 6733 | !! |
|---|
| 6734 | !! FLOWCHART : None |
|---|
| 6735 | !! \n |
|---|
| 6736 | !_ ================================================================================================================================ |
|---|
| 6737 | |
|---|
| 6738 | SUBROUTINE routing_truncate(nbpt, resolution, contfrac, nwbas, basin_count, basin_area, basin_topoind,& |
|---|
| 6739 | & fetch_basin, basin_id, basin_flowdir, outflow_grid, outflow_basin, inflow_number,& |
|---|
| 6740 | & inflow_grid, inflow_basin) |
|---|
| 6741 | ! |
|---|
| 6742 | IMPLICIT NONE |
|---|
| 6743 | ! |
|---|
| 6744 | !! PARAMETERS |
|---|
| 6745 | INTEGER(i_std), PARAMETER :: pickmax = 200 !! |
|---|
| 6746 | |
|---|
| 6747 | !! INPUT VARIABLES |
|---|
| 6748 | INTEGER(i_std) :: nbpt !! Domain size (unitless) |
|---|
| 6749 | ! |
|---|
| 6750 | REAL(r_std), DIMENSION(nbpt,2) :: resolution !! The size of each grid box in X and Y (m) |
|---|
| 6751 | REAL(r_std), DIMENSION(nbpt), INTENT(in) :: contfrac !! Fraction of land in each grid box (unitless;0-1) |
|---|
| 6752 | ! |
|---|
| 6753 | INTEGER(i_std) :: nwbas !! |
|---|
| 6754 | INTEGER(i_std), DIMENSION(nbpt) :: basin_count !! |
|---|
| 6755 | INTEGER(i_std), DIMENSION(nbpt,nwbas) :: basin_id !! |
|---|
| 6756 | INTEGER(i_std), DIMENSION(nbpt,nwbas) :: basin_flowdir !! Water flow directions in the basin (unitless) |
|---|
| 6757 | REAL(r_std), DIMENSION(nbpt,nwbas) :: basin_area !! |
|---|
| 6758 | REAL(r_std), DIMENSION(nbpt,nwbas) :: basin_topoind !! Topographic index of the residence time for a basin (m) |
|---|
| 6759 | REAL(r_std), DIMENSION(nbpt,nwbas) :: fetch_basin !! |
|---|
| 6760 | INTEGER(i_std), DIMENSION(nbpt,nwbas) :: outflow_grid !! Type of outflow on the grid box (unitless) |
|---|
| 6761 | INTEGER(i_std), DIMENSION(nbpt,nwbas) :: outflow_basin !! |
|---|
| 6762 | INTEGER(i_std), DIMENSION(nbpt,nwbas) :: inflow_number !! |
|---|
| 6763 | INTEGER(i_std), DIMENSION(nbpt,nwbas,nwbas) :: inflow_basin !! |
|---|
| 6764 | INTEGER(i_std), DIMENSION(nbpt,nwbas,nwbas) :: inflow_grid !! |
|---|
| 6765 | ! |
|---|
| 6766 | !! LOCAL VARIABLES |
|---|
| 6767 | INTEGER(i_std) :: ib, ij, ibf, ijf, igrif, ibasf, cnt, pold, bold, ff(2) !! Indices (unitless) |
|---|
| 6768 | INTEGER(i_std) :: ii, kbas, sbas, ik, iter, ibt, obj !! Indices (unitless) |
|---|
| 6769 | REAL(r_std), DIMENSION(nbpt,nbasmax) :: floflo !! |
|---|
| 6770 | REAL(r_std), DIMENSION(nbpt) :: gridarea !! |
|---|
| 6771 | REAL(r_std), DIMENSION(nbpt) :: gridbasinarea !! |
|---|
| 6772 | REAL(r_std) :: ratio !! |
|---|
| 6773 | INTEGER(i_std), DIMENSION(pickmax,2) :: largest_basins !! |
|---|
| 6774 | INTEGER(i_std), DIMENSION(pickmax) :: tmp_ids !! |
|---|
| 6775 | INTEGER(i_std) :: multbas !! |
|---|
| 6776 | INTEGER(i_std) :: iml(1) !! X resolution of the high resolution grid |
|---|
| 6777 | INTEGER(i_std), DIMENSION(pickmax) :: multbas_sz !! |
|---|
| 6778 | REAL(r_std), DIMENSION(pickmax) :: tmp_area !! |
|---|
| 6779 | INTEGER(i_std), DIMENSION(pickmax,pickmax) :: multbas_list !! |
|---|
| 6780 | ! |
|---|
| 6781 | INTEGER(i_std) :: nbtruncate !! |
|---|
| 6782 | INTEGER(i_std), SAVE, ALLOCATABLE, DIMENSION(:) :: indextrunc !! |
|---|
| 6783 | !$OMP THREADPRIVATE(indextrunc) |
|---|
| 6784 | |
|---|
| 6785 | !_ ================================================================================================================================ |
|---|
| 6786 | ! |
|---|
| 6787 | ! |
|---|
| 6788 | IF ( .NOT. ALLOCATED(indextrunc)) THEN |
|---|
| 6789 | ALLOCATE(indextrunc(nbpt)) |
|---|
| 6790 | ENDIF |
|---|
| 6791 | ! |
|---|
| 6792 | ! We have to go through the grid as least as often as we have to reduce the number of basins |
|---|
| 6793 | ! For good measure we add 3 more passages. |
|---|
| 6794 | ! |
|---|
| 6795 | ! |
|---|
| 6796 | DO iter = 1, MAXVAL(basin_count) - nbasmax +3 |
|---|
| 6797 | ! |
|---|
| 6798 | ! Get the points over which we wish to truncate |
|---|
| 6799 | ! |
|---|
| 6800 | nbtruncate = 0 |
|---|
| 6801 | DO ib = 1, nbpt |
|---|
| 6802 | IF ( basin_count(ib) .GT. nbasmax ) THEN |
|---|
| 6803 | nbtruncate = nbtruncate + 1 |
|---|
| 6804 | indextrunc(nbtruncate) = ib |
|---|
| 6805 | ENDIF |
|---|
| 6806 | ENDDO |
|---|
| 6807 | ! |
|---|
| 6808 | ! Go through the basins which need to be truncated. |
|---|
| 6809 | ! |
|---|
| 6810 | DO ibt=1,nbtruncate |
|---|
| 6811 | ! |
|---|
| 6812 | ib = indextrunc(ibt) |
|---|
| 6813 | ! |
|---|
| 6814 | ! Check if we have basin which flows into a basin in the same grid |
|---|
| 6815 | ! kbas = basin we will have to kill |
|---|
| 6816 | ! sbas = basin which takes over kbas |
|---|
| 6817 | ! |
|---|
| 6818 | kbas = 0 |
|---|
| 6819 | sbas = 0 |
|---|
| 6820 | ! |
|---|
| 6821 | ! 1) Can we find a basin which flows into a basin of the same grid ? |
|---|
| 6822 | ! |
|---|
| 6823 | DO ij=1,basin_count(ib) |
|---|
| 6824 | DO ii=1,basin_count(ib) |
|---|
| 6825 | IF ( outflow_grid(ib,ii) .EQ. ib .AND. outflow_basin(ib, ii) .EQ. ij .AND. kbas*sbas .NE. 0) THEN |
|---|
| 6826 | kbas = ii |
|---|
| 6827 | sbas = ij |
|---|
| 6828 | ENDIF |
|---|
| 6829 | ENDDO |
|---|
| 6830 | ENDDO |
|---|
| 6831 | ! |
|---|
| 6832 | ! 2) Merge two basins which flow into the ocean as coastal or return flow |
|---|
| 6833 | ! (outflow_grid = -2 or -3). Well obviously only if we have more than 1 and |
|---|
| 6834 | ! have not found anything yet! |
|---|
| 6835 | ! |
|---|
| 6836 | IF ( (COUNT(outflow_grid(ib,1:basin_count(ib)) .EQ. -2) .GT. 1 .OR.& |
|---|
| 6837 | & COUNT(outflow_grid(ib,1:basin_count(ib)) .EQ. -3) .GT. 1) .AND.& |
|---|
| 6838 | & kbas*sbas .EQ. 0) THEN |
|---|
| 6839 | ! |
|---|
| 6840 | multbas = 0 |
|---|
| 6841 | multbas_sz(:) = 0 |
|---|
| 6842 | ! |
|---|
| 6843 | IF ( COUNT(outflow_grid(ib,1:basin_count(ib)) .EQ. -2) .GT. 1 ) THEN |
|---|
| 6844 | obj = -2 |
|---|
| 6845 | ELSE |
|---|
| 6846 | obj = -3 |
|---|
| 6847 | ENDIF |
|---|
| 6848 | ! |
|---|
| 6849 | ! First we get the list of all basins which go out as coastal or return flow (obj) |
|---|
| 6850 | ! |
|---|
| 6851 | DO ij=1,basin_count(ib) |
|---|
| 6852 | IF ( outflow_grid(ib,ij) .EQ. obj ) THEN |
|---|
| 6853 | multbas = multbas + 1 |
|---|
| 6854 | multbas_sz(multbas) = ij |
|---|
| 6855 | tmp_area(multbas) = fetch_basin(ib,ij) |
|---|
| 6856 | ENDIF |
|---|
| 6857 | ENDDO |
|---|
| 6858 | ! |
|---|
| 6859 | ! Now the take the smallest to be transfered to the largest |
|---|
| 6860 | ! |
|---|
| 6861 | iml = MAXLOC(tmp_area(1:multbas), MASK = tmp_area(1:multbas) .GT. zero) |
|---|
| 6862 | sbas = multbas_sz(iml(1)) |
|---|
| 6863 | iml = MINLOC(tmp_area(1:multbas), MASK = tmp_area(1:multbas) .GT. zero) |
|---|
| 6864 | kbas = multbas_sz(iml(1)) |
|---|
| 6865 | ! |
|---|
| 6866 | ENDIF |
|---|
| 6867 | ! |
|---|
| 6868 | ! 3) If we have basins flowing into the same grid but different basins then we put them |
|---|
| 6869 | ! together. Obviously we first work with the grid which has most streams running into it |
|---|
| 6870 | ! and putting the smallest in the largests catchments. |
|---|
| 6871 | ! |
|---|
| 6872 | IF ( kbas*sbas .EQ. 0) THEN |
|---|
| 6873 | ! |
|---|
| 6874 | tmp_ids(1:basin_count(ib)) = outflow_grid(ib,1:basin_count(ib)) |
|---|
| 6875 | multbas = 0 |
|---|
| 6876 | multbas_sz(:) = 0 |
|---|
| 6877 | ! |
|---|
| 6878 | ! First obtain the list of basins which flow into the same basin |
|---|
| 6879 | ! |
|---|
| 6880 | DO ij=1,basin_count(ib) |
|---|
| 6881 | IF ( outflow_grid(ib,ij) .GT. 0 .AND.& |
|---|
| 6882 | & COUNT(tmp_ids(1:basin_count(ib)) .EQ. outflow_grid(ib,ij)) .GT. 1) THEN |
|---|
| 6883 | multbas = multbas + 1 |
|---|
| 6884 | DO ii=1,basin_count(ib) |
|---|
| 6885 | IF ( tmp_ids(ii) .EQ. outflow_grid(ib,ij)) THEN |
|---|
| 6886 | multbas_sz(multbas) = multbas_sz(multbas) + 1 |
|---|
| 6887 | multbas_list(multbas,multbas_sz(multbas)) = ii |
|---|
| 6888 | tmp_ids(ii) = -99 |
|---|
| 6889 | ENDIF |
|---|
| 6890 | ENDDO |
|---|
| 6891 | ELSE |
|---|
| 6892 | tmp_ids(ij) = -99 |
|---|
| 6893 | ENDIF |
|---|
| 6894 | ENDDO |
|---|
| 6895 | ! |
|---|
| 6896 | ! Did we come up with any basins to deal with this way ? |
|---|
| 6897 | ! |
|---|
| 6898 | IF ( multbas .GT. 0 ) THEN |
|---|
| 6899 | ! |
|---|
| 6900 | iml = MAXLOC(multbas_sz(1:multbas)) |
|---|
| 6901 | ik = iml(1) |
|---|
| 6902 | ! |
|---|
| 6903 | ! Take the smallest and largest of these basins ! |
|---|
| 6904 | ! |
|---|
| 6905 | DO ii=1,multbas_sz(ik) |
|---|
| 6906 | tmp_area(ii) = fetch_basin(ib, multbas_list(ik,ii)) |
|---|
| 6907 | ENDDO |
|---|
| 6908 | ! |
|---|
| 6909 | iml = MAXLOC(tmp_area(1:multbas_sz(ik)), MASK = tmp_area(1:multbas_sz(ik)) .GT. zero) |
|---|
| 6910 | sbas = multbas_list(ik,iml(1)) |
|---|
| 6911 | iml = MINLOC(tmp_area(1:multbas_sz(ik)), MASK = tmp_area(1:multbas_sz(ik)) .GT. zero) |
|---|
| 6912 | kbas = multbas_list(ik,iml(1)) |
|---|
| 6913 | ! |
|---|
| 6914 | ENDIF |
|---|
| 6915 | ! |
|---|
| 6916 | ENDIF |
|---|
| 6917 | ! |
|---|
| 6918 | ! 4) If we have twice the same basin we put them together even if they flow into different |
|---|
| 6919 | ! directions. If one of them goes to the ocean it takes the advantage. |
|---|
| 6920 | ! |
|---|
| 6921 | IF ( kbas*sbas .EQ. 0) THEN |
|---|
| 6922 | ! |
|---|
| 6923 | tmp_ids(1:basin_count(ib)) = basin_id(ib,1:basin_count(ib)) |
|---|
| 6924 | multbas = 0 |
|---|
| 6925 | multbas_sz(:) = 0 |
|---|
| 6926 | ! |
|---|
| 6927 | ! First obtain the list of basins which have sub-basins in this grid box. |
|---|
| 6928 | ! (these are identified by their IDs) |
|---|
| 6929 | ! |
|---|
| 6930 | DO ij=1,basin_count(ib) |
|---|
| 6931 | IF ( COUNT(tmp_ids(1:basin_count(ib)) .EQ. basin_id(ib,ij)) .GT. 1) THEN |
|---|
| 6932 | multbas = multbas + 1 |
|---|
| 6933 | DO ii=1,basin_count(ib) |
|---|
| 6934 | IF ( tmp_ids(ii) .EQ. basin_id(ib,ij)) THEN |
|---|
| 6935 | multbas_sz(multbas) = multbas_sz(multbas) + 1 |
|---|
| 6936 | multbas_list(multbas,multbas_sz(multbas)) = ii |
|---|
| 6937 | tmp_ids(ii) = -99 |
|---|
| 6938 | ENDIF |
|---|
| 6939 | ENDDO |
|---|
| 6940 | ELSE |
|---|
| 6941 | tmp_ids(ij) = -99 |
|---|
| 6942 | ENDIF |
|---|
| 6943 | ENDDO |
|---|
| 6944 | ! |
|---|
| 6945 | ! We are going to work on the basin with the largest number of sub-basins. |
|---|
| 6946 | ! (IF we have a basin which has subbasins !) |
|---|
| 6947 | ! |
|---|
| 6948 | IF ( multbas .GT. 0 ) THEN |
|---|
| 6949 | ! |
|---|
| 6950 | iml = MAXLOC(multbas_sz(1:multbas)) |
|---|
| 6951 | ik = iml(1) |
|---|
| 6952 | ! |
|---|
| 6953 | ! If one of the basins goes to the ocean then it is going to have the priority |
|---|
| 6954 | ! |
|---|
| 6955 | tmp_area(:) = zero |
|---|
| 6956 | IF ( COUNT(outflow_grid(ib,multbas_list(ik,1:multbas_sz(ik))) .LT. 0) .GT. 0) THEN |
|---|
| 6957 | DO ii=1,multbas_sz(ik) |
|---|
| 6958 | IF ( outflow_grid(ib,multbas_list(ik,ii)) .LT. 0 .AND. sbas .EQ. 0 ) THEN |
|---|
| 6959 | sbas = multbas_list(ik,ii) |
|---|
| 6960 | ELSE |
|---|
| 6961 | tmp_area(ii) = fetch_basin(ib, multbas_list(ik,ii)) |
|---|
| 6962 | ENDIF |
|---|
| 6963 | ENDDO |
|---|
| 6964 | ! take the smallest of the subbasins |
|---|
| 6965 | iml = MINLOC(tmp_area(1:multbas_sz(ik)), MASK = tmp_area(1:multbas_sz(ik)) .GT. zero) |
|---|
| 6966 | kbas = multbas_list(ik,iml(1)) |
|---|
| 6967 | ELSE |
|---|
| 6968 | ! |
|---|
| 6969 | ! Else we take simply the largest and smallest |
|---|
| 6970 | ! |
|---|
| 6971 | DO ii=1,multbas_sz(ik) |
|---|
| 6972 | tmp_area(ii) = fetch_basin(ib, multbas_list(ik,ii)) |
|---|
| 6973 | ENDDO |
|---|
| 6974 | iml = MAXLOC(tmp_area(1:multbas_sz(ik)), MASK = tmp_area(1:multbas_sz(ik)) .GT. zero) |
|---|
| 6975 | sbas = multbas_list(ik,iml(1)) |
|---|
| 6976 | iml = MINLOC(tmp_area(1:multbas_sz(ik)), MASK = tmp_area(1:multbas_sz(ik)) .GT. zero) |
|---|
| 6977 | kbas = multbas_list(ik,iml(1)) |
|---|
| 6978 | ! |
|---|
| 6979 | ENDIF |
|---|
| 6980 | ! |
|---|
| 6981 | ! |
|---|
| 6982 | ENDIF |
|---|
| 6983 | ENDIF |
|---|
| 6984 | ! |
|---|
| 6985 | ! |
|---|
| 6986 | ! |
|---|
| 6987 | ! Then we call routing_killbas to clean up the basins in this grid |
|---|
| 6988 | ! |
|---|
| 6989 | IF ( kbas .GT. 0 .AND. sbas .GT. 0 ) THEN |
|---|
| 6990 | CALL routing_killbas(nbpt, ib, kbas, sbas, nwbas, basin_count, basin_area, basin_topoind,& |
|---|
| 6991 | & fetch_basin, basin_id, basin_flowdir, outflow_grid, outflow_basin, inflow_number,& |
|---|
| 6992 | & inflow_grid, inflow_basin) |
|---|
| 6993 | ENDIF |
|---|
| 6994 | ! |
|---|
| 6995 | ENDDO |
|---|
| 6996 | ! |
|---|
| 6997 | ! |
|---|
| 6998 | ENDDO |
|---|
| 6999 | ! |
|---|
| 7000 | ! If there are any grids left with too many basins we need to take out the big hammer ! |
|---|
| 7001 | ! We will only do it if this represents less than 5% of all points. |
|---|
| 7002 | ! |
|---|
| 7003 | IF ( COUNT(basin_count .GT. nbasmax) .GT. 0 ) THEN |
|---|
| 7004 | ! |
|---|
| 7005 | ! |
|---|
| 7006 | IF ( COUNT(basin_count .GT. nbasmax)/nbpt*100 .GT. 5 ) THEN |
|---|
| 7007 | WRITE(numout,*) 'We have ', COUNT(basin_count .GT. nbasmax)/nbpt*100, '% of all points which do not yet' |
|---|
| 7008 | WRITE(numout,*) 'have the right trunctaction. That is too much to apply a brutal method' |
|---|
| 7009 | DO ib = 1, nbpt |
|---|
| 7010 | IF ( basin_count(ib) .GT. nbasmax ) THEN |
|---|
| 7011 | ! |
|---|
| 7012 | WRITE(numout,*) 'We did not find a basin which could be supressed. We will' |
|---|
| 7013 | WRITE(numout,*) 'not be able to reduce the truncation in grid ', ib |
|---|
| 7014 | DO ij=1,basin_count(ib) |
|---|
| 7015 | WRITE(numout,*) 'grid, basin nb and id :', ib, ij, basin_id(ib,ij) |
|---|
| 7016 | WRITE(numout,*) 'Outflow grid and basin ->', outflow_grid(ib,ij), outflow_basin(ib, ij) |
|---|
| 7017 | ENDDO |
|---|
| 7018 | ENDIF |
|---|
| 7019 | ENDDO |
|---|
| 7020 | CALL ipslerr_p(3,'routing_truncate','No basin found which could be supressed.','','') |
|---|
| 7021 | ELSE |
|---|
| 7022 | ! |
|---|
| 7023 | ! |
|---|
| 7024 | DO ib = 1,nbpt |
|---|
| 7025 | DO WHILE ( basin_count(ib) .GT. nbasmax ) |
|---|
| 7026 | ! |
|---|
| 7027 | IF (printlev>=3) WRITE(numout,*) 'HAMMER, ib, basin_count :', ib, basin_count(ib) |
|---|
| 7028 | ! |
|---|
| 7029 | ! Here we simply put the smallest basins into the largest ones. It is really a brute force |
|---|
| 7030 | ! method but it will only be applied if everything has failed. |
|---|
| 7031 | ! |
|---|
| 7032 | DO ii = 1,basin_count(ib) |
|---|
| 7033 | tmp_area(ii) = fetch_basin(ib, ii) |
|---|
| 7034 | ENDDO |
|---|
| 7035 | ! |
|---|
| 7036 | iml = MAXLOC(tmp_area(1:basin_count(ib)), MASK = tmp_area(1:basin_count(ib)) .GT. 0.) |
|---|
| 7037 | sbas =iml(1) |
|---|
| 7038 | iml = MINLOC(tmp_area(1:basin_count(ib)), MASK = tmp_area(1:basin_count(ib)) .GT. 0.) |
|---|
| 7039 | kbas = iml(1) |
|---|
| 7040 | ! |
|---|
| 7041 | IF ( kbas .GT. 0 .AND. sbas .GT. 0 ) THEN |
|---|
| 7042 | CALL routing_killbas(nbpt, ib, kbas, sbas, nwbas, basin_count, basin_area, basin_topoind,& |
|---|
| 7043 | & fetch_basin, basin_id, basin_flowdir, outflow_grid, outflow_basin, inflow_number,& |
|---|
| 7044 | & inflow_grid, inflow_basin) |
|---|
| 7045 | ENDIF |
|---|
| 7046 | ENDDO |
|---|
| 7047 | ENDDO |
|---|
| 7048 | ! |
|---|
| 7049 | ENDIF |
|---|
| 7050 | ! |
|---|
| 7051 | ! |
|---|
| 7052 | ENDIF |
|---|
| 7053 | ! |
|---|
| 7054 | ! Now that we have reached the right truncation (resolution) we will start |
|---|
| 7055 | ! to produce the variables we will use to route the water. |
|---|
| 7056 | ! |
|---|
| 7057 | DO ib=1,nbpt |
|---|
| 7058 | ! |
|---|
| 7059 | ! For non existing basins the route_tobasin variable is put to zero. This will allow us |
|---|
| 7060 | ! to pick up the number of basin afterwards. |
|---|
| 7061 | ! |
|---|
| 7062 | route_togrid(ib,:) = ib |
|---|
| 7063 | route_tobasin(ib,:) = 0 |
|---|
| 7064 | routing_area(ib,:) = zero |
|---|
| 7065 | ! |
|---|
| 7066 | ENDDO |
|---|
| 7067 | ! |
|---|
| 7068 | ! Transfer the info into the definitive variables |
|---|
| 7069 | ! |
|---|
| 7070 | DO ib=1,nbpt |
|---|
| 7071 | DO ij=1,basin_count(ib) |
|---|
| 7072 | routing_area(ib,ij) = basin_area(ib,ij) |
|---|
| 7073 | topo_resid(ib,ij) = basin_topoind(ib,ij) |
|---|
| 7074 | global_basinid(ib,ij) = basin_id(ib,ij) |
|---|
| 7075 | route_togrid(ib,ij) = outflow_grid(ib,ij) |
|---|
| 7076 | route_tobasin(ib,ij) = outflow_basin(ib,ij) |
|---|
| 7077 | ENDDO |
|---|
| 7078 | ENDDO |
|---|
| 7079 | ! |
|---|
| 7080 | ! |
|---|
| 7081 | ! Set the new convention for the outflow conditions |
|---|
| 7082 | ! Now it is based in the outflow basin and the outflow grid will |
|---|
| 7083 | ! be the same as the current. |
|---|
| 7084 | ! returnflow to the grid : nbasmax + 1 |
|---|
| 7085 | ! coastal flow : nbasmax + 2 |
|---|
| 7086 | ! river outflow : nbasmax + 3 |
|---|
| 7087 | ! |
|---|
| 7088 | ! Here we put everything here in coastal flow. It is later where we will |
|---|
| 7089 | ! put the largest basins into river outflow. |
|---|
| 7090 | ! |
|---|
| 7091 | DO ib=1,nbpt |
|---|
| 7092 | DO ij=1,basin_count(ib) |
|---|
| 7093 | ! River flows |
|---|
| 7094 | IF ( route_togrid(ib,ij) .EQ. -1 ) THEN |
|---|
| 7095 | route_tobasin(ib,ij) = nbasmax + 2 |
|---|
| 7096 | route_togrid(ib,ij) = ib |
|---|
| 7097 | ! Coastal flows |
|---|
| 7098 | ELSE IF ( route_togrid(ib,ij) .EQ. -2 ) THEN |
|---|
| 7099 | route_tobasin(ib,ij) = nbasmax + 2 |
|---|
| 7100 | route_togrid(ib,ij) = ib |
|---|
| 7101 | ! Return flow |
|---|
| 7102 | ELSE IF ( route_togrid(ib,ij) .EQ. -3 ) THEN |
|---|
| 7103 | route_tobasin(ib,ij) = nbasmax + 1 |
|---|
| 7104 | route_togrid(ib,ij) = ib |
|---|
| 7105 | ENDIF |
|---|
| 7106 | ENDDO |
|---|
| 7107 | ENDDO |
|---|
| 7108 | ! |
|---|
| 7109 | ! A second check on the data. Just make sure that each basin flows somewhere. |
|---|
| 7110 | ! |
|---|
| 7111 | DO ib=1,nbpt |
|---|
| 7112 | DO ij=1,basin_count(ib) |
|---|
| 7113 | ibf = route_togrid(ib,ij) |
|---|
| 7114 | ijf = route_tobasin(ib,ij) |
|---|
| 7115 | IF ( ijf .GT. basin_count(ibf) .AND. ijf .LE. nbasmax) THEN |
|---|
| 7116 | WRITE(numout,*) 'Second check' |
|---|
| 7117 | WRITE(numout,*) 'point :', ib, ' basin :', ij |
|---|
| 7118 | WRITE(numout,*) 'Flows into point :', ibf, ' basin :', ijf |
|---|
| 7119 | WRITE(numout,*) 'But it flows into now here as basin count = ', basin_count(ibf) |
|---|
| 7120 | CALL ipslerr_p(3,'routing_truncate','Problem with routing..','','') |
|---|
| 7121 | ENDIF |
|---|
| 7122 | ENDDO |
|---|
| 7123 | ENDDO |
|---|
| 7124 | ! |
|---|
| 7125 | ! Verify areas of the continents |
|---|
| 7126 | ! |
|---|
| 7127 | floflo(:,:) = zero |
|---|
| 7128 | gridarea(:) = contfrac(:)*resolution(:,1)*resolution(:,2) |
|---|
| 7129 | DO ib=1,nbpt |
|---|
| 7130 | gridbasinarea(ib) = SUM(routing_area(ib,:)) |
|---|
| 7131 | ENDDO |
|---|
| 7132 | ! |
|---|
| 7133 | DO ib=1,nbpt |
|---|
| 7134 | DO ij=1,basin_count(ib) |
|---|
| 7135 | cnt = 0 |
|---|
| 7136 | igrif = ib |
|---|
| 7137 | ibasf = ij |
|---|
| 7138 | DO WHILE (ibasf .LE. nbasmax .AND. cnt .LT. nbasmax*nbpt) |
|---|
| 7139 | cnt = cnt + 1 |
|---|
| 7140 | pold = igrif |
|---|
| 7141 | bold = ibasf |
|---|
| 7142 | igrif = route_togrid(pold, bold) |
|---|
| 7143 | ibasf = route_tobasin(pold, bold) |
|---|
| 7144 | IF ( ibasf .GT. basin_count(igrif) .AND. ibasf .LE. nbasmax) THEN |
|---|
| 7145 | WRITE(numout,*) 'We should not be here as the basin flows into the pampa' |
|---|
| 7146 | WRITE(numout,*) 'Last correct point :', pold, bold |
|---|
| 7147 | WRITE(numout,*) 'It pointed to in the new variables :', route_togrid(pold, bold),route_tobasin(pold, bold) |
|---|
| 7148 | WRITE(numout,*) 'The old variables gave :', outflow_grid(pold, bold), outflow_basin(pold, bold) |
|---|
| 7149 | WRITE(numout,*) 'Where we ended up :', igrif,ibasf |
|---|
| 7150 | CALL ipslerr_p(3,'routing_truncate','Problem with routing..','','') |
|---|
| 7151 | ENDIF |
|---|
| 7152 | ENDDO |
|---|
| 7153 | ! |
|---|
| 7154 | IF ( ibasf .GT. nbasmax ) THEN |
|---|
| 7155 | floflo(igrif,bold) = floflo(igrif,bold) + routing_area(ib,ij) |
|---|
| 7156 | ELSE |
|---|
| 7157 | WRITE(numout,*) 'The flow did not end up in the ocean or in the grid cell.' |
|---|
| 7158 | WRITE(numout,*) 'For grid ', ib, ' and basin ', ij |
|---|
| 7159 | WRITE(numout,*) 'The last grid was ', igrif, ' and basin ', ibasf |
|---|
| 7160 | CALL ipslerr_p(3,'routing_truncate','Problem with routing..','','') |
|---|
| 7161 | ENDIF |
|---|
| 7162 | ENDDO |
|---|
| 7163 | ENDDO |
|---|
| 7164 | ! |
|---|
| 7165 | DO ib=1,nbpt |
|---|
| 7166 | IF ( gridbasinarea(ib) > zero ) THEN |
|---|
| 7167 | ratio = gridarea(ib)/gridbasinarea(ib) |
|---|
| 7168 | routing_area(ib,:) = routing_area(ib,:)*ratio |
|---|
| 7169 | ELSE |
|---|
| 7170 | WRITE(numout,*) 'gridbasinarea(ib) <= zero. We should stop here :', ib |
|---|
| 7171 | ENDIF |
|---|
| 7172 | ENDDO |
|---|
| 7173 | ! |
|---|
| 7174 | WRITE(numout,*) 'Sum of area of all outflow areas :',SUM(routing_area) |
|---|
| 7175 | WRITE(numout,*) 'Surface of all continents :', SUM(gridarea) |
|---|
| 7176 | ! |
|---|
| 7177 | ! Redo the the distinction between river outflow and coastal flow. We can not |
|---|
| 7178 | ! take into account the return flow points. |
|---|
| 7179 | ! |
|---|
| 7180 | ibf = 0 |
|---|
| 7181 | DO ib=1, pickmax |
|---|
| 7182 | ff = MAXLOC(floflo) |
|---|
| 7183 | ! tdo - To take into account rivers that do not flow to the oceans |
|---|
| 7184 | IF ( route_tobasin(ff(1), ff(2)) .GT. nbasmax ) THEN |
|---|
| 7185 | ! IF ( route_tobasin(ff(1), ff(2)) .EQ. nbasmax + 2) THEN |
|---|
| 7186 | ibf = ibf + 1 |
|---|
| 7187 | largest_basins(ibf,:) = ff(:) |
|---|
| 7188 | ENDIF |
|---|
| 7189 | floflo(ff(1), ff(2)) = zero |
|---|
| 7190 | ENDDO |
|---|
| 7191 | ! |
|---|
| 7192 | ! Put the largest basins into river flows. |
|---|
| 7193 | ! |
|---|
| 7194 | IF ( ibf .LT. num_largest) THEN |
|---|
| 7195 | WRITE(numout,*) 'Not enough basins to choose the ', num_largest, 'largest' |
|---|
| 7196 | CALL ipslerr_p(3,'routing_truncate','Not enough basins','','') |
|---|
| 7197 | ENDIF |
|---|
| 7198 | ! |
|---|
| 7199 | ! |
|---|
| 7200 | ! |
|---|
| 7201 | DO ib=1, num_largest |
|---|
| 7202 | route_tobasin(largest_basins(ib,1),largest_basins(ib,2)) = nbasmax + 3 |
|---|
| 7203 | ENDDO |
|---|
| 7204 | ! |
|---|
| 7205 | WRITE(numout,*) 'NUMBER OF RIVERS :', COUNT(route_tobasin .GE. nbasmax + 3) |
|---|
| 7206 | ! |
|---|
| 7207 | END SUBROUTINE routing_truncate |
|---|
| 7208 | ! |
|---|
| 7209 | !! ================================================================================================================================ |
|---|
| 7210 | !! SUBROUTINE : routing_killbas |
|---|
| 7211 | !! |
|---|
| 7212 | !>\BRIEF The aim of this subroutine is to kill a basin (that is put into another larger one). |
|---|
| 7213 | !! When we do this we need to be careful and change all associated variables. |
|---|
| 7214 | !! |
|---|
| 7215 | !! DESCRIPTION (definitions, functional, design, flags) : None |
|---|
| 7216 | !! |
|---|
| 7217 | !! RECENT CHANGE(S): None |
|---|
| 7218 | !! |
|---|
| 7219 | !! MAIN OUTPUT VARIABLE(S): |
|---|
| 7220 | !! |
|---|
| 7221 | !! REFERENCES : None |
|---|
| 7222 | !! |
|---|
| 7223 | !! FLOWCHART : None |
|---|
| 7224 | !! \n |
|---|
| 7225 | !_ ================================================================================================================================ |
|---|
| 7226 | |
|---|
| 7227 | SUBROUTINE routing_killbas(nbpt, ib, tokill, totakeover, nwbas, basin_count, basin_area, basin_topoind,& |
|---|
| 7228 | & fetch_basin, basin_id, basin_flowdir, outflow_grid, outflow_basin, inflow_number,& |
|---|
| 7229 | & inflow_grid, inflow_basin) |
|---|
| 7230 | ! |
|---|
| 7231 | ! |
|---|
| 7232 | IMPLICIT NONE |
|---|
| 7233 | ! |
|---|
| 7234 | INTEGER(i_std) :: tokill !! |
|---|
| 7235 | INTEGER(i_std) :: totakeover !! |
|---|
| 7236 | INTEGER(i_std) :: nbpt !! Domain size (unitless) |
|---|
| 7237 | INTEGER(i_std) :: ib !! Current basin (unitless) |
|---|
| 7238 | ! |
|---|
| 7239 | INTEGER(i_std) :: nwbas !! |
|---|
| 7240 | INTEGER(i_std), DIMENSION(nbpt) :: basin_count !! |
|---|
| 7241 | INTEGER(i_std), DIMENSION(nbpt,nwbas) :: basin_id !! |
|---|
| 7242 | INTEGER(i_std), DIMENSION(nbpt,nwbas) :: basin_flowdir !! Water flow directions in the basin (unitless) |
|---|
| 7243 | REAL(r_std), DIMENSION(nbpt,nwbas) :: basin_area !! |
|---|
| 7244 | REAL(r_std), DIMENSION(nbpt,nwbas) :: basin_topoind !! Topographic index of the residence time for a basin (m) |
|---|
| 7245 | REAL(r_std), DIMENSION(nbpt,nwbas) :: fetch_basin !! |
|---|
| 7246 | INTEGER(i_std), DIMENSION(nbpt,nwbas) :: outflow_grid !! Type of outflow on the grid box (unitless) |
|---|
| 7247 | INTEGER(i_std), DIMENSION(nbpt,nwbas) :: outflow_basin !! |
|---|
| 7248 | INTEGER(i_std), DIMENSION(nbpt,nwbas) :: inflow_number !! |
|---|
| 7249 | INTEGER(i_std), DIMENSION(nbpt,nwbas,nwbas) :: inflow_basin !! |
|---|
| 7250 | INTEGER(i_std), DIMENSION(nbpt,nwbas,nwbas) :: inflow_grid !! |
|---|
| 7251 | ! |
|---|
| 7252 | !! LOCAL VARIABLES |
|---|
| 7253 | INTEGER(i_std) :: inf, ibs, ing, inb, ibasf, igrif, it !! Indices (unitless) |
|---|
| 7254 | LOGICAL :: doshift !! (true/false) |
|---|
| 7255 | |
|---|
| 7256 | !_ ================================================================================================================================ |
|---|
| 7257 | ! |
|---|
| 7258 | ! Update the information needed in the basin "totakeover" |
|---|
| 7259 | ! For the moment only area |
|---|
| 7260 | ! |
|---|
| 7261 | IF (printlev>=3) THEN |
|---|
| 7262 | WRITE(numout,*) 'KILL BASIN :', ib, tokill, totakeover, basin_id(ib,tokill), basin_id(ib,totakeover) |
|---|
| 7263 | END IF |
|---|
| 7264 | ! |
|---|
| 7265 | basin_area(ib, totakeover) = basin_area(ib, totakeover) + basin_area(ib, tokill) |
|---|
| 7266 | basin_topoind(ib, totakeover) = (basin_topoind(ib, totakeover) + basin_topoind(ib, tokill))/2.0 |
|---|
| 7267 | ! |
|---|
| 7268 | ! Add the fetch of the basin will kill to the one which gets the water |
|---|
| 7269 | ! |
|---|
| 7270 | fetch_basin(ib, totakeover) = fetch_basin(ib, totakeover) + fetch_basin(ib, tokill) |
|---|
| 7271 | igrif = outflow_grid(ib,totakeover) |
|---|
| 7272 | ibasf = outflow_basin(ib,totakeover) |
|---|
| 7273 | ! |
|---|
| 7274 | inf = 0 |
|---|
| 7275 | DO WHILE (igrif .GT. 0) |
|---|
| 7276 | fetch_basin(igrif,ibasf) = fetch_basin(igrif,ibasf) + fetch_basin(ib, tokill) |
|---|
| 7277 | it = outflow_grid(igrif, ibasf) |
|---|
| 7278 | ibasf = outflow_basin(igrif, ibasf) |
|---|
| 7279 | igrif = it |
|---|
| 7280 | inf = inf + 1 |
|---|
| 7281 | ENDDO |
|---|
| 7282 | ! |
|---|
| 7283 | ! Take out the basin we have just rerouted from the fetch of the basins in which it used to flow. |
|---|
| 7284 | ! |
|---|
| 7285 | igrif = outflow_grid(ib,tokill) |
|---|
| 7286 | ibasf = outflow_basin(ib,tokill) |
|---|
| 7287 | ! |
|---|
| 7288 | DO WHILE (igrif .GT. 0) |
|---|
| 7289 | fetch_basin(igrif,ibasf) = fetch_basin(igrif,ibasf) - fetch_basin(ib, tokill) |
|---|
| 7290 | it = outflow_grid(igrif, ibasf) |
|---|
| 7291 | ibasf = outflow_basin(igrif, ibasf) |
|---|
| 7292 | igrif = it |
|---|
| 7293 | ENDDO |
|---|
| 7294 | ! |
|---|
| 7295 | ! Redirect the flows which went into the basin to be killed before we change everything |
|---|
| 7296 | ! |
|---|
| 7297 | DO inf = 1, inflow_number(ib, tokill) |
|---|
| 7298 | outflow_basin(inflow_grid(ib, tokill, inf), inflow_basin(ib, tokill, inf)) = totakeover |
|---|
| 7299 | inflow_number(ib, totakeover) = inflow_number(ib, totakeover) + 1 |
|---|
| 7300 | inflow_grid(ib, totakeover, inflow_number(ib, totakeover)) = inflow_grid(ib, tokill, inf) |
|---|
| 7301 | inflow_basin(ib, totakeover, inflow_number(ib, totakeover)) = inflow_basin(ib, tokill, inf) |
|---|
| 7302 | ENDDO |
|---|
| 7303 | ! |
|---|
| 7304 | ! Take out the basin to be killed from the list of inflow basins of the downstream basin |
|---|
| 7305 | ! (In case the basin does not flow into an ocean or lake) |
|---|
| 7306 | ! |
|---|
| 7307 | IF ( outflow_grid(ib,tokill) .GT. 0) THEN |
|---|
| 7308 | ! |
|---|
| 7309 | ing = outflow_grid(ib, tokill) |
|---|
| 7310 | inb = outflow_basin(ib, tokill) |
|---|
| 7311 | doshift = .FALSE. |
|---|
| 7312 | ! |
|---|
| 7313 | DO inf = 1, inflow_number(ing, inb) |
|---|
| 7314 | IF ( doshift ) THEN |
|---|
| 7315 | inflow_grid(ing, inb, inf-1) = inflow_grid(ing, inb, inf) |
|---|
| 7316 | inflow_basin(ing, inb, inf-1) = inflow_basin(ing, inb, inf) |
|---|
| 7317 | ENDIF |
|---|
| 7318 | IF ( inflow_grid(ing, inb, inf) .EQ. ib .AND. inflow_basin(ing, inb, inf) .EQ. tokill) THEN |
|---|
| 7319 | doshift = .TRUE. |
|---|
| 7320 | ENDIF |
|---|
| 7321 | ENDDO |
|---|
| 7322 | ! |
|---|
| 7323 | ! This is only to allow for the last check |
|---|
| 7324 | ! |
|---|
| 7325 | inf = inflow_number(ing, inb) |
|---|
| 7326 | IF ( inflow_grid(ing, inb, inf) .EQ. ib .AND. inflow_basin(ing, inb, inf) .EQ. tokill) THEN |
|---|
| 7327 | doshift = .TRUE. |
|---|
| 7328 | ENDIF |
|---|
| 7329 | ! |
|---|
| 7330 | IF ( .NOT. doshift ) THEN |
|---|
| 7331 | WRITE(numout,*) 'Strange we did not find the basin to kill in the downstream basin' |
|---|
| 7332 | CALL ipslerr_p(3,'routing_killbas','Basin not found','','') |
|---|
| 7333 | ENDIF |
|---|
| 7334 | inflow_number(ing, inb) = inflow_number(ing, inb) - 1 |
|---|
| 7335 | |
|---|
| 7336 | ENDIF |
|---|
| 7337 | ! |
|---|
| 7338 | ! Now remove from the arrays the information of basin "tokill" |
|---|
| 7339 | ! |
|---|
| 7340 | basin_id(ib, tokill:basin_count(ib)-1) = basin_id(ib, tokill+1:basin_count(ib)) |
|---|
| 7341 | basin_flowdir(ib, tokill:basin_count(ib)-1) = basin_flowdir(ib, tokill+1:basin_count(ib)) |
|---|
| 7342 | basin_area(ib, tokill:basin_count(ib)-1) = basin_area(ib, tokill+1:basin_count(ib)) |
|---|
| 7343 | basin_area(ib, basin_count(ib):nwbas) = zero |
|---|
| 7344 | basin_topoind(ib, tokill:basin_count(ib)-1) = basin_topoind(ib, tokill+1:basin_count(ib)) |
|---|
| 7345 | basin_topoind(ib, basin_count(ib):nwbas) = zero |
|---|
| 7346 | fetch_basin(ib, tokill:basin_count(ib)-1) = fetch_basin(ib, tokill+1:basin_count(ib)) |
|---|
| 7347 | fetch_basin(ib, basin_count(ib):nwbas) = zero |
|---|
| 7348 | ! |
|---|
| 7349 | ! Before we remove the information from the outflow fields we have to correct the corresponding inflow fields |
|---|
| 7350 | ! of the grids into which the flow goes |
|---|
| 7351 | ! |
|---|
| 7352 | DO ibs = tokill+1,basin_count(ib) |
|---|
| 7353 | ing = outflow_grid(ib, ibs) |
|---|
| 7354 | inb = outflow_basin(ib, ibs) |
|---|
| 7355 | IF ( ing .GT. 0 ) THEN |
|---|
| 7356 | DO inf = 1, inflow_number(ing, inb) |
|---|
| 7357 | IF ( inflow_grid(ing,inb,inf) .EQ. ib .AND. inflow_basin(ing,inb,inf) .EQ. ibs) THEN |
|---|
| 7358 | inflow_basin(ing,inb,inf) = ibs - 1 |
|---|
| 7359 | ENDIF |
|---|
| 7360 | ENDDO |
|---|
| 7361 | ENDIF |
|---|
| 7362 | ENDDO |
|---|
| 7363 | outflow_grid(ib, tokill:basin_count(ib)-1) = outflow_grid(ib, tokill+1:basin_count(ib)) |
|---|
| 7364 | outflow_basin(ib, tokill:basin_count(ib)-1) = outflow_basin(ib, tokill+1:basin_count(ib)) |
|---|
| 7365 | ! |
|---|
| 7366 | ! Basins which moved down also need to redirect their incoming flows. |
|---|
| 7367 | ! |
|---|
| 7368 | DO ibs=tokill+1, basin_count(ib) |
|---|
| 7369 | DO inf = 1, inflow_number(ib, ibs) |
|---|
| 7370 | outflow_basin(inflow_grid(ib, ibs, inf), inflow_basin(ib, ibs, inf)) = ibs-1 |
|---|
| 7371 | ENDDO |
|---|
| 7372 | ENDDO |
|---|
| 7373 | ! |
|---|
| 7374 | ! Shift the inflow basins |
|---|
| 7375 | ! |
|---|
| 7376 | DO it = tokill+1,basin_count(ib) |
|---|
| 7377 | inflow_grid(ib, it-1, 1:inflow_number(ib,it)) = inflow_grid(ib, it, 1:inflow_number(ib,it)) |
|---|
| 7378 | inflow_basin(ib, it-1, 1:inflow_number(ib,it)) = inflow_basin(ib, it, 1:inflow_number(ib,it)) |
|---|
| 7379 | inflow_number(ib,it-1) = inflow_number(ib,it) |
|---|
| 7380 | ENDDO |
|---|
| 7381 | ! |
|---|
| 7382 | basin_count(ib) = basin_count(ib) - 1 |
|---|
| 7383 | ! |
|---|
| 7384 | END SUBROUTINE routing_killbas |
|---|
| 7385 | ! |
|---|
| 7386 | !! ================================================================================================================================ |
|---|
| 7387 | !! SUBROUTINE : routing_names |
|---|
| 7388 | !! |
|---|
| 7389 | !>\BRIEF This subroutine lists the name of the largest basins which are explicitly listed in the basin |
|---|
| 7390 | !! description file used by ORCHIDEE. |
|---|
| 7391 | !! |
|---|
| 7392 | !! DESCRIPTION (definitions, functional, design, flags) : None |
|---|
| 7393 | !! |
|---|
| 7394 | !! RECENT CHANGE(S): None |
|---|
| 7395 | !! |
|---|
| 7396 | !! MAIN OUTPUT VARIABLE(S): |
|---|
| 7397 | !! |
|---|
| 7398 | !! REFERENCES : None |
|---|
| 7399 | !! |
|---|
| 7400 | !! FLOWCHART : None |
|---|
| 7401 | !! \n |
|---|
| 7402 | !_ ================================================================================================================================ |
|---|
| 7403 | |
|---|
| 7404 | SUBROUTINE routing_names(numlar, basin_names) |
|---|
| 7405 | ! |
|---|
| 7406 | IMPLICIT NONE |
|---|
| 7407 | ! |
|---|
| 7408 | ! Arguments |
|---|
| 7409 | ! |
|---|
| 7410 | INTEGER(i_std), INTENT(in) :: numlar !! |
|---|
| 7411 | CHARACTER(LEN=*), INTENT(inout) :: basin_names(numlar) !! Name of the basins (unitless) |
|---|
| 7412 | !! PARAMETERS |
|---|
| 7413 | INTEGER(i_std), PARAMETER :: listleng=349 !! |
|---|
| 7414 | ! |
|---|
| 7415 | !! LOCAL VARIABLES |
|---|
| 7416 | INTEGER(i_std) :: lenstr, i !! |
|---|
| 7417 | CHARACTER(LEN=60), DIMENSION(listleng) :: list_names !! |
|---|
| 7418 | CHARACTER(LEN=60) :: tmp_str !! |
|---|
| 7419 | |
|---|
| 7420 | !_ ================================================================================================================================ |
|---|
| 7421 | ! |
|---|
| 7422 | |
|---|
| 7423 | lenstr = LEN(basin_names(1)) |
|---|
| 7424 | ! |
|---|
| 7425 | list_names(1) = "Amazon" |
|---|
| 7426 | list_names(2) = "Nile" |
|---|
| 7427 | list_names(3) = "Zaire" |
|---|
| 7428 | list_names(4) = "Mississippi" |
|---|
| 7429 | list_names(5) = "Amur" |
|---|
| 7430 | list_names(6) = "Parana" |
|---|
| 7431 | list_names(7) = "Yenisei" |
|---|
| 7432 | list_names(8) = "Ob" |
|---|
| 7433 | list_names(9) = "Lena" |
|---|
| 7434 | list_names(10) = "Niger" |
|---|
| 7435 | list_names(11) = "Zambezi" |
|---|
| 7436 | list_names(12) = "Erg Iguidi (Sahara)" |
|---|
| 7437 | list_names(13) = "Chang Jiang (Yangtze)" |
|---|
| 7438 | list_names(14) = "Mackenzie" |
|---|
| 7439 | list_names(15) = "Ganges" |
|---|
| 7440 | list_names(16) = "Chari" |
|---|
| 7441 | list_names(17) = "Volga" |
|---|
| 7442 | list_names(18) = "St. Lawrence" |
|---|
| 7443 | list_names(19) = "Indus" |
|---|
| 7444 | list_names(20) = "Syr-Darya" |
|---|
| 7445 | list_names(21) = "Nelson" |
|---|
| 7446 | list_names(22) = "Orinoco" |
|---|
| 7447 | list_names(23) = "Murray" |
|---|
| 7448 | list_names(24) = "Great Artesian Basin" |
|---|
| 7449 | list_names(25) = "Shatt el Arab" |
|---|
| 7450 | list_names(26) = "Orange" |
|---|
| 7451 | list_names(27) = "Huang He" |
|---|
| 7452 | list_names(28) = "Yukon" |
|---|
| 7453 | list_names(29) = "Senegal" |
|---|
| 7454 | list_names(30) = "Chott Jerid" |
|---|
| 7455 | list_names(31) = "Jubba" |
|---|
| 7456 | list_names(32) = "Colorado (Ari)" |
|---|
| 7457 | list_names(33) = "Rio Grande (US)" |
|---|
| 7458 | list_names(34) = "Danube" |
|---|
| 7459 | list_names(35) = "Mekong" |
|---|
| 7460 | list_names(36) = "Tocantins" |
|---|
| 7461 | list_names(37) = "Wadi al Farigh" |
|---|
| 7462 | list_names(38) = "Tarim" |
|---|
| 7463 | list_names(39) = "Columbia" |
|---|
| 7464 | list_names(40) = "Komadugu Yobe (Tchad)" |
|---|
| 7465 | list_names(41) = "Kolyma" |
|---|
| 7466 | list_names(42) = "Sao Francisco" |
|---|
| 7467 | list_names(43) = "Amu-Darya" |
|---|
| 7468 | list_names(44) = "GHAASBasin51" |
|---|
| 7469 | list_names(45) = "Dnepr" |
|---|
| 7470 | list_names(46) = "GHAASBasin61" |
|---|
| 7471 | list_names(47) = "Don" |
|---|
| 7472 | list_names(48) = "Colorado (Arg)" |
|---|
| 7473 | list_names(49) = "Limpopo" |
|---|
| 7474 | list_names(50) = "GHAASBasin50" |
|---|
| 7475 | list_names(51) = "Zhujiang" |
|---|
| 7476 | list_names(52) = "Irrawaddy" |
|---|
| 7477 | list_names(53) = "Volta" |
|---|
| 7478 | list_names(54) = "GHAASBasin54" |
|---|
| 7479 | list_names(55) = "Farah" |
|---|
| 7480 | list_names(56) = "Khatanga" |
|---|
| 7481 | list_names(57) = "Dvina" |
|---|
| 7482 | list_names(58) = "Urugay" |
|---|
| 7483 | list_names(59) = "Qarqan" |
|---|
| 7484 | list_names(60) = "GHAASBasin75" |
|---|
| 7485 | list_names(61) = "Parnaiba" |
|---|
| 7486 | list_names(62) = "GHAASBasin73" |
|---|
| 7487 | list_names(63) = "Indigirka" |
|---|
| 7488 | list_names(64) = "Churchill (Hud)" |
|---|
| 7489 | list_names(65) = "Godavari" |
|---|
| 7490 | list_names(66) = "Pur - Taz" |
|---|
| 7491 | list_names(67) = "Pechora" |
|---|
| 7492 | list_names(68) = "Baker" |
|---|
| 7493 | list_names(69) = "Ural" |
|---|
| 7494 | list_names(70) = "Neva" |
|---|
| 7495 | list_names(71) = "Liao" |
|---|
| 7496 | list_names(72) = "Salween" |
|---|
| 7497 | list_names(73) = "GHAASBasin73" |
|---|
| 7498 | list_names(74) = "Jordan" |
|---|
| 7499 | list_names(75) = "GHAASBasin78" |
|---|
| 7500 | list_names(76) = "Magdalena" |
|---|
| 7501 | list_names(77) = "Krishna" |
|---|
| 7502 | list_names(78) = "Salado" |
|---|
| 7503 | list_names(79) = "Fraser" |
|---|
| 7504 | list_names(80) = "Hai Ho" |
|---|
| 7505 | list_names(81) = "Huai" |
|---|
| 7506 | list_names(82) = "Yana" |
|---|
| 7507 | list_names(83) = "GHAASBasin95" |
|---|
| 7508 | list_names(84) = "GHAASBasin105" |
|---|
| 7509 | list_names(85) = "Kura" |
|---|
| 7510 | list_names(86) = "Olenek" |
|---|
| 7511 | list_names(87) = "Ogooue" |
|---|
| 7512 | list_names(88) = "Taymyr" |
|---|
| 7513 | list_names(89) = "Negro Arg" |
|---|
| 7514 | list_names(90) = "Chubut" |
|---|
| 7515 | list_names(91) = "GHAASBasin91" |
|---|
| 7516 | list_names(92) = "GHAASBasin122" |
|---|
| 7517 | list_names(93) = "GHAASBasin120" |
|---|
| 7518 | list_names(94) = "Sacramento" |
|---|
| 7519 | list_names(95) = "Fitzroy West" |
|---|
| 7520 | list_names(96) = "Grande de Santiago" |
|---|
| 7521 | list_names(97) = "Rufiji" |
|---|
| 7522 | list_names(98) = "Wisla" |
|---|
| 7523 | list_names(99) = "GHAASBasin47" |
|---|
| 7524 | list_names(100) = "GHAASBasin127" |
|---|
| 7525 | list_names(101) = "Hong" |
|---|
| 7526 | list_names(102) = "GHAASBasin97" |
|---|
| 7527 | list_names(103) = "Swan-Avon" |
|---|
| 7528 | list_names(104) = "Rhine" |
|---|
| 7529 | list_names(105) = "Cuanza" |
|---|
| 7530 | list_names(106) = "GHAASBasin106" |
|---|
| 7531 | list_names(107) = "GHAASBasin142" |
|---|
| 7532 | list_names(108) = "Roviuna" |
|---|
| 7533 | list_names(109) = "Essequibo" |
|---|
| 7534 | list_names(110) = "Elbe" |
|---|
| 7535 | list_names(111) = "Koksoak" |
|---|
| 7536 | list_names(112) = "Chao Phraya" |
|---|
| 7537 | list_names(113) = "Brahmani" |
|---|
| 7538 | list_names(114) = "GHAASBasin165" |
|---|
| 7539 | list_names(115) = "Pyasina" |
|---|
| 7540 | list_names(116) = "Fitzroy East" |
|---|
| 7541 | list_names(117) = "GHAASBasin173" |
|---|
| 7542 | list_names(118) = "Albany" |
|---|
| 7543 | list_names(119) = "Sanaga" |
|---|
| 7544 | list_names(120) = "GHAASBasin120" |
|---|
| 7545 | list_names(121) = "GHAASBasin178" |
|---|
| 7546 | list_names(122) = "GHAASBasin148" |
|---|
| 7547 | list_names(123) = "Brazos (Tex)" |
|---|
| 7548 | list_names(124) = "GHAASBasin124" |
|---|
| 7549 | list_names(125) = "Alabama" |
|---|
| 7550 | list_names(126) = "GHAASBasin174" |
|---|
| 7551 | list_names(127) = "GHAASBasin179" |
|---|
| 7552 | list_names(128) = "Balsas" |
|---|
| 7553 | list_names(129) = "GHAASBasin172" |
|---|
| 7554 | list_names(130) = "Burdekin" |
|---|
| 7555 | list_names(131) = "Colorado (Texas)" |
|---|
| 7556 | list_names(132) = "GHAASBasin150" |
|---|
| 7557 | list_names(133) = "Odra" |
|---|
| 7558 | list_names(134) = "Loire" |
|---|
| 7559 | list_names(135) = "GHAASBasin98" |
|---|
| 7560 | list_names(136) = "Galana" |
|---|
| 7561 | list_names(137) = "Kuskowin" |
|---|
| 7562 | list_names(138) = "Moose" |
|---|
| 7563 | list_names(139) = "Narmada" |
|---|
| 7564 | list_names(140) = "GHAASBasin140" |
|---|
| 7565 | list_names(141) = "GHAASBasin141" |
|---|
| 7566 | list_names(142) = "Flinders" |
|---|
| 7567 | list_names(143) = "Kizil Irmak" |
|---|
| 7568 | list_names(144) = "GHAASBasin144" |
|---|
| 7569 | list_names(145) = "Save" |
|---|
| 7570 | list_names(146) = "Roper" |
|---|
| 7571 | list_names(147) = "Churchill (Atlantic)" |
|---|
| 7572 | list_names(148) = "GHAASBasin148" |
|---|
| 7573 | list_names(149) = "Victoria" |
|---|
| 7574 | list_names(150) = "Back" |
|---|
| 7575 | list_names(151) = "Bandama" |
|---|
| 7576 | list_names(152) = "Severn (Can)" |
|---|
| 7577 | list_names(153) = "Po" |
|---|
| 7578 | list_names(154) = "GHAASBasin154" |
|---|
| 7579 | list_names(155) = "GHAASBasin155" |
|---|
| 7580 | list_names(156) = "GHAASBasin156" |
|---|
| 7581 | list_names(157) = "Rhone" |
|---|
| 7582 | list_names(158) = "Tana (Ken)" |
|---|
| 7583 | list_names(159) = "La Grande" |
|---|
| 7584 | list_names(160) = "GHAASBasin160" |
|---|
| 7585 | list_names(161) = "Cunene" |
|---|
| 7586 | list_names(162) = "Douro" |
|---|
| 7587 | list_names(163) = "GHAASBasin163" |
|---|
| 7588 | list_names(164) = "Nemanus" |
|---|
| 7589 | list_names(165) = "GHAASBasin165" |
|---|
| 7590 | list_names(166) = "Anabar" |
|---|
| 7591 | list_names(167) = "Hayes" |
|---|
| 7592 | list_names(168) = "Mearim" |
|---|
| 7593 | list_names(169) = "GHAASBasin169" |
|---|
| 7594 | list_names(170) = "Panuco" |
|---|
| 7595 | list_names(171) = "GHAASBasin171" |
|---|
| 7596 | list_names(172) = "Doce" |
|---|
| 7597 | list_names(173) = "Gasgoyne" |
|---|
| 7598 | list_names(174) = "GHAASBasin174" |
|---|
| 7599 | list_names(175) = "GHAASBasin175" |
|---|
| 7600 | list_names(176) = "Ashburton" |
|---|
| 7601 | list_names(177) = "GHAASBasin177" |
|---|
| 7602 | list_names(178) = "Peel" |
|---|
| 7603 | list_names(179) = "Daugava" |
|---|
| 7604 | list_names(180) = "GHAASBasin180" |
|---|
| 7605 | list_names(181) = "Ebro" |
|---|
| 7606 | list_names(182) = "Comoe" |
|---|
| 7607 | list_names(183) = "Jacui" |
|---|
| 7608 | list_names(184) = "GHAASBasin184" |
|---|
| 7609 | list_names(185) = "Kapuas" |
|---|
| 7610 | list_names(186) = "GHAASBasin186" |
|---|
| 7611 | list_names(187) = "Penzhina" |
|---|
| 7612 | list_names(188) = "Cauweri" |
|---|
| 7613 | list_names(189) = "GHAASBasin189" |
|---|
| 7614 | list_names(190) = "Mamberamo" |
|---|
| 7615 | list_names(191) = "Sepik" |
|---|
| 7616 | list_names(192) = "GHAASBasin192" |
|---|
| 7617 | list_names(193) = "Sassandra" |
|---|
| 7618 | list_names(194) = "GHAASBasin194" |
|---|
| 7619 | list_names(195) = "GHAASBasin195" |
|---|
| 7620 | list_names(196) = "Nottaway" |
|---|
| 7621 | list_names(197) = "Barito" |
|---|
| 7622 | list_names(198) = "GHAASBasin198" |
|---|
| 7623 | list_names(199) = "Seine" |
|---|
| 7624 | list_names(200) = "Tejo" |
|---|
| 7625 | list_names(201) = "GHAASBasin201" |
|---|
| 7626 | list_names(202) = "Gambia" |
|---|
| 7627 | list_names(203) = "Susquehanna" |
|---|
| 7628 | list_names(204) = "Dnestr" |
|---|
| 7629 | list_names(205) = "Murchinson" |
|---|
| 7630 | list_names(206) = "Deseado" |
|---|
| 7631 | list_names(207) = "Mitchell" |
|---|
| 7632 | list_names(208) = "Mahakam" |
|---|
| 7633 | list_names(209) = "GHAASBasin209" |
|---|
| 7634 | list_names(210) = "Pangani" |
|---|
| 7635 | list_names(211) = "GHAASBasin211" |
|---|
| 7636 | list_names(212) = "GHAASBasin212" |
|---|
| 7637 | list_names(213) = "GHAASBasin213" |
|---|
| 7638 | list_names(214) = "GHAASBasin214" |
|---|
| 7639 | list_names(215) = "GHAASBasin215" |
|---|
| 7640 | list_names(216) = "Bug" |
|---|
| 7641 | list_names(217) = "GHAASBasin217" |
|---|
| 7642 | list_names(218) = "Usumacinta" |
|---|
| 7643 | list_names(219) = "Jequitinhonha" |
|---|
| 7644 | list_names(220) = "GHAASBasin220" |
|---|
| 7645 | list_names(221) = "Corantijn" |
|---|
| 7646 | list_names(222) = "Fuchun Jiang" |
|---|
| 7647 | list_names(223) = "Copper" |
|---|
| 7648 | list_names(224) = "Tapti" |
|---|
| 7649 | list_names(225) = "Menjiang" |
|---|
| 7650 | list_names(226) = "Karun" |
|---|
| 7651 | list_names(227) = "Mezen" |
|---|
| 7652 | list_names(228) = "Guadiana" |
|---|
| 7653 | list_names(229) = "Maroni" |
|---|
| 7654 | list_names(230) = "GHAASBasin230" |
|---|
| 7655 | list_names(231) = "Uda" |
|---|
| 7656 | list_names(232) = "GHAASBasin232" |
|---|
| 7657 | list_names(233) = "Kuban" |
|---|
| 7658 | list_names(234) = "Colville" |
|---|
| 7659 | list_names(235) = "Thaane" |
|---|
| 7660 | list_names(236) = "Alazeya" |
|---|
| 7661 | list_names(237) = "Paraiba do Sul" |
|---|
| 7662 | list_names(238) = "GHAASBasin238" |
|---|
| 7663 | list_names(239) = "Fortesque" |
|---|
| 7664 | list_names(240) = "GHAASBasin240" |
|---|
| 7665 | list_names(241) = "GHAASBasin241" |
|---|
| 7666 | list_names(242) = "Winisk" |
|---|
| 7667 | list_names(243) = "GHAASBasin243" |
|---|
| 7668 | list_names(244) = "GHAASBasin244" |
|---|
| 7669 | list_names(245) = "Ikopa" |
|---|
| 7670 | list_names(246) = "Gilbert" |
|---|
| 7671 | list_names(247) = "Kouilou" |
|---|
| 7672 | list_names(248) = "Fly" |
|---|
| 7673 | list_names(249) = "GHAASBasin249" |
|---|
| 7674 | list_names(250) = "GHAASBasin250" |
|---|
| 7675 | list_names(251) = "GHAASBasin251" |
|---|
| 7676 | list_names(252) = "Mangoky" |
|---|
| 7677 | list_names(253) = "Damodar" |
|---|
| 7678 | list_names(254) = "Onega" |
|---|
| 7679 | list_names(255) = "Moulouya" |
|---|
| 7680 | list_names(256) = "GHAASBasin256" |
|---|
| 7681 | list_names(257) = "Ord" |
|---|
| 7682 | list_names(258) = "GHAASBasin258" |
|---|
| 7683 | list_names(259) = "GHAASBasin259" |
|---|
| 7684 | list_names(260) = "GHAASBasin260" |
|---|
| 7685 | list_names(261) = "GHAASBasin261" |
|---|
| 7686 | list_names(262) = "Narva" |
|---|
| 7687 | list_names(263) = "GHAASBasin263" |
|---|
| 7688 | list_names(264) = "Seal" |
|---|
| 7689 | list_names(265) = "Cheliff" |
|---|
| 7690 | list_names(266) = "Garonne" |
|---|
| 7691 | list_names(267) = "Rupert" |
|---|
| 7692 | list_names(268) = "GHAASBasin268" |
|---|
| 7693 | list_names(269) = "Brahmani" |
|---|
| 7694 | list_names(270) = "Sakarya" |
|---|
| 7695 | list_names(271) = "Gourits" |
|---|
| 7696 | list_names(272) = "Sittang" |
|---|
| 7697 | list_names(273) = "Rajang" |
|---|
| 7698 | list_names(274) = "Evros" |
|---|
| 7699 | list_names(275) = "Appalachicola" |
|---|
| 7700 | list_names(276) = "Attawapiskat" |
|---|
| 7701 | list_names(277) = "Lurio" |
|---|
| 7702 | list_names(278) = "Daly" |
|---|
| 7703 | list_names(279) = "Penner" |
|---|
| 7704 | list_names(280) = "GHAASBasin280" |
|---|
| 7705 | list_names(281) = "GHAASBasin281" |
|---|
| 7706 | list_names(282) = "Guadalquivir" |
|---|
| 7707 | list_names(283) = "Nadym" |
|---|
| 7708 | list_names(284) = "GHAASBasin284" |
|---|
| 7709 | list_names(285) = "Saint John" |
|---|
| 7710 | list_names(286) = "GHAASBasin286" |
|---|
| 7711 | list_names(287) = "Cross" |
|---|
| 7712 | list_names(288) = "Omoloy" |
|---|
| 7713 | list_names(289) = "Oueme" |
|---|
| 7714 | list_names(290) = "GHAASBasin290" |
|---|
| 7715 | list_names(291) = "Gota" |
|---|
| 7716 | list_names(292) = "Nueces" |
|---|
| 7717 | list_names(293) = "Stikine" |
|---|
| 7718 | list_names(294) = "Yalu" |
|---|
| 7719 | list_names(295) = "Arnaud" |
|---|
| 7720 | list_names(296) = "GHAASBasin296" |
|---|
| 7721 | list_names(297) = "Jequitinhonha" |
|---|
| 7722 | list_names(298) = "Kamchatka" |
|---|
| 7723 | list_names(299) = "GHAASBasin299" |
|---|
| 7724 | list_names(300) = "Grijalva" |
|---|
| 7725 | list_names(301) = "GHAASBasin301" |
|---|
| 7726 | list_names(302) = "Kemijoki" |
|---|
| 7727 | list_names(303) = "Olifants" |
|---|
| 7728 | list_names(304) = "GHAASBasin304" |
|---|
| 7729 | list_names(305) = "Tsiribihina" |
|---|
| 7730 | list_names(306) = "Coppermine" |
|---|
| 7731 | list_names(307) = "GHAASBasin307" |
|---|
| 7732 | list_names(308) = "GHAASBasin308" |
|---|
| 7733 | list_names(309) = "Kovda" |
|---|
| 7734 | list_names(310) = "Trinity" |
|---|
| 7735 | list_names(311) = "Glama" |
|---|
| 7736 | list_names(312) = "GHAASBasin312" |
|---|
| 7737 | list_names(313) = "Luan" |
|---|
| 7738 | list_names(314) = "Leichhardt" |
|---|
| 7739 | list_names(315) = "GHAASBasin315" |
|---|
| 7740 | list_names(316) = "Gurupi" |
|---|
| 7741 | list_names(317) = "GR Baleine" |
|---|
| 7742 | list_names(318) = "Aux Feuilles" |
|---|
| 7743 | list_names(319) = "GHAASBasin319" |
|---|
| 7744 | list_names(320) = "Weser" |
|---|
| 7745 | list_names(321) = "GHAASBasin321" |
|---|
| 7746 | list_names(322) = "GHAASBasin322" |
|---|
| 7747 | list_names(323) = "Yesil" |
|---|
| 7748 | list_names(324) = "Incomati" |
|---|
| 7749 | list_names(325) = "GHAASBasin325" |
|---|
| 7750 | list_names(326) = "GHAASBasin326" |
|---|
| 7751 | list_names(327) = "Pungoe" |
|---|
| 7752 | list_names(328) = "GHAASBasin328" |
|---|
| 7753 | list_names(329) = "Meuse" |
|---|
| 7754 | list_names(330) = "Eastmain" |
|---|
| 7755 | list_names(331) = "Araguari" |
|---|
| 7756 | list_names(332) = "Hudson" |
|---|
| 7757 | list_names(333) = "GHAASBasin333" |
|---|
| 7758 | list_names(334) = "GHAASBasin334" |
|---|
| 7759 | list_names(335) = "GHAASBasin335" |
|---|
| 7760 | list_names(336) = "GHAASBasin336" |
|---|
| 7761 | list_names(337) = "Kobuk" |
|---|
| 7762 | list_names(338) = "Altamaha" |
|---|
| 7763 | list_names(339) = "GHAASBasin339" |
|---|
| 7764 | list_names(340) = "Mand" |
|---|
| 7765 | list_names(341) = "Santee" |
|---|
| 7766 | list_names(342) = "GHAASBasin342" |
|---|
| 7767 | list_names(343) = "GHAASBasin343" |
|---|
| 7768 | list_names(344) = "GHAASBasin344" |
|---|
| 7769 | list_names(345) = "Hari" |
|---|
| 7770 | list_names(346) = "GHAASBasin346" |
|---|
| 7771 | list_names(347) = "Wami" |
|---|
| 7772 | list_names(348) = "GHAASBasin348" |
|---|
| 7773 | list_names(349) = "GHAASBasin349" |
|---|
| 7774 | ! |
|---|
| 7775 | basin_names(:) = ' ' |
|---|
| 7776 | ! |
|---|
| 7777 | DO i=1,numlar |
|---|
| 7778 | tmp_str = list_names(i) |
|---|
| 7779 | basin_names(i) = tmp_str(1:MIN(lenstr,LEN_TRIM(tmp_str))) |
|---|
| 7780 | ENDDO |
|---|
| 7781 | ! |
|---|
| 7782 | END SUBROUTINE routing_names |
|---|
| 7783 | ! |
|---|
| 7784 | !! ================================================================================================================================ |
|---|
| 7785 | !! SUBROUTINE : routing_irrigmap |
|---|
| 7786 | !! |
|---|
| 7787 | !>\BRIEF This subroutine interpolates the 0.5x0.5 degree based map of irrigated areas to the resolution of the model. |
|---|
| 7788 | !! |
|---|
| 7789 | !! DESCRIPTION (definitions, functional, design, flags) : None |
|---|
| 7790 | !! |
|---|
| 7791 | !! RECENT CHANGE(S): None |
|---|
| 7792 | !! |
|---|
| 7793 | !! MAIN OUTPUT VARIABLE(S): |
|---|
| 7794 | !! |
|---|
| 7795 | !! REFERENCES : None |
|---|
| 7796 | !! |
|---|
| 7797 | !! FLOWCHART : None |
|---|
| 7798 | !! \n |
|---|
| 7799 | !_ ================================================================================================================================ |
|---|
| 7800 | |
|---|
| 7801 | SUBROUTINE routing_irrigmap (nbpt, index, lalo, neighbours, resolution, contfrac, & |
|---|
| 7802 | & init_irrig, irrigated, init_flood, floodplains, init_swamp, swamp, hist_id, hist2_id) |
|---|
| 7803 | ! |
|---|
| 7804 | IMPLICIT NONE |
|---|
| 7805 | ! |
|---|
| 7806 | !! PARAMETERS |
|---|
| 7807 | INTEGER(i_std), PARAMETER :: ilake = 1 !! Number of type of lakes area (unitless) |
|---|
| 7808 | INTEGER(i_std), PARAMETER :: idam = 2 !! Number of type of dams area (unitless) |
|---|
| 7809 | INTEGER(i_std), PARAMETER :: iflood = 3 !! Number of type of floodplains area (unitless) |
|---|
| 7810 | INTEGER(i_std), PARAMETER :: iswamp = 4 !! Number of type of swamps area (unitless) |
|---|
| 7811 | INTEGER(i_std), PARAMETER :: isal = 5 !! Number of type of salines area (unitless) |
|---|
| 7812 | INTEGER(i_std), PARAMETER :: ipond = 6 !! Number of type of ponds area (unitless) |
|---|
| 7813 | INTEGER(i_std), PARAMETER :: ntype = 6 !! Number of types of flooded surfaces (unitless) |
|---|
| 7814 | |
|---|
| 7815 | !! INPUT VARIABLES |
|---|
| 7816 | INTEGER(i_std), INTENT(in) :: nbpt !! Domain size (unitless) |
|---|
| 7817 | INTEGER(i_std), INTENT(in) :: index(nbpt) !! Index on the global map. |
|---|
| 7818 | REAL(r_std), INTENT(in) :: lalo(nbpt,2) !! Vector of latitude and longitudes (beware of the order !) |
|---|
| 7819 | INTEGER(i_std), INTENT(in) :: neighbours(nbpt,NbNeighb)!! Vector of neighbours for each grid point |
|---|
| 7820 | REAL(r_std), INTENT(in) :: resolution(nbpt,2) !! The size of each grid box in X and Y (m) |
|---|
| 7821 | REAL(r_std), INTENT(in) :: contfrac(nbpt) !! Fraction of land in each grid box (unitless;0-1) |
|---|
| 7822 | INTEGER(i_std), INTENT(in) :: hist_id !! Access to history file (unitless) |
|---|
| 7823 | INTEGER(i_std), INTENT(in) :: hist2_id !! Access to history file 2 (unitless) |
|---|
| 7824 | LOGICAL, INTENT(in) :: init_irrig !! Logical to initialize the irrigation (true/false) |
|---|
| 7825 | LOGICAL, INTENT(in) :: init_flood !! Logical to initialize the floodplains (true/false) |
|---|
| 7826 | LOGICAL, INTENT(in) :: init_swamp !! Logical to initialize the swamps (true/false) |
|---|
| 7827 | ! |
|---|
| 7828 | !! OUTPUT VARIABLES |
|---|
| 7829 | REAL(r_std), INTENT(out) :: irrigated(:) !! Irrigated surface in each grid box (m^2) |
|---|
| 7830 | REAL(r_std), INTENT(out) :: floodplains(:) !! Surface which can be inundated in each grid box (m^2) |
|---|
| 7831 | REAL(r_std), INTENT(out) :: swamp(:) !! Surface which can be swamp in each grid box (m^2) |
|---|
| 7832 | ! |
|---|
| 7833 | !! LOCAL VARIABLES |
|---|
| 7834 | ! Interpolation variables |
|---|
| 7835 | ! |
|---|
| 7836 | INTEGER(i_std) :: nbpmax, nix, njx, fopt !! |
|---|
| 7837 | CHARACTER(LEN=30) :: callsign !! |
|---|
| 7838 | REAL(r_std), ALLOCATABLE, DIMENSION(:,:,:) :: resol_lu !! Resolution read on the map |
|---|
| 7839 | INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:) :: mask !! Mask to exclude some points (unitless) |
|---|
| 7840 | REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: irrsub_area !! Area on the fine grid (m^2) |
|---|
| 7841 | INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:,:) :: irrsub_index !! Indices of the points we need on the fine grid (unitless) |
|---|
| 7842 | INTEGER :: ALLOC_ERR !! |
|---|
| 7843 | LOGICAL :: ok_interpol = .FALSE. !! Flag for interpolation (true/false) |
|---|
| 7844 | ! |
|---|
| 7845 | CHARACTER(LEN=80) :: filename !! Name of the netcdf file (unitless) |
|---|
| 7846 | INTEGER(i_std) :: iml, jml, lml, tml, fid, ib, ip, jp, itype !! Indices (unitless) |
|---|
| 7847 | REAL(r_std) :: lev(1), date, dt, coslat !! |
|---|
| 7848 | INTEGER(i_std) :: itau(1) !! |
|---|
| 7849 | REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: latrel !! Latitude |
|---|
| 7850 | REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: lonrel !! Longitude |
|---|
| 7851 | REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: irrigated_frac !! Irrigated fraction of the grid box (unitless;0-1) |
|---|
| 7852 | REAL(r_std), ALLOCATABLE, DIMENSION(:,:,:) :: flood_fracmax !! Maximal flooded fraction of the grid box (unitless;0-1) |
|---|
| 7853 | REAL(r_std) :: area_irrig !! Irrigated surface in the grid box (m^2) |
|---|
| 7854 | REAL(r_std) :: area_flood(ntype) !! Flooded surface in the grid box (m^2) |
|---|
| 7855 | !!$ REAL(r_std) :: irrigmap(nbpt) |
|---|
| 7856 | !!$ REAL(r_std) :: floodmap(nbpt) |
|---|
| 7857 | !!$ REAL(r_std) :: swampmap(nbpt) |
|---|
| 7858 | |
|---|
| 7859 | !_ ================================================================================================================================ |
|---|
| 7860 | |
|---|
| 7861 | nix = 0 |
|---|
| 7862 | njx = 0 |
|---|
| 7863 | ! |
|---|
| 7864 | !Config Key = IRRIGATION_FILE |
|---|
| 7865 | !Config Desc = Name of file which contains the map of irrigated areas |
|---|
| 7866 | !Config Def = floodplains.nc |
|---|
| 7867 | !Config If = DO_IRRIGATION OR DO_FLOODPLAINS |
|---|
| 7868 | !Config Help = The name of the file to be opened to read the field |
|---|
| 7869 | !Config with the area in m^2 of the area irrigated within each |
|---|
| 7870 | !Config 0.5 0.5 deg grid box. The map currently used is the one |
|---|
| 7871 | !Config developed by the Center for Environmental Systems Research |
|---|
| 7872 | !Config in Kassel (1995). |
|---|
| 7873 | !Config Units = [FILE] |
|---|
| 7874 | ! |
|---|
| 7875 | filename = 'floodplains.nc' |
|---|
| 7876 | CALL getin_p('IRRIGATION_FILE',filename) |
|---|
| 7877 | ! |
|---|
| 7878 | IF (is_root_prc) THEN |
|---|
| 7879 | CALL flininfo(filename,iml, jml, lml, tml, fid) |
|---|
| 7880 | CALL flinclo(fid) |
|---|
| 7881 | ELSE |
|---|
| 7882 | iml = 0 |
|---|
| 7883 | jml = 0 |
|---|
| 7884 | lml = 0 |
|---|
| 7885 | tml = 0 |
|---|
| 7886 | ENDIF |
|---|
| 7887 | ! |
|---|
| 7888 | CALL bcast(iml) |
|---|
| 7889 | CALL bcast(jml) |
|---|
| 7890 | CALL bcast(lml) |
|---|
| 7891 | CALL bcast(tml) |
|---|
| 7892 | ! |
|---|
| 7893 | ! |
|---|
| 7894 | ! |
|---|
| 7895 | ALLOCATE (latrel(iml,jml), STAT=ALLOC_ERR) |
|---|
| 7896 | IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_irrigmap','Pb in allocate for latrel','','') |
|---|
| 7897 | |
|---|
| 7898 | ALLOCATE (lonrel(iml,jml), STAT=ALLOC_ERR) |
|---|
| 7899 | IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_irrigmap','Pb in allocate for lonrel','','') |
|---|
| 7900 | |
|---|
| 7901 | ALLOCATE (irrigated_frac(iml,jml), STAT=ALLOC_ERR) |
|---|
| 7902 | IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_irrigmap','Pb in allocate for irrigated_frac','','') |
|---|
| 7903 | |
|---|
| 7904 | ALLOCATE (flood_fracmax(iml,jml,ntype), STAT=ALLOC_ERR) |
|---|
| 7905 | IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_irrigmap','Pb in allocate for flood_fracmax','','') |
|---|
| 7906 | |
|---|
| 7907 | IF (is_root_prc) CALL flinopen(filename, .FALSE., iml, jml, lml, lonrel, latrel, lev, tml, itau, date, dt, fid) |
|---|
| 7908 | |
|---|
| 7909 | CALL bcast(lonrel) |
|---|
| 7910 | CALL bcast(latrel) |
|---|
| 7911 | ! |
|---|
| 7912 | IF (is_root_prc) CALL flinget(fid, 'irrig', iml, jml, lml, tml, 1, 1, irrigated_frac) |
|---|
| 7913 | CALL bcast(irrigated_frac) |
|---|
| 7914 | IF (is_root_prc) CALL flinget(fid, 'lake', iml, jml, lml, tml, 1, 1, flood_fracmax(:,:,ilake)) |
|---|
| 7915 | IF (is_root_prc) CALL flinget(fid, 'dam', iml, jml, lml, tml, 1, 1, flood_fracmax(:,:,idam)) |
|---|
| 7916 | IF (is_root_prc) CALL flinget(fid, 'flood', iml, jml, lml, tml, 1, 1, flood_fracmax(:,:,iflood)) |
|---|
| 7917 | IF (is_root_prc) CALL flinget(fid, 'swamp', iml, jml, lml, tml, 1, 1, flood_fracmax(:,:,iswamp)) |
|---|
| 7918 | IF (is_root_prc) CALL flinget(fid, 'saline', iml, jml, lml, tml, 1, 1, flood_fracmax(:,:,isal)) |
|---|
| 7919 | CALL bcast(flood_fracmax) |
|---|
| 7920 | ! |
|---|
| 7921 | IF (is_root_prc) CALL flinclo(fid) |
|---|
| 7922 | ! |
|---|
| 7923 | ! Set to zero all fraction which are less than 0.5% |
|---|
| 7924 | ! |
|---|
| 7925 | DO ip=1,iml |
|---|
| 7926 | DO jp=1,jml |
|---|
| 7927 | ! |
|---|
| 7928 | IF ( irrigated_frac(ip,jp) .LT. undef_sechiba-un) THEN |
|---|
| 7929 | irrigated_frac(ip,jp) = irrigated_frac(ip,jp)/100. |
|---|
| 7930 | IF ( irrigated_frac(ip,jp) < 0.005 ) irrigated_frac(ip,jp) = zero |
|---|
| 7931 | ENDIF |
|---|
| 7932 | ! |
|---|
| 7933 | DO itype=1,ntype |
|---|
| 7934 | IF ( flood_fracmax(ip,jp,itype) .LT. undef_sechiba-1.) THEN |
|---|
| 7935 | flood_fracmax(ip,jp,itype) = flood_fracmax(ip,jp,itype)/100 |
|---|
| 7936 | IF ( flood_fracmax(ip,jp,itype) < 0.005 ) flood_fracmax(ip,jp,itype) = zero |
|---|
| 7937 | ENDIF |
|---|
| 7938 | ENDDO |
|---|
| 7939 | ! |
|---|
| 7940 | ENDDO |
|---|
| 7941 | ENDDO |
|---|
| 7942 | |
|---|
| 7943 | IF (printlev>=2) THEN |
|---|
| 7944 | WRITE(numout,*) 'lonrel : ', MAXVAL(lonrel), MINVAL(lonrel) |
|---|
| 7945 | WRITE(numout,*) 'latrel : ', MAXVAL(latrel), MINVAL(latrel) |
|---|
| 7946 | WRITE(numout,*) 'irrigated_frac : ', MINVAL(irrigated_frac, MASK=irrigated_frac .GT. 0), & |
|---|
| 7947 | MAXVAL(irrigated_frac, MASK=irrigated_frac .LT. undef_sechiba) |
|---|
| 7948 | WRITE(numout,*) 'flood_fracmax : ', MINVAL(flood_fracmax, MASK=flood_fracmax .GT. 0), & |
|---|
| 7949 | MAXVAL(flood_fracmax, MASK=flood_fracmax .LT. undef_sechiba) |
|---|
| 7950 | END IF |
|---|
| 7951 | |
|---|
| 7952 | ! Consider all points a priori |
|---|
| 7953 | ! |
|---|
| 7954 | ALLOCATE(resol_lu(iml,jml,2), STAT=ALLOC_ERR) |
|---|
| 7955 | IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_irrigmap','Pb in allocate for resol_lu','','') |
|---|
| 7956 | |
|---|
| 7957 | ALLOCATE(mask(iml,jml), STAT=ALLOC_ERR) |
|---|
| 7958 | IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_irrigmap','Pb in allocate for mask','','') |
|---|
| 7959 | mask(:,:) = 0 |
|---|
| 7960 | |
|---|
| 7961 | DO ip=1,iml |
|---|
| 7962 | DO jp=1,jml |
|---|
| 7963 | ! |
|---|
| 7964 | ! Exclude the points where we are close to the missing value. |
|---|
| 7965 | ! |
|---|
| 7966 | !MG This condition cannot be applied in floodplains/swamps configuration because |
|---|
| 7967 | ! the same mask would be used for the interpolation of irrigation, floodplains and swamps maps. |
|---|
| 7968 | ! IF ( irrigated_frac(ip,jp) < undef_sechiba ) THEN |
|---|
| 7969 | mask(ip,jp) = 1 |
|---|
| 7970 | ! ENDIF |
|---|
| 7971 | ! |
|---|
| 7972 | ! Resolution in longitude |
|---|
| 7973 | ! |
|---|
| 7974 | coslat = MAX( COS( latrel(ip,jp) * pi/180. ), mincos ) |
|---|
| 7975 | IF ( ip .EQ. 1 ) THEN |
|---|
| 7976 | resol_lu(ip,jp,1) = ABS( lonrel(ip+1,jp) - lonrel(ip,jp) ) * pi/180. * R_Earth * coslat |
|---|
| 7977 | ELSEIF ( ip .EQ. iml ) THEN |
|---|
| 7978 | resol_lu(ip,jp,1) = ABS( lonrel(ip,jp) - lonrel(ip-1,jp) ) * pi/180. * R_Earth * coslat |
|---|
| 7979 | ELSE |
|---|
| 7980 | resol_lu(ip,jp,1) = ABS( lonrel(ip+1,jp) - lonrel(ip-1,jp) )/2. * pi/180. * R_Earth * coslat |
|---|
| 7981 | ENDIF |
|---|
| 7982 | ! |
|---|
| 7983 | ! Resolution in latitude |
|---|
| 7984 | ! |
|---|
| 7985 | IF ( jp .EQ. 1 ) THEN |
|---|
| 7986 | resol_lu(ip,jp,2) = ABS( latrel(ip,jp) - latrel(ip,jp+1) ) * pi/180. * R_Earth |
|---|
| 7987 | ELSEIF ( jp .EQ. jml ) THEN |
|---|
| 7988 | resol_lu(ip,jp,2) = ABS( latrel(ip,jp-1) - latrel(ip,jp) ) * pi/180. * R_Earth |
|---|
| 7989 | ELSE |
|---|
| 7990 | resol_lu(ip,jp,2) = ABS( latrel(ip,jp-1) - latrel(ip,jp+1) )/2. * pi/180. * R_Earth |
|---|
| 7991 | ENDIF |
|---|
| 7992 | ! |
|---|
| 7993 | ENDDO |
|---|
| 7994 | ENDDO |
|---|
| 7995 | ! |
|---|
| 7996 | ! The number of maximum vegetation map points in the GCM grid is estimated. |
|---|
| 7997 | ! Some lmargin is taken. |
|---|
| 7998 | ! |
|---|
| 7999 | callsign = 'Irrigation map' |
|---|
| 8000 | ok_interpol = .FALSE. |
|---|
| 8001 | IF (is_root_prc) THEN |
|---|
| 8002 | nix=INT(MAXVAL(resolution_g(:,1))/MAXVAL(resol_lu(:,:,1)))+2 |
|---|
| 8003 | njx=INT(MAXVAL(resolution_g(:,2))/MAXVAL(resol_lu(:,:,2)))+2 |
|---|
| 8004 | nbpmax = nix*njx*2 |
|---|
| 8005 | IF (printlev>=1) THEN |
|---|
| 8006 | WRITE(numout,*) "Projection arrays for ",callsign," : " |
|---|
| 8007 | WRITE(numout,*) "nbpmax = ",nbpmax, nix, njx |
|---|
| 8008 | END IF |
|---|
| 8009 | ENDIF |
|---|
| 8010 | CALL bcast(nbpmax) |
|---|
| 8011 | |
|---|
| 8012 | ALLOCATE(irrsub_index(nbpt, nbpmax, 2), STAT=ALLOC_ERR) |
|---|
| 8013 | IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_irrigmap','Pb in allocate for irrsub_index','','') |
|---|
| 8014 | irrsub_index(:,:,:)=0 |
|---|
| 8015 | |
|---|
| 8016 | ALLOCATE(irrsub_area(nbpt, nbpmax), STAT=ALLOC_ERR) |
|---|
| 8017 | IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_irrigmap','Pb in allocate for irrsub_area','','') |
|---|
| 8018 | irrsub_area(:,:)=zero |
|---|
| 8019 | |
|---|
| 8020 | CALL aggregate_p(nbpt, lalo, neighbours, resolution, contfrac, & |
|---|
| 8021 | & iml, jml, lonrel, latrel, mask, callsign, & |
|---|
| 8022 | & nbpmax, irrsub_index, irrsub_area, ok_interpol) |
|---|
| 8023 | ! |
|---|
| 8024 | ! |
|---|
| 8025 | WHERE (irrsub_area < 0) irrsub_area=zero |
|---|
| 8026 | ! |
|---|
| 8027 | ! Test here if not all sub_area are larger than 0 if so, then we need to increase nbpmax |
|---|
| 8028 | ! |
|---|
| 8029 | DO ib=1,nbpt |
|---|
| 8030 | ! |
|---|
| 8031 | area_irrig = 0.0 |
|---|
| 8032 | area_flood = 0.0 |
|---|
| 8033 | ! |
|---|
| 8034 | DO fopt=1,COUNT(irrsub_area(ib,:) > zero) |
|---|
| 8035 | ! |
|---|
| 8036 | ip = irrsub_index(ib, fopt, 1) |
|---|
| 8037 | jp = irrsub_index(ib, fopt, 2) |
|---|
| 8038 | ! |
|---|
| 8039 | IF (irrigated_frac(ip,jp) .LT. undef_sechiba-1.) THEN |
|---|
| 8040 | area_irrig = area_irrig + irrsub_area(ib,fopt)*irrigated_frac(ip,jp) |
|---|
| 8041 | ENDIF |
|---|
| 8042 | ! |
|---|
| 8043 | DO itype=1,ntype |
|---|
| 8044 | IF (flood_fracmax(ip,jp,itype) .LT. undef_sechiba-1.) THEN |
|---|
| 8045 | area_flood(itype) = area_flood(itype) + irrsub_area(ib,fopt)*flood_fracmax(ip,jp,itype) |
|---|
| 8046 | ENDIF |
|---|
| 8047 | ENDDO |
|---|
| 8048 | ENDDO |
|---|
| 8049 | ! |
|---|
| 8050 | ! Put the total irrigated and flooded areas in the output variables |
|---|
| 8051 | ! |
|---|
| 8052 | IF ( init_irrig ) THEN |
|---|
| 8053 | irrigated(ib) = MIN(area_irrig, resolution(ib,1)*resolution(ib,2)*contfrac(ib)) |
|---|
| 8054 | IF ( irrigated(ib) < 0 ) THEN |
|---|
| 8055 | WRITE(numout,*) 'We have a problem here : ', irrigated(ib) |
|---|
| 8056 | WRITE(numout,*) 'resolution :', resolution(ib,1), resolution(ib,2) |
|---|
| 8057 | WRITE(numout,*) area_irrig |
|---|
| 8058 | CALL ipslerr_p(3,'routing_irrigmap','Problem with irrigated...','','') |
|---|
| 8059 | ENDIF |
|---|
| 8060 | !!$ ! Compute a diagnostic of the map. |
|---|
| 8061 | !!$ IF(contfrac(ib).GT.zero) THEN |
|---|
| 8062 | !!$ irrigmap (ib) = irrigated(ib) / ( resolution(ib,1)*resolution(ib,2)*contfrac(ib) ) |
|---|
| 8063 | !!$ ELSE |
|---|
| 8064 | !!$ irrigmap (ib) = zero |
|---|
| 8065 | !!$ ENDIF |
|---|
| 8066 | ! |
|---|
| 8067 | ENDIF |
|---|
| 8068 | ! |
|---|
| 8069 | IF ( init_flood ) THEN |
|---|
| 8070 | floodplains(ib) = MIN(area_flood(iflood)+area_flood(idam)+area_flood(isal), & |
|---|
| 8071 | & resolution(ib,1)*resolution(ib,2)*contfrac(ib)) |
|---|
| 8072 | IF ( floodplains(ib) < 0 ) THEN |
|---|
| 8073 | WRITE(numout,*) 'We have a problem here : ', floodplains(ib) |
|---|
| 8074 | WRITE(numout,*) 'resolution :', resolution(ib,1), resolution(ib,2) |
|---|
| 8075 | WRITE(numout,*) area_flood |
|---|
| 8076 | CALL ipslerr_p(3,'routing_irrigmap','Problem with floodplains..','','') |
|---|
| 8077 | ENDIF |
|---|
| 8078 | !!$ ! Compute a diagnostic of the map. |
|---|
| 8079 | !!$ IF(contfrac(ib).GT.zero) THEN |
|---|
| 8080 | !!$ floodmap(ib) = floodplains(ib) / ( resolution(ib,1)*resolution(ib,2)*contfrac(ib) ) |
|---|
| 8081 | !!$ ELSE |
|---|
| 8082 | !!$ floodmap(ib) = 0.0 |
|---|
| 8083 | !!$ ENDIF |
|---|
| 8084 | ENDIF |
|---|
| 8085 | ! |
|---|
| 8086 | IF ( init_swamp ) THEN |
|---|
| 8087 | swamp(ib) = MIN(area_flood(iswamp), resolution(ib,1)*resolution(ib,2)*contfrac(ib)) |
|---|
| 8088 | IF ( swamp(ib) < 0 ) THEN |
|---|
| 8089 | WRITE(numout,*) 'We have a problem here : ', swamp(ib) |
|---|
| 8090 | WRITE(numout,*) 'resolution :', resolution(ib,1), resolution(ib,2) |
|---|
| 8091 | WRITE(numout,*) area_flood |
|---|
| 8092 | CALL ipslerr_p(3,'routing_irrigmap','Problem with swamp...','','') |
|---|
| 8093 | ENDIF |
|---|
| 8094 | !!$ ! Compute a diagnostic of the map. |
|---|
| 8095 | !!$ IF(contfrac(ib).GT.zero) THEN |
|---|
| 8096 | !!$ swampmap(ib) = swamp(ib) / ( resolution(ib,1)*resolution(ib,2)*contfrac(ib) ) |
|---|
| 8097 | !!$ ELSE |
|---|
| 8098 | !!$ swampmap(ib) = zero |
|---|
| 8099 | !!$ ENDIF |
|---|
| 8100 | ENDIF |
|---|
| 8101 | ! |
|---|
| 8102 | ! |
|---|
| 8103 | ENDDO |
|---|
| 8104 | ! |
|---|
| 8105 | ! |
|---|
| 8106 | |
|---|
| 8107 | IF (printlev>=1) THEN |
|---|
| 8108 | IF ( init_irrig ) WRITE(numout,*) "Diagnostics irrigated :", MINVAL(irrigated), MAXVAL(irrigated) |
|---|
| 8109 | IF ( init_flood ) WRITE(numout,*) "Diagnostics floodplains :", MINVAL(floodplains), MAXVAL(floodplains) |
|---|
| 8110 | IF ( init_swamp ) WRITE(numout,*) "Diagnostics swamp :", MINVAL(swamp), MAXVAL(swamp) |
|---|
| 8111 | END IF |
|---|
| 8112 | |
|---|
| 8113 | ! No compensation is done for overlapping floodplains, swamp and irrig. At least overlapping will not |
|---|
| 8114 | ! happen between floodplains and swamp alone |
|---|
| 8115 | ! IF ( init_irrig .AND. init_flood ) THEN |
|---|
| 8116 | ! DO ib = 1, nbpt |
|---|
| 8117 | ! surp = (floodplains(ib)+swamp(ib)+irrigated(ib)) / (resolution(ib,1)*resolution(ib,2)*contfrac(ib)) |
|---|
| 8118 | ! IF ( surp .GT. un ) THEN |
|---|
| 8119 | ! floodplains(ib) = floodplains(ib) / surp |
|---|
| 8120 | ! swamp(ib) = swamp(ib) / surp |
|---|
| 8121 | ! irrigated(ib) = irrigated(ib) / surp |
|---|
| 8122 | ! ENDIF |
|---|
| 8123 | ! ENDDO |
|---|
| 8124 | ! ENDIF |
|---|
| 8125 | ! |
|---|
| 8126 | DEALLOCATE (irrsub_area) |
|---|
| 8127 | DEALLOCATE (irrsub_index) |
|---|
| 8128 | ! |
|---|
| 8129 | DEALLOCATE (mask) |
|---|
| 8130 | DEALLOCATE (resol_lu) |
|---|
| 8131 | ! |
|---|
| 8132 | DEALLOCATE (lonrel) |
|---|
| 8133 | DEALLOCATE (latrel) |
|---|
| 8134 | ! |
|---|
| 8135 | END SUBROUTINE routing_irrigmap |
|---|
| 8136 | ! |
|---|
| 8137 | !! ================================================================================================================================ |
|---|
| 8138 | !! SUBROUTINE : routing_waterbal |
|---|
| 8139 | !! |
|---|
| 8140 | !>\BRIEF This subroutine checks the water balance in the routing module. |
|---|
| 8141 | !! |
|---|
| 8142 | !! DESCRIPTION (definitions, functional, design, flags) : None |
|---|
| 8143 | !! |
|---|
| 8144 | !! RECENT CHANGE(S): None |
|---|
| 8145 | !! |
|---|
| 8146 | !! MAIN OUTPUT VARIABLE(S): |
|---|
| 8147 | !! |
|---|
| 8148 | !! REFERENCES : None |
|---|
| 8149 | !! |
|---|
| 8150 | !! FLOWCHART : None |
|---|
| 8151 | !! \n |
|---|
| 8152 | !_ ================================================================================================================================ |
|---|
| 8153 | |
|---|
| 8154 | SUBROUTINE routing_waterbal(nbpt, reinit, floodout, runoff, drainage, returnflow, & |
|---|
| 8155 | & reinfiltration, irrigation, riverflow, coastalflow) |
|---|
| 8156 | ! |
|---|
| 8157 | IMPLICIT NONE |
|---|
| 8158 | ! |
|---|
| 8159 | !! INPUT VARIABLES |
|---|
| 8160 | INTEGER(i_std), INTENT(in) :: nbpt !! Domain size (unitless) |
|---|
| 8161 | LOGICAL, INTENT(in) :: reinit !! Controls behaviour (true/false) |
|---|
| 8162 | REAL(r_std), INTENT(in) :: floodout(nbpt) !! Grid-point flow out of floodplains (kg/m^2/dt) |
|---|
| 8163 | REAL(r_std), INTENT(in) :: runoff(nbpt) !! Grid-point runoff (kg/m^2/dt) |
|---|
| 8164 | REAL(r_std), INTENT(in) :: drainage(nbpt) !! Grid-point drainage (kg/m^2/dt) |
|---|
| 8165 | REAL(r_std), INTENT(in) :: returnflow(nbpt) !! The water flow from lakes and swamps which returns to the grid box. |
|---|
| 8166 | !! This water will go back into the hydrol or hydrolc module to allow re-evaporation (kg/m^2/dt) |
|---|
| 8167 | REAL(r_std), INTENT(in) :: reinfiltration(nbpt) !! Water flow from ponds and floodplains which returns to the grid box (kg/m^2/dt) |
|---|
| 8168 | 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) |
|---|
| 8169 | 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) |
|---|
| 8170 | 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) |
|---|
| 8171 | ! |
|---|
| 8172 | ! We sum-up all the water we have in the warious reservoirs |
|---|
| 8173 | ! |
|---|
| 8174 | REAL(r_std), SAVE :: totw_flood !! Sum of all the water amount in the floodplains reservoirs (kg) |
|---|
| 8175 | !$OMP THREADPRIVATE(totw_flood) |
|---|
| 8176 | REAL(r_std), SAVE :: totw_stream !! Sum of all the water amount in the stream reservoirs (kg) |
|---|
| 8177 | !$OMP THREADPRIVATE(totw_stream) |
|---|
| 8178 | REAL(r_std), SAVE :: totw_fast !! Sum of all the water amount in the fast reservoirs (kg) |
|---|
| 8179 | !$OMP THREADPRIVATE(totw_fast) |
|---|
| 8180 | REAL(r_std), SAVE :: totw_slow !! Sum of all the water amount in the slow reservoirs (kg) |
|---|
| 8181 | !$OMP THREADPRIVATE(totw_slow) |
|---|
| 8182 | REAL(r_std), SAVE :: totw_lake !! Sum of all the water amount in the lake reservoirs (kg) |
|---|
| 8183 | !$OMP THREADPRIVATE(totw_lake) |
|---|
| 8184 | REAL(r_std), SAVE :: totw_pond !! Sum of all the water amount in the pond reservoirs (kg) |
|---|
| 8185 | !$OMP THREADPRIVATE(totw_pond) |
|---|
| 8186 | REAL(r_std), SAVE :: totw_in !! Sum of the water flow in to the routing scheme |
|---|
| 8187 | !$OMP THREADPRIVATE(totw_in) |
|---|
| 8188 | REAL(r_std), SAVE :: totw_out !! Sum of the water flow out to the routing scheme |
|---|
| 8189 | !$OMP THREADPRIVATE(totw_out) |
|---|
| 8190 | REAL(r_std), SAVE :: totw_return !! |
|---|
| 8191 | !$OMP THREADPRIVATE(totw_return) |
|---|
| 8192 | REAL(r_std), SAVE :: totw_irrig !! |
|---|
| 8193 | !$OMP THREADPRIVATE(totw_irrig) |
|---|
| 8194 | REAL(r_std), SAVE :: totw_river !! |
|---|
| 8195 | !$OMP THREADPRIVATE(totw_river) |
|---|
| 8196 | REAL(r_std), SAVE :: totw_coastal !! |
|---|
| 8197 | !$OMP THREADPRIVATE(totw_coastal) |
|---|
| 8198 | REAL(r_std) :: totarea !! Total area of basin (m^2) |
|---|
| 8199 | REAL(r_std) :: area !! Total area of routing (m^2) |
|---|
| 8200 | INTEGER(i_std) :: ig !! |
|---|
| 8201 | ! |
|---|
| 8202 | ! Just to make sure we do not get too large numbers ! |
|---|
| 8203 | ! |
|---|
| 8204 | !! PARAMETERS |
|---|
| 8205 | REAL(r_std), PARAMETER :: scaling = 1.0E+6 !! |
|---|
| 8206 | REAL(r_std), PARAMETER :: allowed_err = 50. !! |
|---|
| 8207 | |
|---|
| 8208 | !_ ================================================================================================================================ |
|---|
| 8209 | ! |
|---|
| 8210 | IF ( reinit ) THEN |
|---|
| 8211 | ! |
|---|
| 8212 | totw_flood = zero |
|---|
| 8213 | totw_stream = zero |
|---|
| 8214 | totw_fast = zero |
|---|
| 8215 | totw_slow = zero |
|---|
| 8216 | totw_lake = zero |
|---|
| 8217 | totw_pond = zero |
|---|
| 8218 | totw_in = zero |
|---|
| 8219 | ! |
|---|
| 8220 | DO ig=1,nbpt |
|---|
| 8221 | ! |
|---|
| 8222 | totarea = SUM(routing_area(ig,:)) |
|---|
| 8223 | ! |
|---|
| 8224 | totw_flood = totw_flood + SUM(flood_reservoir(ig,:)/scaling) |
|---|
| 8225 | totw_stream = totw_stream + SUM(stream_reservoir(ig,:)/scaling) |
|---|
| 8226 | totw_fast = totw_fast + SUM(fast_reservoir(ig,:)/scaling) |
|---|
| 8227 | totw_slow = totw_slow + SUM(slow_reservoir(ig,:)/scaling) |
|---|
| 8228 | totw_lake = totw_lake + lake_reservoir(ig)/scaling |
|---|
| 8229 | totw_pond = totw_pond + pond_reservoir(ig)/scaling |
|---|
| 8230 | ! |
|---|
| 8231 | totw_in = totw_in + (runoff(ig)*totarea + drainage(ig)*totarea - floodout(ig)*totarea)/scaling |
|---|
| 8232 | ! |
|---|
| 8233 | ENDDO |
|---|
| 8234 | ! |
|---|
| 8235 | ELSE |
|---|
| 8236 | ! |
|---|
| 8237 | totw_out = zero |
|---|
| 8238 | totw_return = zero |
|---|
| 8239 | totw_irrig = zero |
|---|
| 8240 | totw_river = zero |
|---|
| 8241 | totw_coastal = zero |
|---|
| 8242 | area = zero |
|---|
| 8243 | ! |
|---|
| 8244 | DO ig=1,nbpt |
|---|
| 8245 | ! |
|---|
| 8246 | totarea = SUM(routing_area(ig,:)) |
|---|
| 8247 | ! |
|---|
| 8248 | totw_flood = totw_flood - SUM(flood_reservoir(ig,:)/scaling) |
|---|
| 8249 | totw_stream = totw_stream - SUM(stream_reservoir(ig,:)/scaling) |
|---|
| 8250 | totw_fast = totw_fast - SUM(fast_reservoir(ig,:)/scaling) |
|---|
| 8251 | totw_slow = totw_slow - SUM(slow_reservoir(ig,:)/scaling) |
|---|
| 8252 | totw_lake = totw_lake - lake_reservoir(ig)/scaling |
|---|
| 8253 | totw_pond = totw_pond - pond_reservoir(ig)/scaling |
|---|
| 8254 | ! |
|---|
| 8255 | totw_return = totw_return + (reinfiltration(ig)+returnflow(ig))*totarea/scaling |
|---|
| 8256 | totw_irrig = totw_irrig + irrigation(ig)*totarea/scaling |
|---|
| 8257 | totw_river = totw_river + riverflow(ig)/scaling |
|---|
| 8258 | totw_coastal = totw_coastal + coastalflow(ig)/scaling |
|---|
| 8259 | ! |
|---|
| 8260 | area = area + totarea |
|---|
| 8261 | ! |
|---|
| 8262 | ENDDO |
|---|
| 8263 | totw_out = totw_return + totw_irrig + totw_river + totw_coastal |
|---|
| 8264 | ! |
|---|
| 8265 | ! Now we have all the information to balance our water |
|---|
| 8266 | ! |
|---|
| 8267 | IF ( ABS((totw_flood + totw_stream + totw_fast + totw_slow + totw_lake + totw_pond) - & |
|---|
| 8268 | & (totw_out - totw_in)) > allowed_err ) THEN |
|---|
| 8269 | WRITE(numout,*) 'WARNING : Water not conserved in routing. Limit at ', allowed_err, ' 10^6 kg' |
|---|
| 8270 | WRITE(numout,*) '--Water-- change : flood stream fast ', totw_flood, totw_stream, totw_fast |
|---|
| 8271 | WRITE(numout,*) '--Water-- change : slow, lake ', totw_slow, totw_lake |
|---|
| 8272 | WRITE(numout,*) '--Water>>> change in the routing res. : ', totw_flood + totw_stream + totw_fast + totw_slow + totw_lake |
|---|
| 8273 | WRITE(numout,*) '--Water input : ', totw_in |
|---|
| 8274 | WRITE(numout,*) '--Water output : ', totw_out |
|---|
| 8275 | WRITE(numout,*) '--Water output : return, irrig ', totw_return, totw_irrig |
|---|
| 8276 | WRITE(numout,*) '--Water output : river, coastal ',totw_river, totw_coastal |
|---|
| 8277 | WRITE(numout,*) '--Water>>> change by fluxes : ', totw_out - totw_in, ' Diff [mm/dt]: ', & |
|---|
| 8278 | & ((totw_flood + totw_stream + totw_fast + totw_slow + totw_lake) - (totw_out - totw_in))/area |
|---|
| 8279 | |
|---|
| 8280 | ! Stop the model |
|---|
| 8281 | CALL ipslerr_p(3, 'routing_waterbal', 'Water is not conserved in routing.','','') |
|---|
| 8282 | ENDIF |
|---|
| 8283 | ! |
|---|
| 8284 | ENDIF |
|---|
| 8285 | ! |
|---|
| 8286 | END SUBROUTINE routing_waterbal |
|---|
| 8287 | ! |
|---|
| 8288 | ! |
|---|
| 8289 | END MODULE routing |
|---|
