Changeset 4803
- Timestamp:
- Nov 30, 2020 4:57:54 PM (4 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
palm/trunk/SOURCE/plant_canopy_model_mod.f90
r4770 r4803 1 1 !> @file plant_canopy_model_mod.f90 2 !------------------------------------------------------------------------------ !2 !--------------------------------------------------------------------------------------------------! 3 3 ! This file is part of the PALM model system. 4 4 ! 5 ! PALM is free software: you can redistribute it and/or modify it under the 6 ! terms of the GNU General Public License as published by the Free Software 7 ! Foundation, either version 3 of the License, or (at your option) any later 8 ! version. 9 ! 10 ! PALM is distributed in the hope that it will be useful, but WITHOUT ANY 11 ! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR 12 ! A PARTICULAR PURPOSE. See the GNU General Public License for more details. 13 ! 14 ! You should have received a copy of the GNU General Public License along with 15 ! PALM. If not, see <http://www.gnu.org/licenses/>. 5 ! PALM is free software: you can redistribute it and/or modify it under the terms of the GNU General 6 ! Public License as published by the Free Software Foundation, either version 3 of the License, or 7 ! (at your option) any later version. 8 ! 9 ! PALM is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the 10 ! implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General 11 ! Public License for more details. 12 ! 13 ! You should have received a copy of the GNU General Public License along with PALM. If not, see 14 ! <http://www.gnu.org/licenses/>. 16 15 ! 17 16 ! Copyright 1997-2020 Leibniz Universitaet Hannover 18 17 ! Copyright 2017-2020 Institute of Computer Science of the 19 18 ! Czech Academy of Sciences, Prague 20 !------------------------------------------------------------------------------ !19 !--------------------------------------------------------------------------------------------------! 21 20 ! 22 21 ! Current revisions: … … 27 26 ! ----------------- 28 27 ! $Id$ 29 ! Consider basal-area density as an additional sink for momentum in the 30 ! prognostic equations for momentum and SGS TKE 28 ! file re-formatted to follow the PALM coding standard 29 ! 30 ! 4770 2020-11-03 14:04:53Z suehring 31 ! Consider basal-area density as an additional sink for momentum in the prognostic equations for 32 ! momentum and SGS TKE 31 33 ! 32 34 ! 4768 2020-11-02 19:11:23Z suehring … … 35 37 ! 4671 2020-09-09 20:27:58Z pavelkrc 36 38 ! Implementation of downward facing USM and LSM surfaces 37 ! 39 ! 38 40 ! 4535 2020-05-15 12:07:23Z raasch 39 41 ! bugfix for restart data format query 40 ! 42 ! 41 43 ! 4525 2020-05-10 17:05:07Z raasch 42 44 ! bugfix for reading/writing pcm_...rate_av with MPI-IO 43 ! 45 ! 44 46 ! 4517 2020-05-03 14:29:30Z raasch 45 47 ! added restart with MPI-IO for reading local arrays 46 ! 48 ! 47 49 ! 4515 2020-04-30 16:37:18Z suehring 48 50 ! Rename error number again since this was recently given in -r 4511 49 ! 51 ! 50 52 ! 4514 2020-04-30 16:29:59Z suehring 51 ! - Bugfix in output of pcm_heatrate_av in a restart run. In order to fix this, 52 ! pch_index is now output for a restart run. Therefore, define global restart 53 ! routines. 54 ! - Error message number renamed and check for PA0505 revised in order to also 55 ! consider natural surfaces with plant-canopy. 56 ! 53 ! - Bugfix in output of pcm_heatrate_av in a restart run. In order to fix this, pch_index is now 54 ! output for a restart run. Therefore, define global restart routines. 55 ! - Error message number renamed and check for PA0505 revised in order to also consider natural 56 ! surfaces with plant-canopy. 57 ! 57 58 ! 4495 2020-04-13 20:11:20Z raasch 58 59 ! restart data handling with MPI-IO added … … 63 64 ! (salim) removed the error message PA0672 to consider PC 3d data via ascii file 64 65 ! 65 ! 4392 2020-01-31 16:14:57Z pavelkrc (resler) 66 ! Make pcm_heatrate_av, pcm_latentrate_av public to allow calculation 67 ! of averaged Bowen ratio in theuser procedure66 ! 4392 2020-01-31 16:14:57Z pavelkrc (resler) 67 ! Make pcm_heatrate_av, pcm_latentrate_av public to allow calculation of averaged Bowen ratio in the 68 ! user procedure 68 69 ! 69 70 ! 4381 2020-01-20 13:51:46Z suehring 70 71 ! Give error message 313 only once 71 ! 72 ! 72 73 ! 4363 2020-01-07 18:11:28Z suehring 73 74 ! Fix for last commit 74 ! 75 ! 75 76 ! 4362 2020-01-07 17:15:02Z suehring 76 ! Input of plant canopy variables from static driver moved to plant-canopy 77 ! model 78 ! 77 ! Input of plant canopy variables from static driver moved to plant-canopy model 78 ! 79 79 ! 4361 2020-01-07 12:22:38Z suehring 80 80 ! - Remove unused arrays in pmc_rrd_local 81 81 ! - Remove one exchange of ghost points 82 ! 82 ! 83 83 ! 4360 2020-01-07 11:25:50Z suehring 84 84 ! - Bugfix, read restart data for time-averaged pcm output quantities 85 85 ! - Output of plant-canopy quantities will fill values 86 ! 86 ! 87 87 ! 4356 2019-12-20 17:09:33Z suehring 88 ! Correct single message call, local check must be given by the respective 89 ! mpi rank. 90 ! 88 ! Correct single message call, local check must be given by the respective mpi rank. 89 ! 91 90 ! 4346 2019-12-18 11:55:56Z motisi 92 ! Introduction of wall_flags_total_0, which currently sets bits based on static 93 ! topographyinformation used in wall_flags_static_094 ! 91 ! Introduction of wall_flags_total_0, which currently sets bits based on static topography 92 ! information used in wall_flags_static_0 93 ! 95 94 ! 4342 2019-12-16 13:49:14Z Giersch 96 ! Use statements moved to module level, ocean dependency removed, redundant 97 ! variables removed 98 ! 95 ! Use statements moved to module level, ocean dependency removed, redundant variables removed 96 ! 99 97 ! 4341 2019-12-16 10:43:49Z motisi 100 ! - Unification of variable names: pc_-variables now pcm_-variables 101 ! (pc_latent_rate,pc_heating_rate, pc_transpiration_rate)98 ! - Unification of variable names: pc_-variables now pcm_-variables (pc_latent_rate, 99 ! pc_heating_rate, pc_transpiration_rate) 102 100 ! - Removal of pcm_bowenratio output 103 101 ! - Renamed canopy-mode 'block' to 'homogeneous' … … 106 104 ! - Replacement of k_wall by topo_top_ind 107 105 ! - Removal of Else-Statement in tendency-calculation 108 ! 106 ! 109 107 ! 4335 2019-12-12 16:39:05Z suehring 110 108 ! Fix for LAD at building edges also implemented in vector branch. 111 ! 109 ! 112 110 ! 4331 2019-12-10 18:25:02Z suehring 113 111 ! Typo corrected 114 ! 112 ! 115 113 ! 4329 2019-12-10 15:46:36Z motisi 116 114 ! Renamed wall_flags_0 to wall_flags_static_0 117 ! 115 ! 118 116 ! 4314 2019-11-29 10:29:20Z suehring 119 ! - Bugfix, plant canopy was still considered at building edges on for the u- 120 ! and v-component. 121 ! - Relax restriction of LAD on building tops. LAD is only omitted at 122 ! locations where building grid points emerged artificially by the 123 ! topography filtering. 124 ! 117 ! - Bugfix, plant canopy was still considered at building edges on for the u- and v-component. 118 ! - Relax restriction of LAD on building tops. LAD is only omitted at locations where building grid 119 ! points emerged artificially by the topography filtering. 120 ! 125 121 ! 4309 2019-11-26 18:49:59Z suehring 126 122 ! Typo 127 ! 123 ! 128 124 ! 4302 2019-11-22 13:15:56Z suehring 129 125 ! Omit tall canopy mapped on top of buildings 130 ! 126 ! 131 127 ! 4279 2019-10-29 08:48:17Z scharf 132 128 ! unused variables removed 133 ! 129 ! 134 130 ! 4258 2019-10-07 13:29:08Z scharf 135 131 ! changed check for static driver and fixed bugs in initialization and header 136 ! 132 ! 137 133 ! 4258 2019-10-07 13:29:08Z suehring 138 134 ! Check if any LAD is prescribed when plant-canopy model is applied. 139 ! 135 ! 140 136 ! 4226 2019-09-10 17:03:24Z suehring 141 137 ! Bugfix, missing initialization of heating rate 142 ! 138 ! 143 139 ! 4221 2019-09-09 08:50:35Z suehring 144 140 ! Further bugfix in 3d data output for plant canopy 145 ! 141 ! 146 142 ! 4216 2019-09-04 09:09:03Z suehring 147 143 ! Bugfixes in 3d data output 148 ! 144 ! 149 145 ! 4205 2019-08-30 13:25:00Z suehring 150 146 ! Missing working precision + bugfix in calculation of wind speed 151 ! 147 ! 152 148 ! 4188 2019-08-26 14:15:47Z suehring 153 149 ! Minor adjustment in error number 154 ! 150 ! 155 151 ! 4187 2019-08-26 12:43:15Z suehring 156 152 ! Give specific error numbers instead of PA0999 157 ! 153 ! 158 154 ! 4182 2019-08-22 15:20:23Z scharf 159 155 ! Corrected "Former revisions" section 160 ! 156 ! 161 157 ! 4168 2019-08-16 13:50:17Z suehring 162 158 ! Replace function get_topography_top_index by topo_top_ind 163 ! 159 ! 164 160 ! 4127 2019-07-30 14:47:10Z suehring 165 ! Output of 3D plant canopy variables changed. It is now relative to the local 166 ! terrain rather than located at the acutal vertical level in the model. This167 ! way, the vertical dimension of the output can be significantly reduced.168 ! (merge from branch resler) 169 ! 161 ! Output of 3D plant canopy variables changed. It is now relative to the local terrain rather than 162 ! located at the acutal vertical level in the model. This way, the vertical dimension of the output 163 ! can be significantly reduced. 164 ! (merge from branch resler) 165 ! 170 166 ! 3885 2019-04-11 11:29:34Z kanani 171 ! Changes related to global restructuring of location messages and introduction 172 ! of additional debugmessages173 ! 167 ! Changes related to global restructuring of location messages and introduction of additional debug 168 ! messages 169 ! 174 170 ! 3864 2019-04-05 09:01:56Z monakurppa 175 171 ! unsed variables removed 176 ! 172 ! 177 173 ! 3745 2019-02-15 18:57:56Z suehring 178 ! Bugfix in transpiration, floating invalid when temperature 179 ! becomes > 40 degrees 180 ! 174 ! Bugfix in transpiration, floating invalid when temperature becomes > 40 degrees 175 ! 181 176 ! 3744 2019-02-15 18:38:58Z suehring 182 177 ! Some interface calls moved to module_interface + cleanup 183 ! 178 ! 184 179 ! 3655 2019-01-07 16:51:22Z knoop 185 180 ! unused variables removed … … 190 185 ! Description: 191 186 ! ------------ 192 !> 1) Initialization of the canopy model, e.g. construction of leaf area density 193 !> profile(subroutine pcm_init).194 !> 2) Calculation of sinks and sources of momentum, heat and scalar concentration 195 !> due to canopyelements (subroutine pcm_tendency).187 !> 1) Initialization of the canopy model, e.g. construction of leaf area density profile 188 !> (subroutine pcm_init). 189 !> 2) Calculation of sinks and sources of momentum, heat and scalar concentration due to canopy 190 !> elements (subroutine pcm_tendency). 196 191 ! 197 192 ! @todo - precalculate constant terms in pcm_calc_transpiration_rate 198 193 ! @todo - unify variable names (pcm_, pc_, ...) 199 194 ! @todo - get rid-off dependency on radiation model 200 !------------------------------------------------------------------------------ !195 !--------------------------------------------------------------------------------------------------! 201 196 MODULE plant_canopy_model_mod 202 197 203 USE arrays_3d, &198 USE arrays_3d, & 204 199 ONLY: dzu, dzw, e, exner, hyp, pt, q, s, tend, u, v, w, zu, zw 205 200 206 USE basic_constants_and_equations_mod, &201 USE basic_constants_and_equations_mod, & 207 202 ONLY: c_p, degc_to_k, l_v, lv_d_cp, r_d, rd_d_rv 208 203 209 USE bulk_cloud_model_mod, &204 USE bulk_cloud_model_mod, & 210 205 ONLY: bulk_cloud_model, microphysics_seifert 211 206 212 USE control_parameters, &213 ONLY: average_count_3d, &214 coupling_char, &215 debug_output, &216 dt_3d, &217 dz, &218 humidity, &219 land_surface, &220 length, &221 message_string, &222 ocean_mode, &223 passive_scalar, &224 plant_canopy, &225 restart_data_format_output, &226 restart_string, &207 USE control_parameters, & 208 ONLY: average_count_3d, & 209 coupling_char, & 210 debug_output, & 211 dt_3d, & 212 dz, & 213 humidity, & 214 land_surface, & 215 length, & 216 message_string, & 217 ocean_mode, & 218 passive_scalar, & 219 plant_canopy, & 220 restart_data_format_output, & 221 restart_string, & 227 222 urban_surface 228 223 229 USE grid_variables, &224 USE grid_variables, & 230 225 ONLY: dx, dy 231 226 232 USE indices, &233 ONLY: nbgp, nxl, nxlg, nxlu, nxr, nxrg, nyn, nyng, nys, nysg, nysv, &234 nz, nzb, nzt,topo_top_ind, wall_flags_total_0227 USE indices, & 228 ONLY: nbgp, nxl, nxlg, nxlu, nxr, nxrg, nyn, nyng, nys, nysg, nysv, nz, nzb, nzt, & 229 topo_top_ind, wall_flags_total_0 235 230 236 231 USE kinds 237 232 238 USE netcdf_data_input_mod, &239 ONLY: input_pids_static,&240 ch ar_fill,&241 c heck_existence,&242 close_input_file,&243 get_ attribute,&244 get_ dimension_length,&245 get_variable,&246 in quire_num_variables,&247 inquire_ variable_names,&248 in put_file_static,&249 num_var_pids, &250 open_read_file, &251 pids_id, &252 real_3d, &233 USE netcdf_data_input_mod, & 234 ONLY: char_fill, & 235 check_existence, & 236 close_input_file, & 237 get_attribute, & 238 get_dimension_length, & 239 get_variable, & 240 input_file_static, & 241 input_pids_static, & 242 inquire_num_variables, & 243 inquire_variable_names, & 244 num_var_pids, & 245 open_read_file, & 246 pids_id, & 247 real_3d, & 253 248 vars_pids 254 249 … … 260 255 wrd_mpi_io 261 256 262 USE surface_mod, &257 USE surface_mod, & 263 258 ONLY: surf_def_h, surf_lsm_h, surf_usm_h 264 259 … … 266 261 IMPLICIT NONE 267 262 268 CHARACTER (LEN=30) :: canopy_mode = 'homogeneous' !< canopy coverage 269 LOGICAL :: plant_canopy_transpiration = .FALSE. !< flag to switch calculation of transpiration and corresponding latent heat 270 !< for resolved plant canopy inside radiation model 271 !< (calls subroutine pcm_calc_transpiration_rate from module plant_canopy_mod) 272 263 CHARACTER (LEN=30) :: canopy_mode = 'homogeneous' !< canopy coverage 273 264 INTEGER(iwp) :: pch_index = 0 !< plant canopy height/top index 265 274 266 INTEGER(iwp) :: lad_vertical_gradient_level_ind(10) = -9999 !< lad-profile levels (index) 275 267 276 268 INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: pch_index_ji !< local plant canopy top 277 269 278 LOGICAL :: calc_beta_lad_profile = .FALSE. !< switch for calc. of lad from beta func. 279 280 REAL(wp) :: alpha_lad = 9999999.9_wp !< coefficient for lad calculation 281 REAL(wp) :: beta_lad = 9999999.9_wp !< coefficient for lad calculation 282 REAL(wp) :: canopy_drag_coeff = 0.0_wp !< canopy drag coefficient (parameter) 283 REAL(wp) :: cthf = 0.0_wp !< canopy top heat flux 284 REAL(wp) :: dt_plant_canopy = 0.0_wp !< timestep account. for canopy drag 285 REAL(wp) :: ext_coef = 0.6_wp !< extinction coefficient 286 REAL(wp) :: lad_surface = 0.0_wp !< lad surface value 287 REAL(wp) :: lai_beta = 0.0_wp !< leaf area index (lai) for lad calc. 288 REAL(wp) :: leaf_scalar_exch_coeff = 0.0_wp !< canopy scalar exchange coeff. 289 REAL(wp) :: leaf_surface_conc = 0.0_wp !< leaf surface concentration 290 270 LOGICAL :: calc_beta_lad_profile = .FALSE. !< switch for calc. of lad from beta func. 271 LOGICAL :: plant_canopy_transpiration = .FALSE. !< flag to switch calculation of transpiration and corresponding latent heat 272 !< for resolved plant canopy inside radiation model 273 !< (calls subroutine pcm_calc_transpiration_rate from module plant_canopy_mod) 274 275 REAL(wp) :: alpha_lad = 9999999.9_wp !< coefficient for lad calculation 276 REAL(wp) :: beta_lad = 9999999.9_wp !< coefficient for lad calculation 277 REAL(wp) :: canopy_drag_coeff = 0.0_wp !< canopy drag coefficient (parameter) 278 REAL(wp) :: cthf = 0.0_wp !< canopy top heat flux 279 REAL(wp) :: dt_plant_canopy = 0.0_wp !< timestep account. for canopy drag 280 REAL(wp) :: ext_coef = 0.6_wp !< extinction coefficient 281 REAL(wp) :: lad_surface = 0.0_wp !< lad surface value 282 REAL(wp) :: lad_type_coef(0:10) = 1.0_wp !< multiplicative coeficients for particular types 283 !< of plant canopy (e.g. deciduous tree during winter) 291 284 REAL(wp) :: lad_vertical_gradient(10) = 0.0_wp !< lad gradient 292 285 REAL(wp) :: lad_vertical_gradient_level(10) = -9999999.9_wp !< lad-prof. levels (in m) 293 294 REAL(wp) :: l ad_type_coef(0:10) = 1.0_wp !< multiplicative coeficients for particular types295 !< of plant canopy (e.g. deciduous tree during winter)286 REAL(wp) :: lai_beta = 0.0_wp !< leaf area index (lai) for lad calc. 287 REAL(wp) :: leaf_scalar_exch_coeff = 0.0_wp !< canopy scalar exchange coeff. 288 REAL(wp) :: leaf_surface_conc = 0.0_wp !< leaf surface concentration 296 289 297 290 REAL(wp), DIMENSION(:), ALLOCATABLE :: lad !< leaf area density … … 302 295 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: lad_s !< lad on scalar-grid 303 296 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: pcm_heating_rate !< plant canopy heating rate 297 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: pcm_heatrate_av !< array for averaging plant canopy sensible heating rate 298 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: pcm_latent_rate !< plant canopy latent heating rate 299 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: pcm_latentrate_av !< array for averaging plant canopy latent heating rate 304 300 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: pcm_transpiration_rate !< plant canopy transpiration rate 305 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: pcm_latent_rate !< plant canopy latent heating rate306 307 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: pcm_heatrate_av !< array for averaging plant canopy sensible heating rate308 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: pcm_latentrate_av !< array for averaging plant canopy latent heating rate309 301 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: pcm_transpirationrate_av !< array for averaging plant canopy transpiration rate 310 302 … … 316 308 317 309 PRIVATE 318 310 319 311 ! 320 312 !-- Public functions 321 PUBLIC pcm_calc_transpiration_rate, &322 pcm_check_data_output, &323 pcm_check_parameters, &324 pcm_3d_data_averaging, &325 pcm_data_output_3d, &326 pcm_define_netcdf_grid, &327 pcm_header, &328 pcm_init, &329 pcm_parin, &330 pcm_rrd_global, &331 pcm_rrd_local, &332 pcm_tendency, &333 pcm_wrd_global, &313 PUBLIC pcm_calc_transpiration_rate, & 314 pcm_check_data_output, & 315 pcm_check_parameters, & 316 pcm_3d_data_averaging, & 317 pcm_data_output_3d, & 318 pcm_define_netcdf_grid, & 319 pcm_header, & 320 pcm_init, & 321 pcm_parin, & 322 pcm_rrd_global, & 323 pcm_rrd_local, & 324 pcm_tendency, & 325 pcm_wrd_global, & 334 326 pcm_wrd_local 335 327 336 328 ! 337 329 !-- Public variables and constants 338 PUBLIC canopy_drag_coeff, pcm_heating_rate, pcm_transpiration_rate, & 339 pcm_latent_rate, canopy_mode, cthf, dt_plant_canopy, lad, lad_s, & 340 pch_index, plant_canopy_transpiration, & 330 PUBLIC canopy_drag_coeff, pcm_heating_rate, pcm_transpiration_rate, pcm_latent_rate, & 331 canopy_mode, cthf, dt_plant_canopy, lad, lad_s, pch_index, plant_canopy_transpiration, & 341 332 pcm_heatrate_av, pcm_latentrate_av 342 333 … … 348 339 MODULE PROCEDURE pcm_check_data_output 349 340 END INTERFACE pcm_check_data_output 350 341 351 342 INTERFACE pcm_check_parameters 352 343 MODULE PROCEDURE pcm_check_parameters … … 364 355 MODULE PROCEDURE pcm_define_netcdf_grid 365 356 END INTERFACE pcm_define_netcdf_grid 366 357 367 358 INTERFACE pcm_header 368 359 MODULE PROCEDURE pcm_header 369 END INTERFACE pcm_header 370 360 END INTERFACE pcm_header 361 371 362 INTERFACE pcm_init 372 363 MODULE PROCEDURE pcm_init … … 406 397 407 398 CONTAINS 408 409 410 !------------------------------------------------------------------------------ !399 400 401 !--------------------------------------------------------------------------------------------------! 411 402 ! Description: 412 403 ! ------------ 413 !> Calculation of the plant canopy transpiration rate based on the Jarvis-Stewart 414 !> with parametrizations described in Daudet et al. (1999; Agricult. and Forest 415 !> Meteorol. 97) and Ngao, Adam and Saudreau (2017; Agricult. and Forest Meteorol 416 !> 237-238). Model functions f1-f4 were adapted from Stewart (1998; Agric. 417 !> and Forest. Meteorol. 43) instead, because they are valid for broader intervals 418 !> of values. Funcion f4 used in form present in van Wijk et al. (1998; 419 !> Tree Physiology 20). 404 !> Calculation of the plant canopy transpiration rate based on the Jarvis-Stewart with 405 !> parametrizations described in Daudet et al. (1999; Agricult. and Forest Meteorol. 97) and Ngao, 406 !> Adam and Saudreau (2017; Agricult. and Forest Meteorol 237-238). Model functions f1-f4 were 407 !> adapted from Stewart (1998; Agric. and Forest. Meteorol. 43) instead, because they are valid for 408 !> broader intervals of values. Funcion f4 used in form present in van Wijk et al. (1998; Tree 409 !> Physiology 20). 420 410 !> 421 !> This subroutine is called from subroutine radiation_interaction 422 !> after the calculation ofradiation in plant canopy boxes.411 !> This subroutine is called from subroutine radiation_interaction after the calculation of 412 !> radiation in plant canopy boxes. 423 413 !> (arrays pcbinsw and pcbinlw). 424 414 !> 425 !------------------------------------------------------------------------------ !415 !--------------------------------------------------------------------------------------------------! 426 416 SUBROUTINE pcm_calc_transpiration_rate(i, j, k, kk, pcbsw, pcblw, pcbtr, pcblh) 427 417 428 418 ! 429 !-- input parameters419 !-- Input parameters 430 420 INTEGER(iwp), INTENT(IN) :: i, j, k, kk !< indices of the pc gridbox 421 REAL(wp), INTENT(IN) :: pcblw !< lw radiation in gridbox (W) 431 422 REAL(wp), INTENT(IN) :: pcbsw !< sw radiation in gridbox (W) 432 REAL(wp), INTENT( IN) :: pcblw !< lw radiation in gridbox (W)423 REAL(wp), INTENT(OUT) :: pcblh !< latent heat from transpiration dT/dt (K/s) 433 424 REAL(wp), INTENT(OUT) :: pcbtr !< transpiration rate dq/dt (kg/kg/s) 434 REAL(wp), INTENT(OUT) :: pcblh !< latent heat from transpiration dT/dt (K/s) 435 436 !-- variables and parameters for calculation of transpiration rate 437 REAL(wp) :: sat_press, sat_press_d, temp, v_lad 438 REAL(wp) :: d_fact, g_b, g_s, wind_speed, evapor_rate 439 REAL(wp) :: f1, f2, f3, f4, vpd, rswc, e_eq, e_imp, rad 440 REAL(wp), PARAMETER :: gama_psychr = 66.0_wp !< psychrometric constant (Pa/K) 441 REAL(wp), PARAMETER :: g_s_max = 0.01 !< maximum stomatal conductivity (m/s) 442 REAL(wp), PARAMETER :: m_soil = 0.4_wp !< soil water content (needs to adjust or take from LSM) 443 REAL(wp), PARAMETER :: m_wilt = 0.01_wp !< wilting point soil water content (needs to adjust or take from LSM) 444 REAL(wp), PARAMETER :: m_sat = 0.51_wp !< saturation soil water content (needs to adjust or take from LSM) 445 REAL(wp), PARAMETER :: t2_min = 0.0_wp !< minimal temperature for calculation of f2 446 REAL(wp), PARAMETER :: t2_max = 40.0_wp !< maximal temperature for calculation of f2 447 448 425 426 !-- Variables and parameters for calculation of transpiration rate 427 REAL(wp), PARAMETER :: gama_psychr = 66.0_wp !< psychrometric constant (Pa/K) 428 REAL(wp), PARAMETER :: g_s_max = 0.01 !< maximum stomatal conductivity (m/s) 429 REAL(wp), PARAMETER :: m_soil = 0.4_wp !< soil water content (needs to adjust or take from LSM) 430 REAL(wp), PARAMETER :: m_wilt = 0.01_wp !< wilting point soil water content (needs to adjust or take from LSM) 431 REAL(wp), PARAMETER :: m_sat = 0.51_wp !< saturation soil water content (needs to adjust or take from LSM) 432 REAL(wp), PARAMETER :: t2_min = 0.0_wp !< minimal temperature for calculation of f2 433 REAL(wp), PARAMETER :: t2_max = 40.0_wp !< maximal temperature for calculation of f2 434 435 REAL(wp) :: d_fact 436 REAL(wp) :: e_eq 437 REAL(wp) :: e_imp 438 REAL(wp) :: evapor_rate 439 REAL(wp) :: f1 440 REAL(wp) :: f2 441 REAL(wp) :: f3 442 REAL(wp) :: f4 443 REAL(wp) :: g_b 444 REAL(wp) :: g_s 445 REAL(wp) :: rad 446 REAL(wp) :: rswc 447 REAL(wp) :: sat_press 448 REAL(wp) :: sat_press_d 449 REAL(wp) :: temp 450 REAL(wp) :: v_lad 451 REAL(wp) :: vpd 452 REAL(wp) :: wind_speed 453 454 ! 449 455 !-- Temperature (deg C) 450 456 temp = pt(k,j,i) * exner(k) - degc_to_k 457 ! 451 458 !-- Coefficient for conversion of radiation to grid to radiation to unit leaves surface 452 459 v_lad = 1.0_wp / ( MAX( lad_s(kk,j,i), 1.0E-10_wp ) * dx * dy * dz(1) ) 460 ! 453 461 !-- Magnus formula for the saturation pressure (see Ngao, Adam and Saudreau (2017) eq. 1) 454 462 !-- There are updated formulas available, kept consistent with the rest of the parametrization 455 sat_press = 610.8_wp * exp(17.27_wp * temp/(temp + 237.3_wp)) 463 sat_press = 610.8_wp * EXP( 17.27_wp * temp / ( temp + 237.3_wp ) ) 464 ! 456 465 !-- Saturation pressure derivative (derivative of the above) 457 sat_press_d = sat_press * 17.27_wp * 237.3_wp / (temp + 237.3_wp)**2 466 sat_press_d = sat_press * 17.27_wp * 237.3_wp / ( temp + 237.3_wp )**2 467 ! 458 468 !-- Wind speed 459 wind_speed = SQRT( ( 0.5_wp * ( u(k,j,i) + u(k,j,i+1) ) )**2 + &460 ( 0.5_wp * ( v(k,j,i) + v(k,j+1,i) ) )**2 + &469 wind_speed = SQRT( ( 0.5_wp * ( u(k,j,i) + u(k,j,i+1) ) )**2 + & 470 ( 0.5_wp * ( v(k,j,i) + v(k,j+1,i) ) )**2 + & 461 471 ( 0.5_wp * ( w(k,j,i) + w(k-1,j,i) ) )**2 ) 472 ! 462 473 !-- Aerodynamic conductivity (Daudet et al. (1999) eq. 14 463 474 g_b = 0.01_wp * wind_speed + 0.0071_wp 475 ! 464 476 !-- Radiation flux per leaf surface unit 465 477 rad = pcbsw * v_lad 478 ! 466 479 !-- First function for calculation of stomatal conductivity (radiation dependency) 467 480 !-- Stewart (1988; Agric. and Forest. Meteorol. 43) eq. 17 468 f1 = rad * (1000.0_wp+42.1_wp) / 1000.0_wp / (rad+42.1_wp) 481 f1 = rad * ( 1000.0_wp + 42.1_wp ) / 1000.0_wp / ( rad + 42.1_wp ) 482 ! 469 483 !-- Second function for calculation of stomatal conductivity (temperature dependency) 470 484 !-- Stewart (1988; Agric. and Forest. Meteorol. 43) eq. 21 471 f2 = MAX(t2_min, (temp-t2_min) * MAX(0.0_wp,t2_max-temp)**((t2_max-16.9_wp)/(16.9_wp-t2_min)) / & 472 ((16.9_wp-t2_min) * (t2_max-16.9_wp)**((t2_max-16.9_wp)/(16.9_wp-t2_min))) ) 485 f2 = MAX( t2_min, ( temp - t2_min ) * MAX( 0.0_wp, t2_max - temp )**( ( t2_max - 16.9_wp ) / & 486 ( 16.9_wp - t2_min ) ) & 487 / ( ( 16.9_wp - t2_min ) * ( t2_max - 16.9_wp )**( ( t2_max - 16.9_wp ) / & 488 ( 16.9_wp - t2_min ) ) ) ) 489 ! 473 490 !-- Water pressure deficit 474 491 !-- Ngao, Adam and Saudreau (2017) eq. 6 but with water vapour partial pressure 475 vpd = max( sat_press - q(k,j,i) * hyp(k) / rd_d_rv, 0._wp ) 492 vpd = MAX( sat_press - q(k,j,i) * hyp(k) / rd_d_rv, 0._wp ) 493 ! 476 494 !-- Third function for calculation of stomatal conductivity (water pressure deficit dependency) 477 495 !-- Ngao, Adam and Saudreau (2017) Table 1, limited from below according to Stewart (1988) 478 !-- The coefficients of the linear dependence should better correspond to broad-leaved trees 479 !-- th an the coefficients from Stewart (1988) which correspond to conifer trees.480 vpd = MIN( MAX(vpd,770.0_wp),3820.0_wp)496 !-- The coefficients of the linear dependence should better correspond to broad-leaved trees than 497 !-- the coefficients from Stewart (1988) which correspond to conifer trees. 498 vpd = MIN( MAX( vpd, 770.0_wp ), 3820.0_wp ) 481 499 f3 = -2E-4_wp * vpd + 1.154_wp 500 ! 482 501 !-- Fourth function for calculation of stomatal conductivity (soil moisture dependency) 483 502 !-- Residual soil water content … … 485 504 !-- TODO - over LSM surface might be calculated from LSM parameters 486 505 rswc = ( m_sat - m_soil ) / ( m_sat - m_wilt ) 487 !-- van Wijk et al. (1998; Tree Physiology 20) eq. 5-6 (it is a reformulation of eq. 22-23 of Stewart(1988)) 488 f4 = MAX(0.0_wp, MIN(1.0_wp - 0.041_wp * EXP(3.2_wp * rswc), 1.0_wp - 0.041_wp)) 506 ! 507 !-- van Wijk et al. (1998; Tree Physiology 20) eq. 5-6 (it is a reformulation of eq. 22-23 of 508 !-- Stewart(1988)) 509 f4 = MAX( 0.0_wp, MIN( 1.0_wp - 0.041_wp * EXP( 3.2_wp * rswc ), 1.0_wp - 0.041_wp ) ) 510 ! 489 511 !-- Stomatal conductivity 490 512 !-- Stewart (1988; Agric. and Forest. Meteorol. 43) eq. 12 491 513 !-- (notation according to Ngao, Adam and Saudreau (2017) and others) 492 514 g_s = g_s_max * f1 * f2 * f3 * f4 + 1.0E-10_wp 515 ! 493 516 !-- Decoupling factor 494 517 !-- Daudet et al. (1999) eq. 6 495 d_fact = (sat_press_d / gama_psychr + 2.0_wp ) / & 496 (sat_press_d / gama_psychr + 2.0_wp + 2.0_wp * g_b / g_s ) 518 d_fact = ( sat_press_d / gama_psychr + 2.0_wp ) / & 519 ( sat_press_d / gama_psychr + 2.0_wp + 2.0_wp * g_b / g_s ) 520 ! 497 521 !-- Equilibrium evaporation rate 498 522 !-- Daudet et al. (1999) eq. 4 499 e_eq = (pcbsw + pcblw) * v_lad * sat_press_d / & 500 gama_psychr /( sat_press_d / gama_psychr + 2.0_wp ) / l_v 523 e_eq = ( pcbsw + pcblw ) * v_lad * sat_press_d / & 524 gama_psychr / ( sat_press_d / gama_psychr + 2.0_wp ) / l_v 525 ! 501 526 !-- Imposed evaporation rate 502 527 !-- Daudet et al. (1999) eq. 5 503 528 e_imp = r_d * pt(k,j,i) * exner(k) / hyp(k) * c_p * g_s * vpd / gama_psychr / l_v 529 ! 504 530 !-- Evaporation rate 505 531 !-- Daudet et al. (1999) eq. 3 506 532 !-- (evaporation rate is limited to non-negative values) 507 evapor_rate = MAX(d_fact * e_eq + ( 1.0_wp - d_fact ) * e_imp, 0.0_wp) 533 evapor_rate = MAX( d_fact * e_eq + ( 1.0_wp - d_fact ) * e_imp, 0.0_wp ) 534 ! 508 535 !-- Conversion of evaporation rate to q tendency in gridbox 509 536 !-- dq/dt = E * LAD * V_g / (rho_air * V_g) 510 537 pcbtr = evapor_rate * r_d * pt(k,j,i) * exner(k) * lad_s(kk,j,i) / hyp(k) !-- = dq/dt 538 ! 511 539 !-- latent heat from evaporation 512 540 pcblh = pcbtr * lv_d_cp !-- = - dT/dt … … 515 543 516 544 517 !------------------------------------------------------------------------------ !545 !--------------------------------------------------------------------------------------------------! 518 546 ! Description: 519 547 ! ------------ 520 548 !> Check data output for plant canopy model 521 !------------------------------------------------------------------------------ !549 !--------------------------------------------------------------------------------------------------! 522 550 SUBROUTINE pcm_check_data_output( var, unit ) 523 551 524 CHARACTER (LEN=*) :: unit !< 552 CHARACTER (LEN=*) :: unit !< 525 553 CHARACTER (LEN=*) :: var !< 526 554 … … 530 558 CASE ( 'pcm_heatrate' ) 531 559 ! 532 !-- Output of heatrate can be only done if it is explicitely set by cthf, 533 !-- or parametrized by absorption of radiation. The latter, however, is 534 !-- only available if radiation_interactions are on. Note, these are 535 !-- enabled if land-surface or urban-surface is switched-on. Using 536 !-- radiation_interactions_on directly is not possible since it belongs 537 !-- to the radition_model, which in turn depends on the plant-canopy model, 538 !-- creating circular dependencies. 539 IF ( cthf == 0.0_wp .AND. ( .NOT. urban_surface .AND. & 540 .NOT. land_surface ) ) THEN 541 message_string = 'output of "' // TRIM( var ) // '" requi' // & 560 !-- Output of heatrate can be only done if it is explicitely set by cthf, or parametrized by 561 !-- absorption of radiation. The latter, however, is only available if radiation_interactions 562 !-- are on. Note, these are enabled if land-surface or urban-surface is switched-on. Using 563 !-- radiation_interactions_on directly is not possible since it belongs to the 564 !-- radition_model, which in turn depends on the plant-canopy model, creating circular 565 !-- dependencies. 566 IF ( cthf == 0.0_wp .AND. ( .NOT. urban_surface .AND. .NOT. land_surface ) ) THEN 567 message_string = 'output of "' // TRIM( var ) // '" requi' // & 542 568 'res setting of parameter cthf /= 0.0' 543 569 CALL message( 'pcm_check_data_output', 'PA0718', 1, 2, 0, 6, 0 ) 544 570 ENDIF 545 571 unit = 'K s-1' 546 572 547 573 CASE ( 'pcm_transpirationrate' ) 548 574 unit = 'kg kg-1 s-1' … … 562 588 563 589 END SUBROUTINE pcm_check_data_output 564 565 566 !------------------------------------------------------------------------------ !590 591 592 !--------------------------------------------------------------------------------------------------! 567 593 ! Description: 568 594 ! ------------ 569 595 !> Check parameters routine for plant canopy model 570 !------------------------------------------------------------------------------ !596 !--------------------------------------------------------------------------------------------------! 571 597 SUBROUTINE pcm_check_parameters 572 598 573 599 IF ( ocean_mode ) THEN 574 message_string = 'plant_canopy = .TRUE. is not allowed in the '// & 575 'ocean' 600 message_string = 'plant_canopy = .TRUE. is not allowed in the ocean' 576 601 CALL message( 'pcm_check_parameters', 'PA0696', 1, 2, 0, 6, 0 ) 577 602 ENDIF 578 603 579 604 IF ( canopy_drag_coeff == 0.0_wp ) THEN 580 message_string = 'plant_canopy = .TRUE. requires a non-zero drag ' //&605 message_string = 'plant_canopy = .TRUE. requires a non-zero drag ' // & 581 606 'coefficient & given value is canopy_drag_coeff = 0.0' 582 607 CALL message( 'pcm_check_parameters', 'PA0041', 1, 2, 0, 6, 0 ) 583 608 ENDIF 584 609 585 IF ( ( alpha_lad /= 9999999.9_wp .AND. beta_lad == 9999999.9_wp ) .OR.&586 beta_lad /= 9999999.9_wp.AND. alpha_lad == 9999999.9_wp ) THEN587 message_string = 'using the beta function for the construction ' // &588 'of the leaf area density profile requires ' // &610 IF ( ( alpha_lad /= 9999999.9_wp .AND. beta_lad == 9999999.9_wp ) .OR. & 611 beta_lad /= 9999999.9_wp .AND. alpha_lad == 9999999.9_wp ) THEN 612 message_string = 'using the beta function for the construction ' // & 613 'of the leaf area density profile requires ' // & 589 614 'both alpha_lad and beta_lad to be /= 9999999.9' 590 615 CALL message( 'pcm_check_parameters', 'PA0118', 1, 2, 0, 6, 0 ) … … 592 617 593 618 IF ( calc_beta_lad_profile .AND. lai_beta == 0.0_wp ) THEN 594 message_string = 'using the beta function for the construction ' // &595 'of the leaf area density profile requires ' // &596 'a non-zero lai_beta, but given value is ' // &619 message_string = 'using the beta function for the construction ' // & 620 'of the leaf area density profile requires ' // & 621 'a non-zero lai_beta, but given value is ' // & 597 622 'lai_beta = 0.0' 598 623 CALL message( 'pcm_check_parameters', 'PA0119', 1, 2, 0, 6, 0 ) … … 600 625 601 626 IF ( calc_beta_lad_profile .AND. lad_surface /= 0.0_wp ) THEN 602 message_string = 'simultaneous setting of alpha_lad /= 9999999.9 '// &603 'combined with beta_lad /= 9999999.9 ' // &604 'and lad_surface /= 0.0 is not possible, ' // &605 'use either vertical gradients or the beta ' // &606 'function for the construction of the leaf area '// &627 message_string = 'simultaneous setting of alpha_lad /= 9999999.9 '// & 628 'combined with beta_lad /= 9999999.9 ' // & 629 'and lad_surface /= 0.0 is not possible, ' // & 630 'use either vertical gradients or the beta ' // & 631 'function for the construction of the leaf area '// & 607 632 'density profile' 608 633 CALL message( 'pcm_check_parameters', 'PA0120', 1, 2, 0, 6, 0 ) 609 ENDIF 634 ENDIF 610 635 611 636 IF ( bulk_cloud_model .AND. microphysics_seifert ) THEN 612 message_string = 'plant_canopy = .TRUE. requires cloud_scheme /=' // & 613 ' seifert_beheng' 637 message_string = 'plant_canopy = .TRUE. requires cloud_scheme /= seifert_beheng' 614 638 CALL message( 'pcm_check_parameters', 'PA0360', 1, 2, 0, 6, 0 ) 615 639 ENDIF 616 640 617 END SUBROUTINE pcm_check_parameters 618 619 620 !------------------------------------------------------------------------------ !641 END SUBROUTINE pcm_check_parameters 642 643 644 !--------------------------------------------------------------------------------------------------! 621 645 ! 622 646 ! Description: 623 647 ! ------------ 624 648 !> Subroutine for averaging 3D data 625 !------------------------------------------------------------------------------ !649 !--------------------------------------------------------------------------------------------------! 626 650 SUBROUTINE pcm_3d_data_averaging( mode, variable ) 627 651 628 652 CHARACTER (LEN=*) :: mode !< 629 CHARACTER (LEN=*) :: variable !<653 CHARACTER (LEN=*) :: variable !< 630 654 631 655 INTEGER(iwp) :: i !< … … 663 687 END SELECT 664 688 665 ELSE IF ( mode == 'sum' ) THEN689 ELSE IF ( mode == 'sum' ) THEN 666 690 667 691 SELECT CASE ( TRIM( variable ) ) 668 692 669 693 CASE ( 'pcm_heatrate' ) 670 IF ( ALLOCATED( pcm_heatrate_av ) ) THEN694 IF ( ALLOCATED( pcm_heatrate_av ) ) THEN 671 695 DO i = nxl, nxr 672 696 DO j = nys, nyn 673 697 IF ( pch_index_ji(j,i) /= 0 ) THEN 674 698 DO k = 0, pch_index_ji(j,i) 675 pcm_heatrate_av(k,j,i) = pcm_heatrate_av(k,j,i) + pcm_heating_rate(k,j,i) 699 pcm_heatrate_av(k,j,i) = pcm_heatrate_av(k,j,i) + & 700 pcm_heating_rate(k,j,i) 676 701 ENDDO 677 702 ENDIF … … 682 707 683 708 CASE ( 'pcm_latentrate' ) 684 IF ( ALLOCATED( pcm_latentrate_av ) ) THEN709 IF ( ALLOCATED( pcm_latentrate_av ) ) THEN 685 710 DO i = nxl, nxr 686 711 DO j = nys, nyn 687 712 IF ( pch_index_ji(j,i) /= 0 ) THEN 688 713 DO k = 0, pch_index_ji(j,i) 689 pcm_latentrate_av(k,j,i) = pcm_latentrate_av(k,j,i) + pcm_latent_rate(k,j,i) 714 pcm_latentrate_av(k,j,i) = pcm_latentrate_av(k,j,i) + & 715 pcm_latent_rate(k,j,i) 690 716 ENDDO 691 717 ENDIF … … 696 722 697 723 CASE ( 'pcm_transpirationrate' ) 698 IF ( ALLOCATED( pcm_transpirationrate_av ) ) THEN724 IF ( ALLOCATED( pcm_transpirationrate_av ) ) THEN 699 725 DO i = nxl, nxr 700 726 DO j = nys, nyn 701 727 IF ( pch_index_ji(j,i) /= 0 ) THEN 702 728 DO k = 0, pch_index_ji(j,i) 703 pcm_transpirationrate_av(k,j,i) = pcm_transpirationrate_av(k,j,i) + pcm_transpiration_rate(k,j,i) 729 pcm_transpirationrate_av(k,j,i) = pcm_transpirationrate_av(k,j,i) + & 730 pcm_transpiration_rate(k,j,i) 704 731 ENDDO 705 732 ENDIF … … 713 740 END SELECT 714 741 715 ELSE IF ( mode == 'average' ) THEN742 ELSE IF ( mode == 'average' ) THEN 716 743 717 744 SELECT CASE ( TRIM( variable ) ) 718 745 719 746 CASE ( 'pcm_heatrate' ) 720 IF ( ALLOCATED( pcm_heatrate_av ) ) THEN747 IF ( ALLOCATED( pcm_heatrate_av ) ) THEN 721 748 DO i = nxlg, nxrg 722 749 DO j = nysg, nyng 723 750 IF ( pch_index_ji(j,i) /= 0 ) THEN 724 751 DO k = 0, pch_index_ji(j,i) 725 pcm_heatrate_av(k,j,i) = pcm_heatrate_av(k,j,i) &752 pcm_heatrate_av(k,j,i) = pcm_heatrate_av(k,j,i) & 726 753 / REAL( average_count_3d, KIND=wp ) 727 754 ENDDO … … 733 760 734 761 CASE ( 'pcm_latentrate' ) 735 IF ( ALLOCATED( pcm_latentrate_av ) ) THEN762 IF ( ALLOCATED( pcm_latentrate_av ) ) THEN 736 763 DO i = nxlg, nxrg 737 764 DO j = nysg, nyng 738 765 IF ( pch_index_ji(j,i) /= 0 ) THEN 739 766 DO k = 0, pch_index_ji(j,i) 740 pcm_latentrate_av(k,j,i) = pcm_latentrate_av(k,j,i) &767 pcm_latentrate_av(k,j,i) = pcm_latentrate_av(k,j,i) & 741 768 / REAL( average_count_3d, KIND=wp ) 742 769 ENDDO … … 748 775 749 776 CASE ( 'pcm_transpirationrate' ) 750 IF ( ALLOCATED( pcm_transpirationrate_av ) ) THEN777 IF ( ALLOCATED( pcm_transpirationrate_av ) ) THEN 751 778 DO i = nxlg, nxrg 752 779 DO j = nysg, nyng 753 780 IF ( pch_index_ji(j,i) /= 0 ) THEN 754 781 DO k = 0, pch_index_ji(j,i) 755 pcm_transpirationrate_av(k,j,i) = pcm_transpirationrate_av(k,j,i) &782 pcm_transpirationrate_av(k,j,i) = pcm_transpirationrate_av(k,j,i) & 756 783 / REAL( average_count_3d, KIND=wp ) 757 784 ENDDO … … 767 794 END SUBROUTINE pcm_3d_data_averaging 768 795 769 !------------------------------------------------------------------------------ !796 !--------------------------------------------------------------------------------------------------! 770 797 ! 771 798 ! Description: 772 799 ! ------------ 773 !> Subroutine defining 3D output variables. 774 !> Note, 3D plant-canopy output has it's own vertical output dimension, meaning 775 !> that 3D output is relative to the model surface now rather than at the actual 776 !> grid point where the plant canopy is located. 777 !------------------------------------------------------------------------------! 778 SUBROUTINE pcm_data_output_3d( av, variable, found, local_pf, fill_value, & 779 nzb_do, nzt_do ) 800 !> Subroutine defining 3D output variables. 801 !> Note, 3D plant-canopy output has it's own vertical output dimension, meaning that 3D output is 802 !> relative to the model surface now rather than at the actual grid point where the plant canopy is 803 !> located. 804 !--------------------------------------------------------------------------------------------------! 805 SUBROUTINE pcm_data_output_3d( av, variable, found, local_pf, fill_value, nzb_do, nzt_do ) 780 806 781 807 CHARACTER (LEN=*) :: variable !< treated variable … … 791 817 792 818 REAL(wp) :: fill_value !< fill value 819 793 820 REAL(wp), DIMENSION(nxl:nxr,nys:nyn,nzb_do:nzt_do) :: local_pf !< data output array 794 821 … … 801 828 ! 802 829 !-- Note, to save memory arrays for heating are allocated from 0:pch_index. 803 !-- Thus, output must be relative to these array indices. Further, check 804 !-- whether the output is within the vertical output range, 805 !-- i.e. nzb_do:nzt_do, which is necessary as local_pf is only allocated 806 !-- for this index space. Note, plant-canopy output has a separate 807 !-- vertical output coordinate zlad, so that output is mapped down to the 808 !-- surface. 830 !-- Thus, output must be relative to these array indices. Further, check whether the output is 831 !-- within the vertical output range, i.e. nzb_do:nzt_do, which is necessary as local_pf is only 832 !-- allocated for this index space. Note, plant-canopy output has a separate vertical output 833 !-- coordinate zlad, so that output is mapped down to the surface. 809 834 CASE ( 'pcm_heatrate' ) 810 835 IF ( av == 0 ) THEN … … 891 916 END SELECT 892 917 893 END SUBROUTINE pcm_data_output_3d 894 895 !------------------------------------------------------------------------------ !918 END SUBROUTINE pcm_data_output_3d 919 920 !--------------------------------------------------------------------------------------------------! 896 921 ! 897 922 ! Description: … … 899 924 !> Subroutine defining appropriate grid for netcdf variables. 900 925 !> It is called from subroutine netcdf. 901 !------------------------------------------------------------------------------ !926 !--------------------------------------------------------------------------------------------------! 902 927 SUBROUTINE pcm_define_netcdf_grid( var, found, grid_x, grid_y, grid_z ) 903 928 904 CHARACTER (LEN=*), INTENT(IN) :: var !< 905 LOGICAL, INTENT(OUT) :: found !< 906 CHARACTER (LEN=*), INTENT(OUT) :: grid_x !< 907 CHARACTER (LEN=*), INTENT(OUT) :: grid_y !< 908 CHARACTER (LEN=*), INTENT(OUT) :: grid_z !< 929 CHARACTER (LEN=*), INTENT(IN) :: var !< 930 CHARACTER (LEN=*), INTENT(OUT) :: grid_x !< 931 CHARACTER (LEN=*), INTENT(OUT) :: grid_y !< 932 CHARACTER (LEN=*), INTENT(OUT) :: grid_z !< 933 934 LOGICAL, INTENT(OUT) :: found !< 935 909 936 910 937 found = .TRUE. … … 914 941 SELECT CASE ( TRIM( var ) ) 915 942 916 CASE ( 'pcm_heatrate', 'pcm_bad', 'pcm_lad', 'pcm_transpirationrate', 'pcm_latentrate' )943 CASE ( 'pcm_heatrate', 'pcm_bad', 'pcm_lad', 'pcm_transpirationrate', 'pcm_latentrate' ) 917 944 grid_x = 'x' 918 945 grid_y = 'y' … … 927 954 928 955 END SUBROUTINE pcm_define_netcdf_grid 929 930 931 !------------------------------------------------------------------------------ !956 957 958 !--------------------------------------------------------------------------------------------------! 932 959 ! Description: 933 960 ! ------------ 934 961 !> Header output for plant canopy model 935 !------------------------------------------------------------------------------ !962 !--------------------------------------------------------------------------------------------------! 936 963 SUBROUTINE pcm_header ( io ) 937 964 938 965 CHARACTER (LEN=10) :: coor_chr !< 939 940 966 CHARACTER (LEN=86) :: coordinates !< 941 967 CHARACTER (LEN=86) :: gradients !< 942 968 CHARACTER (LEN=86) :: leaf_area_density !< 943 969 CHARACTER (LEN=86) :: slices !< 944 945 INTEGER(iwp) :: i !<946 INTEGER(iwp), INTENT(IN) :: io !< Unit of the output file947 INTEGER(iwp) :: k !<948 970 971 INTEGER(iwp) :: i !< 972 INTEGER(iwp), INTENT(IN) :: io !< Unit of the output file 973 INTEGER(iwp) :: k !< 974 949 975 REAL(wp) :: canopy_height !< canopy height (in m) 950 976 977 951 978 canopy_height = zw(pch_index) 952 979 953 WRITE ( io, 1 ) canopy_mode, canopy_height, pch_index, & 954 canopy_drag_coeff 955 IF ( passive_scalar ) THEN 956 WRITE ( io, 2 ) leaf_scalar_exch_coeff, & 957 leaf_surface_conc 980 WRITE( io, 1 ) canopy_mode, canopy_height, pch_index, canopy_drag_coeff 981 IF ( passive_scalar ) THEN 982 WRITE( io, 2 ) leaf_scalar_exch_coeff, leaf_surface_conc 958 983 ENDIF 959 984 960 985 ! 961 ! 962 WRITE 963 964 ! 965 ! Leaf area density profile, calculated either from given vertical966 ! gradients or from betaprobability density function.967 IF ( .NOT.calc_beta_lad_profile ) THEN986 !-- Heat flux at the top of vegetation 987 WRITE( io, 3 ) cthf 988 989 ! 990 !-- Leaf area density profile, calculated either from given vertical gradients or from beta 991 !-- probability density function. 992 IF ( .NOT. calc_beta_lad_profile ) THEN 968 993 969 994 ! Building output strings, starting with surface value 970 WRITE 995 WRITE( leaf_area_density, '(F7.4)' ) lad_surface 971 996 gradients = '------' 972 997 slices = ' 0' 973 998 coordinates = ' 0.0' 974 DO i = 1, UBOUND(lad_vertical_gradient_level_ind, DIM=1)975 IF ( lad_vertical_gradient_level_ind(i) /= -9999 ) THEN976 977 WRITE (coor_chr,'(F7.2)') lad(lad_vertical_gradient_level_ind(i))999 DO i = 1, UBOUND( lad_vertical_gradient_level_ind, DIM=1 ) 1000 IF ( lad_vertical_gradient_level_ind(i) /= -9999 ) THEN 1001 1002 WRITE( coor_chr, '(F7.2)' ) lad(lad_vertical_gradient_level_ind(i)) 978 1003 leaf_area_density = TRIM( leaf_area_density ) // ' ' // TRIM( coor_chr ) 979 1004 980 WRITE (coor_chr,'(F7.2)') lad_vertical_gradient(i)1005 WRITE( coor_chr, '(F7.2)' ) lad_vertical_gradient(i) 981 1006 gradients = TRIM( gradients ) // ' ' // TRIM( coor_chr ) 982 1007 983 WRITE (coor_chr,'(I7)') lad_vertical_gradient_level_ind(i)1008 WRITE( coor_chr, '(I7)' ) lad_vertical_gradient_level_ind(i) 984 1009 slices = TRIM( slices ) // ' ' // TRIM( coor_chr ) 985 1010 986 WRITE (coor_chr,'(F7.1)') lad_vertical_gradient_level(i)1011 WRITE( coor_chr, '(F7.1)' ) lad_vertical_gradient_level(i) 987 1012 coordinates = TRIM( coordinates ) // ' ' // TRIM( coor_chr ) 988 1013 ELSE … … 991 1016 ENDDO 992 1017 993 WRITE ( io, 4 ) TRIM( coordinates ), TRIM( leaf_area_density ),&994 TRIM( gradients ),TRIM( slices )1018 WRITE( io, 4 ) TRIM( coordinates ), TRIM( leaf_area_density ), TRIM( gradients ), & 1019 TRIM( slices ) 995 1020 996 1021 ELSE 997 998 WRITE 1022 1023 WRITE( leaf_area_density, '(F7.4)' ) lad_surface 999 1024 coordinates = ' 0.0' 1000 1025 1001 1026 DO k = 1, pch_index 1002 1027 1003 WRITE (coor_chr,'(F7.2)') lad(k) 1004 leaf_area_density = TRIM( leaf_area_density ) // ' ' // & 1005 TRIM( coor_chr ) 1006 1007 WRITE (coor_chr,'(F7.1)') zu(k) 1008 coordinates = TRIM( coordinates ) // ' ' // TRIM( coor_chr ) 1009 1010 ENDDO 1011 1012 WRITE ( io, 5 ) TRIM( coordinates ), TRIM( leaf_area_density ), & 1013 alpha_lad, beta_lad, lai_beta 1014 1015 ENDIF 1016 1017 1 FORMAT (//' Vegetation canopy (drag) model:'/ & 1018 ' ------------------------------'// & 1019 ' Canopy mode: ', A / & 1020 ' Canopy height: ',F6.2,'m (',I4,' grid points)' / & 1021 ' Leaf drag coefficient: ',F6.2 /) 1022 2 FORMAT (/ ' Scalar exchange coefficient: ',F6.2 / & 1023 ' Scalar concentration at leaf surfaces in kg/m**3: ',F6.2 /) 1024 3 FORMAT (' Predefined constant heatflux at the top of the vegetation: ', & 1025 F6.2, ' K m/s') 1026 4 FORMAT (/ ' Characteristic levels of the leaf area density:'// & 1027 ' Height: ',A,' m'/ & 1028 ' Leaf area density: ',A,' m**2/m**3'/ & 1029 ' Gradient: ',A,' m**2/m**4'/ & 1030 ' Gridpoint: ',A) 1031 5 FORMAT (//' Characteristic levels of the leaf area density and coefficients:'& 1032 // ' Height: ',A,' m'/ & 1033 ' Leaf area density: ',A,' m**2/m**3'/ & 1034 ' Coefficient alpha: ',F6.2 / & 1035 ' Coefficient beta: ',F6.2 / & 1036 ' Leaf area index: ',F6.2,' m**2/m**2' /) 1037 1028 WRITE( coor_chr,'(F7.2)' ) lad(k) 1029 leaf_area_density = TRIM( leaf_area_density ) // ' ' // TRIM( coor_chr ) 1030 1031 WRITE(coor_chr,'(F7.1)') zu(k) 1032 coordinates = TRIM( coordinates ) // ' ' // TRIM( coor_chr ) 1033 1034 ENDDO 1035 1036 WRITE( io, 5 ) TRIM( coordinates ), TRIM( leaf_area_density ), alpha_lad, beta_lad, lai_beta 1037 1038 ENDIF 1039 1040 1 FORMAT (/ /' Vegetation canopy (drag) model:' / ' ------------------------------' // & 1041 ' Canopy mode: ', A / ' Canopy height: ', F6.2, 'm (',I4,' grid points)' / & 1042 ' Leaf drag coefficient: ', F6.2 /) 1043 2 FORMAT (/ ' Scalar exchange coefficient: ',F6.2 / & 1044 ' Scalar concentration at leaf surfaces in kg/m**3: ', F6.2 /) 1045 3 FORMAT ( ' Predefined constant heatflux at the top of the vegetation: ', F6.2, ' K m/s') 1046 4 FORMAT (/ ' Characteristic levels of the leaf area density:' // & 1047 ' Height: ', A, ' m' / & 1048 ' Leaf area density: ', A, ' m**2/m**3' / & 1049 ' Gradient: ', A, ' m**2/m**4' / & 1050 ' Gridpoint: ', A ) 1051 5 FORMAT (//' Characteristic levels of the leaf area density and coefficients:' // & 1052 ' Height: ', A, ' m' / & 1053 ' Leaf area density: ', A, ' m**2/m**3' / & 1054 ' Coefficient alpha: ',F6.2 / & 1055 ' Coefficient beta: ',F6.2 / & 1056 ' Leaf area index: ',F6.2,' m**2/m**2' /) 1057 1038 1058 END SUBROUTINE pcm_header 1039 1040 1041 !------------------------------------------------------------------------------ !1059 1060 1061 !--------------------------------------------------------------------------------------------------! 1042 1062 ! Description: 1043 1063 ! ------------ 1044 1064 !> Initialization of the plant canopy model 1045 !------------------------------------------------------------------------------ !1065 !--------------------------------------------------------------------------------------------------! 1046 1066 SUBROUTINE pcm_init 1047 1067 1048 USE exchange_horiz_mod, &1068 USE exchange_horiz_mod, & 1049 1069 ONLY: exchange_horiz 1050 1070 … … 1054 1074 INTEGER(iwp) :: m !< running index 1055 1075 1056 LOGICAL 1057 LOGICAL 1076 LOGICAL :: lad_on_top = .FALSE. !< dummy flag to indicate that LAD is defined on a building roof 1077 LOGICAL :: bad_on_top = .FALSE. !< dummy flag to indicate that BAD is defined on a building roof 1058 1078 1059 1079 REAL(wp) :: canopy_height !< canopy height for lad-profile construction 1060 1080 REAL(wp) :: gradient !< gradient for lad-profile construction 1061 REAL(wp) :: int_bpdf !< vertical integral for lad-profile construction 1081 REAL(wp) :: int_bpdf !< vertical integral for lad-profile construction 1062 1082 REAL(wp) :: lad_max !< maximum LAD value in the model domain, used to perform a check 1063 1083 1084 1064 1085 IF ( debug_output ) CALL debug_message( 'pcm_init', 'start' ) 1065 1086 ! 1066 !-- Allocate one-dimensional arrays for the computation of the 1067 !-- leaf area density (lad) profile 1087 !-- Allocate one-dimensional arrays for the computation of the leaf area density (lad) profile 1068 1088 ALLOCATE( lad(0:nz+1), pre_lad(0:nz+1) ) 1069 1089 lad = 0.0_wp … … 1071 1091 1072 1092 ! 1073 !-- Set flag that indicates that the lad-profile shall be calculated by using 1074 !-- a beta probabilitydensity function1093 !-- Set flag that indicates that the lad-profile shall be calculated by using a beta probability 1094 !-- density function 1075 1095 IF ( alpha_lad /= 9999999.9_wp .AND. beta_lad /= 9999999.9_wp ) THEN 1076 1096 calc_beta_lad_profile = .TRUE. 1077 1097 ENDIF 1078 1079 1080 ! 1081 !-- Compute the profile of leaf area density used in the plant 1082 !-- canopy model. The profile can either be constructed from 1083 !-- prescribed vertical gradients of the leaf area density or by 1084 !-- using a beta probability density function (see e.g. Markkanen et al., 1085 !-- 2003: Boundary-Layer Meteorology, 106, 437-459) 1086 IF ( .NOT. calc_beta_lad_profile ) THEN 1087 1088 ! 1089 !-- Use vertical gradients for lad-profile construction 1098 1099 1100 ! 1101 !-- Compute the profile of leaf area density used in the plant canopy model. The profile can 1102 !-- either be constructed from prescribed vertical gradients of the leaf area density or by using 1103 !-- a beta probability density function (see e.g. Markkanen et al., 2003: Boundary-Layer 1104 !-- Meteorology, 106, 437-459) 1105 IF ( .NOT. calc_beta_lad_profile ) THEN 1106 1107 ! 1108 !-- Use vertical gradients for lad-profile construction 1090 1109 i = 1 1091 1110 gradient = 0.0_wp … … 1094 1113 lad_vertical_gradient_level_ind(1) = 0 1095 1114 1096 DO k = 1, pch_index1115 DO k = 1, pch_index 1097 1116 IF ( i < 11 ) THEN 1098 IF ( lad_vertical_gradient_level(i) < zu(k) .AND. &1117 IF ( lad_vertical_gradient_level(i) < zu(k) .AND. & 1099 1118 lad_vertical_gradient_level(i) >= 0.0_wp ) THEN 1100 1119 gradient = lad_vertical_gradient(i) … … 1115 1134 1116 1135 ! 1117 !-- In case of no given leaf area density gradients, choose a vanishing 1118 !-- gradient. This information is used for the HEADER and the RUN_CONTROL 1119 !-- file. 1136 !-- In case of no given leaf area density gradients, choose a vanishing gradient. This 1137 !-- information is used for the HEADER and the RUN_CONTROL file. 1120 1138 IF ( lad_vertical_gradient_level(1) == -9999999.9_wp ) THEN 1121 1139 lad_vertical_gradient_level(1) = 0.0_wp … … 1124 1142 ELSE 1125 1143 1126 ! 1144 ! 1127 1145 !-- Use beta function for lad-profile construction 1128 1146 int_bpdf = 0.0_wp 1129 1147 canopy_height = zw(pch_index) 1130 1148 1131 DO k = 0, pch_index 1132 int_bpdf = int_bpdf + & 1133 ( ( ( zw(k) / canopy_height )**( alpha_lad-1.0_wp ) ) * & 1134 ( ( 1.0_wp - ( zw(k) / canopy_height ) )**( & 1135 beta_lad-1.0_wp ) ) & 1136 * ( ( zw(k+1)-zw(k) ) / canopy_height ) ) 1149 DO k = 0, pch_index 1150 int_bpdf = int_bpdf + & 1151 ( ( ( zw(k) / canopy_height )**( alpha_lad-1.0_wp ) ) * & 1152 ( ( 1.0_wp - ( zw(k) / canopy_height ) )**( beta_lad-1.0_wp ) ) & 1153 * ( ( zw(k+1)-zw(k) ) / canopy_height ) ) 1137 1154 ENDDO 1138 1155 1139 1156 ! 1140 1157 !-- Preliminary lad profile (defined on w-grid) 1141 DO k = 0, pch_index1142 pre_lad(k) = lai_beta * &1143 ( ( ( zw(k) / canopy_height )**( alpha_lad-1.0_wp ) )&1144 * ( ( 1.0_wp - ( zw(k) / canopy_height ) )**(&1145 beta_lad-1.0_wp ) ) / int_bpdf&1146 ) / canopy_height1158 DO k = 0, pch_index 1159 pre_lad(k) = lai_beta * & 1160 ( ( ( zw(k) / canopy_height )**( alpha_lad-1.0_wp ) ) & 1161 * ( ( 1.0_wp - ( zw(k) / canopy_height ) )**( beta_lad-1.0_wp ) ) & 1162 / int_bpdf & 1163 ) / canopy_height 1147 1164 ENDDO 1148 1165 1149 1166 ! 1150 !-- Final lad profile (defined on scalar-grid level, since most prognostic 1151 !-- quantities are defined there, hence, less interpolation is required1152 !-- when calculating the canopytendencies)1167 !-- Final lad profile (defined on scalar-grid level, since most prognostic quantities are 1168 !-- defined there, hence, less interpolation is required when calculating the canopy 1169 !-- tendencies) 1153 1170 lad(0) = pre_lad(0) 1154 DO k = 1, pch_index1171 DO k = 1, pch_index 1155 1172 lad(k) = 0.5 * ( pre_lad(k-1) + pre_lad(k) ) 1156 1173 ENDDO … … 1159 1176 1160 1177 ! 1161 !-- Allocate 3D-array for the leaf-area density (lad_s) as well as 1162 !-- for basal-area densitiy(bad_s). Note, by default bad_s is zero.1178 !-- Allocate 3D-array for the leaf-area density (lad_s) as well as for basal-area densitiy 1179 !-- (bad_s). Note, by default bad_s is zero. 1163 1180 ALLOCATE( lad_s(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 1164 1181 ALLOCATE( bad_s(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) … … 1166 1183 ! 1167 1184 !-- Initialization of the canopy coverage in the model domain: 1168 !-- Setting the parameter canopy_mode = 'homogeneous' initializes a canopy, which 1169 !-- fully coversthe domain surface1185 !-- Setting the parameter canopy_mode = 'homogeneous' initializes a canopy, which fully covers 1186 !-- the domain surface 1170 1187 SELECT CASE ( TRIM( canopy_mode ) ) 1171 1188 1172 CASE ( 'homogeneous' )1189 CASE ( 'homogeneous' ) 1173 1190 1174 1191 DO i = nxlg, nxrg … … 1185 1202 !-- Open the static input file 1186 1203 #if defined( __netcdf ) 1187 CALL open_read_file( TRIM( input_file_static ) // &1188 TRIM( coupling_char ), &1204 CALL open_read_file( TRIM( input_file_static ) // & 1205 TRIM( coupling_char ), & 1189 1206 pids_id ) 1190 1207 … … 1198 1215 IF ( check_existence( vars_pids, 'lad' ) ) THEN 1199 1216 leaf_area_density_f%from_file = .TRUE. 1200 CALL get_attribute( pids_id, char_fill, &1201 leaf_area_density_f%fill, &1217 CALL get_attribute( pids_id, char_fill, & 1218 leaf_area_density_f%fill, & 1202 1219 .FALSE., 'lad' ) 1203 1220 ! 1204 1221 !-- Inquire number of vertical vegetation layer 1205 CALL get_dimension_length( pids_id, &1206 leaf_area_density_f%nz, &1222 CALL get_dimension_length( pids_id, & 1223 leaf_area_density_f%nz, & 1207 1224 'zlad' ) 1208 1225 ! 1209 1226 !-- Allocate variable for leaf-area density 1210 ALLOCATE( leaf_area_density_f%var & 1211 (0:leaf_area_density_f%nz-1, & 1212 nys:nyn,nxl:nxr) ) 1213 1214 CALL get_variable( pids_id, 'lad', leaf_area_density_f%var, & 1215 nxl, nxr, nys, nyn, & 1227 ALLOCATE( leaf_area_density_f%var & 1228 (0:leaf_area_density_f%nz-1,nys:nyn,nxl:nxr) ) 1229 1230 CALL get_variable( pids_id, 'lad', leaf_area_density_f%var, nxl, nxr, nys, nyn, & 1216 1231 0, leaf_area_density_f%nz-1 ) 1217 1232 … … 1223 1238 IF ( check_existence( vars_pids, 'bad' ) ) THEN 1224 1239 basal_area_density_f%from_file = .TRUE. 1225 CALL get_attribute( pids_id, char_fill, &1226 basal_area_density_f%fill, &1240 CALL get_attribute( pids_id, char_fill, & 1241 basal_area_density_f%fill, & 1227 1242 .FALSE., 'bad' ) 1228 1243 ! 1229 1244 !-- Inquire number of vertical vegetation layer 1230 CALL get_dimension_length( pids_id, &1231 basal_area_density_f%nz, &1245 CALL get_dimension_length( pids_id, & 1246 basal_area_density_f%nz, & 1232 1247 'zlad' ) 1233 1248 ! 1234 1249 !-- Allocate variable 1235 ALLOCATE( basal_area_density_f%var & 1236 (0:basal_area_density_f%nz-1, & 1237 nys:nyn,nxl:nxr) ) 1238 1239 CALL get_variable( pids_id, 'bad', basal_area_density_f%var,& 1240 nxl, nxr, nys, nyn, & 1241 0, basal_area_density_f%nz-1 ) 1250 ALLOCATE( basal_area_density_f%var & 1251 (0:basal_area_density_f%nz-1,nys:nyn,nxl:nxr) ) 1252 1253 CALL get_variable( pids_id, 'bad', basal_area_density_f%var, nxl, nxr, nys, nyn,& 1254 0, basal_area_density_f%nz-1 ) 1242 1255 ELSE 1243 1256 basal_area_density_f%from_file = .FALSE. … … 1247 1260 IF ( check_existence( vars_pids, 'root_area_dens_r' ) ) THEN 1248 1261 root_area_density_lad_f%from_file = .TRUE. 1249 CALL get_attribute( pids_id, char_fill, &1250 root_area_density_lad_f%fill, &1262 CALL get_attribute( pids_id, char_fill, & 1263 root_area_density_lad_f%fill, & 1251 1264 .FALSE., 'root_area_dens_r' ) 1252 1265 ! 1253 1266 !-- Inquire number of vertical soil layers 1254 CALL get_dimension_length( pids_id, &1255 root_area_density_lad_f%nz, &1267 CALL get_dimension_length( pids_id, & 1268 root_area_density_lad_f%nz, & 1256 1269 'zsoil' ) 1257 1270 ! 1258 1271 !-- Allocate variable 1259 ALLOCATE( root_area_density_lad_f%var & 1260 (0:root_area_density_lad_f%nz-1,& 1261 nys:nyn,nxl:nxr) ) 1262 1263 CALL get_variable( pids_id, 'root_area_dens_r', & 1264 root_area_density_lad_f%var, & 1265 nxl, nxr, nys, nyn, & 1266 0, root_area_density_lad_f%nz-1 ) 1272 ALLOCATE( root_area_density_lad_f%var & 1273 (0:root_area_density_lad_f%nz-1,nys:nyn,nxl:nxr) ) 1274 1275 CALL get_variable( pids_id, 'root_area_dens_r', root_area_density_lad_f%var, & 1276 nxl, nxr, nys, nyn, 0, root_area_density_lad_f%nz-1 ) 1267 1277 ELSE 1268 1278 root_area_density_lad_f%from_file = .FALSE. … … 1277 1287 1278 1288 ! 1279 !-- Initialize LAD with data from file. If LAD is given in NetCDF file, 1280 !-- use these values, else take LAD profiles from ASCII file.1281 !-- Please note, in NetCDF file LAD is only given up to the maximum 1282 !-- canopy top, indicated by leaf_area_density_f%nz.1289 !-- Initialize LAD with data from file. If LAD is given in NetCDF file, use these values, 1290 !-- else take LAD profiles from ASCII file. 1291 !-- Please note, in NetCDF file LAD is only given up to the maximum canopy top, indicated 1292 !-- by leaf_area_density_f%nz. 1283 1293 lad_s = 0.0_wp 1284 1294 IF ( leaf_area_density_f%from_file ) THEN 1285 1295 ! 1286 !-- Set also pch_index, used to be the upper bound of the vertical 1287 !-- loops. Therefore, use the global top of the canopy layer.1296 !-- Set also pch_index, used to be the upper bound of the vertical loops. Therefore, use 1297 !-- the global top of the canopy layer. 1288 1298 pch_index = leaf_area_density_f%nz - 1 1289 1299 … … 1291 1301 DO j = nys, nyn 1292 1302 DO k = 0, leaf_area_density_f%nz - 1 1293 IF ( leaf_area_density_f%var(k,j,i) /= & 1294 leaf_area_density_f%fill ) & 1295 lad_s(k,j,i) = leaf_area_density_f%var(k,j,i) 1303 IF ( leaf_area_density_f%var(k,j,i) /= leaf_area_density_f%fill ) & 1304 lad_s(k,j,i) = leaf_area_density_f%var(k,j,i) 1296 1305 ENDDO 1297 1306 ! 1298 1307 !-- Check if resolved vegetation is mapped onto buildings. 1299 !-- In general, this is allowed and also meaningful, e.g. 1300 !-- when trees carry across roofs. However, due to the 1301 !-- topography filtering, new building grid points can emerge 1302 !-- at location where also plant canopy is defined. As a 1303 !-- result, plant canopy is mapped on top of roofs, with 1304 !-- siginficant impact on the downstream flow field and the 1305 !-- nearby surface radiation. In order to avoid that 1306 !-- plant canopy is mistakenly mapped onto building roofs, 1307 !-- check for building grid points (bit 6) that emerge from 1308 !-- the filtering (bit 4) and set LAD to zero at these 1309 !-- artificially created building grid points. This case, 1310 !-- an informative message is given. 1311 IF ( ANY( lad_s(:,j,i) /= 0.0_wp ) .AND. & 1312 ANY( BTEST( wall_flags_total_0(:,j,i), 6 ) ) .AND. & 1308 !-- In general, this is allowed and also meaningful, e.g. when trees carry across 1309 !-- roofs. However, due to the topography filtering, new building grid points can 1310 !-- emerge at locations where also plant canopy is defined. As a result, plant 1311 !-- canopy is mapped on top of roofs, with siginficant impact on the downstream 1312 !-- flow field and the nearby surface radiation. In order to avoid that plant 1313 !-- canopy is mistakenly mapped onto building roofs, check for building grid 1314 !-- points (bit 6) that emerge from the filtering (bit 4) and set LAD to zero at 1315 !-- these artificially created building grid points. This case, an informative 1316 !-- message is given. 1317 IF ( ANY( lad_s(:,j,i) /= 0.0_wp ) .AND. & 1318 ANY( BTEST( wall_flags_total_0(:,j,i), 6 ) ) .AND. & 1313 1319 ANY( BTEST( wall_flags_total_0(:,j,i), 4 ) ) ) THEN 1314 1320 lad_s(:,j,i) = 0.0_wp … … 1318 1324 ENDDO 1319 1325 #if defined( __parallel ) 1320 CALL MPI_ALLREDUCE( MPI_IN_PLACE, lad_on_top, 1, MPI_LOGICAL, & 1321 MPI_LOR, comm2d, ierr) 1326 CALL MPI_ALLREDUCE( MPI_IN_PLACE, lad_on_top, 1, MPI_LOGICAL, MPI_LOR, comm2d, ierr) 1322 1327 #endif 1323 1328 IF ( lad_on_top ) THEN … … 1332 1337 ! 1333 1338 ! ASCII file 1334 !-- Initialize canopy parameters canopy_drag_coeff, 1335 !-- leaf_scalar_exch_coeff, leaf_surface_conc 1336 !-- from file which contains complete 3D data (separate vertical profiles for 1337 !-- each location). 1339 !-- Initialize canopy parameters canopy_drag_coeff, leaf_scalar_exch_coeff, 1340 !-- leaf_surface_conc from file which contains complete 3D data (separate vertical profiles 1341 !-- for each location). 1338 1342 ELSE 1339 1343 CALL pcm_read_plant_canopy_3d 1340 1344 ENDIF 1341 1345 ! 1342 !-- Initialize LAD with data from file. If LAD is given in NetCDF file, 1343 !-- use these values, else take LAD profiles from ASCII file.1344 !-- Please note, in NetCDF file LAD is only given up to the maximum 1345 !-- canopy top, indicated by basal_area_density_f%nz.1346 !-- Initialize LAD with data from file. If LAD is given in NetCDF file, use these values, 1347 !-- else take LAD profiles from ASCII file. 1348 !-- Please note, in NetCDF file LAD is only given up to the maximum canopy top, indicated 1349 !-- by basal_area_density_f%nz. 1346 1350 bad_s = 0.0_wp 1347 1351 IF ( basal_area_density_f%from_file ) THEN 1348 1352 ! 1349 !-- Set also pch_index, used to be the upper bound of the vertical 1350 !-- loops. Therefore, use the global top of the canopy layer.1353 !-- Set also pch_index, used to be the upper bound of the vertical loops. Therefore, use 1354 !-- the global top of the canopy layer. 1351 1355 pch_index = basal_area_density_f%nz - 1 1352 1356 … … 1360 1364 !-- Check if resolved vegetation is mapped onto buildings. 1361 1365 !-- Please see comment for leaf_area density 1362 IF ( ANY( bad_s(:,j,i) /= 0.0_wp ) .AND.&1363 ANY( BTEST( wall_flags_total_0(:,j,i), 6 ) ) .AND.&1366 IF ( ANY( bad_s(:,j,i) /= 0.0_wp ) .AND. & 1367 ANY( BTEST( wall_flags_total_0(:,j,i), 6 ) ) .AND. & 1364 1368 ANY( BTEST( wall_flags_total_0(:,j,i), 4 ) ) ) THEN 1365 1369 bad_s(:,j,i) = 0.0_wp … … 1369 1373 ENDDO 1370 1374 #if defined( __parallel ) 1371 CALL MPI_ALLREDUCE( MPI_IN_PLACE, bad_on_top, 1, MPI_LOGICAL, & 1372 MPI_LOR, comm2d, ierr) 1375 CALL MPI_ALLREDUCE( MPI_IN_PLACE, bad_on_top, 1, MPI_LOGICAL, MPI_LOR, comm2d, ierr) 1373 1376 #endif 1374 1377 IF ( bad_on_top ) THEN … … 1385 1388 CASE DEFAULT 1386 1389 ! 1387 !-- The DEFAULT case is reached either if the parameter 1388 !-- canopy mode contains a wrong character string or if the 1389 !-- user has coded a special case in the user interface. 1390 !-- There, the subroutine user_init_plant_canopy checks 1391 !-- which of these two conditions applies. 1390 !-- The DEFAULT case is reached either if the parameter canopy mode contains a wrong 1391 !-- character string or if the user has coded a special case in the user interface. 1392 !-- There, the subroutine user_init_plant_canopy checks which of these two conditions 1393 !-- applies. 1392 1394 CALL user_init_plant_canopy 1393 1395 1394 1396 END SELECT 1395 1397 ! 1396 !-- Check that at least one grid point has an LAD /= 0, else this may 1397 !-- cause errors in the radiation model.1398 !-- Check that at least one grid point has an LAD /= 0, else this may cause errors in the 1399 !-- radiation model. 1398 1400 lad_max = MAXVAL( lad_s ) 1399 1401 #if defined( __parallel ) 1400 CALL MPI_ALLREDUCE( MPI_IN_PLACE, lad_max, 1, MPI_REAL, MPI_MAX, & 1401 comm2d, ierr) 1402 CALL MPI_ALLREDUCE( MPI_IN_PLACE, lad_max, 1, MPI_REAL, MPI_MAX, comm2d, ierr) 1402 1403 #endif 1403 1404 IF ( lad_max <= 0.0_wp ) THEN 1404 message_string = 'Plant-canopy model is switched-on but no ' // &1405 message_string = 'Plant-canopy model is switched-on but no ' // & 1405 1406 'plant canopy is present in the model domain.' 1406 1407 CALL message( 'pcm_init', 'PA0685', 1, 2, 0, 6, 0 ) 1407 1408 ENDIF 1408 1409 ! 1410 !-- Initialize 2D index array indicating canopy top index. 1409 1410 ! 1411 !-- Initialize 2D index array indicating canopy top index. 1411 1412 ALLOCATE( pch_index_ji(nysg:nyng,nxlg:nxrg) ) 1412 1413 pch_index_ji = 0 1413 1414 1414 1415 DO i = nxlg, nxrg 1415 1416 DO j = nysg, nyng … … 1418 1419 ENDDO 1419 1420 ! 1420 !-- Check whether topography and local vegetation on top exceed 1421 !-- height of the model domain. 1421 !-- Check whether topography and local vegetation on top exceed height of the model domain. 1422 1422 IF ( topo_top_ind(j,i,0) + pch_index_ji(j,i) >= nzt + 1 ) THEN 1423 message_string = 'Local vegetation height on top of ' // &1423 message_string = 'Local vegetation height on top of ' // & 1424 1424 'topography exceeds height of model domain.' 1425 1425 CALL message( 'pcm_init', 'PA0674', 2, 2, myid, 6, 0 ) … … 1434 1434 !-- Exchange pch_index from all processors 1435 1435 #if defined( __parallel ) 1436 CALL MPI_ALLREDUCE( MPI_IN_PLACE, pch_index, 1, MPI_INTEGER, & 1437 MPI_MAX, comm2d, ierr) 1436 CALL MPI_ALLREDUCE( MPI_IN_PLACE, pch_index, 1, MPI_INTEGER, MPI_MAX, comm2d, ierr) 1438 1437 #endif 1439 1438 ! … … 1441 1440 ALLOCATE( pcm_heating_rate(0:pch_index,nysg:nyng,nxlg:nxrg) ) 1442 1441 pcm_heating_rate = 0.0_wp 1443 1442 1444 1443 IF ( humidity ) THEN 1445 1444 ALLOCATE( pcm_transpiration_rate(0:pch_index,nysg:nyng,nxlg:nxrg) ) … … 1449 1448 ENDIF 1450 1449 ! 1451 !-- Initialization of the canopy heat source distribution due to heating 1452 !-- of the canopy layers by incoming solar radiation, in case that a non-zero 1453 !-- value is set for the canopy top heat flux (cthf), which equals the 1454 !-- available net radiation at canopy top. 1455 !-- The heat source distribution is calculated by a decaying exponential 1456 !-- function of the downward cumulative leaf area index (cum_lai_hf), 1457 !-- assuming that the foliage inside the plant canopy is heated by solar 1458 !-- radiation penetrating the canopy layers according to the distribution 1459 !-- of net radiation as suggested by Brown & Covey (1966; Agric. Meteorol. 3, 1460 !-- 73â96). This approach has been applied e.g. by Shaw & Schumann (1992; 1461 !-- Bound.-Layer Meteorol. 61, 47â64). 1462 !-- When using the radiation_interactions, canopy heating (pcm_heating_rate) 1463 !-- and plant canopy transpiration (pcm_transpiration_rate, pcm_latent_rate) 1464 !-- are calculated in the RTM after the calculation of radiation. 1450 !-- Initialization of the canopy heat source distribution due to heating of the canopy layers by 1451 !-- incoming solar radiation, in case that a non-zero 1452 !-- value is set for the canopy top heat flux (cthf), which equals the available net radiation at 1453 !-- canopy top. 1454 !-- The heat source distribution is calculated by a decaying exponential function of the downward 1455 !-- cumulative leaf area index (cum_lai_hf), assuming that the foliage inside the plant canopy is 1456 !-- heated by solar radiation penetrating the canopy layers according to the distribution of net 1457 !-- radiation as suggested by Brown & Covey (1966; Agric. Meteorol. 3, 73â96). This approach has 1458 !-- been applied e.g. by Shaw & Schumann (1992; Bound.-Layer Meteorol. 61, 47â64). 1459 !-- When using the radiation_interactions, canopy heating (pcm_heating_rate) and plant canopy 1460 !-- transpiration (pcm_transpiration_rate, pcm_latent_rate) are calculated in the RTM after the 1461 !-- calculation of radiation. 1465 1462 IF ( cthf /= 0.0_wp ) THEN 1466 1463 1467 1464 ALLOCATE( cum_lai_hf(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 1468 1465 ! 1469 !-- Piecewise calculation of the cumulative leaf area index by vertical 1470 !-- integration of theleaf area density1466 !-- Piecewise calculation of the cumulative leaf area index by vertical integration of the 1467 !-- leaf area density 1471 1468 cum_lai_hf(:,:,:) = 0.0_wp 1472 1469 DO i = nxlg, nxrg … … 1474 1471 DO k = pch_index_ji(j,i)-1, 0, -1 1475 1472 IF ( k == pch_index_ji(j,i)-1 ) THEN 1476 cum_lai_hf(k,j,i) = cum_lai_hf(k+1,j,i) + &1477 ( 0.5_wp * lad_s(k+1,j,i) *&1478 ( zw(k+1) - zu(k+1) ) ) +&1479 ( 0.5_wp * ( 0.5_wp * ( lad_s(k+1,j,i) +&1480 lad_s(k,j,i) ) +&1481 lad_s(k+1,j,i) ) *&1482 ( zu(k+1) - zw(k) ) )1473 cum_lai_hf(k,j,i) = cum_lai_hf(k+1,j,i) + & 1474 ( 0.5_wp * lad_s(k+1,j,i) * & 1475 ( zw(k+1) - zu(k+1) ) ) + & 1476 ( 0.5_wp * ( 0.5_wp * ( lad_s(k+1,j,i) + & 1477 lad_s(k,j,i) ) + & 1478 lad_s(k+1,j,i) ) * & 1479 ( zu(k+1) - zw(k) ) ) 1483 1480 ELSE 1484 cum_lai_hf(k,j,i) = cum_lai_hf(k+1,j,i) + &1485 ( 0.5_wp * ( 0.5_wp * ( lad_s(k+2,j,i) +&1486 lad_s(k+1,j,i) ) +&1487 lad_s(k+1,j,i) ) *&1488 ( zw(k+1) - zu(k+1) ) ) +&1489 ( 0.5_wp * ( 0.5_wp * ( lad_s(k+1,j,i) +&1490 lad_s(k,j,i) ) +&1491 lad_s(k+1,j,i) ) *&1492 ( zu(k+1) - zw(k) ) )1481 cum_lai_hf(k,j,i) = cum_lai_hf(k+1,j,i) + & 1482 ( 0.5_wp * ( 0.5_wp * ( lad_s(k+2,j,i) + & 1483 lad_s(k+1,j,i) ) + & 1484 lad_s(k+1,j,i) ) * & 1485 ( zw(k+1) - zu(k+1) ) ) + & 1486 ( 0.5_wp * ( 0.5_wp * ( lad_s(k+1,j,i) + & 1487 lad_s(k,j,i) ) + & 1488 lad_s(k+1,j,i) ) * & 1489 ( zu(k+1) - zw(k) ) ) 1493 1490 ENDIF 1494 1491 ENDDO … … 1497 1494 1498 1495 ! 1499 !-- In areas with canopy the surface value of the canopy heat 1500 !-- flux distribution overrides the surface heat flux (shf)1496 !-- In areas with canopy the surface value of the canopy heat flux distribution overrides the 1497 !-- surface heat flux (shf), 1501 1498 !-- Start with default surface type 1502 1499 DO m = 1, surf_def_h(0)%ns 1503 1500 i = surf_def_h(0)%i(m) 1504 1501 j = surf_def_h(0)%j(m) 1505 IF ( cum_lai_hf(0,j,i) /= 0.0_wp ) &1506 surf_def_h(0)%shf(m) = cthf * exp( -ext_coef * cum_lai_hf(0,j,i) )1502 IF ( cum_lai_hf(0,j,i) /= 0.0_wp ) & 1503 surf_def_h(0)%shf(m) = cthf * EXP( -ext_coef * cum_lai_hf(0,j,i) ) 1507 1504 ENDDO 1508 1505 ! … … 1511 1508 i = surf_lsm_h(0)%i(m) 1512 1509 j = surf_lsm_h(0)%j(m) 1513 IF ( cum_lai_hf(0,j,i) /= 0.0_wp ) &1514 surf_lsm_h(0)%shf(m) = cthf * exp( -ext_coef * cum_lai_hf(0,j,i) )1510 IF ( cum_lai_hf(0,j,i) /= 0.0_wp ) & 1511 surf_lsm_h(0)%shf(m) = cthf * EXP( -ext_coef * cum_lai_hf(0,j,i) ) 1515 1512 ENDDO 1516 1513 ! … … 1519 1516 i = surf_usm_h(0)%i(m) 1520 1517 j = surf_usm_h(0)%j(m) 1521 IF ( cum_lai_hf(0,j,i) /= 0.0_wp ) &1522 surf_usm_h(0)%shf(m) = cthf * exp( -ext_coef * cum_lai_hf(0,j,i) )1518 IF ( cum_lai_hf(0,j,i) /= 0.0_wp ) & 1519 surf_usm_h(0)%shf(m) = cthf * EXP( -ext_coef * cum_lai_hf(0,j,i) ) 1523 1520 ENDDO 1524 1521 ! 1525 1522 ! 1526 !-- Calculation of the heating rate (K/s) within the different layers of 1527 !-- the plant canopy. Calculation is only necessary in areas covered with 1528 !-- canopy. 1529 !-- Within the different canopy layers the plant-canopy heating 1530 !-- rate (pcm_heating_rate) is calculated as the vertical 1531 !-- divergence of the canopy heat fluxes at the top and bottom 1532 !-- of the respective layer 1523 !-- Calculation of the heating rate (K/s) within the different layers of the plant canopy. 1524 !-- Calculation is only necessary in areas covered with canopy. 1525 !-- Within the different canopy layers the plant-canopy heating rate (pcm_heating_rate) is 1526 !-- calculated as the vertical divergence of the canopy heat fluxes at the top and bottom of 1527 !-- the respective layer. 1533 1528 DO i = nxlg, nxrg 1534 1529 DO j = nysg, nyng 1535 1530 DO k = 1, pch_index_ji(j,i) 1536 1531 IF ( cum_lai_hf(0,j,i) /= 0.0_wp ) THEN 1537 pcm_heating_rate(k,j,i) = cthf * &1538 ( exp(-ext_coef*cum_lai_hf(k,j,i)) - &1539 exp(-ext_coef*cum_lai_hf(k-1,j,i) ) ) / dzw(k)1532 pcm_heating_rate(k,j,i) = cthf * & 1533 ( EXP( -ext_coef * cum_lai_hf(k,j,i) ) - & 1534 EXP( -ext_coef * cum_lai_hf(k-1,j,i) ) ) / dzw(k) 1540 1535 ENDIF 1541 1536 ENDDO … … 1550 1545 1551 1546 1552 !------------------------------------------------------------------------------ !1547 !--------------------------------------------------------------------------------------------------! 1553 1548 ! Description: 1554 1549 ! ------------ 1555 1550 !> Parin for &plant_canopy_parameters for plant canopy model 1556 !------------------------------------------------------------------------------ !1551 !--------------------------------------------------------------------------------------------------! 1557 1552 SUBROUTINE pcm_parin 1558 1553 1559 CHARACTER (LEN=80) :: line !< dummy string that contains the current line of the parameter file 1560 1561 NAMELIST /plant_canopy_parameters/ & 1562 alpha_lad, beta_lad, canopy_drag_coeff, & 1563 canopy_mode, cthf, & 1564 lad_surface, lad_type_coef, & 1565 lad_vertical_gradient, & 1566 lad_vertical_gradient_level, & 1567 lai_beta, & 1568 leaf_scalar_exch_coeff, & 1569 leaf_surface_conc, pch_index, & 1570 plant_canopy_transpiration 1571 1572 NAMELIST /canopy_par/ alpha_lad, beta_lad, canopy_drag_coeff, & 1573 canopy_mode, cthf, & 1574 lad_surface, lad_type_coef, & 1575 lad_vertical_gradient, & 1576 lad_vertical_gradient_level, & 1577 lai_beta, & 1578 leaf_scalar_exch_coeff, & 1579 leaf_surface_conc, pch_index, & 1580 plant_canopy_transpiration 1554 CHARACTER (LEN=80) :: line !< dummy string that contains the current line of the parameter file 1555 1556 NAMELIST /plant_canopy_parameters/ alpha_lad, & 1557 beta_lad, & 1558 canopy_drag_coeff, & 1559 canopy_mode, & 1560 cthf, & 1561 lad_surface, & 1562 lad_type_coef, & 1563 lad_vertical_gradient, & 1564 lad_vertical_gradient_level, & 1565 lai_beta, & 1566 leaf_scalar_exch_coeff, & 1567 leaf_surface_conc, & 1568 pch_index, & 1569 plant_canopy_transpiration 1570 1571 NAMELIST /canopy_par/ alpha_lad, & 1572 beta_lad, & 1573 canopy_drag_coeff, & 1574 canopy_mode, & 1575 cthf, & 1576 lad_surface, & 1577 lad_type_coef, & 1578 lad_vertical_gradient, & 1579 lad_vertical_gradient_level, & 1580 lai_beta, & 1581 leaf_scalar_exch_coeff, & 1582 leaf_surface_conc, & 1583 pch_index, & 1584 plant_canopy_transpiration 1581 1585 1582 1586 line = ' ' … … 1584 1588 ! 1585 1589 !-- Try to find plant-canopy model package 1586 REWIND 1590 REWIND( 11 ) 1587 1591 line = ' ' 1588 1592 DO WHILE ( INDEX( line, '&plant_canopy_parameters' ) == 0 ) 1589 READ 1593 READ( 11, '(A)', END=12 ) line 1590 1594 ENDDO 1591 BACKSPACE 1595 BACKSPACE( 11 ) 1592 1596 1593 1597 ! 1594 1598 !-- Read user-defined namelist 1595 READ 1599 READ( 11, plant_canopy_parameters, ERR = 10 ) 1596 1600 1597 1601 ! … … 1606 1610 ! 1607 1611 !-- Try to find old namelist 1608 12 REWIND 1612 12 REWIND( 11 ) 1609 1613 line = ' ' 1610 1614 DO WHILE ( INDEX( line, '&canopy_par' ) == 0 ) 1611 READ 1615 READ( 11, '(A)', END=14 ) line 1612 1616 ENDDO 1613 BACKSPACE 1617 BACKSPACE( 11 ) 1614 1618 1615 1619 ! 1616 1620 !-- Read user-defined namelist 1617 READ 1618 1619 message_string = 'namelist canopy_par is deprecated and will be ' // &1620 'removed in near future. Please use namelist ' //&1621 'plant_canopy_parameters instead'1621 READ( 11, canopy_par, ERR = 13, END = 14 ) 1622 1623 message_string = 'namelist canopy_par is deprecated and will be ' // & 1624 'removed in near future. Please use namelist ' // & 1625 'plant_canopy_parameters instead' 1622 1626 CALL message( 'pcm_parin', 'PA0487', 0, 1, 0, 6, 0 ) 1623 1627 … … 1637 1641 1638 1642 1639 !------------------------------------------------------------------------------ !1643 !--------------------------------------------------------------------------------------------------! 1640 1644 ! Description: 1641 1645 ! ------------ … … 1649 1653 !> ... 1650 1654 !> 1651 !> i.e. first line determines number of levels and further lines represent plant 1652 !> canopy data, one line per column and variable. In each data line, 1653 !> dtype represents variable to be set: 1655 !> i.e. first line determines number of levels and further lines represent plant canopy data, one 1656 !> line per column and variable. In each data line, dtype represents variable to be set: 1654 1657 !> 1655 1658 !> dtype=1: leaf area density (lad_s) 1656 1659 !> dtype=2....n: some additional plant canopy input data quantity 1657 1660 !> 1658 !> Zeros are added automatically above num_levels until top of domain. Any1659 !> non-specified (x,y)columns have zero values as default.1660 !------------------------------------------------------------------------------ !1661 !> Zeros are added automatically above num_levels until top of domain. Any non-specified (x,y) 1662 !> columns have zero values as default. 1663 !--------------------------------------------------------------------------------------------------! 1661 1664 SUBROUTINE pcm_read_plant_canopy_3d 1662 1665 1663 USE exchange_horiz_mod, &1666 USE exchange_horiz_mod, & 1664 1667 ONLY: exchange_horiz 1665 1668 1666 INTEGER(iwp) :: dtype !< type of input data (1=lad) 1667 INTEGER(iwp) :: pctype !< type of plant canopy (deciduous,non-deciduous,...) 1668 INTEGER(iwp) :: i, j !< running index 1669 INTEGER(iwp) :: nzp !< number of vertical layers of plant canopy 1670 INTEGER(iwp) :: nzpltop !< 1671 INTEGER(iwp) :: nzpl !< 1672 INTEGER(iwp) :: kk !< 1673 1669 INTEGER(iwp) :: dtype !< type of input data (1=lad) 1670 INTEGER(iwp) :: i !< running index 1671 INTEGER(iwp) :: j !< running index 1672 INTEGER(iwp) :: kk !< 1673 INTEGER(iwp) :: nzp !< number of vertical layers of plant canopy 1674 INTEGER(iwp) :: nzpltop !< 1675 INTEGER(iwp) :: nzpl !< 1676 INTEGER(iwp) :: pctype !< type of plant canopy (deciduous,non-deciduous,...) 1677 1674 1678 REAL(wp), DIMENSION(:), ALLOCATABLE :: col !< vertical column of input data 1675 1679 … … 1677 1681 !-- Initialize lad_s array 1678 1682 lad_s = 0.0_wp 1679 1683 1680 1684 ! 1681 1685 !-- Open and read plant canopy input data 1682 OPEN(152, FILE='PLANT_CANOPY_DATA_3D' // TRIM( coupling_char ), & 1683 ACCESS='SEQUENTIAL', ACTION='READ', STATUS='OLD', & 1684 FORM='FORMATTED', ERR=515) 1685 READ(152, *, ERR=516, END=517) nzp !< read first line = number of vertical layers 1686 OPEN( 152, FILE='PLANT_CANOPY_DATA_3D' // TRIM( coupling_char ), ACCESS='SEQUENTIAL', & 1687 ACTION='READ', STATUS='OLD', FORM='FORMATTED', ERR=515 ) 1688 READ( 152, *, ERR=516, END=517 ) nzp !< read first line = number of vertical layers 1686 1689 nzpltop = MIN(nzt+1, nzb+nzp-1) 1687 1690 nzpl = nzpltop - nzb + 1 !< no. of layers to assign … … 1689 1692 1690 1693 DO 1691 READ( 152, *, ERR=516, END=517) dtype, i, j, pctype, col(:)1694 READ( 152, *, ERR=516, END=517 ) dtype, i, j, pctype, col(:) 1692 1695 IF ( i < nxlg .OR. i > nxrg .OR. j < nysg .OR. j > nyng ) CYCLE 1693 1694 SELECT CASE ( dtype)1696 1697 SELECT CASE ( dtype ) 1695 1698 CASE( 1 ) !< leaf area density 1696 1699 ! 1697 !-- This is just the pure canopy layer assumed to be grounded to 1698 !-- a flat domain surface. At locations where plant canopy sits 1699 !-- on top of any kind of topography, the vertical plant column 1700 !-- must be "lifted", which is done in SUBROUTINE pcm_tendency. 1700 !-- This is just the pure canopy layer assumed to be grounded to a flat domain surface. 1701 !-- At locations where plant canopy sits on top of any kind of topography, the vertical 1702 !-- plant column must be "lifted", which is done in SUBROUTINE pcm_tendency. 1701 1703 IF ( pctype < 0 .OR. pctype > 10 ) THEN !< incorrect plant canopy type 1702 WRITE( message_string, * ) 'Incorrect type of plant canopy. ' // &1703 'Allowed values 0 <= pctype <= 10, ' // &1704 WRITE( message_string, * ) 'Incorrect type of plant canopy. ' // & 1705 'Allowed values 0 <= pctype <= 10, ' // & 1704 1706 'but pctype is ', pctype 1705 1707 CALL message( 'pcm_read_plant_canopy_3d', 'PA0349', 1, 2, 0, 6, 0 ) … … 1708 1710 lad_s(nzb:nzpltop-kk, j, i) = col(kk:nzpl-1)*lad_type_coef(pctype) 1709 1711 CASE DEFAULT 1710 WRITE( message_string, '(a,i2,a)')&1712 WRITE( message_string, '(a,i2,a)' ) & 1711 1713 'Unknown record type in file PLANT_CANOPY_DATA_3D: "', dtype, '"' 1712 1714 CALL message( 'pcm_read_plant_canopy_3d', 'PA0530', 1, 2, 0, 6, 0 ) … … 1720 1722 CALL message( 'pcm_read_plant_canopy_3d', 'PA0532', 1, 2, 0, 6, 0 ) 1721 1723 1722 517 CLOSE( 152)1724 517 CLOSE( 152 ) 1723 1725 DEALLOCATE( col ) 1724 1726 1725 1727 CALL exchange_horiz( lad_s, nbgp ) 1726 1728 1727 1729 END SUBROUTINE pcm_read_plant_canopy_3d 1728 1730 1729 !------------------------------------------------------------------------------ !1731 !--------------------------------------------------------------------------------------------------! 1730 1732 ! Description: 1731 1733 ! ------------ 1732 1734 !> Read module-specific global restart data (Fortran binary format). 1733 !------------------------------------------------------------------------------ !1735 !--------------------------------------------------------------------------------------------------! 1734 1736 SUBROUTINE pcm_rrd_global_ftn( found ) 1735 1737 1736 LOGICAL, INTENT(OUT) :: found 1738 LOGICAL, INTENT(OUT) :: found 1739 1737 1740 1738 1741 found = .TRUE. … … 1741 1744 1742 1745 CASE ( 'pch_index' ) 1743 READ 1746 READ( 13 ) pch_index 1744 1747 1745 1748 CASE DEFAULT … … 1751 1754 END SUBROUTINE pcm_rrd_global_ftn 1752 1755 1753 !------------------------------------------------------------------------------ !1756 !--------------------------------------------------------------------------------------------------! 1754 1757 ! Description: 1755 1758 ! ------------ 1756 1759 !> Read module-specific global restart data (MPI-IO). 1757 !------------------------------------------------------------------------------ !1760 !--------------------------------------------------------------------------------------------------! 1758 1761 SUBROUTINE pcm_rrd_global_mpi 1759 1762 … … 1763 1766 1764 1767 1765 !------------------------------------------------------------------------------ !1768 !--------------------------------------------------------------------------------------------------! 1766 1769 ! Description: 1767 1770 ! ------------ 1768 1771 !> Read module-specific local restart data arrays (Fortran binary format). 1769 !------------------------------------------------------------------------------! 1770 SUBROUTINE pcm_rrd_local_ftn( k, nxlf, nxlc, nxl_on_file, nxrf, nxrc, & 1771 nxr_on_file, nynf, nync, nyn_on_file, nysf, & 1772 nysc, nys_on_file, found ) 1773 1774 INTEGER(iwp) :: k !< 1775 INTEGER(iwp) :: nxlc !< 1776 INTEGER(iwp) :: nxlf !< 1777 INTEGER(iwp) :: nxl_on_file !< 1778 INTEGER(iwp) :: nxrc !< 1779 INTEGER(iwp) :: nxrf !< 1780 INTEGER(iwp) :: nxr_on_file !< 1781 INTEGER(iwp) :: nync !< 1782 INTEGER(iwp) :: nynf !< 1783 INTEGER(iwp) :: nyn_on_file !< 1784 INTEGER(iwp) :: nysc !< 1785 INTEGER(iwp) :: nysf !< 1786 INTEGER(iwp) :: nys_on_file !< 1787 1788 LOGICAL, INTENT(OUT) :: found 1789 1790 REAL(wp), DIMENSION(0:pch_index, & 1791 nys_on_file-nbgp:nyn_on_file+nbgp, & 1792 nxl_on_file-nbgp:nxr_on_file+nbgp) :: tmp_3d2 !< temporary 3D array for entire vertical 1793 !< extension of canopy layer 1772 !--------------------------------------------------------------------------------------------------! 1773 SUBROUTINE pcm_rrd_local_ftn( k, nxlf, nxlc, nxl_on_file, nxrf, nxrc, nxr_on_file, nynf, nync, & 1774 nyn_on_file, nysf, nysc, nys_on_file, found ) 1775 1776 INTEGER(iwp) :: k !< 1777 INTEGER(iwp) :: nxl_on_file !< 1778 INTEGER(iwp) :: nxlc !< 1779 INTEGER(iwp) :: nxlf !< 1780 INTEGER(iwp) :: nxr_on_file !< 1781 INTEGER(iwp) :: nxrc !< 1782 INTEGER(iwp) :: nxrf !< 1783 INTEGER(iwp) :: nyn_on_file !< 1784 INTEGER(iwp) :: nync !< 1785 INTEGER(iwp) :: nynf !< 1786 INTEGER(iwp) :: nys_on_file !< 1787 INTEGER(iwp) :: nysc !< 1788 INTEGER(iwp) :: nysf !< 1789 1790 LOGICAL, INTENT(OUT) :: found 1791 1792 REAL(wp), DIMENSION( 0:pch_index, & 1793 nys_on_file-nbgp:nyn_on_file+nbgp, & 1794 nxl_on_file-nbgp:nxr_on_file+nbgp) :: tmp_3d2 !< temporary 3D array for entire vertical 1795 !< extension of canopy layer 1794 1796 found = .TRUE. 1797 1795 1798 1796 1799 SELECT CASE ( restart_string(1:length) ) … … 1800 1803 ALLOCATE( pcm_heatrate_av(0:pch_index,nysg:nyng,nxlg:nxrg) ) 1801 1804 pcm_heatrate_av = 0.0_wp 1802 ENDIF 1803 IF ( k == 1 ) READ 1804 pcm_heatrate_av(0:pch_index,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &1805 ENDIF 1806 IF ( k == 1 ) READ( 13 ) tmp_3d2 1807 pcm_heatrate_av(0:pch_index,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = & 1805 1808 tmp_3d2(0:pch_index,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) 1806 1809 … … 1809 1812 ALLOCATE( pcm_latentrate_av(0:pch_index,nysg:nyng,nxlg:nxrg) ) 1810 1813 pcm_latentrate_av = 0.0_wp 1811 ENDIF 1812 IF ( k == 1 ) READ 1813 pcm_latentrate_av(0:pch_index,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &1814 ENDIF 1815 IF ( k == 1 ) READ( 13 ) tmp_3d2 1816 pcm_latentrate_av(0:pch_index,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = & 1814 1817 tmp_3d2(0:pch_index,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) 1815 1818 … … 1818 1821 ALLOCATE( pcm_transpirationrate_av(0:pch_index,nysg:nyng,nxlg:nxrg) ) 1819 1822 pcm_transpirationrate_av = 0.0_wp 1820 ENDIF 1821 IF ( k == 1 ) READ 1822 pcm_transpirationrate_av(0:pch_index,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &1823 ENDIF 1824 IF ( k == 1 ) READ( 13 ) tmp_3d2 1825 pcm_transpirationrate_av(0:pch_index,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = & 1823 1826 tmp_3d2(0:pch_index,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) 1824 1827 … … 1832 1835 1833 1836 1834 !------------------------------------------------------------------------------ !1837 !--------------------------------------------------------------------------------------------------! 1835 1838 ! Description: 1836 1839 ! ------------ 1837 1840 !> Read module-specific local restart data arrays (MPI-IO). 1838 !------------------------------------------------------------------------------ !1841 !--------------------------------------------------------------------------------------------------! 1839 1842 SUBROUTINE pcm_rrd_local_mpi 1840 1843 … … 1885 1888 1886 1889 1887 !------------------------------------------------------------------------------ !1890 !--------------------------------------------------------------------------------------------------! 1888 1891 ! Description: 1889 1892 ! ------------ 1890 !> Calculation of the tendency terms, accounting for the effect of the plant 1891 !> canopy on momentum andscalar quantities.1893 !> Calculation of the tendency terms, accounting for the effect of the plant canopy on momentum and 1894 !> scalar quantities. 1892 1895 !> 1893 !> The canopy is located where the leaf area density lad_s(k,j,i) > 0.0 1894 !> (defined on scalar grid), as initialized in subroutine pcm_init. 1895 !> The lad on the w-grid is vertically interpolated from the surrounding 1896 !> lad_s. The upper boundary of the canopy is defined on the w-grid at 1897 !> k = pch_index. Here, the lad is zero. 1896 !> The canopy is located where the leaf area density lad_s(k,j,i) > 0.0 (defined on scalar grid), as 1897 !> initialized in subroutine pcm_init. 1898 !> The lad on the w-grid is vertically interpolated from the surrounding lad_s. The upper boundary 1899 !> of the canopy is defined on the w-grid at k = pch_index. Here, the lad is zero. 1898 1900 !> 1899 !> The canopy drag must be limited (previously accounted for by calculation of 1900 !> a limiting canopy timestep for the determination of the maximum LES timestep 1901 !> in subroutine timestep), since it is physically impossible that the canopy 1902 !> drag alone can locally change the sign of a velocity component. This 1903 !> limitation is realized by calculating preliminary tendencies and velocities. 1904 !> It is subsequently checked if the preliminary new velocity has a different 1905 !> sign than the current velocity. If so, the tendency is limited in a way that 1906 !> the velocity can at maximum be reduced to zero by the canopy drag. 1901 !> The canopy drag must be limited (previously accounted for by calculation of a limiting canopy 1902 !> timestep for the determination of the maximum LES timestep in subroutine timestep), since it is 1903 !> physically impossible that the canopy drag alone can locally change the sign of a velocity 1904 !> component. This limitation is realized by calculating preliminary tendencies and velocities. It 1905 !> is subsequently checked if the preliminary new velocity has a different sign than the current 1906 !> velocity. If so, the tendency is limited in a way that the velocity can at maximum be reduced to 1907 !> zero by the canopy drag. 1907 1908 !> 1908 1909 !> 1909 1910 !> Call for all grid points 1910 !------------------------------------------------------------------------------ !1911 !--------------------------------------------------------------------------------------------------! 1911 1912 SUBROUTINE pcm_tendency( component ) 1912 1913 … … 1926 1927 REAL(wp) :: lad_local !< local lad value 1927 1928 REAL(wp) :: pre_tend !< preliminary tendency 1928 REAL(wp) :: pre_u !< preliminary u-value 1929 REAL(wp) :: pre_v !< preliminary v-value 1930 REAL(wp) :: pre_w !< preliminary w-value 1929 REAL(wp) :: pre_u !< preliminary u-value 1930 REAL(wp) :: pre_v !< preliminary v-value 1931 REAL(wp) :: pre_w !< preliminary w-value 1931 1932 1932 1933 1933 1934 ddt_3d = 1.0_wp / dt_3d 1934 1935 1935 1936 ! 1936 1937 !-- Compute drag for the three velocity components and the SGS-TKE: … … 1943 1944 DO j = nys, nyn 1944 1945 ! 1945 !-- Set control flags indicating east- and westward-orientated 1946 !-- building edges. Note, building_egde_w is set from the perspective 1947 !-- of the potential rooftop grid point, while building_edge_e is 1948 !-- is set from the perspective of the non-building grid point. 1949 building_edge_w = ANY( BTEST( wall_flags_total_0(:,j,i), 6 ) )& 1950 .AND. .NOT. ANY( BTEST( wall_flags_total_0(:,j,i-1), 6 ) ) 1951 building_edge_e = ANY( BTEST( wall_flags_total_0(:,j,i-1), 6 ) )& 1952 .AND. .NOT. ANY( BTEST( wall_flags_total_0(:,j,i), 6 ) ) 1946 !-- Set control flags indicating east- and westward-orientated building edges. Note, 1947 !-- building_egde_w is set from the perspective of the potential rooftop grid point, 1948 !-- while building_edge_e is set from the perspective of the non-building grid point. 1949 building_edge_w = ANY( BTEST( wall_flags_total_0(:,j,i), 6 ) ) & 1950 .AND. .NOT. ANY( BTEST( wall_flags_total_0(:,j,i-1), 6 ) ) 1951 building_edge_e = ANY( BTEST( wall_flags_total_0(:,j,i-1), 6 ) ) & 1952 .AND. .NOT. ANY( BTEST( wall_flags_total_0(:,j,i), 6 ) ) 1953 1953 ! 1954 1954 !-- Determine topography-top index on u-grid … … 1957 1957 kk = k - topo_top_ind(j,i,1) !- lad arrays are defined flat 1958 1958 ! 1959 !-- In order to create sharp boundaries of the plant canopy, 1960 !-- the lad on the u-grid at index (k,j,i) is equal to lad_s(k,j,i), 1961 !-- rather than being interpolated from the surrounding lad_s, 1962 !-- because this would yield smaller lad at the canopy boundaries 1963 !-- than inside of the canopy. 1964 !-- For the same reason, the lad at the rightmost(i+1)canopy 1965 !-- boundary on the u-grid equals lad_s(k,j,i), which is considered 1966 !-- in the next if-statement. Note, at left-sided building edges 1967 !-- this is not applied, here the LAD is equals the LAD at grid 1968 !-- point (k,j,i), in order to avoid that LAD is mistakenly mapped 1969 !-- on top of a roof where (usually) is no LAD is defined. The same is 1970 !-- also valid for bad_s. 1959 !-- In order to create sharp boundaries of the plant canopy, the lad on the u-grid 1960 !-- at index (k,j,i) is equal to lad_s(k,j,i), rather than being interpolated from 1961 !-- the surrounding lad_s, because this would yield smaller lad at the canopy 1962 !-- boundaries than inside of the canopy. 1963 !-- For the same reason, the lad at the rightmost(i+1)canopy boundary on the 1964 !-- u-grid equals lad_s(k,j,i), which is considered in the next if-statement. 1965 !-- Note, at left-sided building edges this is not applied, here the LAD equals 1966 !-- the LAD at grid point (k,j,i), in order to avoid that LAD is mistakenly mapped 1967 !-- on top of a roof where (usually) no LAD is defined. The same is also valid for 1968 !-- bad_s. 1971 1969 lad_local = lad_s(kk,j,i) 1972 1970 IF ( lad_local == 0.0_wp .AND. lad_s(kk,j,i-1) > 0.0_wp & … … 1977 1975 .AND. .NOT. building_edge_w ) bad_local = bad_s(kk,j,i-1) 1978 1976 ! 1979 !-- In order to avoid that LAD is mistakenly considered at right- 1980 !-- sided building edges (here the topography-top index for the 1981 !-- u-component at index j,i is still on the building while the 1982 !-- topography top for the scalar isn't), LAD is taken from grid 1983 !-- point (j,i-1). The same is also valid for bad_s. 1977 !-- In order to avoid that LAD is mistakenly considered at right-sided building 1978 !-- edges (here the topography-top index for the u-component at index j,i is still 1979 !-- on the building while the topography top for the scalar isn't), LAD is taken 1980 !-- from grid point (j,i-1). The same is also valid for bad_s. 1984 1981 IF ( lad_local > 0.0_wp .AND. lad_s(kk,j,i-1) == 0.0_wp & 1985 1982 .AND. building_edge_e ) lad_local = lad_s(kk,j,i-1) … … 1991 1988 ! 1992 1989 !-- Calculate preliminary value (pre_tend) of the tendency 1993 pre_tend = - canopy_drag_coeff * &1994 ( lad_local + bad_local ) * &1995 SQRT( u(k,j,i)**2 + &1996 ( 0.25_wp * ( v(k,j,i-1) + &1997 v(k,j,i) + &1998 v(k,j+1,i) + &1999 v(k,j+1,i-1) ) &2000 )**2 + &2001 ( 0.25_wp * ( w(k-1,j,i-1) + &2002 w(k-1,j,i) + &2003 w(k,j,i-1) + &2004 w(k,j,i) ) &2005 )**2 &2006 ) * &1990 pre_tend = - canopy_drag_coeff * & 1991 ( lad_local + bad_local ) * & 1992 SQRT( u(k,j,i)**2 + & 1993 ( 0.25_wp * ( v(k,j,i-1) + & 1994 v(k,j,i) + & 1995 v(k,j+1,i) + & 1996 v(k,j+1,i-1) ) & 1997 )**2 + & 1998 ( 0.25_wp * ( w(k-1,j,i-1) + & 1999 w(k-1,j,i) + & 2000 w(k,j,i-1) + & 2001 w(k,j,i) ) & 2002 )**2 & 2003 ) * & 2007 2004 u(k,j,i) 2008 2005 … … 2013 2010 !-- Compare sign of old velocity and new preliminary velocity, 2014 2011 !-- and in case the signs are different, limit the tendency 2015 IF ( SIGN( pre_u,u(k,j,i)) /= pre_u ) THEN2012 IF ( SIGN( pre_u,u(k,j,i) ) /= pre_u ) THEN 2016 2013 pre_tend = - u(k,j,i) * ddt_3d 2017 2014 ENDIF … … 2030 2027 DO j = nysv, nyn 2031 2028 ! 2032 !-- Set control flags indicating north- and southward-orientated 2033 !-- building edges. Note, building_egde_s is set from the perspective2034 !-- of the potential rooftop grid point, while building_edge_n is2035 !-- is set from the perspective of the non-building gridpoint.2036 building_edge_s = ANY( BTEST( wall_flags_total_0(:,j,i), 6 ) )&2037 .AND. .NOT. ANY( BTEST( wall_flags_total_0(:,j-1,i), 6 ) )2038 building_edge_n = ANY( BTEST( wall_flags_total_0(:,j-1,i), 6 ) )&2039 .AND. .NOT. ANY( BTEST( wall_flags_total_0(:,j,i), 6 ) )2029 !-- Set control flags indicating north- and southward-orientated building edges. 2030 !-- Note, building_egde_s is set from the perspective of the potential rooftop grid 2031 !-- point, while building_edge_n is set from the perspective of the non-building grid 2032 !-- point. 2033 building_edge_s = ANY( BTEST( wall_flags_total_0(:,j,i), 6 ) ) & 2034 .AND. .NOT. ANY( BTEST( wall_flags_total_0(:,j-1,i), 6 ) ) 2035 building_edge_n = ANY( BTEST( wall_flags_total_0(:,j-1,i), 6 ) ) & 2036 .AND. .NOT. ANY( BTEST( wall_flags_total_0(:,j,i), 6 ) ) 2040 2037 ! 2041 2038 !-- Determine topography-top index on v-grid … … 2044 2041 kk = k - topo_top_ind(j,i,2) !- lad arrays are defined flat 2045 2042 ! 2046 !-- In order to create sharp boundaries of the plant canopy, 2047 !-- the lad on the v-grid at index (k,j,i) is equal to lad_s(k,j,i), 2048 !-- rather than being interpolated from the surrounding lad_s, 2049 !-- because this would yield smaller lad at the canopy boundaries 2050 !-- than inside of the canopy. 2051 !-- For the same reason, the lad at the northmost(j+1)canopy 2052 !-- boundary on the v-grid equals lad_s(k,j,i), which is considered 2053 !-- in the next if-statement. Note, at left-sided building edges 2054 !-- this is not applied, here the LAD is equals the LAD at grid 2055 !-- point (k,j,i), in order to avoid that LAD is mistakenly mapped 2056 !-- on top of a roof where (usually) is no LAD is defined. 2043 !-- In order to create sharp boundaries of the plant canopy, the lad on the v-grid 2044 !-- at index (k,j,i) is equal to lad_s(k,j,i), rather than being interpolated from 2045 !-- the surrounding lad_s, because this would yield smaller lad at the canopy 2046 !-- boundaries than inside of the canopy. 2047 !-- For the same reason, the lad at the northmost (j+1) canopy boundary on the 2048 !-- v-grid equals lad_s(k,j,i), which is considered in the next if-statement. 2049 !-- Note, at left-sided building edges this is not applied, here the LAD equals 2050 !-- the LAD at grid point (k,j,i), in order to avoid that LAD is mistakenly mapped 2051 !-- on top of a roof where (usually) no LAD is defined. 2057 2052 !-- The same is also valid for bad_s. 2058 2053 lad_local = lad_s(kk,j,i) 2059 2054 IF ( lad_local == 0.0_wp .AND. lad_s(kk,j-1,i) > 0.0_wp & 2060 .AND. .NOT. building_edge_s ) lad_local = lad_s(kk,j-1,i)2055 .AND. .NOT. building_edge_s ) lad_local = lad_s(kk,j-1,i) 2061 2056 2062 2057 bad_local = bad_s(kk,j,i) 2063 2058 IF ( bad_local == 0.0_wp .AND. bad_s(kk,j-1,i) > 0.0_wp & 2064 .AND. .NOT. building_edge_s ) bad_local = bad_s(kk,j-1,i) 2065 ! 2066 !-- In order to avoid that LAD is mistakenly considered at right- 2067 !-- sided building edges (here the topography-top index for the 2068 !-- u-component at index j,i is still on the building while the 2069 !-- topography top for the scalar isn't), LAD is taken from grid 2070 !-- point (j,i-1). The same is also valid for bad_s. 2059 .AND. .NOT. building_edge_s ) bad_local = bad_s(kk,j-1,i) 2060 ! 2061 !-- In order to avoid that LAD is mistakenly considered at right-sided building 2062 !-- edges (here the topography-top index for the u-component at index j,i is still 2063 !-- on the building while the topography top for the scalar isn't), LAD is taken 2064 !-- from grid point (j,i-1). The same is also valid for bad_s. 2071 2065 IF ( lad_local > 0.0_wp .AND. lad_s(kk,j-1,i) == 0.0_wp & 2072 .AND. building_edge_n ) lad_local = lad_s(kk,j-1,i)2066 .AND. building_edge_n ) lad_local = lad_s(kk,j-1,i) 2073 2067 2074 2068 IF ( bad_local > 0.0_wp .AND. bad_s(kk,j-1,i) == 0.0_wp & 2075 .AND. building_edge_n ) bad_local = bad_s(kk,j-1,i)2069 .AND. building_edge_n ) bad_local = bad_s(kk,j-1,i) 2076 2070 2077 2071 pre_tend = 0.0_wp … … 2079 2073 ! 2080 2074 !-- Calculate preliminary value (pre_tend) of the tendency 2081 pre_tend = - canopy_drag_coeff * &2082 ( lad_local + bad_local ) * &2083 SQRT( ( 0.25_wp * ( u(k,j-1,i) + &2084 u(k,j-1,i+1) + &2085 u(k,j,i) + &2086 u(k,j,i+1) ) &2087 )**2 + &2088 v(k,j,i)**2 + &2089 ( 0.25_wp * ( w(k-1,j-1,i) + &2090 w(k-1,j,i) + &2091 w(k,j-1,i) + &2092 w(k,j,i) ) &2093 )**2 &2094 ) * &2075 pre_tend = - canopy_drag_coeff * & 2076 ( lad_local + bad_local ) * & 2077 SQRT( ( 0.25_wp * ( u(k,j-1,i) + & 2078 u(k,j-1,i+1) + & 2079 u(k,j,i) + & 2080 u(k,j,i+1) ) & 2081 )**2 + & 2082 v(k,j,i)**2 + & 2083 ( 0.25_wp * ( w(k-1,j-1,i) + & 2084 w(k-1,j,i) + & 2085 w(k,j-1,i) + & 2086 w(k,j,i) ) & 2087 )**2 & 2088 ) * & 2095 2089 v(k,j,i) 2096 2090 … … 2099 2093 pre_v = v(k,j,i) + dt_3d * pre_tend 2100 2094 ! 2101 !-- Compare sign of old velocity and new preliminary velocity, 2102 !-- and in case the signs are different, limit the tendency2103 IF ( SIGN( pre_v,v(k,j,i)) /= pre_v ) THEN2095 !-- Compare sign of old velocity and new preliminary velocity, and in case the 2096 !-- signs are different, limit the tendency. 2097 IF ( SIGN( pre_v,v(k,j,i) ) /= pre_v ) THEN 2104 2098 pre_tend = - v(k,j,i) * ddt_3d 2105 2099 ELSE … … 2129 2123 ! 2130 2124 !-- Calculate preliminary value (pre_tend) of the tendency 2131 pre_tend = - canopy_drag_coeff * & 2132 ( 0.5_wp * & 2133 ( lad_s(kk+1,j,i) + lad_s(kk,j,i) ) + & 2134 0.5_wp * & 2135 ( bad_s(kk+1,j,i) + bad_s(kk,j,i) ) ) * & 2136 SQRT( ( 0.25_wp * ( u(k,j,i) + & 2137 u(k,j,i+1) + & 2138 u(k+1,j,i) + & 2139 u(k+1,j,i+1) ) & 2140 )**2 + & 2141 ( 0.25_wp * ( v(k,j,i) + & 2142 v(k,j+1,i) + & 2143 v(k+1,j,i) + & 2144 v(k+1,j+1,i) ) & 2145 )**2 + & 2146 w(k,j,i)**2 & 2147 ) * & 2125 pre_tend = - canopy_drag_coeff * & 2126 ( 0.5_wp * ( lad_s(kk+1,j,i) + lad_s(kk,j,i) ) + & 2127 0.5_wp * ( bad_s(kk+1,j,i) + bad_s(kk,j,i) ) ) * & 2128 SQRT( ( 0.25_wp * ( u(k,j,i) + & 2129 u(k,j,i+1) + & 2130 u(k+1,j,i) + & 2131 u(k+1,j,i+1) ) & 2132 )**2 + & 2133 ( 0.25_wp * ( v(k,j,i) + & 2134 v(k,j+1,i) + & 2135 v(k+1,j,i) + & 2136 v(k+1,j+1,i) ) & 2137 )**2 + & 2138 w(k,j,i)**2 & 2139 ) * & 2148 2140 w(k,j,i) 2149 2141 ! … … 2151 2143 pre_w = w(k,j,i) + dt_3d * pre_tend 2152 2144 ! 2153 !-- Compare sign of old velocity and new preliminary velocity, 2154 !-- and in case thesigns are different, limit the tendency2155 IF ( SIGN( pre_w,w(k,j,i)) /= pre_w ) THEN2145 !-- Compare sign of old velocity and new preliminary velocity, and in case the 2146 !-- signs are different, limit the tendency 2147 IF ( SIGN( pre_w,w(k,j,i) ) /= pre_w ) THEN 2156 2148 pre_tend = - w(k,j,i) * ddt_3d 2157 2149 ELSE … … 2169 2161 !-- potential temperature 2170 2162 CASE ( 4 ) 2171 IF ( humidity ) THEN2163 IF ( humidity ) THEN 2172 2164 DO i = nxl, nxr 2173 2165 DO j = nys, nyn … … 2202 2194 kk = k - topo_top_ind(j,i,0) !- lad arrays are defined flat 2203 2195 2204 IF ( .NOT. plant_canopy_transpiration ) THEN2196 IF ( .NOT. plant_canopy_transpiration ) THEN 2205 2197 ! pcm_transpiration_rate is calculated in radiation model 2206 2198 ! in case of plant_canopy_transpiration = .T. 2207 2199 ! to include also the dependecy to the radiation 2208 2200 ! in the plant canopy box 2209 pcm_transpiration_rate(kk,j,i) = - leaf_scalar_exch_coeff&2210 * lad_s(kk,j,i) *&2211 SQRT( ( 0.5_wp * ( u(k,j,i) +&2212 u(k,j,i+1) )&2213 )**2 +&2214 ( 0.5_wp * ( v(k,j,i) +&2215 v(k,j+1,i) )&2216 )**2 +&2217 ( 0.5_wp * ( w(k-1,j,i) +&2218 w(k,j,i) )&2219 )**2&2220 ) *&2221 ( q(k,j,i) - leaf_surface_conc )2201 pcm_transpiration_rate(kk,j,i) = - leaf_scalar_exch_coeff & 2202 * lad_s(kk,j,i) * & 2203 SQRT( ( 0.5_wp * ( u(k,j,i) + & 2204 u(k,j,i+1) ) & 2205 )**2 + & 2206 ( 0.5_wp * ( v(k,j,i) + & 2207 v(k,j+1,i) ) & 2208 )**2 + & 2209 ( 0.5_wp * ( w(k-1,j,i) + & 2210 w(k,j,i) ) & 2211 )**2 & 2212 ) * & 2213 ( q(k,j,i) - leaf_surface_conc ) 2222 2214 ENDIF 2223 2215 … … 2237 2229 2238 2230 kk = k - topo_top_ind(j,i,0) !- lad arrays are defined flat 2239 tend(k,j,i) = tend(k,j,i) - & 2240 2.0_wp * canopy_drag_coeff * & 2241 ( lad_s(kk,j,i) + bad_s(kk,j,i) ) * & 2242 SQRT( ( 0.5_wp * ( u(k,j,i) + & 2243 u(k,j,i+1) ) & 2244 )**2 + & 2245 ( 0.5_wp * ( v(k,j,i) + & 2246 v(k,j+1,i) ) & 2247 )**2 + & 2248 ( 0.5_wp * ( w(k,j,i) + & 2249 w(k+1,j,i) ) & 2250 )**2 & 2251 ) * & 2252 e(k,j,i) 2231 tend(k,j,i) = tend(k,j,i) - 2.0_wp * canopy_drag_coeff * & 2232 ( lad_s(kk,j,i) + bad_s(kk,j,i) ) * & 2233 SQRT( ( 0.5_wp * ( u(k,j,i) + & 2234 u(k,j,i+1) ) & 2235 )**2 + & 2236 ( 0.5_wp * ( v(k,j,i) + & 2237 v(k,j+1,i) ) & 2238 )**2 + & 2239 ( 0.5_wp * ( w(k,j,i) + & 2240 w(k+1,j,i) ) & 2241 )**2 & 2242 ) * & 2243 e(k,j,i) 2253 2244 ENDDO 2254 2245 ENDDO 2255 ENDDO 2246 ENDDO 2256 2247 ! 2257 2248 !-- scalar concentration … … 2264 2255 2265 2256 kk = k - topo_top_ind(j,i,0) !- lad arrays are defined flat 2266 tend(k,j,i) = tend(k,j,i) - & 2267 leaf_scalar_exch_coeff * & 2268 lad_s(kk,j,i) * & 2269 SQRT( ( 0.5_wp * ( u(k,j,i) + & 2270 u(k,j,i+1) ) & 2271 )**2 + & 2272 ( 0.5_wp * ( v(k,j,i) + & 2273 v(k,j+1,i) ) & 2274 )**2 + & 2275 ( 0.5_wp * ( w(k-1,j,i) + & 2276 w(k,j,i) ) & 2277 )**2 & 2278 ) * & 2279 ( s(k,j,i) - leaf_surface_conc ) 2257 tend(k,j,i) = tend(k,j,i) - leaf_scalar_exch_coeff * & 2258 lad_s(kk,j,i) * & 2259 SQRT( ( 0.5_wp * ( u(k,j,i) + & 2260 u(k,j,i+1) ) & 2261 )**2 + & 2262 ( 0.5_wp * ( v(k,j,i) + & 2263 v(k,j+1,i) ) & 2264 )**2 + & 2265 ( 0.5_wp * ( w(k-1,j,i) + & 2266 w(k,j,i) ) & 2267 )**2 & 2268 ) * & 2269 ( s(k,j,i) - leaf_surface_conc ) 2280 2270 ENDDO 2281 2271 ENDDO 2282 ENDDO 2272 ENDDO 2283 2273 2284 2274 … … 2287 2277 2288 2278 WRITE( message_string, * ) 'wrong component: ', component 2289 CALL message( 'pcm_tendency', 'PA0279', 1, 2, 0, 6, 0 ) 2279 CALL message( 'pcm_tendency', 'PA0279', 1, 2, 0, 6, 0 ) 2290 2280 2291 2281 END SELECT … … 2294 2284 2295 2285 2296 !------------------------------------------------------------------------------ !2286 !--------------------------------------------------------------------------------------------------! 2297 2287 ! Description: 2298 2288 ! ------------ 2299 !> Calculation of the tendency terms, accounting for the effect of the plant 2300 !> canopy on momentum andscalar quantities.2289 !> Calculation of the tendency terms, accounting for the effect of the plant canopy on momentum and 2290 !> scalar quantities. 2301 2291 !> 2302 !> The canopy is located where the leaf area density lad_s(k,j,i) > 0.0 2303 !> (defined on scalar grid), as initialized in subroutine pcm_init. 2304 !> The lad on the w-grid is vertically interpolated from the surrounding 2305 !> lad_s. The upper boundary of the canopy is defined on the w-grid at 2306 !> k = pch_index. Here, the lad is zero. 2292 !> The canopy is located where the leaf area density lad_s(k,j,i) > 0.0 (defined on scalar grid), as 2293 !> initialized in subroutine pcm_init. 2294 !> The lad on the w-grid is vertically interpolated from the surrounding lad_s. The upper boundary 2295 !> of the canopy is defined on the w-grid at k = pch_index. Here, the lad is zero. 2307 2296 !> 2308 !> The canopy drag must be limited (previously accounted for by calculation of 2309 !> a limiting canopy timestep for the determination of the maximum LES timestep 2310 !> in subroutine timestep), since it is physically impossible that the canopy 2311 !> drag alone can locally change the sign of a velocity component. This 2312 !> limitation is realized by calculating preliminary tendencies and velocities. 2313 !> It is subsequently checked if the preliminary new velocity has a different 2314 !> sign than the current velocity. If so, the tendency is limited in a way that 2315 !> the velocity can at maximum be reduced to zero by the canopy drag. 2297 !> The canopy drag must be limited (previously accounted for by calculation of a limiting canopy 2298 !> timestep for the determination of the maximum LES timestep in subroutine timestep), since it is 2299 !> physically impossible that the canopy drag alone can locally change the sign of a velocity 2300 !> component. This limitation is realized by calculating preliminary tendencies and velocities. It 2301 !> is subsequently checked if the preliminary new velocity has a different sign than the current 2302 !> velocity. If so, the tendency is limited in a way that the velocity can at maximum be reduced to 2303 !> zero by the canopy drag. 2316 2304 !> 2317 2305 !> 2318 2306 !> Call for grid point i,j 2319 !------------------------------------------------------------------------------ !2307 !--------------------------------------------------------------------------------------------------! 2320 2308 SUBROUTINE pcm_tendency_ij( i, j, component ) 2321 2309 … … 2335 2323 REAL(wp) :: lad_local !< local lad value 2336 2324 REAL(wp) :: pre_tend !< preliminary tendency 2337 REAL(wp) :: pre_u !< preliminary u-value 2338 REAL(wp) :: pre_v !< preliminary v-value 2339 REAL(wp) :: pre_w !< preliminary w-value 2325 REAL(wp) :: pre_u !< preliminary u-value 2326 REAL(wp) :: pre_v !< preliminary v-value 2327 REAL(wp) :: pre_w !< preliminary w-value 2340 2328 2341 2329 … … 2349 2337 CASE ( 1 ) 2350 2338 ! 2351 !-- Set control flags indicating east- and westward-orientated 2352 !-- building edges. Note, building_egde_w is set from the perspective 2353 !-- of the potential rooftop grid point, while building_edge_e is 2354 !-- is set from the perspective of the non-building grid point. 2355 building_edge_w = ANY( BTEST( wall_flags_total_0(:,j,i), 6 ) ) .AND. & 2356 .NOT. ANY( BTEST( wall_flags_total_0(:,j,i-1), 6 ) ) 2357 building_edge_e = ANY( BTEST( wall_flags_total_0(:,j,i-1), 6 ) ) .AND. & 2358 .NOT. ANY( BTEST( wall_flags_total_0(:,j,i), 6 ) ) 2339 !-- Set control flags indicating east- and westward-orientated building edges. Note, 2340 !-- building_egde_w is set from the perspective of the potential rooftop grid point, while 2341 !-- building_edge_e is set from the perspective of the non-building grid point. 2342 building_edge_w = ANY( BTEST( wall_flags_total_0(:,j,i), 6 ) ) .AND. & 2343 .NOT. ANY( BTEST( wall_flags_total_0(:,j,i-1), 6 ) ) 2344 building_edge_e = ANY( BTEST( wall_flags_total_0(:,j,i-1), 6 ) ) .AND. & 2345 .NOT. ANY( BTEST( wall_flags_total_0(:,j,i), 6 ) ) 2359 2346 ! 2360 2347 !-- Determine topography-top index on u-grid … … 2364 2351 2365 2352 ! 2366 !-- In order to create sharp boundaries of the plant canopy, 2367 !-- the lad on the u-grid at index (k,j,i) is equal to lad_s(k,j,i), 2368 !-- rather than being interpolated from the surrounding lad_s, 2369 !-- because this would yield smaller lad at the canopy boundaries 2353 !-- In order to create sharp boundaries of the plant canopy, the lad on the u-grid at 2354 !-- index (k,j,i) is equal to lad_s(k,j,i), rather than being interpolated from the 2355 !-- surrounding lad_s, because this would yield smaller lad at the canopy boundaries 2370 2356 !-- than inside of the canopy. 2371 !-- For the same reason, the lad at the rightmost(i+1)canopy 2372 !-- boundary on the u-grid equals lad_s(k,j,i), which is considered 2373 !-- in the next if-statement. Note, at left-sided building edges 2374 !-- this is not applied, here the LAD is equals the LAD at grid 2375 !-- point (k,j,i), in order to avoid that LAD is mistakenly mapped 2376 !-- on top of a roof where (usually) is no LAD is defined. 2357 !-- For the same reason, the lad at the rightmost(i+1)canopy boundary on the u-grid 2358 !-- equals lad_s(k,j,i), which is considered in the next if-statement. Note, at 2359 !-- left-sided building edges this is not applied, here the LAD is equals the LAD at 2360 !-- grid point (k,j,i), in order to avoid that LAD is mistakenly mapped on top of a roof 2361 !-- where (usually) is no LAD is defined. 2377 2362 !-- The same is also valid for bad_s. 2378 2363 lad_local = lad_s(kk,j,i) … … 2384 2369 .NOT. building_edge_w ) bad_local = bad_s(kk,j,i-1) 2385 2370 ! 2386 !-- In order to avoid that LAD is mistakenly considered at right- 2387 !-- sided building edges (here the topography-top index for the 2388 !-- u-component at index j,i is still on the building while the 2389 !-- topography top for the scalar isn't), LAD is taken from grid 2371 !-- In order to avoid that LAD is mistakenly considered at right-sided building edges 2372 !-- (here the topography-top index for the u-component at index j,i is still on the 2373 !-- building while the topography top for the scalar isn't), LAD is taken from grid 2390 2374 !-- point (j,i-1). The same is also valid for bad_s. 2391 2375 IF ( lad_local > 0.0_wp .AND. lad_s(kk,j,i-1) == 0.0_wp .AND. & … … 2398 2382 ! 2399 2383 !-- Calculate preliminary value (pre_tend) of the tendency 2400 pre_tend = - canopy_drag_coeff * &2401 ( lad_local + bad_local ) * &2402 SQRT( u(k,j,i)**2 + &2403 ( 0.25_wp * ( v(k,j,i-1) + &2404 v(k,j,i) + &2405 v(k,j+1,i) + &2406 v(k,j+1,i-1) ) &2407 )**2 + &2408 ( 0.25_wp * ( w(k-1,j,i-1) + &2409 w(k-1,j,i) + &2410 w(k,j,i-1) + &2411 w(k,j,i) ) &2412 )**2 &2413 ) * &2384 pre_tend = - canopy_drag_coeff * & 2385 ( lad_local + bad_local ) * & 2386 SQRT( u(k,j,i)**2 + & 2387 ( 0.25_wp * ( v(k,j,i-1) + & 2388 v(k,j,i) + & 2389 v(k,j+1,i) + & 2390 v(k,j+1,i-1) ) & 2391 )**2 + & 2392 ( 0.25_wp * ( w(k-1,j,i-1) + & 2393 w(k-1,j,i) + & 2394 w(k,j,i-1) + & 2395 w(k,j,i) ) & 2396 )**2 & 2397 ) * & 2414 2398 u(k,j,i) 2415 2399 … … 2418 2402 pre_u = u(k,j,i) + dt_3d * pre_tend 2419 2403 ! 2420 !-- Compare sign of old velocity and new preliminary velocity, 2421 !-- and in case the signs are different, limit the tendency2422 IF ( SIGN( pre_u,u(k,j,i)) /= pre_u ) THEN2404 !-- Compare sign of old velocity and new preliminary velocity, and in case the signs are 2405 !-- different, limit the tendency. 2406 IF ( SIGN( pre_u,u(k,j,i) ) /= pre_u ) THEN 2423 2407 pre_tend = - u(k,j,i) * ddt_3d 2424 2408 ELSE … … 2435 2419 CASE ( 2 ) 2436 2420 ! 2437 !-- Set control flags indicating north- and southward-orientated 2438 !-- building edges. Note, building_egde_s is set from the perspective 2439 !-- of the potential rooftop grid point, while building_edge_n is 2440 !-- is set from the perspective of the non-building grid point. 2441 building_edge_s = ANY( BTEST( wall_flags_total_0(:,j,i), 6 ) ) .AND. & 2442 .NOT. ANY( BTEST( wall_flags_total_0(:,j-1,i), 6 ) ) 2443 building_edge_n = ANY( BTEST( wall_flags_total_0(:,j-1,i), 6 ) ) .AND. & 2444 .NOT. ANY( BTEST( wall_flags_total_0(:,j,i), 6 ) ) 2421 !-- Set control flags indicating north- and southward-orientated building edges. Note, 2422 !-- building_egde_s is set from the perspective of the potential rooftop grid point, while 2423 !-- building_edge_n is set from the perspective of the non-building grid point. 2424 building_edge_s = ANY( BTEST( wall_flags_total_0(:,j,i), 6 ) ) .AND. & 2425 .NOT. ANY( BTEST( wall_flags_total_0(:,j-1,i), 6 ) ) 2426 building_edge_n = ANY( BTEST( wall_flags_total_0(:,j-1,i), 6 ) ) .AND. & 2427 .NOT. ANY( BTEST( wall_flags_total_0(:,j,i), 6 ) ) 2445 2428 ! 2446 2429 !-- Determine topography-top index on v-grid … … 2449 2432 kk = k - topo_top_ind(j,i,2) !- lad arrays are defined flat 2450 2433 ! 2451 !-- In order to create sharp boundaries of the plant canopy, 2452 !-- the lad on the v-grid at index (k,j,i) is equal to lad_s(k,j,i), 2453 !-- rather than being interpolated from the surrounding lad_s, 2454 !-- because this would yield smaller lad at the canopy boundaries 2434 !-- In order to create sharp boundaries of the plant canopy, the lad on the v-grid at 2435 !-- index (k,j,i) is equal to lad_s(k,j,i), rather than being interpolated from the 2436 !-- surrounding lad_s, because this would yield smaller lad at the canopy boundaries 2455 2437 !-- than inside of the canopy. 2456 !-- For the same reason, the lad at the northmost(j+1)canopy 2457 !-- boundary on the v-grid equals lad_s(k,j,i), which is considered 2458 !-- in the next if-statement. Note, at left-sided building edges 2459 !-- this is not applied, here the LAD is equals the LAD at grid 2460 !-- point (k,j,i), in order to avoid that LAD is mistakenly mapped 2461 !-- on top of a roof where (usually) is no LAD is defined. 2438 !-- For the same reason, the lad at the northmost (j+1) canopy boundary on the v-grid 2439 !-- equals lad_s(k,j,i), which is considered in the next if-statement. Note, at 2440 !-- left-sided building edges this is not applied, here the LAD is equals the LAD at 2441 !-- grid point (k,j,i), in order to avoid that LAD is mistakenly mapped on top of a roof 2442 !-- where (usually) is no LAD is defined. 2462 2443 !-- The same is also valid for bad_s. 2463 2444 lad_local = lad_s(kk,j,i) … … 2469 2450 .NOT. building_edge_s ) bad_local = bad_s(kk,j-1,i) 2470 2451 ! 2471 !-- In order to avoid that LAD is mistakenly considered at right- 2472 !-- sided building edges (here the topography-top index for the 2473 !-- u-component at index j,i is still on the building while the 2474 !-- topography top for the scalar isn't), LAD is taken from grid 2452 !-- In order to avoid that LAD is mistakenly considered at right-sided building edges 2453 !-- (here the topography-top index for the u-component at index j,i is still on the 2454 !-- building while the topography top for the scalar isn't), LAD is taken from grid 2475 2455 !-- point (j,i-1). The same is also valid for bad_s. 2476 2456 IF ( lad_local > 0.0_wp .AND. lad_s(kk,j-1,i) == 0.0_wp .AND. & … … 2483 2463 ! 2484 2464 !-- Calculate preliminary value (pre_tend) of the tendency 2485 pre_tend = - canopy_drag_coeff * &2486 ( lad_local + bad_local ) * &2487 SQRT( ( 0.25_wp * ( u(k,j-1,i) + &2488 u(k,j-1,i+1) + &2489 u(k,j,i) + &2490 u(k,j,i+1) ) &2491 )**2 + &2492 v(k,j,i)**2 + &2493 ( 0.25_wp * ( w(k-1,j-1,i) + &2494 w(k-1,j,i) + &2495 w(k,j-1,i) + &2496 w(k,j,i) ) &2497 )**2 &2498 ) * &2465 pre_tend = - canopy_drag_coeff * & 2466 ( lad_local + bad_local ) * & 2467 SQRT( ( 0.25_wp * ( u(k,j-1,i) + & 2468 u(k,j-1,i+1) + & 2469 u(k,j,i) + & 2470 u(k,j,i+1) ) & 2471 )**2 + & 2472 v(k,j,i)**2 + & 2473 ( 0.25_wp * ( w(k-1,j-1,i) + & 2474 w(k-1,j,i) + & 2475 w(k,j-1,i) + & 2476 w(k,j,i) ) & 2477 )**2 & 2478 ) * & 2499 2479 v(k,j,i) 2500 2480 … … 2505 2485 !-- Compare sign of old velocity and new preliminary velocity, 2506 2486 !-- and in case the signs are different, limit the tendency 2507 IF ( SIGN( pre_v,v(k,j,i)) /= pre_v ) THEN2487 IF ( SIGN( pre_v,v(k,j,i) ) /= pre_v ) THEN 2508 2488 pre_tend = - v(k,j,i) * ddt_3d 2509 2489 ELSE … … 2529 2509 ! 2530 2510 !-- Calculate preliminary value (pre_tend) of the tendency 2531 pre_tend = - canopy_drag_coeff * & 2532 ( 0.5_wp * & 2533 ( lad_s(kk+1,j,i) + lad_s(kk,j,i) ) + & 2534 0.5_wp * & 2535 ( bad_s(kk+1,j,i) + bad_s(kk,j,i) ) ) * & 2536 SQRT( ( 0.25_wp * ( u(k,j,i) + & 2537 u(k,j,i+1) + & 2538 u(k+1,j,i) + & 2539 u(k+1,j,i+1) ) & 2540 )**2 + & 2541 ( 0.25_wp * ( v(k,j,i) + & 2542 v(k,j+1,i) + & 2543 v(k+1,j,i) + & 2544 v(k+1,j+1,i) ) & 2545 )**2 + & 2546 w(k,j,i)**2 & 2547 ) * & 2511 pre_tend = - canopy_drag_coeff * & 2512 ( 0.5_wp * ( lad_s(kk+1,j,i) + lad_s(kk,j,i) ) + & 2513 0.5_wp * ( bad_s(kk+1,j,i) + bad_s(kk,j,i) ) ) * & 2514 SQRT( ( 0.25_wp * ( u(k,j,i) + & 2515 u(k,j,i+1) + & 2516 u(k+1,j,i) + & 2517 u(k+1,j,i+1) ) & 2518 )**2 + & 2519 ( 0.25_wp * ( v(k,j,i) + & 2520 v(k,j+1,i) + & 2521 v(k+1,j,i) + & 2522 v(k+1,j+1,i) ) & 2523 )**2 + & 2524 w(k,j,i)**2 & 2525 ) * & 2548 2526 w(k,j,i) 2549 2527 ! … … 2551 2529 pre_w = w(k,j,i) + dt_3d * pre_tend 2552 2530 ! 2553 !-- Compare sign of old velocity and new preliminary velocity, 2554 !-- and in case the signs are different, limit the tendency2555 IF ( SIGN( pre_w,w(k,j,i)) /= pre_w ) THEN2531 !-- Compare sign of old velocity and new preliminary velocity, and in case the signs are 2532 !-- different, limit the tendency. 2533 IF ( SIGN( pre_w,w(k,j,i) ) /= pre_w ) THEN 2556 2534 pre_tend = - w(k,j,i) * ddt_3d 2557 2535 ELSE … … 2568 2546 ! 2569 2547 !-- Determine topography-top index on scalar grid 2570 IF ( humidity ) THEN2548 IF ( humidity ) THEN 2571 2549 DO k = topo_top_ind(j,i,0) + 1, topo_top_ind(j,i,0) + pch_index_ji(j,i) 2572 2550 kk = k - topo_top_ind(j,i,0) !- lad arrays are defined flat 2573 tend(k,j,i) = tend(k,j,i) + pcm_heating_rate(kk,j,i) - & 2574 pcm_latent_rate(kk,j,i) 2551 tend(k,j,i) = tend(k,j,i) + pcm_heating_rate(kk,j,i) - pcm_latent_rate(kk,j,i) 2575 2552 ENDDO 2576 2553 ELSE … … 2588 2565 DO k = topo_top_ind(j,i,0) + 1, topo_top_ind(j,i,0) + pch_index_ji(j,i) 2589 2566 kk = k - topo_top_ind(j,i,0) !- lad arrays are defined flat 2590 IF ( .NOT. plant_canopy_transpiration ) THEN2567 IF ( .NOT. plant_canopy_transpiration ) THEN 2591 2568 ! pcm_transpiration_rate is calculated in radiation model 2592 2569 ! in case of plant_canopy_transpiration = .T. 2593 2570 ! to include also the dependecy to the radiation 2594 2571 ! in the plant canopy box 2595 pcm_transpiration_rate(kk,j,i) = - leaf_scalar_exch_coeff &2596 * lad_s(kk,j,i) *&2597 SQRT( ( 0.5_wp * ( u(k,j,i) +&2598 u(k,j,i+1) )&2599 )**2 +&2600 ( 0.5_wp * ( v(k,j,i) +&2601 v(k,j+1,i) )&2602 )**2 +&2603 ( 0.5_wp * ( w(k-1,j,i) +&2604 w(k,j,i) )&2605 )**2&2606 ) *&2607 ( q(k,j,i) - leaf_surface_conc )2572 pcm_transpiration_rate(kk,j,i) = - leaf_scalar_exch_coeff & 2573 * lad_s(kk,j,i) * & 2574 SQRT( ( 0.5_wp * ( u(k,j,i) + & 2575 u(k,j,i+1) ) & 2576 )**2 + & 2577 ( 0.5_wp * ( v(k,j,i) + & 2578 v(k,j+1,i) ) & 2579 )**2 + & 2580 ( 0.5_wp * ( w(k-1,j,i) + & 2581 w(k,j,i) ) & 2582 )**2 & 2583 ) * & 2584 ( q(k,j,i) - leaf_surface_conc ) 2608 2585 ENDIF 2609 2586 2610 2587 tend(k,j,i) = tend(k,j,i) + pcm_transpiration_rate(kk,j,i) 2611 2588 2612 ENDDO 2589 ENDDO 2613 2590 2614 2591 ! … … 2620 2597 2621 2598 kk = k - topo_top_ind(j,i,0) 2622 tend(k,j,i) = tend(k,j,i) - & 2623 2.0_wp * canopy_drag_coeff * & 2624 ( lad_s(kk,j,i) + bad_s(kk,j,i) ) * & 2625 SQRT( ( 0.5_wp * ( u(k,j,i) + & 2626 u(k,j,i+1) ) & 2627 )**2 + & 2628 ( 0.5_wp * ( v(k,j,i) + & 2629 v(k,j+1,i) ) & 2630 )**2 + & 2631 ( 0.5_wp * ( w(k,j,i) + & 2632 w(k+1,j,i) ) & 2633 )**2 & 2634 ) * & 2635 e(k,j,i) 2599 tend(k,j,i) = tend(k,j,i) - 2.0_wp * canopy_drag_coeff * & 2600 ( lad_s(kk,j,i) + bad_s(kk,j,i) ) * & 2601 SQRT( ( 0.5_wp * ( u(k,j,i) + & 2602 u(k,j,i+1) ) & 2603 )**2 + & 2604 ( 0.5_wp * ( v(k,j,i) + & 2605 v(k,j+1,i) ) & 2606 )**2 + & 2607 ( 0.5_wp * ( w(k,j,i) + & 2608 w(k+1,j,i) ) & 2609 )**2 & 2610 ) * & 2611 e(k,j,i) 2636 2612 ENDDO 2637 2613 ! 2638 !-- scalar concentration 2614 !-- scalar concentration 2639 2615 CASE ( 7 ) 2640 2616 ! … … 2643 2619 2644 2620 kk = k - topo_top_ind(j,i,0) 2645 tend(k,j,i) = tend(k,j,i) - & 2646 leaf_scalar_exch_coeff * & 2647 lad_s(kk,j,i) * & 2648 SQRT( ( 0.5_wp * ( u(k,j,i) + & 2649 u(k,j,i+1) ) & 2650 )**2 + & 2651 ( 0.5_wp * ( v(k,j,i) + & 2652 v(k,j+1,i) ) & 2653 )**2 + & 2654 ( 0.5_wp * ( w(k-1,j,i) + & 2655 w(k,j,i) ) & 2656 )**2 & 2657 ) * & 2658 ( s(k,j,i) - leaf_surface_conc ) 2659 ENDDO 2621 tend(k,j,i) = tend(k,j,i) - leaf_scalar_exch_coeff * & 2622 lad_s(kk,j,i) * & 2623 SQRT( ( 0.5_wp * ( u(k,j,i) + & 2624 u(k,j,i+1) ) & 2625 )**2 + & 2626 ( 0.5_wp * ( v(k,j,i) + & 2627 v(k,j+1,i) ) & 2628 )**2 + & 2629 ( 0.5_wp * ( w(k-1,j,i) + & 2630 w(k,j,i) ) & 2631 )**2 & 2632 ) * & 2633 ( s(k,j,i) - leaf_surface_conc ) 2634 ENDDO 2660 2635 2661 2636 CASE DEFAULT 2662 2637 2663 2638 WRITE( message_string, * ) 'wrong component: ', component 2664 CALL message( 'pcm_tendency', 'PA0279', 1, 2, 0, 6, 0 ) 2639 CALL message( 'pcm_tendency', 'PA0279', 1, 2, 0, 6, 0 ) 2665 2640 2666 2641 END SELECT … … 2668 2643 END SUBROUTINE pcm_tendency_ij 2669 2644 2670 !------------------------------------------------------------------------------ !2645 !--------------------------------------------------------------------------------------------------! 2671 2646 ! Description: 2672 2647 ! ------------ 2673 2648 !> Subroutine writes global restart data 2674 !------------------------------------------------------------------------------ !2649 !--------------------------------------------------------------------------------------------------! 2675 2650 SUBROUTINE pcm_wrd_global 2676 2651 … … 2678 2653 2679 2654 CALL wrd_write_string( 'pch_index' ) 2680 WRITE 2681 2682 ELSE IF ( restart_data_format_output(1:3) == 'mpi' ) THEN2655 WRITE( 14 ) pch_index 2656 2657 ELSE IF ( restart_data_format_output(1:3) == 'mpi' ) THEN 2683 2658 2684 2659 CALL wrd_mpi_io( 'pch_index', pch_index ) … … 2688 2663 END SUBROUTINE pcm_wrd_global 2689 2664 2690 !------------------------------------------------------------------------------ !2665 !--------------------------------------------------------------------------------------------------! 2691 2666 ! Description: 2692 2667 ! ------------ 2693 2668 !> Subroutine writes local (subdomain) restart data 2694 !------------------------------------------------------------------------------ !2669 !--------------------------------------------------------------------------------------------------! 2695 2670 SUBROUTINE pcm_wrd_local 2696 2671 … … 2698 2673 !< non-standard vertical index bounds 2699 2674 2675 2700 2676 IF ( TRIM( restart_data_format_output ) == 'fortran_binary' ) THEN 2701 2677 2702 2678 IF ( ALLOCATED( pcm_heatrate_av ) ) THEN 2703 2679 CALL wrd_write_string( 'pcm_heatrate_av' ) 2704 WRITE 2680 WRITE( 14 ) pcm_heatrate_av 2705 2681 ENDIF 2706 2682 2707 2683 IF ( ALLOCATED( pcm_latentrate_av ) ) THEN 2708 2684 CALL wrd_write_string( 'pcm_latentrate_av' ) 2709 WRITE 2685 WRITE( 14 ) pcm_latentrate_av 2710 2686 ENDIF 2711 2687 2712 2688 IF ( ALLOCATED( pcm_transpirationrate_av ) ) THEN 2713 2689 CALL wrd_write_string( 'pcm_transpirationrate_av' ) 2714 WRITE 2690 WRITE( 14 ) pcm_transpirationrate_av 2715 2691 ENDIF 2716 2692 2717 ELSE IF ( restart_data_format_output(1:3) == 'mpi' ) THEN2693 ELSE IF ( restart_data_format_output(1:3) == 'mpi' ) THEN 2718 2694 2719 2695 !
Note: See TracChangeset
for help on using the changeset viewer.