Changeset 4648 for palm/trunk/SOURCE/init_grid.f90
- Timestamp:
- Aug 25, 2020 7:52:08 AM (4 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
palm/trunk/SOURCE/init_grid.f90
r4630 r4648 1 1 !> @file init_grid.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 !--------------------------------------------------------------------------------------------------! 19 18 ! 20 19 ! Current revisions: … … 25 24 ! ----------------- 26 25 ! $Id$ 26 ! file re-formatted to follow the PALM coding standard 27 ! 28 ! 4630 2020-07-30 14:54:34Z suehring 27 29 ! In case of ASCII topography input flag grid points as terrain and building. 28 30 ! 29 31 ! 4601 2020-07-14 12:06:09Z suehring 30 32 ! Minor formatting adjustments 31 ! 33 ! 32 34 ! 4564 2020-06-12 14:03:36Z raasch 33 35 ! Vertical nesting method of Huq et al. (2019) removed 34 ! 36 ! 35 37 ! 4543 2020-05-20 14:12:22Z gronemeier 36 38 ! Remove non-required check for canyon height 37 ! 39 ! 38 40 ! 4507 2020-04-22 18:21:45Z gronemeier 39 41 ! update origin_z with shifting height of orography (oro_min) 40 ! 42 ! 41 43 ! 4457 2020-03-11 14:20:43Z raasch 42 44 ! use statement for exchange horiz added, 43 45 ! bugfix for call of exchange horiz 2d 44 ! 46 ! 45 47 ! 4444 2020-03-05 15:59:50Z raasch 46 48 ! bugfix: cpp-directives for serial mode added 47 ! 49 ! 48 50 ! 4414 2020-02-19 20:16:04Z suehring 49 51 ! - Remove deprecated topography arrays nzb_s_inner, nzb_u_inner, etc. 50 ! - Move initialization of boundary conditions and multigrid into an extra 51 ! module interface. 52 ! 52 ! - Move initialization of boundary conditions and multigrid into an extra module interface. 53 ! 53 54 ! 4386 2020-01-27 15:07:30Z Giersch 54 ! Allocation statements, comments, naming of variables revised and _wp added to 55 ! real type values 56 ! 55 ! Allocation statements, comments, naming of variables revised and _wp added to real type values 56 ! 57 57 ! 4360 2020-01-07 11:25:50Z suehring 58 58 ! Revise error messages for generic tunnel setup. 59 ! 59 ! 60 60 ! 4346 2019-12-18 11:55:56Z motisi 61 ! Introduction of wall_flags_total_0, which currently sets bits based on static 62 ! topographyinformation used in wall_flags_static_063 ! 61 ! Introduction of wall_flags_total_0, which currently sets bits based on static topography 62 ! information used in wall_flags_static_0 63 ! 64 64 ! 4340 2019-12-16 08:17:03Z Giersch 65 65 ! Topography closed channel flow with symmetric boundaries implemented 66 ! 66 ! 67 67 ! 4329 2019-12-10 15:46:36Z motisi 68 68 ! Renamed wall_flags_0 to wall_flags_static_0 69 ! 69 ! 70 70 ! 4328 2019-12-09 18:53:04Z suehring 71 71 ! Minor change in nzb_max computation. Commentation added. 72 ! 72 ! 73 73 ! 4314 2019-11-29 10:29:20Z suehring 74 ! Set additional topography flag 4 to mark topography grid points emerged 75 ! from the filtering process. 76 ! 74 ! Set additional topography flag 4 to mark topography grid points emerged from the filtering process. 75 ! 77 76 ! 4294 2019-11-13 18:34:16Z suehring 78 ! Bugfix, always set bit 5 and 6 of wall_flags, indicating terrain- and 79 ! building surfaces in all cases, in order to enable terrain-following output80 ! a lso when no land- or urban-surface model is applied.81 ! 77 ! Bugfix, always set bit 5 and 6 of wall_flags, indicating terrain- and building surfaces in all 78 ! cases, in order to enable terrain-following output also when no land- or urban-surface model is 79 ! applied. 80 ! 82 81 ! 4265 2019-10-15 16:16:24Z suehring 83 ! Bugfix for last commit, exchange oro_max variable only when it is allocated 84 ! (not necessarily thecase when topography is input from ASCII file).85 ! 82 ! Bugfix for last commit, exchange oro_max variable only when it is allocated (not necessarily the 83 ! case when topography is input from ASCII file). 84 ! 86 85 ! 4245 2019-09-30 08:40:37Z pavelkrc 87 86 ! Store oro_max (building z-offset) in 2D for building surfaces 88 ! 87 ! 89 88 ! 4189 2019-08-26 16:19:38Z suehring 90 89 ! - Add check for proper setting of namelist parameter topography 91 90 ! - Set flag to indicate land surfaces in case no topography is provided 92 ! 91 ! 93 92 ! 4182 2019-08-22 15:20:23Z scharf 94 93 ! Corrected "Former revisions" section 95 ! 94 ! 96 95 ! 4168 2019-08-16 13:50:17Z suehring 97 ! Pre-calculate topography top index and store it on an array (replaces former 98 ! functionsget_topography_top_index)99 ! 96 ! Pre-calculate topography top index and store it on an array (replaces former functions 97 ! get_topography_top_index) 98 ! 100 99 ! 4159 2019-08-15 13:31:35Z suehring 101 ! Revision of topography processing. This was not consistent between 2D and 3D 102 ! buildings. 103 ! 100 ! Revision of topography processing. This was not consistent between 2D and 3D buildings. 101 ! 104 102 ! 4144 2019-08-06 09:11:47Z raasch 105 103 ! relational operators .EQ., .NE., etc. replaced by ==, /=, etc. 106 ! 104 ! 107 105 ! 4115 2019-07-24 12:50:49Z suehring 108 ! Bugfix in setting near-surface flag 24, inidicating wall-bounded grid points 109 ! 106 ! Bugfix in setting near-surface flag 24, inidicating wall-bounded grid points 107 ! 110 108 ! 4110 2019-07-22 17:05:21Z suehring 111 109 ! - Separate initialization of advection flags for momentum and scalars. 112 110 ! - Change subroutine interface for ws_init_flags_scalar to pass boundary flags 113 ! 111 ! 114 112 ! 4109 2019-07-22 17:00:34Z suehring 115 113 ! Fix bad commit 116 ! 114 ! 117 115 ! 3926 2019-04-23 12:56:42Z suehring 118 ! Minor bugfix in building mapping when all building IDs in the model domain 119 ! are missing 120 ! 116 ! Minor bugfix in building mapping when all building IDs in the model domain are missing 117 ! 121 118 ! 3857 2019-04-03 13:00:16Z knoop 122 ! In projection of non-building 3D objects onto numerical grid remove 123 ! dependency on building_type 124 ! 119 ! In projection of non-building 3D objects onto numerical grid remove dependency on building_type 120 ! 125 121 ! 3763 2019-02-25 17:33:49Z suehring 126 ! Replace work-around for ghost point exchange of 1-byte arrays with specific 127 ! routine as alreadydone in other routines128 ! 122 ! Replace work-around for ghost point exchange of 1-byte arrays with specific routine as already 123 ! done in other routines 124 ! 129 125 ! 3761 2019-02-25 15:31:42Z raasch 130 126 ! unused variables removed 131 ! 127 ! 132 128 ! 3661 2019-01-08 18:22:50Z suehring 133 ! Remove setting of nzb_max to nzt at non-cyclic boundary PEs, instead, 134 ! order degradation ofadvection scheme is handeled directly in advec_ws135 ! 129 ! Remove setting of nzb_max to nzt at non-cyclic boundary PEs, instead, order degradation of 130 ! advection scheme is handeled directly in advec_ws 131 ! 136 132 ! 3655 2019-01-07 16:51:22Z knoop 137 133 ! Comment added … … 142 138 ! 143 139 ! Description: 144 ! ----------------------------------------------------------------------------- !140 ! -------------------------------------------------------------------------------------------------! 145 141 !> Creating grid depending constants 146 142 !> @todo: Rearrange topo flag list 147 !> @todo: reference 3D buildings on top of orography is not tested and may need 148 !> f urther improvement for steep slopes149 !> @todo: Use more advanced setting of building type at filled holes 150 !------------------------------------------------------------------------------ !143 !> @todo: reference 3D buildings on top of orography is not tested and may need further improvement 144 !> for steep slopes 145 !> @todo: Use more advanced setting of building type at filled holes 146 !--------------------------------------------------------------------------------------------------! 151 147 SUBROUTINE init_grid 152 148 153 USE arrays_3d, &149 USE arrays_3d, & 154 150 ONLY: dd2zu, ddzu, ddzu_pres, ddzw, dzu, dzw, x, xu, y, yv, zu, zw 155 151 156 USE control_parameters, &157 ONLY: constant_flux_layer, dz, dz_max, dz_stretch_factor, &158 dz_stretch_factor_array, dz_stretch_level, dz_stretch_level_end, &159 dz_stretch_level_end_index, dz_stretch_level_start_index, &160 dz_stretch_level_start, ibc_uv_b, message_string, &161 number_stretch_level_end, &162 number_stretch_level_start, &163 ocean_mode, &164 psolver, &165 symmetry_flag, &166 topography, &152 USE control_parameters, & 153 ONLY: constant_flux_layer, dz, dz_max, dz_stretch_factor, & 154 dz_stretch_factor_array, dz_stretch_level, dz_stretch_level_end, & 155 dz_stretch_level_end_index, dz_stretch_level_start_index, & 156 dz_stretch_level_start, ibc_uv_b, message_string, & 157 number_stretch_level_end, & 158 number_stretch_level_start, & 159 ocean_mode, & 160 psolver, & 161 symmetry_flag, & 162 topography, & 167 163 use_surface_fluxes 168 164 169 USE grid_variables, &165 USE grid_variables, & 170 166 ONLY: ddx, ddx2, ddy, ddy2, dx, dx2, dy, dy2, zu_s_inner, zw_w_inner 171 167 172 USE indices, &173 ONLY: nbgp, &174 nx, &175 nxl, &176 nxlg, &177 nxr, &178 nxrg, &179 ny, &180 nyn, &181 nyng, &182 nys, &183 nysg, &184 nz, &185 nzb, &186 nzb_diff, &187 nzb_max, &188 nzt, &189 topo_top_ind, &168 USE indices, & 169 ONLY: nbgp, & 170 nx, & 171 nxl, & 172 nxlg, & 173 nxr, & 174 nxrg, & 175 ny, & 176 nyn, & 177 nyng, & 178 nys, & 179 nysg, & 180 nz, & 181 nzb, & 182 nzb_diff, & 183 nzb_max, & 184 nzt, & 185 topo_top_ind, & 190 186 topo_min_level 191 187 … … 196 192 IMPLICIT NONE 197 193 198 INTEGER(iwp) :: i !< index variable along x 194 INTEGER(iwp) :: i !< index variable along x 199 195 INTEGER(iwp) :: j !< index variable along y 200 196 INTEGER(iwp) :: k !< index variable along z 201 197 INTEGER(iwp) :: k_top !< topography top index on local PE 202 198 INTEGER(iwp) :: n !< loop variable for stretching 203 INTEGER(iwp) :: number_dz !< number of user-specified dz values 199 INTEGER(iwp) :: number_dz !< number of user-specified dz values 204 200 INTEGER(iwp) :: nzb_local_max !< vertical grid index of maximum topography height 205 201 INTEGER(iwp) :: nzb_local_min !< vertical grid index of minimum topography height … … 209 205 REAL(wp) :: dz_level_end !< distance between calculated height level for u/v-grid and user-specified end level for stretching 210 206 REAL(wp) :: dz_stretched !< stretched vertical grid spacing 211 212 REAL(wp), DIMENSION(:), ALLOCATABLE :: min_dz_stretch_level_end !< Array that contains all minimum heights where the stretching can end 207 208 REAL(wp), DIMENSION(:), ALLOCATABLE :: min_dz_stretch_level_end !< Array that contains all minimum heights where the stretching 209 !< can end 213 210 214 211 … … 224 221 ALLOCATE( x(0:nx) ) 225 222 ALLOCATE( xu(0:nx) ) 226 223 227 224 DO i = 0, nx 228 225 xu(i) = i * dx … … 232 229 ALLOCATE( y(0:ny) ) 233 230 ALLOCATE( yv(0:ny) ) 234 231 235 232 DO j = 0, ny 236 233 yv(j) = j * dy … … 247 244 248 245 ! 249 !-- For constructing an appropriate grid, the vertical grid spacing dz has to 250 !-- be specified with a non-negative value in the parameter file246 !-- For constructing an appropriate grid, the vertical grid spacing dz has to be specified with a 247 !-- non-negative value in the parameter file. 251 248 IF ( dz(1) == -1.0_wp ) THEN 252 249 message_string = 'missing dz' 253 CALL message( 'init_grid', 'PA0200', 1, 2, 0, 6, 0 ) 250 CALL message( 'init_grid', 'PA0200', 1, 2, 0, 6, 0 ) 254 251 ELSEIF ( dz(1) <= 0.0_wp ) THEN 255 252 WRITE( message_string, * ) 'dz=',dz(1),' <= 0.0' … … 258 255 259 256 ! 260 !-- Initialize dz_stretch_level_start with the value of dz_stretch_level 261 !-- if it was set by the user 257 !-- Initialize dz_stretch_level_start with the value of dz_stretch_level if it was set by the user. 262 258 IF ( dz_stretch_level /= -9999999.9_wp ) THEN 263 259 dz_stretch_level_start(1) = dz_stretch_level 264 260 ENDIF 265 266 ! 267 !-- Determine number of dz values and stretching levels specified by the 268 !-- user to allow right controlling of the stretching mechanism and to 269 !-- perform error checks. The additional requirement that dz /= dz_max 270 !-- for counting number of user-specified dz values is necessary. Otherwise 271 !-- restarts would abort if the old stretching mechanism with dz_stretch_level 272 !-- is used (Attention: The user is not allowed to specify a dz value equal 273 !-- to the default of dz_max = 999.0). 274 number_dz = COUNT( dz /= -1.0_wp .AND. dz /= dz_max) 275 number_stretch_level_start = COUNT( dz_stretch_level_start /= & 276 -9999999.9_wp ) 277 number_stretch_level_end = COUNT( dz_stretch_level_end /= & 278 9999999.9_wp ) 279 280 ! 281 !-- The number of specified end levels +1 has to be the same as the number 261 262 ! 263 !-- Determine number of dz values and stretching levels specified by the user to allow right 264 !-- controlling of the stretching mechanism and to perform error checks. The additional requirement 265 !-- that dz /= dz_max for counting number of user-specified dz values is necessary. Otherwise 266 !-- restarts would abort if the old stretching mechanism with dz_stretch_level is used (Attention: 267 !-- The user is not allowed to specify a dz value equal to the default of dz_max = 999.0). 268 number_dz = COUNT( dz /= -1.0_wp .AND. dz /= dz_max) 269 number_stretch_level_start = COUNT( dz_stretch_level_start /= -9999999.9_wp ) 270 number_stretch_level_end = COUNT( dz_stretch_level_end /= 9999999.9_wp ) 271 272 ! 273 !-- The number of specified end levels +1 has to be the same as the number 282 274 !-- of specified dz values 283 275 IF ( number_dz /= number_stretch_level_end + 1 ) THEN 284 WRITE( message_string, * ) 'The number of values for dz = ', & 285 number_dz, 'has to be the same as& ', & 286 'the number of values for ', & 287 'dz_stretch_level_end + 1 = ', & 288 number_stretch_level_end+1 276 WRITE( message_string, * ) 'The number of values for dz = ', number_dz, & 277 'has to be the same as& ', 'the number of values for ', & 278 'dz_stretch_level_end + 1 = ', number_stretch_level_end+1 289 279 CALL message( 'init_grid', 'PA0156', 1, 2, 0, 6, 0 ) 290 280 ENDIF 291 292 ! 293 !-- The number of specified start levels has to be the same or one less than 294 !-- the number of specified dz values 295 IF ( number_dz /= number_stretch_level_start + 1 .AND. & 296 number_dz /= number_stretch_level_start ) THEN 297 WRITE( message_string, * ) 'The number of values for dz = ', & 298 number_dz, 'has to be the same as or one ', & 299 'more than& the number of values for ', & 300 'dz_stretch_level_start = ', & 301 number_stretch_level_start 281 282 ! 283 !-- The number of specified start levels has to be the same or one less than the number of specified 284 !-- dz values 285 IF ( number_dz /= number_stretch_level_start + 1 .AND. & 286 number_dz /= number_stretch_level_start ) THEN 287 WRITE( message_string, * ) 'The number of values for dz = ', number_dz, & 288 'has to be the same as or one ', & 289 'more than& the number of values for ', & 290 'dz_stretch_level_start = ', number_stretch_level_start 302 291 CALL message( 'init_grid', 'PA0211', 1, 2, 0, 6, 0 ) 303 292 ENDIF 304 305 !-- The number of specified start levels has to be the same or one more than 306 !-- the number of specifiedend levels307 IF ( number_stretch_level_start /= number_stretch_level_end + 1 .AND.&293 294 !-- The number of specified start levels has to be the same or one more than the number of specified 295 !-- end levels 296 IF ( number_stretch_level_start /= number_stretch_level_end + 1 .AND. & 308 297 number_stretch_level_start /= number_stretch_level_end ) THEN 309 WRITE( message_string, * ) 'The number of values for ', & 310 'dz_stretch_level_start = ', & 311 dz_stretch_level_start, 'has to be the ', & 312 'same or one more than& the number of ', & 313 'values for dz_stretch_level_end = ', & 314 number_stretch_level_end 298 WRITE( message_string, * ) 'The number of values for ', & 299 'dz_stretch_level_start = ', dz_stretch_level_start, & 300 'has to be the ', 'same or one more than& the number of ', & 301 'values for dz_stretch_level_end = ', number_stretch_level_end 315 302 CALL message( 'init_grid', 'PA0216', 1, 2, 0, 6, 0 ) 316 303 ENDIF … … 318 305 ! 319 306 !-- Initialize dz for the free atmosphere with the value of dz_max 320 IF ( dz(number_stretch_level_start+1) == -1.0_wp .AND. & 321 number_stretch_level_start /= 0 ) THEN 307 IF ( dz(number_stretch_level_start+1) == -1.0_wp .AND. number_stretch_level_start /= 0 ) THEN 322 308 dz(number_stretch_level_start+1) = dz_max 323 309 ENDIF 324 325 ! 326 !-- Initialize the stretching factor if (infinitely) stretching in the free 327 !-- atmosphere is desired (dz_stretch_level_end was not specified for the 328 !-- free atmosphere) 329 IF ( number_stretch_level_start == number_stretch_level_end + 1 ) THEN 330 dz_stretch_factor_array(number_stretch_level_start) = & 331 dz_stretch_factor 310 311 ! 312 !-- Initialize the stretching factor if (infinitely) stretching in the free atmosphere is desired 313 !-- (dz_stretch_level_end was not specified for the free atmosphere) 314 IF ( number_stretch_level_start == number_stretch_level_end + 1 ) THEN 315 dz_stretch_factor_array(number_stretch_level_start) = dz_stretch_factor 332 316 ENDIF 333 317 334 318 ! 335 319 !-- Allocation of arrays for stretching … … 339 323 !-- Define the vertical grid levels. Start with atmosphere branch 340 324 IF ( .NOT. ocean_mode ) THEN 341 342 ! 343 !-- The stretching region has to be large enough to allow for a smooth 344 !-- transition between two different grid spacings. The number 4 is an 345 !-- empirical value 325 326 ! 327 !-- The stretching region has to be large enough to allow for a smooth transition between two 328 !-- different grid spacings. The number 4 is an empirical value. 346 329 DO n = 1, number_stretch_level_start 347 min_dz_stretch_level_end(n) = dz_stretch_level_start(n) + & 348 4 * MAX( dz(n),dz(n+1) ) 330 min_dz_stretch_level_end(n) = dz_stretch_level_start(n) + 4 * MAX( dz(n),dz(n+1) ) 349 331 ENDDO 350 332 351 IF ( ANY( min_dz_stretch_level_end(1:number_stretch_level_start) > &352 dz_stretch_level_end(1:number_stretch_level_start) ) ) THEN353 message_string= 'Each dz_stretch_level_end has to be larger ' // &354 'than its corresponding value for &' // &355 'dz_stretch_level_start + 4*MAX(dz(n),dz(n+1)) '// &333 IF ( ANY( min_dz_stretch_level_end(1:number_stretch_level_start) > & 334 dz_stretch_level_end(1:number_stretch_level_start) ) ) THEN 335 message_string= 'Each dz_stretch_level_end has to be larger ' // & 336 'than its corresponding value for &' // & 337 'dz_stretch_level_start + 4*MAX(dz(n),dz(n+1)) '// & 356 338 'to allow for smooth grid stretching' 357 339 CALL message( 'init_grid', 'PA0224', 1, 2, 0, 6, 0 ) 358 340 ENDIF 359 360 ! 361 !-- Stretching must not be applied within the surface layer 362 !-- (first two grid points). For the default case dz_stretch_level_start 363 !-- is negative. Therefore the absolut value is checked here. 341 342 ! 343 !-- Stretching must not be applied within the surface layer (first two grid points). For the 344 !-- default case dz_stretch_level_start is negative. Therefore the absolut value is checked here. 364 345 IF ( ANY( ABS( dz_stretch_level_start ) <= dz(1) * 1.5_wp ) ) THEN 365 WRITE( message_string, * ) 'Each dz_stretch_level_start has to be ',&366 'larger than ', dz(1) * 1.5346 WRITE( message_string, * ) 'Each dz_stretch_level_start has to be ', & 347 'larger than ', dz(1) * 1.5 367 348 CALL message( 'init_grid', 'PA0226', 1, 2, 0, 6, 0 ) 368 349 ENDIF 369 350 370 351 ! 371 !-- The stretching has to start and end on a grid level. Therefore 372 !-- user-specified values are mapped to the next lowest level. The 373 !-- calculation of the first level is realized differently just because of 374 !-- historical reasons (the advanced/new stretching mechanism was realized 375 !-- in a way that results don't change if the old parameters 376 !-- dz_stretch_level, dz_stretch_factor and dz_max are used) 377 IF ( number_stretch_level_start /= 0 ) THEN 378 dz_stretch_level_start(1) = INT( (dz_stretch_level_start(1) - & 379 dz(1)/2.0) / dz(1) ) & 352 !-- The stretching has to start and end on a grid level. Therefore user-specified values are 353 !-- mapped to the next lowest level. The calculation of the first level is realized differently 354 !-- just because of historical reasons (the advanced/new stretching mechanism was realized in a 355 !-- way that results don't change if the old parameters dz_stretch_level, dz_stretch_factor and 356 !-- dz_max are used). 357 IF ( number_stretch_level_start /= 0 ) THEN 358 dz_stretch_level_start(1) = INT( (dz_stretch_level_start(1) - dz(1)/2.0) / dz(1) ) & 380 359 * dz(1) + dz(1)/2.0 381 360 ENDIF 382 361 383 362 IF ( number_stretch_level_start > 1 ) THEN 384 363 DO n = 2, number_stretch_level_start 385 dz_stretch_level_start(n) = INT( dz_stretch_level_start(n) / & 386 dz(n) ) * dz(n) 387 ENDDO 388 ENDIF 389 364 dz_stretch_level_start(n) = INT( dz_stretch_level_start(n) / dz(n) ) * dz(n) 365 ENDDO 366 ENDIF 367 390 368 IF ( number_stretch_level_end /= 0 ) THEN 391 369 DO n = 1, number_stretch_level_end 392 dz_stretch_level_end(n) = INT( dz_stretch_level_end(n) / & 393 dz(n+1) ) * dz(n+1) 370 dz_stretch_level_end(n) = INT( dz_stretch_level_end(n) / dz(n+1) ) * dz(n+1) 394 371 ENDDO 395 372 ENDIF … … 397 374 ! 398 375 !-- Determine stretching factor if necessary 399 IF ( number_stretch_level_end >= 1 ) THEN 376 IF ( number_stretch_level_end >= 1 ) THEN 400 377 CALL calculate_stretching_factor( number_stretch_level_end ) 401 378 ENDIF … … 403 380 ! 404 381 !-- Grid for atmosphere with surface at z=0 (k=0, w-grid). 405 !-- First compute the u- and v-levels. In case of dirichlet bc for u and v 406 !-- the first u/v- and w-level (k=0) are defined at same height (z=0). 407 !-- The second u-level (k=1) corresponds to the top of the 408 !-- surface layer. In case of symmetric boundaries (closed channel flow), 409 !-- the first grid point is always at z=0. 410 IF ( ibc_uv_b == 0 .OR. ibc_uv_b == 2 .OR. & 411 topography == 'closed_channel' ) THEN 382 !-- First compute the u- and v-levels. In case of dirichlet bc for u and v the first u/v- and 383 !-- w-level (k=0) are defined at same height (z=0). 384 !-- The second u-level (k=1) corresponds to the top of the surface layer. In case of symmetric 385 !-- boundaries (closed channel flow), the first grid point is always at z=0. 386 IF ( ibc_uv_b == 0 .OR. ibc_uv_b == 2 .OR. topography == 'closed_channel' ) THEN 412 387 zu(0) = 0.0_wp 413 388 ELSE 414 389 zu(0) = - dz(1) * 0.5_wp 415 390 ENDIF 416 391 417 392 zu(1) = dz(1) * 0.5_wp 418 419 ! 420 !-- Determine u and v height levels considering the possibility of grid 421 !-- stretching in severalheights.393 394 ! 395 !-- Determine u and v height levels considering the possibility of grid stretching in several 396 !-- heights. 422 397 n = 1 423 398 dz_stretch_level_start_index = nzt+1 … … 425 400 dz_stretched = dz(1) 426 401 427 !-- The default value of dz_stretch_level_start is negative, thus the first 428 !-- condition is true even if no stretching shall be applied. Hence, the 429 !-- second condition is also necessary. 402 !-- The default value of dz_stretch_level_start is negative, thus the first condition is true 403 !-- even if no stretching shall be applied. Hence, the second condition is also necessary. 430 404 DO k = 2, nzt+1-symmetry_flag 431 IF ( dz_stretch_level_start(n) <= zu(k-1) .AND.&432 dz_stretch_level_start(n) /= -9999999.9_wp ) THEN405 IF ( dz_stretch_level_start(n) <= zu(k-1) .AND. & 406 dz_stretch_level_start(n) /= -9999999.9_wp ) THEN 433 407 dz_stretched = dz_stretched * dz_stretch_factor_array(n) 434 435 IF ( dz(n) > dz(n+1) ) THEN408 409 IF ( dz(n) > dz(n+1) ) THEN 436 410 dz_stretched = MAX( dz_stretched, dz(n+1) ) !Restrict dz_stretched to the user-specified (higher) dz 437 411 ELSE 438 412 dz_stretched = MIN( dz_stretched, dz(n+1) ) !Restrict dz_stretched to the user-specified (lower) dz 439 413 ENDIF 440 441 IF ( dz_stretch_level_start_index(n) == nzt+1 ) & 442 dz_stretch_level_start_index(n) = k-1 443 444 ENDIF 445 414 415 IF ( dz_stretch_level_start_index(n) == nzt+1 ) dz_stretch_level_start_index(n) = k-1 416 417 ENDIF 418 446 419 zu(k) = zu(k-1) + dz_stretched 447 448 ! 449 !-- Make sure that the stretching ends exactly at dz_stretch_level_end 450 dz_level_end = ABS( zu(k) - dz_stretch_level_end(n) ) 451 452 IF ( dz_level_end < dz(n+1)/3.0 ) THEN420 421 ! 422 !-- Make sure that the stretching ends exactly at dz_stretch_level_end 423 dz_level_end = ABS( zu(k) - dz_stretch_level_end(n) ) 424 425 IF ( dz_level_end < dz(n+1)/3.0 ) THEN 453 426 zu(k) = dz_stretch_level_end(n) 454 427 dz_stretched = dz(n+1) 455 428 dz_stretch_level_end_index(n) = k 456 n = n + 1 429 n = n + 1 457 430 ENDIF 458 431 ENDDO 459 460 ! 461 !-- If a closed channel flow is simulated, make sure that grid structure is 462 !-- the same for both bottom and top boundary. (Hint: Using a different dz 463 !-- at the bottom and at the top makes no sense due to symmetric boundaries 464 !-- where dz should be equal. Therefore, different dz at the bottom and top 465 !-- causes an abort (see check_parameters).) 466 IF ( topography == 'closed_channel' ) THEN 432 433 ! 434 !-- If a closed channel flow is simulated, make sure that grid structure is the same for both 435 !-- bottom and top boundary. (Hint: Using a different dz at the bottom and at the top makes no 436 !-- sense due to symmetric boundaries where dz should be equal. Therefore, different dz at the 437 !-- bottom and top causes an abort (see check_parameters).) 438 IF ( topography == 'closed_channel' ) THEN 467 439 zu(nzt+1) = zu(nzt) + dz(1) * 0.5_wp 468 440 ENDIF 469 441 470 442 ! 471 !-- Compute the w-levels. They are always staggered half-way between the 472 !-- corresponding u-levels. In case of dirichlet bc for u and v at the 473 !-- ground the first u- and w-level (k=0) are defined at same height (z=0). 474 !-- Per default, the top w-level is extrapolated linearly. In case of 475 !-- a closed channel flow, zu(nzt+1) and zw(nzt) must be set explicitely. 476 !-- (Hint: Using a different dz at the bottom and at the top makes no sense 477 !-- due to symmetric boundaries where dz should be equal. Therefore, 478 !-- different dz at the bottom and top causes an abort (see 479 !-- check_parameters).) 443 !-- Compute the w-levels. They are always staggered half-way between the corresponding u-levels. 444 !-- In case of dirichlet bc for u and v at the ground the first u- and w-level (k=0) are defined 445 !-- at same height (z=0). 446 !-- Per default, the top w-level is extrapolated linearly. In case of a closed channel flow, 447 !-- zu(nzt+1) and zw(nzt) must be set explicitely. 448 !-- (Hint: Using a different dz at the bottom and at the top makes no sense due to symmetric 449 !-- boundaries where dz should be equal. Therefore, different dz at the bottom and top causes an 450 !-- abort (see check_parameters).) 480 451 zw(0) = 0.0_wp 481 452 DO k = 1, nzt-symmetry_flag 482 453 zw(k) = ( zu(k) + zu(k+1) ) * 0.5_wp 483 454 ENDDO 484 IF ( topography == 'closed_channel' ) THEN455 IF ( topography == 'closed_channel' ) THEN 485 456 zw(nzt) = zw(nzt-1) + dz(1) 486 457 zw(nzt+1) = zw(nzt) + dz(1) … … 492 463 493 464 ! 494 !-- The stretching region has to be large enough to allow for a smooth 495 !-- transition between two different grid spacings. The number 4 is an 496 !-- empirical value 465 !-- The stretching region has to be large enough to allow for a smooth transition between two 466 !-- different grid spacings. The number 4 is an empirical value 497 467 DO n = 1, number_stretch_level_start 498 min_dz_stretch_level_end(n) = dz_stretch_level_start(n) - & 499 4 * MAX( dz(n),dz(n+1) ) 468 min_dz_stretch_level_end(n) = dz_stretch_level_start(n) - 4 * MAX( dz(n),dz(n+1) ) 500 469 ENDDO 501 502 IF ( ANY( min_dz_stretch_level_end (1:number_stretch_level_start) < &503 dz_stretch_level_end(1:number_stretch_level_start) ) ) THEN504 message_string= 'Each dz_stretch_level_end has to be less ' // &505 'than its corresponding value for &' // &506 'dz_stretch_level_start - 4*MAX(dz(n),dz(n+1)) '// &470 471 IF ( ANY( min_dz_stretch_level_end (1:number_stretch_level_start) < & 472 dz_stretch_level_end(1:number_stretch_level_start) ) ) THEN 473 message_string= 'Each dz_stretch_level_end has to be less ' // & 474 'than its corresponding value for &' // & 475 'dz_stretch_level_start - 4*MAX(dz(n),dz(n+1)) '// & 507 476 'to allow for smooth grid stretching' 508 477 CALL message( 'init_grid', 'PA0224', 1, 2, 0, 6, 0 ) 509 478 ENDIF 510 511 ! 512 !-- Stretching must not be applied close to the surface (last two grid 513 !-- points). For the default case dz_stretch_level_start is negative.514 IF ( ANY( dz_stretch_level_start >= - dz(1) * 1.5_wp ) ) THEN515 WRITE( message_string, * ) 'Each dz_stretch_level_start has to be ',&516 'less than ', -dz(1) * 1.5479 480 ! 481 !-- Stretching must not be applied close to the surface (last two grid points). For the default 482 !-- case dz_stretch_level_start is negative. 483 IF ( ANY( dz_stretch_level_start >= - dz(1) * 1.5_wp ) ) THEN 484 WRITE( message_string, * ) 'Each dz_stretch_level_start has to be ', & 485 'less than ', -dz(1) * 1.5 517 486 CALL message( 'init_grid', 'PA0226', 1, 2, 0, 6, 0 ) 518 487 ENDIF 519 488 520 489 ! 521 !-- The stretching has to start and end on a grid level. Therefore 522 !-- user-specified values are mapped to the next highest level. The 523 !-- calculation of the first level is realized differently just because of 524 !-- historical reasons (the advanced/new stretching mechanism was realized 525 !-- in a way that results don't change if the old parameters 526 !-- dz_stretch_level, dz_stretch_factor and dz_max are used) 527 IF ( number_stretch_level_start /= 0 ) THEN 528 dz_stretch_level_start(1) = INT( (dz_stretch_level_start(1) + & 529 dz(1)/2.0) / dz(1) ) & 490 !-- The stretching has to start and end on a grid level. Therefore user-specified values are 491 !-- mapped to the next highest level. The calculation of the first level is realized differently 492 !-- just because of historical reasons (the advanced/new stretching mechanism was realized in a 493 !-- way that results don't change if the old parameters dz_stretch_level, dz_stretch_factor and 494 !-- dz_max are used) 495 IF ( number_stretch_level_start /= 0 ) THEN 496 dz_stretch_level_start(1) = INT( (dz_stretch_level_start(1) + dz(1)/2.0) / dz(1) ) & 530 497 * dz(1) - dz(1)/2.0 531 498 ENDIF 532 533 IF ( number_stretch_level_start > 1 ) THEN499 500 IF ( number_stretch_level_start > 1 ) THEN 534 501 DO n = 2, number_stretch_level_start 535 dz_stretch_level_start(n) = INT( dz_stretch_level_start(n) / & 536 dz(n) ) * dz(n) 537 ENDDO 538 ENDIF 539 540 IF ( number_stretch_level_end /= 0 ) THEN 502 dz_stretch_level_start(n) = INT( dz_stretch_level_start(n) / dz(n) ) * dz(n) 503 ENDDO 504 ENDIF 505 506 IF ( number_stretch_level_end /= 0 ) THEN 541 507 DO n = 1, number_stretch_level_end 542 dz_stretch_level_end(n) = INT( dz_stretch_level_end(n) / & 543 dz(n+1) ) * dz(n+1) 544 ENDDO 545 ENDIF 546 508 dz_stretch_level_end(n) = INT( dz_stretch_level_end(n) / dz(n+1) ) * dz(n+1) 509 ENDDO 510 ENDIF 511 547 512 ! 548 513 !-- Determine stretching factor if necessary 549 IF ( number_stretch_level_end >= 1 ) THEN 514 IF ( number_stretch_level_end >= 1 ) THEN 550 515 CALL calculate_stretching_factor( number_stretch_level_end ) 551 516 ENDIF … … 553 518 ! 554 519 !-- Grid for ocean with free water surface is at k=nzt (w-grid). 555 !-- In case of neumann bc at the ground the first first u-level (k=0) lies 556 !-- below the first w-level (k=0). In case of dirichlet bc the first u- and557 !-- w-level are defined at same height,but staggered from the second level.520 !-- In case of neumann bc at the ground the first first u-level (k=0) lies below the first 521 !-- w-level (k=0). In case of dirichlet bc the first u- and w-level are defined at same height, 522 !-- but staggered from the second level. 558 523 !-- The second u-level (k=1) corresponds to the top of the surface layer. 559 524 !-- z values are negative starting from z=0 (surface) … … 562 527 563 528 ! 564 !-- Determine u and v height levels considering the possibility of grid 565 !-- stretching in severalheights.529 !-- Determine u and v height levels considering the possibility of grid stretching in several 530 !-- heights. 566 531 n = 1 567 532 dz_stretch_level_start_index = 0 … … 570 535 571 536 DO k = nzt-1, 0, -1 572 573 IF ( dz_stretch_level_start(n) >= zu(k+1) ) THEN537 538 IF ( dz_stretch_level_start(n) >= zu(k+1) ) THEN 574 539 dz_stretched = dz_stretched * dz_stretch_factor_array(n) 575 540 576 IF ( dz(n) > dz(n+1) ) THEN541 IF ( dz(n) > dz(n+1) ) THEN 577 542 dz_stretched = MAX( dz_stretched, dz(n+1) ) !Restrict dz_stretched to the user-specified (higher) dz 578 543 ELSE 579 544 dz_stretched = MIN( dz_stretched, dz(n+1) ) !Restrict dz_stretched to the user-specified (lower) dz 580 545 ENDIF 581 582 IF ( dz_stretch_level_start_index(n) == 0 ) & 583 dz_stretch_level_start_index(n) = k+1 584 585 ENDIF 586 546 547 IF ( dz_stretch_level_start_index(n) == 0 ) dz_stretch_level_start_index(n) = k+1 548 549 ENDIF 550 587 551 zu(k) = zu(k+1) - dz_stretched 588 589 ! 590 !-- Make sure that the stretching ends exactly at dz_stretch_level_end 591 dz_level_end = ABS( zu(k) - dz_stretch_level_end(n) ) 592 593 IF ( dz_level_end < dz(n+1)/3.0 ) THEN552 553 ! 554 !-- Make sure that the stretching ends exactly at dz_stretch_level_end 555 dz_level_end = ABS( zu(k) - dz_stretch_level_end(n) ) 556 557 IF ( dz_level_end < dz(n+1)/3.0 ) THEN 594 558 zu(k) = dz_stretch_level_end(n) 595 559 dz_stretched = dz(n+1) 596 560 dz_stretch_level_end_index(n) = k 597 n = n + 1 561 n = n + 1 598 562 ENDIF 599 563 ENDDO 600 601 ! 602 !-- Compute the w-levels. They are always staggered half-way between the 603 !-- corresponding u-levels, except in case of dirichlet bc for u and v 604 !-- at the ground. In this case the first u- and w-level are defined at 605 !-- same height. The top w-level (nzt+1) is not used but set for 564 565 ! 566 !-- Compute the w-levels. They are always staggered half-way between the corresponding u-levels, 567 !-- except in case of dirichlet bc for u and v at the ground. In this case the first u- and 568 !-- w-level are defined at same height. The top w-level (nzt+1) is not used but set for 606 569 !-- consistency, since w and all scalar variables are defined up tp nzt+1. 607 570 zw(nzt+1) = dz(1) … … 612 575 613 576 ! 614 !-- In case of dirichlet bc for u and v the first u- and w-level are defined 615 !-- at same height. 577 !-- In case of dirichlet bc for u and v the first u- and w-level are defined at same height. 616 578 IF ( ibc_uv_b == 0 ) THEN 617 579 zu(0) = zw(0) … … 632 594 dd2zu(k) = 1.0_wp / ( dzu(k) + dzu(k+1) ) 633 595 ENDDO 634 635 ! 636 !-- The FFT- SOR-pressure solvers assume grid spacings of a staggered grid 637 !-- everywhere. For the actual grid, the grid spacing at the lowest level 638 !-- is only dz/2, but should be dz. Therefore, an additional array 639 !-- containing with appropriate grid information is created for these 640 !-- solvers. 596 597 ! 598 !-- The FFT- SOR-pressure solvers assume grid spacings of a staggered grid everywhere. For the 599 !-- actual grid, the grid spacing at the lowest level is only dz/2, but should be dz. Therefore, an 600 !-- additional array containing with appropriate grid information is created for these solvers. 641 601 IF ( psolver(1:9) /= 'multigrid' ) THEN 642 602 ALLOCATE( ddzu_pres(1:nzt+1) ) … … 659 619 topo = 0 660 620 ! 661 !-- Initialize topography by generic topography or read topography from file. 621 !-- Initialize topography by generic topography or read topography from file. 662 622 CALL init_topo( topo ) 663 623 ! 664 !-- Set flags to mask topography on the grid. 624 !-- Set flags to mask topography on the grid. 665 625 CALL set_topo_flags( topo ) 666 626 667 627 ! 668 !-- Determine the maximum level of topography. It is used for 669 !-- steering the degradation of order of the applied advection scheme, 670 !-- as well in the lpm. 628 !-- Determine the maximum level of topography. It is used for steering the degradation of order of 629 !-- the applied advection scheme, as well in the lpm. 671 630 k_top = 0 672 631 DO i = nxl, nxr … … 678 637 ENDDO 679 638 #if defined( __parallel ) 680 CALL MPI_ALLREDUCE( k_top, nzb_max, 1, MPI_INTEGER, & 681 MPI_MAX, comm2d, ierr ) 639 CALL MPI_ALLREDUCE( k_top, nzb_max, 1, MPI_INTEGER, MPI_MAX, comm2d, ierr ) 682 640 #else 683 641 nzb_max = k_top … … 686 644 !-- Increment nzb_max by 1 in order to allow for proper diverengence correction. 687 645 !-- Further, in case topography extents up to the model top, limit to nzt. 688 nzb_max = MIN( nzb_max+1, nzt ) 689 ! 690 !-- Determine minimum index of topography. Usually, this will be nzb. In case 691 !-- t here is elevated topography, however, the lowest topography will be higher.692 !-- This index is e.g. used to calculate mean first-grid point atmosphere 693 !-- temperature, surfacepressure and density, etc. .646 nzb_max = MIN( nzb_max+1, nzt ) 647 ! 648 !-- Determine minimum index of topography. Usually, this will be nzb. In case there is elevated 649 !-- topography, however, the lowest topography will be higher. 650 !-- This index is e.g. used to calculate mean first-grid point atmosphere temperature, surface 651 !-- pressure and density, etc. . 694 652 topo_min_level = 0 695 653 #if defined( __parallel ) 696 CALL MPI_ALLREDUCE( MINVAL( topo_top_ind(nys:nyn,nxl:nxr,0) ), 697 topo_min_level, 1, MPI_INTEGER,MPI_MIN, comm2d, ierr )654 CALL MPI_ALLREDUCE( MINVAL( topo_top_ind(nys:nyn,nxl:nxr,0) ), topo_min_level, 1, MPI_INTEGER, & 655 MPI_MIN, comm2d, ierr ) 698 656 #else 699 657 topo_min_level = MINVAL( topo_top_ind(nys:nyn,nxl:nxr,0) ) … … 701 659 702 660 ! 703 !-- Check topography for consistency with model domain. Therefore, use 704 !-- maximum and minium topography-top indices. Note, minimum topography top 705 !-- index is already calculated. 661 !-- Check topography for consistency with model domain. Therefore, use maximum and minium 662 !-- topography-top indices. Note, minimum topography top index is already calculated. 706 663 IF ( TRIM( topography ) /= 'flat' ) THEN 707 664 #if defined( __parallel ) 708 CALL MPI_ALLREDUCE( MAXVAL( topo_top_ind(nys:nyn,nxl:nxr,0) ), &709 nzb_local_max, 1, MPI_INTEGER, MPI_MAX, comm2d, ierr )665 CALL MPI_ALLREDUCE( MAXVAL( topo_top_ind(nys:nyn,nxl:nxr,0) ), nzb_local_max, 1, & 666 MPI_INTEGER, MPI_MAX, comm2d, ierr ) 710 667 #else 711 668 nzb_local_max = MAXVAL( topo_top_ind(nys:nyn,nxl:nxr,0) ) … … 715 672 !-- Consistency checks 716 673 IF ( nzb_local_min < 0 .OR. nzb_local_max > nz + 1 ) THEN 717 WRITE( message_string, * ) 'nzb_local values are outside the', & 718 ' model domain', & 719 '&MINVAL( nzb_local ) = ', nzb_local_min, & 720 '&MAXVAL( nzb_local ) = ', nzb_local_max 674 WRITE( message_string, * ) 'nzb_local values are outside the model domain', & 675 '&MINVAL( nzb_local ) = ', nzb_local_min, & 676 '&MAXVAL( nzb_local ) = ', nzb_local_max 721 677 CALL message( 'init_grid', 'PA0210', 1, 2, 0, 6, 0 ) 722 678 ENDIF 723 679 ENDIF 724 680 ! 725 !-- Define vertical gridpoint from (or to) which on the usual finite difference 726 !-- form (which does not use surface fluxes) is applied681 !-- Define vertical gridpoint from (or to) which on the usual finite difference form (which does not 682 !-- use surface fluxes) is applied. 727 683 IF ( constant_flux_layer .OR. use_surface_fluxes ) THEN 728 684 nzb_diff = nzb + 2 … … 733 689 IF ( TRIM( topography ) /= 'flat' ) THEN 734 690 ! 735 !-- Allocate and set the arrays containing the topography height (for output 736 !-- reasons only). 691 !-- Allocate and set the arrays containing the topography height (for output reasons only). 737 692 IF ( nxr == nx .AND. nyn /= ny ) THEN 738 ALLOCATE( zu_s_inner(nxl:nxr+1,nys:nyn), & 739 zw_w_inner(nxl:nxr+1,nys:nyn) ) 693 ALLOCATE( zu_s_inner(nxl:nxr+1,nys:nyn), zw_w_inner(nxl:nxr+1,nys:nyn) ) 740 694 ELSEIF ( nxr /= nx .AND. nyn == ny ) THEN 741 ALLOCATE( zu_s_inner(nxl:nxr,nys:nyn+1), & 742 zw_w_inner(nxl:nxr,nys:nyn+1) ) 695 ALLOCATE( zu_s_inner(nxl:nxr,nys:nyn+1), zw_w_inner(nxl:nxr,nys:nyn+1) ) 743 696 ELSEIF ( nxr == nx .AND. nyn == ny ) THEN 744 ALLOCATE( zu_s_inner(nxl:nxr+1,nys:nyn+1), & 745 zw_w_inner(nxl:nxr+1,nys:nyn+1) ) 697 ALLOCATE( zu_s_inner(nxl:nxr+1,nys:nyn+1), zw_w_inner(nxl:nxr+1,nys:nyn+1) ) 746 698 ELSE 747 ALLOCATE( zu_s_inner(nxl:nxr,nys:nyn), & 748 zw_w_inner(nxl:nxr,nys:nyn) ) 699 ALLOCATE( zu_s_inner(nxl:nxr,nys:nyn), zw_w_inner(nxl:nxr,nys:nyn) ) 749 700 ENDIF 750 701 … … 752 703 zw_w_inner = 0.0_wp 753 704 ! 754 !-- Determine local topography height on scalar and w-grid. Note, setting 755 !-- lateral boundary values is not necessary, realized via wall_flags_static_0 756 !-- array. Further, please note that loop bounds are different from 757 !-- nxl to nxr and nys to nyn on south and right model boundary, hence, 705 !-- Determine local topography height on scalar and w-grid. Note, setting lateral boundary values 706 !-- is not necessary, realized via wall_flags_static_0 array. Further, please note that loop 707 !-- bounds are different from nxl to nxr and nys to nyn on south and right model boundary, hence, 758 708 !-- use intrinsic lbound and ubound functions to infer array bounds. 759 709 DO i = LBOUND(zu_s_inner, 1), UBOUND(zu_s_inner, 1) 760 710 DO j = LBOUND(zu_s_inner, 2), UBOUND(zu_s_inner, 2) 761 711 ! 762 !-- Topography height on scalar grid. Therefore, determine index of 763 !-- upward-facing surfaceelement on scalar grid.712 !-- Topography height on scalar grid. Therefore, determine index of upward-facing surface 713 !-- element on scalar grid. 764 714 zu_s_inner(i,j) = zu(topo_top_ind(j,i,0)) 765 715 ! 766 !-- Topography height on w grid. Therefore, determine index of 767 !-- upward-facing surfaceelement on w grid.716 !-- Topography height on w grid. Therefore, determine index of upward-facing surface 717 !-- element on w grid. 768 718 zw_w_inner(i,j) = zw(topo_top_ind(j,i,3)) 769 719 ENDDO … … 775 725 776 726 ! Description: 777 ! -----------------------------------------------------------------------------! 778 !> Calculation of the stretching factor through an iterative method. Ideas were 779 !> taken from the paper "Regional stretched grid generation and its application 780 !> to the NCAR RegCM (1999)". Normally, no analytic solution exists because the 781 !> system of equations has two variables (r,l) but four requirements 782 !> (l=integer, r=[0,88;1,2], Eq(6), Eq(5) starting from index j=1) which 783 !> results into an overdetermined system. 784 !------------------------------------------------------------------------------! 727 ! -------------------------------------------------------------------------------------------------! 728 !> Calculation of the stretching factor through an iterative method. Ideas were taken from the paper 729 !> "Regional stretched grid generation and its application to the NCAR RegCM (1999)". Normally, no 730 !> analytic solution exists because the system of equations has two variables (r,l) but four 731 !> requirements (l=integer, r=[0,88;1,2], Eq(6), Eq(5) starting from index j=1) which results into 732 !> an overdetermined system. 733 !--------------------------------------------------------------------------------------------------! 785 734 SUBROUTINE calculate_stretching_factor( number_end ) 786 787 USE control_parameters, &788 ONLY: dz, dz_stretch_factor_array, 789 dz_stretch_level_end, dz_stretch_level_start,message_string790 735 736 USE control_parameters, & 737 ONLY: dz, dz_stretch_factor_array, dz_stretch_level_end, dz_stretch_level_start, & 738 message_string 739 791 740 USE kinds 792 741 793 742 IMPLICIT NONE 794 795 INTEGER(iwp) :: iterations !< number of iterations until stretch_factor_lower/upper_limit is reached 796 INTEGER(iwp) :: l_rounded !< after l_rounded grid levels dz(n) is strechted to dz(n+1) with stretch_factor_2 743 744 REAL(wp), PARAMETER :: stretch_factor_interval = 1.0E-06_wp !< interval for sampling possible stretching factors 745 REAL(wp), PARAMETER :: stretch_factor_lower_limit = 0.88_wp !< lowest possible stretching factor 746 REAL(wp), PARAMETER :: stretch_factor_upper_limit = 1.12_wp !< highest possible stretching factor 747 748 INTEGER(iwp) :: iterations !< number of iterations until stretch_factor_lower/upper_limit is reached 749 INTEGER(iwp) :: l_rounded !< after l_rounded grid levels dz(n) is strechted to dz(n+1) with stretch_factor_2 797 750 INTEGER(iwp) :: n !< loop variable for stretching 798 751 799 752 INTEGER(iwp), INTENT(IN) :: number_end !< number of user-specified end levels for stretching 800 753 801 754 REAL(wp) :: delta_l !< absolute difference between l and l_rounded 802 755 REAL(wp) :: delta_stretch_factor !< absolute difference between stretch_factor_1 and stretch_factor_2 803 REAL(wp) :: delta_total_new !< sum of delta_l and delta_stretch_factor for the next iteration (should be as small as possible) 804 REAL(wp) :: delta_total_old !< sum of delta_l and delta_stretch_factor for the last iteration 756 REAL(wp) :: delta_total_new !< sum of delta_l and delta_stretch_factor for the next iteration (should be as small as 757 !< possible) 758 REAL(wp) :: delta_total_old !< sum of delta_l and delta_stretch_factor for the last iteration 805 759 REAL(wp) :: distance !< distance between dz_stretch_level_start and dz_stretch_level_end (stretching region) 806 REAL(wp) :: l !< value that fulfil Eq. (5) in the paper mentioned above together with stretch_factor_1 exactly 760 REAL(wp) :: l !< value that fulfil Eq. (5) in the paper mentioned above together with stretch_factor_1 761 !< exactly 807 762 REAL(wp) :: numerator !< numerator of the quotient 808 763 REAL(wp) :: stretch_factor_1 !< stretching factor that fulfil Eq. (5) togehter with l exactly 809 764 REAL(wp) :: stretch_factor_2 !< stretching factor that fulfil Eq. (6) togehter with l_rounded exactly 810 811 REAL(wp) :: dz_stretch_factor_array_2(9) = 1.08_wp !< Array that contains all stretch_factor_2 that belongs to stretch_factor_1 812 813 REAL(wp), PARAMETER :: stretch_factor_interval = 1.0E-06_wp !< interval for sampling possible stretching factors 814 REAL(wp), PARAMETER :: stretch_factor_lower_limit = 0.88_wp !< lowest possible stretching factor 815 REAL(wp), PARAMETER :: stretch_factor_upper_limit = 1.12_wp !< highest possible stretching factor 816 817 765 766 REAL(wp) :: dz_stretch_factor_array_2(9) = 1.08_wp !< Array that contains all stretch_factor_2 that belongs to 767 !< stretch_factor_1 768 769 818 770 l = 0 819 771 DO n = 1, number_end 820 772 821 773 iterations = 1 822 stretch_factor_1 = 1.0_wp 774 stretch_factor_1 = 1.0_wp 823 775 stretch_factor_2 = 1.0_wp 824 776 delta_total_old = 1.0_wp 825 777 826 778 ! 827 779 !-- First branch for stretching from rough to fine 828 IF ( dz(n) > dz(n+1) ) THEN829 DO WHILE ( stretch_factor_1 >= stretch_factor_lower_limit ) 830 780 IF ( dz(n) > dz(n+1) ) THEN 781 DO WHILE ( stretch_factor_1 >= stretch_factor_lower_limit ) 782 831 783 stretch_factor_1 = 1.0_wp - iterations * stretch_factor_interval 832 distance = ABS( dz_stretch_level_end(n) - & 833 dz_stretch_level_start(n) ) 834 numerator = distance*stretch_factor_1/dz(n) + & 835 stretch_factor_1 - distance/dz(n) 836 837 IF ( numerator > 0.0_wp ) THEN 784 distance = ABS( dz_stretch_level_end(n) - dz_stretch_level_start(n) ) 785 numerator = distance * stretch_factor_1 / dz(n) + stretch_factor_1 - distance / dz(n) 786 787 IF ( numerator > 0.0_wp ) THEN 838 788 l = LOG( numerator ) / LOG( stretch_factor_1 ) - 1.0_wp 839 789 l_rounded = NINT( l ) 840 790 delta_l = ABS( l_rounded - l ) / l 841 791 ENDIF 842 792 843 793 stretch_factor_2 = EXP( LOG( dz(n+1)/dz(n) ) / (l_rounded) ) 844 845 delta_stretch_factor = ABS( stretch_factor_1 - & 846 stretch_factor_2 ) / & 847 stretch_factor_2 848 794 795 delta_stretch_factor = ABS( stretch_factor_1 - stretch_factor_2 ) / stretch_factor_2 796 849 797 delta_total_new = delta_l + delta_stretch_factor 850 798 851 799 ! 852 !-- stretch_factor_1 is taken to guarantee that the stretching 853 !-- p rocedure ends as close as possible to dz_stretch_level_end.854 !-- stretch_factor_2 would guarantee that the stretched dz(n) is 855 !-- equal to dz(n+1) afterl_rounded grid levels.856 IF (delta_total_new < delta_total_old) THEN800 !-- stretch_factor_1 is taken to guarantee that the stretching procedure ends as close as 801 !-- possible to dz_stretch_level_end. 802 !-- stretch_factor_2 would guarantee that the stretched dz(n) is equal to dz(n+1) after 803 !-- l_rounded grid levels. 804 IF (delta_total_new < delta_total_old) THEN 857 805 dz_stretch_factor_array(n) = stretch_factor_1 858 806 dz_stretch_factor_array_2(n) = stretch_factor_2 859 807 delta_total_old = delta_total_new 860 808 ENDIF 861 809 862 810 iterations = iterations + 1 863 811 864 812 ENDDO 865 813 866 814 ! 867 815 !-- Second branch for stretching from fine to rough 868 ELSEIF ( dz(n) < dz(n+1) ) THEN816 ELSEIF ( dz(n) < dz(n+1) ) THEN 869 817 DO WHILE ( stretch_factor_1 <= stretch_factor_upper_limit ) 870 818 871 819 stretch_factor_1 = 1.0_wp + iterations * stretch_factor_interval 872 distance = ABS( dz_stretch_level_end(n) - & 873 dz_stretch_level_start(n) ) 874 numerator = distance*stretch_factor_1/dz(n) + & 875 stretch_factor_1 - distance/dz(n) 876 820 distance = ABS( dz_stretch_level_end(n) - dz_stretch_level_start(n) ) 821 numerator = distance * stretch_factor_1 / dz(n) + stretch_factor_1 - distance / dz(n) 822 877 823 l = LOG( numerator ) / LOG( stretch_factor_1 ) - 1.0_wp 878 824 l_rounded = NINT( l ) 879 825 delta_l = ABS( l_rounded - l ) / l 880 826 881 827 stretch_factor_2 = EXP( LOG( dz(n+1)/dz(n) ) / (l_rounded) ) 882 828 883 delta_stretch_factor = ABS( stretch_factor_1 - & 884 stretch_factor_2 ) / & 885 stretch_factor_2 886 829 delta_stretch_factor = ABS( stretch_factor_1 - stretch_factor_2 ) / stretch_factor_2 830 887 831 delta_total_new = delta_l + delta_stretch_factor 888 889 ! 890 !-- stretch_factor_1 is taken to guarantee that the stretching 891 !-- p rocedure ends as close as possible to dz_stretch_level_end.892 !-- stretch_factor_2 would guarantee that the stretched dz(n) is 893 !-- equal to dz(n+1) afterl_rounded grid levels.894 IF (delta_total_new < delta_total_old) THEN832 833 ! 834 !-- stretch_factor_1 is taken to guarantee that the stretching procedure ends as close as 835 !-- possible to dz_stretch_level_end. 836 !-- stretch_factor_2 would guarantee that the stretched dz(n) is equal to dz(n+1) after 837 !-- l_rounded grid levels. 838 IF (delta_total_new < delta_total_old) THEN 895 839 dz_stretch_factor_array(n) = stretch_factor_1 896 840 dz_stretch_factor_array_2(n) = stretch_factor_2 897 841 delta_total_old = delta_total_new 898 842 ENDIF 899 843 900 844 iterations = iterations + 1 901 845 ENDDO 902 846 903 847 ELSE 904 848 message_string= 'Two adjacent values of dz must be different' 905 849 CALL message( 'init_grid', 'PA0228', 1, 2, 0, 6, 0 ) 906 907 ENDIF 908 909 ! 910 !-- Check if also the second stretching factor fits into the allowed 911 !-- interval. If not, print a warning for the user. 912 IF ( dz_stretch_factor_array_2(n) < stretch_factor_lower_limit .OR. & 913 dz_stretch_factor_array_2(n) > stretch_factor_upper_limit ) THEN 914 WRITE( message_string, * ) 'stretch_factor_2 = ', & 915 dz_stretch_factor_array_2(n), ' which is',& 916 ' responsible for exactly reaching& dz =',& 917 dz(n+1), 'after a specific amount of', & 918 ' grid levels& exceeds the upper', & 919 ' limit =', stretch_factor_upper_limit, & 920 ' &or lower limit = ', & 921 stretch_factor_lower_limit 850 851 ENDIF 852 853 ! 854 !-- Check if also the second stretching factor fits into the allowed interval. If not, print a 855 !-- warning for the user. 856 IF ( dz_stretch_factor_array_2(n) < stretch_factor_lower_limit .OR. & 857 dz_stretch_factor_array_2(n) > stretch_factor_upper_limit ) THEN 858 WRITE( message_string, * ) 'stretch_factor_2 = ', dz_stretch_factor_array_2(n), & 859 ' which is', ' responsible for exactly reaching& dz =', & 860 dz(n+1), 'after a specific amount of', & 861 ' grid levels& exceeds the upper', & 862 ' limit =', stretch_factor_upper_limit, & 863 ' &or lower limit = ', stretch_factor_lower_limit 922 864 CALL message( 'init_grid', 'PA0499', 0, 1, 0, 6, 0 ) 923 865 924 866 ENDIF 925 867 ENDDO 926 868 927 869 END SUBROUTINE calculate_stretching_factor 928 929 870 871 930 872 ! Description: 931 ! -----------------------------------------------------------------------------! 932 !> Set temporary topography flags and reference buildings on top of underlying 933 !> orography. 934 !------------------------------------------------------------------------------! 873 ! -------------------------------------------------------------------------------------------------! 874 !> Set temporary topography flags and reference buildings on top of underlying orography. 875 !--------------------------------------------------------------------------------------------------! 935 876 SUBROUTINE process_topography( topo_3d ) 936 877 937 USE arrays_3d, &878 USE arrays_3d, & 938 879 ONLY: zu, zw 939 880 940 USE control_parameters, &881 USE control_parameters, & 941 882 ONLY: bc_lr_cyc, bc_ns_cyc, ocean_mode 942 883 943 USE exchange_horiz_mod, & 944 ONLY: exchange_horiz_int, exchange_horiz_2d 945 946 USE indices, & 947 ONLY: nbgp, nx, nxl, nxlg, nxr, nxrg, ny, nyn, nyng, nys, nysg, nzb, & 948 nzt 949 950 USE netcdf_data_input_mod, & 951 ONLY: buildings_f, building_id_f, building_type_f, & 952 init_model, & 953 input_pids_static, & 884 USE exchange_horiz_mod, & 885 ONLY: exchange_horiz_2d, exchange_horiz_int 886 887 USE indices, & 888 ONLY: nbgp, nx, nxl, nxlg, nxr, nxrg, ny, nyn, nyng, nys, nysg, nzb, nzt 889 890 USE netcdf_data_input_mod, & 891 ONLY: buildings_f, building_id_f, building_type_f, & 892 init_model, & 893 input_pids_static, & 954 894 terrain_height_f 955 895 … … 972 912 #endif 973 913 INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: build_ids !< building IDs on entire model domain 974 INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: build_ids_final !< building IDs on entire model domain, multiple occurences are sorted out 914 INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: build_ids_final !< building IDs on entire model domain, multiple occurences are 915 !< sorted out 975 916 INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: build_ids_final_tmp !< temporary array used for resizing 976 917 INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: build_ids_l !< building IDs on local subdomain … … 980 921 INTEGER(iwp), DIMENSION(0:numprocs-1) :: num_buildings_l !< number of buildings with different ID on local subdomain 981 922 982 INTEGER(iwp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg) :: topo_3d !< input array for 3D topography and dummy array for setting "outer"-flags 983 984 REAL(wp) :: ocean_offset !< offset to consider inverse vertical coordinate at topography definition 985 REAL(wp) :: oro_min = 0.0_wp !< minimum terrain height in entire model domain, used to reference terrain to zero 923 INTEGER(iwp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg) :: topo_3d !< input array for 3D topography and dummy array for setting 924 !< "outer"-flags 925 926 REAL(wp) :: ocean_offset !< offset to consider inverse vertical coordinate at topography 927 !< definition 928 REAL(wp) :: oro_min = 0.0_wp !< minimum terrain height in entire model domain, used to reference 929 !< terrain to zero 986 930 REAL(wp), DIMENSION(:), ALLOCATABLE :: oro_max !< maximum terrain height occupied by an building with certain id 987 REAL(wp), DIMENSION(:), ALLOCATABLE :: oro_max_l !< maximum terrain height occupied by an building with certain id, on local subdomain988 989 ! 990 ! -- Reference lowest terrain height to zero. This ensures that first,991 !-- non-required gird levels (those which lie entirely below the minimum992 !-- orography) are avoided, and second, that also negative orography can be used993 !-- within the input file.994 !-- Please note, in case of a nested run, the global minimum from all parent and 995 !-- childs need to be removeto avoid steep edges at the child-domain boundaries.931 REAL(wp), DIMENSION(:), ALLOCATABLE :: oro_max_l !< maximum terrain height occupied by an building with certain id, 932 !< on local subdomain 933 934 ! 935 !-- Reference lowest terrain height to zero. This ensures that first, non-required gird levels 936 !-- (those which lie entirely below the minimum orography) are avoided, and second, that also 937 !-- negative orography can be used within the input file. 938 !-- Please note, in case of a nested run, the global minimum from all parent and childs needs to be 939 !-- removed to avoid steep edges at the child-domain boundaries. 996 940 IF ( input_pids_static ) THEN 997 998 #if defined( __parallel ) 999 CALL MPI_ALLREDUCE( MINVAL( terrain_height_f%var ), oro_min, 1, &1000 MPI_ REAL, MPI_MIN, MPI_COMM_WORLD, ierr )941 942 #if defined( __parallel ) 943 CALL MPI_ALLREDUCE( MINVAL( terrain_height_f%var ), oro_min, 1, MPI_REAL, MPI_MIN, & 944 MPI_COMM_WORLD, ierr ) 1001 945 #else 1002 946 oro_min = MINVAL( terrain_height_f%var ) … … 1007 951 init_model%origin_z = init_model%origin_z + oro_min 1008 952 1009 ENDIF 1010 1011 ! 1012 !-- In the following, buildings and orography are further preprocessed 1013 !-- before they are mapped on the LES grid. 1014 !-- Buildings are mapped on top of the orography by maintaining the roof 1015 !-- shape of the building. This can be achieved by referencing building on 1016 !-- top of the maximum terrain height within the area occupied by the 1017 !-- respective building. As buildings and terrain height are defined PE-wise, 1018 !-- parallelization of this referencing is required (a building can be 1019 !-- distributed between different PEs). 1020 !-- In a first step, determine the number of buildings with different 1021 !-- building id on each PE. In a next step, all building ids are gathered 1022 !-- into one array which is present to all PEs. For each building ID, 1023 !-- the maximum terrain height occupied by the respective building is 1024 !-- computed and distributed to each PE. 1025 !-- Finally, for each building id and its respective reference orography, 1026 !-- builidings are mapped on top. 1027 !-- 1028 !-- First, pre-set topography flags, bit 1 indicates orography, bit 2 1029 !-- buildings 1030 !-- classify the respective surfaces. 953 ENDIF 954 955 ! 956 !-- In the following, buildings and orography are further preprocessed before they are mapped on the 957 !-- LES grid. 958 !-- Buildings are mapped on top of the orography by maintaining the roof shape of the building. This 959 !-- can be achieved by referencing building on top of the maximum terrain height within the area 960 !-- occupied by the respective building. As buildings and terrain height are defined PE-wise, 961 !-- parallelization of this referencing is required (a building can be distributed between different 962 !-- PEs). 963 !-- In a first step, determine the number of buildings with different building id on each PE. In a 964 !-- next step, all building ids are gathered into one array which is present to all PEs. For each 965 !-- building ID, the maximum terrain height occupied by the respective building is computed and 966 !-- distributed to each PE. 967 !-- Finally, for each building id and its respective reference orography, builidings are mapped on 968 !-- top. 969 !-- 970 !-- First, pre-set topography flags, bit 1 indicates orography, bit 2 buildings classify the 971 !-- respective surfaces. 1031 972 topo_3d = IBSET( topo_3d, 0 ) 1032 973 topo_3d(nzb,:,:) = IBCLR( topo_3d(nzb,:,:), 0 ) 1033 974 ! 1034 !-- In order to map topography on PALM grid also in case of ocean simulations, 1035 !-- pre-calculate anoffset value.975 !-- In order to map topography on PALM grid also in case of ocean simulations, pre-calculate an 976 !-- offset value. 1036 977 ocean_offset = MERGE( zw(0), 0.0_wp, ocean_mode ) 1037 978 ! 1038 !-- Reference buildings on top of orography. This is not necessary 1039 !-- if topography is read from ASCII file as no distinction between buildings 1040 !-- and terrain height can be made. Moreover, this is also not necessary if 1041 !-- urban-surface and land-surface model are used at the same time. 979 !-- Reference buildings on top of orography. This is not necessary if topography is read from ASCII 980 !-- file as no distinction between buildings and terrain height can be made. Moreover, this is also 981 !-- not necessary if urban-surface and land-surface model are used at the same time. 1042 982 IF ( input_pids_static ) THEN 1043 983 1044 IF ( buildings_f%from_file ) THEN 984 IF ( buildings_f%from_file ) THEN 1045 985 num_buildings_l = 0 1046 986 num_buildings = 0 1047 987 ! 1048 !-- Allocate at least one element for building ids and give it an inital 1049 !-- negative value that will be overwritten later. This, however, is1050 !-- necessary in case there all IDs in the model domain are fill values.988 !-- Allocate at least one element for building ids and give it an inital negative value that 989 !-- will be overwritten later. This, however, is necessary in case there all IDs in the model 990 !-- domain are fill values. 1051 991 ALLOCATE( build_ids_l(1) ) 1052 build_ids_l = -1 992 build_ids_l = -1 1053 993 DO i = nxl, nxr 1054 994 DO j = nys, nyn 1055 995 IF ( building_id_f%var(j,i) /= building_id_f%fill ) THEN 1056 996 IF ( num_buildings_l(myid) > 0 ) THEN 1057 IF ( ANY( building_id_f%var(j,i) == build_ids_l ) ) & 1058 THEN 997 IF ( ANY( building_id_f%var(j,i) == build_ids_l ) ) THEN 1059 998 CYCLE 1060 999 ELSE … … 1066 1005 DEALLOCATE( build_ids_l ) 1067 1006 ALLOCATE( build_ids_l(1:num_buildings_l(myid)) ) 1068 build_ids_l(1:num_buildings_l(myid)-1) = &1069 build_ids_l_tmp(1:num_buildings_l(myid)-1)1007 build_ids_l(1:num_buildings_l(myid)-1) = & 1008 build_ids_l_tmp(1:num_buildings_l(myid)-1) 1070 1009 build_ids_l(num_buildings_l(myid)) = building_id_f%var(j,i) 1071 1010 DEALLOCATE( build_ids_l_tmp ) 1072 1011 ENDIF 1073 1012 ! 1074 !-- First occuring building id on PE 1075 ELSE 1013 !-- First occuring building id on PE 1014 ELSE 1076 1015 num_buildings_l(myid) = num_buildings_l(myid) + 1 1077 1016 build_ids_l(1) = building_id_f%var(j,i) … … 1081 1020 ENDDO 1082 1021 ! 1083 !-- Determine number of different building ids for the entire domain 1084 #if defined( __parallel ) 1085 CALL MPI_ALLREDUCE( num_buildings_l, num_buildings, numprocs, 1086 MPI_INTEGER, MPI_SUM, comm2d, ierr )1022 !-- Determine number of different building ids for the entire domain 1023 #if defined( __parallel ) 1024 CALL MPI_ALLREDUCE( num_buildings_l, num_buildings, numprocs, MPI_INTEGER, MPI_SUM, & 1025 comm2d, ierr ) 1087 1026 #else 1088 1027 num_buildings = num_buildings_l 1089 1028 #endif 1090 1029 ! 1091 !-- Gather all buildings ids on each PEs. 1092 !-- First, allocate array encompassing all building ids in model domain. 1030 !-- Gather all buildings ids on each PEs. 1031 !-- First, allocate array encompassing all building ids in model domain. 1093 1032 ALLOCATE( build_ids(1:SUM(num_buildings)) ) 1094 #if defined( __parallel ) 1095 ! 1096 !-- Allocate array for displacements. 1097 !-- As each PE may has a different number of buildings, so that 1098 !-- the block sizes send by each PE may not be equal. Hence, 1099 !-- information about the respective displacement is required, indicating 1100 !-- the respective adress where each MPI-task writes into the receive 1101 !-- buffer array 1033 #if defined( __parallel ) 1034 ! 1035 !-- Allocate array for displacements. 1036 !-- As each PE may has a different number of buildings, so that the block sizes send by each 1037 !-- PE may not be equal. Hence, information about the respective displacement is required, 1038 !-- indicating the respective adress where each MPI-task writes into the receive buffer array. 1102 1039 ALLOCATE( displace_dum(0:numprocs-1) ) 1103 1040 displace_dum(0) = 0 … … 1106 1043 ENDDO 1107 1044 1108 CALL MPI_ALLGATHERV( build_ids_l(1:num_buildings_l(myid)), & 1109 num_buildings(myid), & 1110 MPI_INTEGER, & 1111 build_ids, & 1112 num_buildings, & 1113 displace_dum, & 1114 MPI_INTEGER, & 1115 comm2d, ierr ) 1045 CALL MPI_ALLGATHERV( build_ids_l(1:num_buildings_l(myid)), num_buildings(myid), & 1046 MPI_INTEGER, build_ids, num_buildings, displace_dum, MPI_INTEGER, & 1047 comm2d, ierr ) 1116 1048 1117 1049 DEALLOCATE( displace_dum ) … … 1122 1054 1123 1055 ! 1124 !-- Note, in parallel mode building ids can occure mutliple times, as 1125 !-- each PE has send its own ids. Therefore, sort out building ids which 1126 !-- appear more than one time. 1056 !-- Note, in parallel mode building ids can occure mutliple times, as each PE has send its own 1057 !-- ids. Therefore, sort out building ids which appear more than one time. 1127 1058 num_build = 0 1128 1059 DO nr = 1, SIZE(build_ids) … … 1142 1073 build_ids_final(num_build) = build_ids(nr) 1143 1074 DEALLOCATE( build_ids_final_tmp ) 1144 ENDIF 1075 ENDIF 1145 1076 ELSE 1146 1077 num_build = num_build + 1 … … 1151 1082 1152 1083 ! 1153 !-- Determine maximumum terrain height occupied by the respective 1154 !-- building and temporalily store on oro_max1084 !-- Determine maximumum terrain height occupied by the respective building and temporalily 1085 !-- store on oro_max. 1155 1086 ALLOCATE( oro_max_l(1:SIZE(build_ids_final)) ) 1156 1087 ALLOCATE( oro_max(1:SIZE(build_ids_final)) ) … … 1158 1089 1159 1090 DO nr = 1, SIZE(build_ids_final) 1160 oro_max_l(nr) = MAXVAL( & 1161 MERGE( terrain_height_f%var(nys:nyn,nxl:nxr), & 1162 0.0_wp, & 1163 building_id_f%var(nys:nyn,nxl:nxr) == & 1164 build_ids_final(nr) ) ) 1165 ENDDO 1166 1167 #if defined( __parallel ) 1168 IF ( SIZE(build_ids_final) >= 1 ) THEN 1169 CALL MPI_ALLREDUCE( oro_max_l, oro_max, SIZE( oro_max ), MPI_REAL,& 1170 MPI_MAX, comm2d, ierr ) 1091 oro_max_l(nr) = MAXVAL( MERGE( terrain_height_f%var(nys:nyn,nxl:nxr), & 1092 0.0_wp, & 1093 building_id_f%var(nys:nyn,nxl:nxr) == & 1094 build_ids_final(nr) ) ) 1095 ENDDO 1096 1097 #if defined( __parallel ) 1098 IF ( SIZE(build_ids_final) >= 1 ) THEN 1099 CALL MPI_ALLREDUCE( oro_max_l, oro_max, SIZE( oro_max ), MPI_REAL, MPI_MAX, comm2d, & 1100 ierr ) 1171 1101 ENDIF 1172 1102 #else … … 1174 1104 #endif 1175 1105 ! 1176 !-- Finally, determine discrete grid height of maximum orography occupied 1177 !-- by a building. Use all-or-nothing approach, i.e. if terrain 1178 !-- exceeds the scalar level the grid box is fully terrain and the 1179 !-- maximum terrain is set to the zw level. 1180 !-- terrain or 1106 !-- Finally, determine discrete grid height of maximum orography occupied by a building. Use 1107 !-- all-or-nothing approach, i.e. if terrain exceeds the scalar level the grid box is fully 1108 !-- terrain and the maximum terrain is set to the zw level. 1109 !-- terrain or 1181 1110 oro_max_l = 0.0 1182 1111 DO nr = 1, SIZE(build_ids_final) 1183 1112 DO k = nzb, nzt 1184 IF ( zu(k) - ocean_offset <= oro_max(nr) ) & 1185 oro_max_l(nr) = zw(k) - ocean_offset 1113 IF ( zu(k) - ocean_offset <= oro_max(nr) ) oro_max_l(nr) = zw(k) - ocean_offset 1186 1114 ENDDO 1187 1115 oro_max(nr) = oro_max_l(nr) … … 1195 1123 END IF 1196 1124 ! 1197 !-- Map orography as well as buildings onto grid. 1125 !-- Map orography as well as buildings onto grid. 1198 1126 DO i = nxl, nxr 1199 1127 DO j = nys, nyn … … 1204 1132 IF ( building_id_f%var(j,i) /= building_id_f%fill ) THEN 1205 1133 ! 1206 !-- Determine index where maximum terrain height occupied by 1207 !-- the respective building height is stored. 1208 nr = MINLOC( ABS( build_ids_final - & 1209 building_id_f%var(j,i) ), DIM = 1 ) 1134 !-- Determine index where maximum terrain height occupied by the respective building 1135 !-- height is stored. 1136 nr = MINLOC( ABS( build_ids_final - building_id_f%var(j,i) ), DIM=1 ) 1210 1137 ! 1211 1138 !-- Save grid-indexed oro_max … … 1215 1142 DO k = nzb, nzt 1216 1143 ! 1217 !-- In a first step, if grid point is below or equal the given 1218 !-- terrain height, grid point is flagged to be of type natural. 1219 !-- Please note, in case there is also a building which is lower 1220 !-- than the vertical grid spacing, initialization of surface 1221 !-- attributes will not be correct as given surface information 1222 !-- will not be in accordance to the classified grid points. 1144 !-- In a first step, if grid point is below or equal the given terrain height, grid 1145 !-- point is flagged to be of type natural. 1146 !-- Please note, in case there is also a building which is lower than the vertical grid 1147 !-- spacing, initialization of surface attributes will not be correct as given surface 1148 !-- information will not be in accordance to the classified grid points. 1223 1149 !-- Hence, in this case, also a building flag. 1224 1150 IF ( zu(k) - ocean_offset <= terrain_height_f%var(j,i) ) THEN … … 1228 1154 ENDIF 1229 1155 ! 1230 !-- Set building grid points. Here, only consider 2D buildings. 1231 !-- 3D buildings require separate treatment. 1156 !-- Set building grid points. Here, only consider 2D buildings. 1157 !-- 3D buildings require separate treatment. 1232 1158 IF ( buildings_f%from_file .AND. buildings_f%lod == 1 ) THEN 1233 1159 ! 1234 !-- Fill-up the terrain to the level of maximum orography 1235 !-- within the building-coveredarea.1160 !-- Fill-up the terrain to the level of maximum orography within the building-covered 1161 !-- area. 1236 1162 IF ( building_id_f%var(j,i) /= building_id_f%fill ) THEN 1237 1163 ! 1238 !-- Note, oro_max is always on zw level 1164 !-- Note, oro_max is always on zw level 1239 1165 IF ( zu(k) - ocean_offset < oro_max(nr) ) THEN 1240 1166 topo_3d(k,j,i) = IBCLR( topo_3d(k,j,i), 0 ) 1241 1167 topo_3d(k,j,i) = IBSET( topo_3d(k,j,i), 1 ) 1242 ELSEIF ( zu(k) - ocean_offset <= & 1243 oro_max(nr) + buildings_f%var_2d(j,i) ) THEN 1168 ELSEIF ( zu(k) - ocean_offset <= oro_max(nr) + buildings_f%var_2d(j,i) ) THEN 1244 1169 topo_3d(k,j,i) = IBCLR( topo_3d(k,j,i), 0 ) 1245 1170 topo_3d(k,j,i) = IBSET( topo_3d(k,j,i), 2 ) … … 1249 1174 ENDDO 1250 1175 ! 1251 !-- Special treatment for non grid-resolved buildings. This case, 1252 !-- the uppermost terrain grid point is flagged as building as well 1253 !-- well, even though no building exists at all. However, the 1254 !-- surface element will be identified as urban-surface and the 1255 !-- input data provided by the drivers is consistent to the surface 1256 !-- classification. Else, all non grid-resolved buildings would vanish 1257 !-- and identified as terrain grid points, which, however, won't be 1258 !-- consistent with the input data. 1176 !-- Special treatment for non grid-resolved buildings. This case, the uppermost terrain 1177 !-- grid point is flagged as building as well, even though no building exists at all. 1178 !-- However, the surface element will be identified as urban-surface and the input data 1179 !-- provided by the drivers is consistent to the surface classification. Else, all non 1180 !-- grid-resolved buildings would vanish and identified as terrain grid points, which, 1181 !-- however, won't be consistent with the input data. 1259 1182 IF ( buildings_f%from_file .AND. buildings_f%lod == 1 ) THEN 1260 1183 IF ( building_id_f%var(j,i) /= building_id_f%fill ) THEN … … 1269 1192 ENDIF 1270 1193 ! 1271 !-- Map 3D buildings onto terrain height. 1272 !-- In case of any slopes, map building on top of maximum terrain 1273 !-- height covered by the building. In other words, extend1274 !-- building down to the respective local terrain-surface height.1194 !-- Map 3D buildings onto terrain height. 1195 !-- In case of any slopes, map building on top of maximum terrain height covered by the 1196 !-- building. In other words, extend building down to the respective local terrain-surface 1197 !-- height. 1275 1198 IF ( buildings_f%from_file .AND. buildings_f%lod == 2 ) THEN 1276 1199 IF ( building_id_f%var(j,i) /= building_id_f%fill ) THEN 1277 1200 ! 1278 !-- Extend building down to the terrain surface, i.e. fill-up 1279 !-- surface irregularities below a building. Note, oro_max 1280 !-- is already a discrete height according to the all-or-nothing 1281 !-- approach, i.e. grid box is either topography or atmosphere, 1201 !-- Extend building down to the terrain surface, i.e. fill-up surface irregularities 1202 !-- below a building. Note, oro_max is already a discrete height according to the 1203 !-- all-or-nothing approach, i.e. grid box is either topography or atmosphere, 1282 1204 !-- terrain top is defined at upper bound of the grid box. 1283 !-- Hence, check for zw in this case. 1284 !-- Note, do this only for buildings which are surface mounted, 1285 !-- i.e. building types 1-6. Below bridges, which are represented 1286 !-- exclusively by building type 7, terrain shape should be 1287 !-- maintained. 1205 !-- Hence, check for zw in this case. 1206 !-- Note, do this only for buildings which are surface mounted, i.e. building types 1207 !-- 1-6. Below bridges, which are represented exclusively by building type 7, terrain 1208 !-- shape should be maintained. 1288 1209 IF ( building_type_f%from_file ) THEN 1289 1210 IF ( building_type_f%var(j,i) /= 7 ) THEN 1290 DO k = topo_top_index + 1, nzt + 1 1211 DO k = topo_top_index + 1, nzt + 1 1291 1212 IF ( zu(k) - ocean_offset <= oro_max(nr) ) THEN 1292 1213 topo_3d(k,j,i) = IBCLR( topo_3d(k,j,i), 0 ) 1293 1214 topo_3d(k,j,i) = IBSET( topo_3d(k,j,i), 1 ) 1294 1215 ENDIF 1295 ENDDO 1296 ! 1297 !-- After surface irregularities are smoothen, determine 1298 !-- lower start index where building starts.1216 ENDDO 1217 ! 1218 !-- After surface irregularities are smoothen, determine lower start index 1219 !-- where building starts. 1299 1220 DO k = nzb, nzt 1300 IF ( zu(k) - ocean_offset <= oro_max(nr) ) & 1301 topo_top_index = k 1221 IF ( zu(k) - ocean_offset <= oro_max(nr) ) topo_top_index = k 1302 1222 ENDDO 1303 1223 ENDIF … … 1320 1240 ENDDO 1321 1241 ! 1322 !-- Horizontal exchange the oro_max array, which is required to for 1323 !-- initialization ofbuilding-surface properties.1242 !-- Horizontal exchange the oro_max array, which is required to for initialization of 1243 !-- building-surface properties. 1324 1244 IF ( ALLOCATED( buildings_f%oro_max ) ) THEN 1325 1245 CALL exchange_horiz_2d( buildings_f%oro_max(:,:) ) … … 1331 1251 IF ( ALLOCATED( build_ids_final ) ) DEALLOCATE( build_ids_final ) 1332 1252 ! 1333 !-- Topography input via ASCII format. 1253 !-- Topography input via ASCII format. 1334 1254 ELSE 1335 1255 ocean_offset = MERGE( zw(0), 0.0_wp, ocean_mode ) 1336 1256 ! 1337 !-- Initialize topography bit 0 (indicates obstacle) everywhere to zero 1338 !-- and clear all grid points at nzb, where alway a surface is defined. 1339 !-- Further, set also bit 1 (indicates terrain) at nzb, which is further 1340 !-- used for masked data output and further processing. Note, in the 1341 !-- ASCII case no distinction is made between buildings and terrain, 1342 !-- so that setting of bit 1 and 2 at the same time has no effect. 1257 !-- Initialize topography bit 0 (indicates obstacle) everywhere to zero and clear all grid points 1258 !-- at nzb, where alway a surface is defined. 1259 !-- Further, set also bit 1 (indicates terrain) at nzb, which is further used for masked data 1260 !-- output and further processing. Note, in the ASCII case no distinction is made between 1261 !-- buildings and terrain, so that setting of bit 1 and 2 at the same time has no effect. 1343 1262 topo_3d = IBSET( topo_3d, 0 ) 1344 1263 topo_3d(nzb,:,:) = IBCLR( topo_3d(nzb,:,:), 0 ) … … 1348 1267 DO k = nzb, nzt 1349 1268 ! 1350 !-- Flag topography for all grid points which are below 1351 !-- the local topography height. 1352 !-- Note, each topography is flagged as building (bit 2) as well as 1353 !-- terrain (bit 1) in order to employ urban-surface as well as 1354 !-- land-surface model. 1269 !-- Flag topography for all grid points which are below the local topography height. 1270 !-- Note, each topography is flagged as building (bit 2) as well as terrain (bit 1) in 1271 !-- order to employ urban-surface as well as land-surface model. 1355 1272 IF ( zu(k) - ocean_offset <= buildings_f%var_2d(j,i) ) THEN 1356 1273 topo_3d(k,j,i) = IBCLR( topo_3d(k,j,i), 0 ) … … 1372 1289 IF ( .NOT. bc_lr_cyc ) THEN 1373 1290 IF ( nxl == 0 ) topo_3d(:,:,-1) = topo_3d(:,:,0) 1374 IF ( nxr == nx ) topo_3d(:,:,nx+1) = topo_3d(:,:,nx) 1291 IF ( nxr == nx ) topo_3d(:,:,nx+1) = topo_3d(:,:,nx) 1375 1292 ENDIF 1376 1293 … … 1379 1296 1380 1297 ! Description: 1381 ! ----------------------------------------------------------------------------- !1382 !> Filter topography, i.e. fill holes resolved by only one grid point. 1383 !> Such holes are suspected to lead to velocity blow-ups as continuity 1384 !> equation on discrete gridcannot be fulfilled in such case.1385 !------------------------------------------------------------------------------ !1298 ! -------------------------------------------------------------------------------------------------! 1299 !> Filter topography, i.e. fill holes resolved by only one grid point. 1300 !> Such holes are suspected to lead to velocity blow-ups as continuity equation on discrete grid 1301 !> cannot be fulfilled in such case. 1302 !--------------------------------------------------------------------------------------------------! 1386 1303 SUBROUTINE filter_topography( topo_3d ) 1387 1304 1388 USE control_parameters, &1305 USE control_parameters, & 1389 1306 ONLY: bc_lr_cyc, bc_ns_cyc, message_string 1390 1307 1391 USE exchange_horiz_mod, &1308 USE exchange_horiz_mod, & 1392 1309 ONLY: exchange_horiz_int, exchange_horiz_2d_byte, exchange_horiz_2d_int 1393 1310 1394 USE indices, &1311 USE indices, & 1395 1312 ONLY: nbgp, nx, nxl, nxlg, nxr, nxrg, ny, nyn, nyng, nys, nysg, nzb, nzt 1396 1313 1397 USE netcdf_data_input_mod, &1398 ONLY: building_id_f, building_type_f 1314 USE netcdf_data_input_mod, & 1315 ONLY: building_id_f, building_type_f 1399 1316 1400 1317 USE pegrid 1401 1318 1402 1319 IMPLICIT NONE 1403 1404 LOGICAL :: filled = .FALSE. !< flag indicating if holes were filled1405 1320 1406 1321 INTEGER(iwp) :: i !< running index along x-direction 1407 1322 INTEGER(iwp) :: j !< running index along y-direction 1408 1323 INTEGER(iwp) :: k !< running index along z-direction 1409 INTEGER(iwp) :: num_hole !< number of holes (in topography) resolved by only one grid point 1410 INTEGER(iwp) :: num_hole_l !< number of holes (in topography) resolved by only one grid point on local PE 1324 INTEGER(iwp) :: num_hole !< number of holes (in topography) resolved by only one grid point 1325 INTEGER(iwp) :: num_hole_l !< number of holes (in topography) resolved by only one grid point on local PE 1411 1326 INTEGER(iwp) :: num_wall !< number of surrounding vertical walls for a single grid point 1412 1327 1413 1328 INTEGER(iwp), DIMENSION(:,:,:), ALLOCATABLE :: topo_tmp !< temporary 3D-topography used to fill holes 1414 INTEGER(iwp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg) :: topo_3d !< 3D-topography array merging buildings and orography 1415 ! 1416 !-- Before checking for holes, set lateral boundary conditions for 1329 INTEGER(iwp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg) :: topo_3d !< 3D-topography array merging buildings and 1330 !< orography 1331 1332 LOGICAL :: filled = .FALSE. !< flag indicating if holes were filled 1333 1334 ! 1335 !-- Before checking for holes, set lateral boundary conditions for 1417 1336 !-- topography. After hole-filling, boundary conditions must be set again. 1418 !-- Several iterations are performed, in order to fill holes which might 1337 !-- Several iterations are performed, in order to fill holes which might 1419 1338 !-- emerge by the filling-algorithm itself. 1420 1339 ALLOCATE( topo_tmp(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) … … 1422 1341 1423 1342 num_hole = 99999 1424 DO WHILE ( num_hole > 0 ) 1425 1426 num_hole = 0 1343 DO WHILE ( num_hole > 0 ) 1344 1345 num_hole = 0 1427 1346 CALL exchange_horiz_int( topo_3d, nys, nyn, nxl, nxr, nzt, nbgp ) 1428 1347 ! 1429 !-- Exchange also building ID and type. Note, building_type is an one-byte 1430 !-- variable. 1431 IF ( building_id_f%from_file ) & 1348 !-- Exchange also building ID and type. Note, building_type is an one-byte variable. 1349 IF ( building_id_f%from_file ) & 1432 1350 CALL exchange_horiz_2d_int( building_id_f%var, nys, nyn, nxl, nxr, nbgp ) 1433 IF ( building_type_f%from_file ) &1351 IF ( building_type_f%from_file ) & 1434 1352 CALL exchange_horiz_2d_byte( building_type_f%var, nys, nyn, nxl, nxr, nbgp ) 1435 1353 1436 1354 topo_tmp = topo_3d 1437 1355 ! 1438 !-- In case of non-cyclic lateral boundaries, assume lateral boundary to be 1439 !-- a solid wall. Thus, intermediate spaces of one grid point between1440 !-- boundary and some topographic structure will be filled.1356 !-- In case of non-cyclic lateral boundaries, assume lateral boundary to be a solid wall. Thus, 1357 !-- intermediate spaces of one grid point between boundary and some topographic structure will be 1358 !-- filled. 1441 1359 IF ( .NOT. bc_ns_cyc ) THEN 1442 1360 IF ( nys == 0 ) topo_tmp(:,-1,:) = IBCLR( topo_tmp(:,0,:), 0 ) … … 1446 1364 IF ( .NOT. bc_lr_cyc ) THEN 1447 1365 IF ( nxl == 0 ) topo_tmp(:,:,-1) = IBCLR( topo_tmp(:,:,0), 0 ) 1448 IF ( nxr == nx ) topo_tmp(:,:,nx+1) = IBCLR( topo_tmp(:,:,nx), 0 ) 1366 IF ( nxr == nx ) topo_tmp(:,:,nx+1) = IBCLR( topo_tmp(:,:,nx), 0 ) 1449 1367 ENDIF 1450 1368 … … 1455 1373 IF ( BTEST( topo_tmp(k,j,i), 0 ) ) THEN 1456 1374 num_wall = 0 1457 IF ( .NOT. BTEST( topo_tmp(k,j-1,i), 0 ) ) & 1458 num_wall = num_wall + 1 1459 IF ( .NOT. BTEST( topo_tmp(k,j+1,i), 0 ) ) & 1460 num_wall = num_wall + 1 1461 IF ( .NOT. BTEST( topo_tmp(k,j,i-1), 0 ) ) & 1462 num_wall = num_wall + 1 1463 IF ( .NOT. BTEST( topo_tmp(k,j,i+1), 0 ) ) & 1464 num_wall = num_wall + 1 1465 IF ( .NOT. BTEST( topo_tmp(k-1,j,i), 0 ) ) & 1466 num_wall = num_wall + 1 1467 IF ( .NOT. BTEST( topo_tmp(k+1,j,i), 0 ) ) & 1468 num_wall = num_wall + 1 1375 IF ( .NOT. BTEST( topo_tmp(k,j-1,i), 0 ) ) num_wall = num_wall + 1 1376 IF ( .NOT. BTEST( topo_tmp(k,j+1,i), 0 ) ) num_wall = num_wall + 1 1377 IF ( .NOT. BTEST( topo_tmp(k,j,i-1), 0 ) ) num_wall = num_wall + 1 1378 IF ( .NOT. BTEST( topo_tmp(k,j,i+1), 0 ) ) num_wall = num_wall + 1 1379 IF ( .NOT. BTEST( topo_tmp(k-1,j,i), 0 ) ) num_wall = num_wall + 1 1380 IF ( .NOT. BTEST( topo_tmp(k+1,j,i), 0 ) ) num_wall = num_wall + 1 1469 1381 1470 1382 IF ( num_wall >= 4 ) THEN 1471 1383 num_hole_l = num_hole_l + 1 1472 1384 ! 1473 !-- Clear flag 0 and set special flag ( bit 4) to indicate 1474 !-- that new topographypoint is a result of filtering process.1385 !-- Clear flag 0 and set special flag ( bit 4) to indicate that new topography 1386 !-- point is a result of filtering process. 1475 1387 topo_3d(k,j,i) = IBCLR( topo_3d(k,j,i), 0 ) 1476 1388 topo_3d(k,j,i) = IBSET( topo_3d(k,j,i), 4 ) 1477 1389 ! 1478 !-- If filled grid point is occupied by a building, classify 1479 !-- it as building gridpoint.1390 !-- If filled grid point is occupied by a building, classify it as building grid 1391 !-- point. 1480 1392 IF ( building_type_f%from_file ) THEN 1481 IF ( building_type_f%var(j,i) /= & 1482 building_type_f%fill .OR. & 1483 building_type_f%var(j+1,i) /= & 1484 building_type_f%fill .OR. & 1485 building_type_f%var(j-1,i) /= & 1486 building_type_f%fill .OR. & 1487 building_type_f%var(j,i+1) /= & 1488 building_type_f%fill .OR. & 1489 building_type_f%var(j,i-1) /= & 1490 building_type_f%fill ) THEN 1393 IF ( building_type_f%var(j,i) /= building_type_f%fill .OR. & 1394 building_type_f%var(j+1,i) /= building_type_f%fill .OR. & 1395 building_type_f%var(j-1,i) /= building_type_f%fill .OR. & 1396 building_type_f%var(j,i+1) /= building_type_f%fill .OR. & 1397 building_type_f%var(j,i-1) /= building_type_f%fill ) THEN 1491 1398 ! 1492 1399 !-- Set flag indicating building surfaces 1493 1400 topo_3d(k,j,i) = IBSET( topo_3d(k,j,i), 2 ) 1494 1401 ! 1495 !-- Set building_type and ID at this position if not 1496 !-- already set. This is required for proper 1497 !-- initialization of urban-surface energy balance 1402 !-- Set building_type and ID at this position if not already set. This is 1403 !-- required for proper initialization of urban-surface energy balance 1498 1404 !-- solver. 1499 IF ( building_type_f%var(j,i) == & 1500 building_type_f%fill ) THEN 1501 1502 IF ( building_type_f%var(j+1,i) /= & 1503 building_type_f%fill ) THEN 1504 building_type_f%var(j,i) = & 1505 building_type_f%var(j+1,i) 1506 building_id_f%var(j,i) = & 1507 building_id_f%var(j+1,i) 1508 ELSEIF ( building_type_f%var(j-1,i) /= & 1509 building_type_f%fill ) THEN 1510 building_type_f%var(j,i) = & 1511 building_type_f%var(j-1,i) 1512 building_id_f%var(j,i) = & 1513 building_id_f%var(j-1,i) 1514 ELSEIF ( building_type_f%var(j,i+1) /= & 1515 building_type_f%fill ) THEN 1516 building_type_f%var(j,i) = & 1517 building_type_f%var(j,i+1) 1518 building_id_f%var(j,i) = & 1519 building_id_f%var(j,i+1) 1520 ELSEIF ( building_type_f%var(j,i-1) /= & 1521 building_type_f%fill ) THEN 1522 building_type_f%var(j,i) = & 1523 building_type_f%var(j,i-1) 1524 building_id_f%var(j,i) = & 1525 building_id_f%var(j,i-1) 1405 IF ( building_type_f%var(j,i) == building_type_f%fill ) THEN 1406 1407 IF ( building_type_f%var(j+1,i) /= building_type_f%fill ) THEN 1408 building_type_f%var(j,i) = building_type_f%var(j+1,i) 1409 building_id_f%var(j,i) = building_id_f%var(j+1,i) 1410 ELSEIF ( building_type_f%var(j-1,i) /= building_type_f%fill ) THEN 1411 building_type_f%var(j,i) = building_type_f%var(j-1,i) 1412 building_id_f%var(j,i) = building_id_f%var(j-1,i) 1413 ELSEIF ( building_type_f%var(j,i+1) /= building_type_f%fill ) THEN 1414 building_type_f%var(j,i) = building_type_f%var(j,i+1) 1415 building_id_f%var(j,i) = building_id_f%var(j,i+1) 1416 ELSEIF ( building_type_f%var(j,i-1) /= building_type_f%fill ) THEN 1417 building_type_f%var(j,i) = building_type_f%var(j,i-1) 1418 building_id_f%var(j,i) = building_id_f%var(j,i-1) 1526 1419 ENDIF 1527 1420 ENDIF … … 1529 1422 ENDIF 1530 1423 ! 1531 !-- If filled grid point is already classified as building 1532 !-- everything is fine, else classify this grid point as 1533 !-- natural type grid point. This case, values for the 1534 !-- surface type are already set. 1424 !-- If filled grid point is already classified as building everything is fine, 1425 !-- else classify this grid point as natural type grid point. This case, values 1426 !-- for the surface type are already set. 1535 1427 IF ( .NOT. BTEST( topo_3d(k,j,i), 2 ) ) THEN 1536 1428 topo_3d(k,j,i) = IBSET( topo_3d(k,j,i), 1 ) … … 1544 1436 !-- Count the total number of holes, required for informative message. 1545 1437 #if defined( __parallel ) 1546 CALL MPI_ALLREDUCE( num_hole_l, num_hole, 1, MPI_INTEGER, MPI_SUM, & 1547 comm2d, ierr ) 1438 CALL MPI_ALLREDUCE( num_hole_l, num_hole, 1, MPI_INTEGER, MPI_SUM, comm2d, ierr ) 1548 1439 #else 1549 1440 num_hole = num_hole_l 1550 #endif 1441 #endif 1551 1442 IF ( num_hole > 0 .AND. .NOT. filled ) filled = .TRUE. 1552 1443 … … 1555 1446 !-- Create an informative message if any holes were filled. 1556 1447 IF ( filled ) THEN 1557 WRITE( message_string, * ) 'Topography was filtered, i.e. holes ' // &1558 'resolved by only one grid point ' // &1448 WRITE( message_string, * ) 'Topography was filtered, i.e. holes ' // & 1449 'resolved by only one grid point ' // & 1559 1450 'were filled during initialization.' 1560 1451 CALL message( 'init_grid', 'PA0430', 0, 0, 0, 6, 0 ) … … 1563 1454 DEALLOCATE( topo_tmp ) 1564 1455 ! 1565 !-- Finally, exchange topo_3d array again and if necessary set Neumann boundary 1566 !-- condition in case of non-cyclic lateral boundaries.1456 !-- Finally, exchange topo_3d array again and if necessary set Neumann boundary condition in case of 1457 !-- non-cyclic lateral boundaries. 1567 1458 CALL exchange_horiz_int( topo_3d, nys, nyn, nxl, nxr, nzt, nbgp ) 1568 1459 … … 1574 1465 IF ( .NOT. bc_lr_cyc ) THEN 1575 1466 IF ( nxl == 0 ) topo_3d(:,:,-1) = topo_3d(:,:,0) 1576 IF ( nxr == nx ) topo_3d(:,:,nx+1) = topo_3d(:,:,nx) 1467 IF ( nxr == nx ) topo_3d(:,:,nx+1) = topo_3d(:,:,nx) 1577 1468 ENDIF 1578 1469 ! 1579 1470 !-- Exchange building ID and type. Note, building_type is an one-byte variable. 1580 IF ( building_id_f%from_file ) &1471 IF ( building_id_f%from_file ) & 1581 1472 CALL exchange_horiz_2d_int( building_id_f%var, nys, nyn, nxl, nxr, nbgp ) 1582 IF ( building_type_f%from_file ) &1473 IF ( building_type_f%from_file ) & 1583 1474 CALL exchange_horiz_2d_byte( building_type_f%var, nys, nyn, nxl, nxr, nbgp ) 1584 1475 … … 1587 1478 1588 1479 ! Description: 1589 ! -----------------------------------------------------------------------------! 1590 !> Reads topography information from file or sets generic topography. Moreover, 1591 !> all topography-relevant topography arrays are initialized, and grid flags 1592 !> are set. 1593 !------------------------------------------------------------------------------! 1480 ! -------------------------------------------------------------------------------------------------! 1481 !> Reads topography information from file or sets generic topography. Moreover, all 1482 !> topography-relevant topography arrays are initialized, and grid flags are set. 1483 !--------------------------------------------------------------------------------------------------! 1594 1484 SUBROUTINE init_topo( topo ) 1595 1485 1596 USE arrays_3d, &1486 USE arrays_3d, & 1597 1487 ONLY: zw 1598 1599 USE control_parameters, & 1600 ONLY: bc_lr_cyc, bc_ns_cyc, building_height, building_length_x, & 1601 building_length_y, building_wall_left, building_wall_south, & 1602 canyon_height, canyon_wall_left, canyon_wall_south, & 1603 canyon_width_x, canyon_width_y, dp_level_ind_b, dz, & 1604 message_string, topography, topography_grid_convention, & 1605 tunnel_height, tunnel_length, tunnel_width_x, tunnel_width_y, & 1606 tunnel_wall_depth 1607 1608 USE exchange_horiz_mod, & 1488 1489 USE control_parameters, & 1490 ONLY: bc_lr_cyc, bc_ns_cyc, building_height, building_length_x, building_length_y, & 1491 building_wall_left, building_wall_south, canyon_height, canyon_wall_left, & 1492 canyon_wall_south, canyon_width_x, canyon_width_y, dp_level_ind_b, dz, & 1493 message_string, topography, topography_grid_convention, tunnel_height, & 1494 tunnel_length, tunnel_width_x, tunnel_width_y, tunnel_wall_depth 1495 1496 USE exchange_horiz_mod, & 1609 1497 ONLY: exchange_horiz_int 1610 1498 1611 USE grid_variables, &1499 USE grid_variables, & 1612 1500 ONLY: dx, dy 1613 1614 USE indices, & 1615 ONLY: nbgp, nx, nxl, nxlg, nxr, nxrg, ny, nyn, nyng, nys, nysg, nz, & 1616 nzb, nzt 1617 1501 1502 USE indices, & 1503 ONLY: nbgp, nx, nxl, nxlg, nxr, nxrg, ny, nyn, nyng, nys, nysg, nz, nzb, nzt 1504 1618 1505 USE kinds 1619 1620 USE netcdf_data_input_mod, &1621 ONLY: buildings_f, terrain_height_f 1506 1507 USE netcdf_data_input_mod, & 1508 ONLY: buildings_f, terrain_height_f 1622 1509 1623 1510 USE pegrid … … 1626 1513 1627 1514 INTEGER(iwp) :: bh !< temporary vertical index of building height 1515 INTEGER(iwp) :: ch !< temporary vertical index for canyon height 1516 INTEGER(iwp) :: hv_in !< heavyside function to model inner tunnel surface 1517 INTEGER(iwp) :: i !< index variable along x 1518 INTEGER(iwp) :: index_left_bwall !< index for left building wall 1519 INTEGER(iwp) :: index_north_bwall !< index for north building wall 1520 INTEGER(iwp) :: index_right_bwall !< index for right building wall 1521 INTEGER(iwp) :: index_south_bwall !< index for south building wall 1522 INTEGER(iwp) :: index_left_cwall !< index for left canyon wall 1523 INTEGER(iwp) :: index_north_cwall !< index for north canyon wall 1524 INTEGER(iwp) :: index_right_cwall !< index for right canyon wall 1525 INTEGER(iwp) :: index_south_cwall !< index for south canyon wall 1526 INTEGER(iwp) :: j !< index variable along y 1527 INTEGER(iwp) :: k !< index variable along z 1628 1528 INTEGER(iwp) :: ngp_bx !< grid point number of building size along x 1629 1529 INTEGER(iwp) :: ngp_by !< grid point number of building size along y 1630 INTEGER(iwp) :: index_left_bwall !< index for left building wall1631 INTEGER(iwp) :: index_right_bwall !< index for right building wall1632 INTEGER(iwp) :: index_north_bwall !< index for north building wall1633 INTEGER(iwp) :: index_south_bwall !< index for south building wall1634 INTEGER(iwp) :: ch !< temporary vertical index for canyon height1635 1530 INTEGER(iwp) :: ngp_cx !< grid point number of canyon size along x 1636 1531 INTEGER(iwp) :: ngp_cy !< grid point number of canyon size along y 1637 INTEGER(iwp) :: index_left_cwall !< index for left canyon wall 1638 INTEGER(iwp) :: index_right_cwall !< index for right canyon wall 1639 INTEGER(iwp) :: index_north_cwall !< index for north canyon wall 1640 INTEGER(iwp) :: index_south_cwall !< index for south canyon wall 1641 INTEGER(iwp) :: i !< index variable along x 1642 INTEGER(iwp) :: j !< index variable along y 1643 INTEGER(iwp) :: k !< index variable along z 1644 INTEGER(iwp) :: hv_in !< heavyside function to model inner tunnel surface 1645 INTEGER(iwp) :: hv_out !< heavyside function to model outer tunnel surface 1646 INTEGER(iwp) :: txe_out !< end position of outer tunnel wall in x 1647 INTEGER(iwp) :: txs_out !< start position of outer tunnel wall in x 1648 INTEGER(iwp) :: tye_out !< end position of outer tunnel wall in y 1649 INTEGER(iwp) :: tys_out !< start position of outer tunnel wall in y 1650 INTEGER(iwp) :: txe_in !< end position of inner tunnel wall in x 1651 INTEGER(iwp) :: txs_in !< start position of inner tunnel wall in x 1652 INTEGER(iwp) :: tye_in !< end position of inner tunnel wall in y 1653 INTEGER(iwp) :: tys_in !< start position of inner tunnel wall in y 1532 INTEGER(iwp) :: hv_out !< heavyside function to model outer tunnel surface 1654 1533 INTEGER(iwp) :: td !< tunnel wall depth 1655 1534 INTEGER(iwp) :: th !< height of outer tunnel wall 1535 INTEGER(iwp) :: txe_in !< end position of inner tunnel wall in x 1536 INTEGER(iwp) :: txe_out !< end position of outer tunnel wall in x 1537 INTEGER(iwp) :: txs_in !< start position of inner tunnel wall in x 1538 INTEGER(iwp) :: txs_out !< start position of outer tunnel wall in x 1539 INTEGER(iwp) :: tye_in !< end position of inner tunnel wall in y 1540 INTEGER(iwp) :: tye_out !< end position of outer tunnel wall in y 1541 INTEGER(iwp) :: tys_in !< start position of inner tunnel wall in y 1542 INTEGER(iwp) :: tys_out !< start position of outer tunnel wall in y 1656 1543 1657 1544 INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: nzb_local !< index for topography top at cell-center 1658 INTEGER(iwp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg) :: topo !< input array for 3D topography and dummy array for setting "outer"-flags1659 ! 1660 ! -- Check for correct setting of the namelist parameter topography. If1661 !-- topography information is read from file but topography = 'flat',1662 !-- initialization does not work properly.1663 IF ( ( buildings_f%from_file .OR. terrain_height_f%from_file ) .AND. &1545 INTEGER(iwp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg) :: topo !< input array for 3D topography and dummy array for setting 1546 !< "outer"-flags 1547 ! 1548 !-- Check for correct setting of the namelist parameter topography. If topography information is 1549 !-- read from file but topography = 'flat', initialization does not work properly. 1550 IF ( ( buildings_f%from_file .OR. terrain_height_f%from_file ) .AND. & 1664 1551 TRIM( topography ) /= 'read_from_file' ) THEN 1665 message_string = 'If topography information is provided (via ' // &1666 'Netcdf or ASCII input) topography = ' // &1552 message_string = 'If topography information is provided (via ' // & 1553 'Netcdf or ASCII input) topography = ' // & 1667 1554 '"read_from_file" is required.' 1668 CALL message( 'init_grid', 'PA0437', 1, 2, 0, 6, 0 ) 1555 CALL message( 'init_grid', 'PA0437', 1, 2, 0, 6, 0 ) 1669 1556 ENDIF 1670 1557 ! 1671 1558 !-- Set outer and inner index arrays for non-flat topography. 1672 !-- Here consistency checks concerning domain size and periodicity are 1673 !-- necessary. 1674 !-- Within this SELECT CASE structure only nzb_local is initialized 1675 !-- individually depending on the chosen topography type, all other index 1676 !-- arrays are initialized further below. 1559 !-- Here consistency checks concerning domain size and periodicity are necessary. 1560 !-- Within this SELECT CASE structure only nzb_local is initialized individually depending on the 1561 !-- chosen topography type, all other index arrays are initialized further below. 1677 1562 SELECT CASE ( TRIM( topography ) ) 1678 1563 1679 1564 CASE ( 'flat' ) 1680 ! 1565 ! 1681 1566 !-- Initialilize 3D topography array, used later for initializing flags 1682 1567 topo(nzb+1:nzt+1,:,:) = IBSET( topo(nzb+1:nzt+1,:,:), 0 ) 1683 1568 1684 1569 CASE ( 'closed_channel' ) 1685 ! 1570 ! 1686 1571 !-- Initialilize 3D topography array, used later for initializing flags 1687 topo(nzb+1:nzt,:,:) = IBSET( topo(nzb+1:nzt,:,:), 0 ) 1572 topo(nzb+1:nzt,:,:) = IBSET( topo(nzb+1:nzt,:,:), 0 ) 1688 1573 1689 1574 CASE ( 'single_building' ) … … 1694 1579 ngp_by = NINT( building_length_y / dy ) 1695 1580 bh = MINLOC( ABS( zw - building_height ), 1 ) - 1 1696 IF ( ABS( zw(bh) - building_height ) == & 1697 ABS( zw(bh+1) - building_height ) ) bh = bh + 1 1581 IF ( ABS( zw(bh) - building_height ) == ABS( zw(bh+1) - building_height ) ) bh = bh + 1 1698 1582 IF ( building_wall_left == 9999999.9_wp ) THEN 1699 1583 building_wall_left = ( nx + 1 - ngp_bx ) / 2 * dx … … 1710 1594 ! 1711 1595 !-- Building size has to meet some requirements 1712 IF ( ( index_left_bwall < 1 ) .OR. ( index_right_bwall > nx-1 ) .OR.&1713 ( index_right_bwall < index_left_bwall+3 ) .OR.&1714 ( index_south_bwall < 1 ) .OR. ( index_north_bwall > ny-1 ) .OR.&1596 IF ( ( index_left_bwall < 1 ) .OR. ( index_right_bwall > nx-1 ) .OR. & 1597 ( index_right_bwall < index_left_bwall+3 ) .OR. & 1598 ( index_south_bwall < 1 ) .OR. ( index_north_bwall > ny-1 ) .OR. & 1715 1599 ( index_north_bwall < index_south_bwall+3 ) ) THEN 1716 WRITE( message_string, * ) 'inconsistent building parameters:', &1717 '&index_left_bwall=', index_left_bwall, &1718 'index_right_bwall=', index_right_bwall, &1719 'index_south_bwall=', index_south_bwall, &1720 'index_north_bwall=', index_north_bwall, &1600 WRITE( message_string, * ) 'inconsistent building parameters:', & 1601 '&index_left_bwall=', index_left_bwall, & 1602 'index_right_bwall=', index_right_bwall, & 1603 'index_south_bwall=', index_south_bwall, & 1604 'index_north_bwall=', index_north_bwall, & 1721 1605 'nx=', nx, 'ny=', ny 1722 1606 CALL message( 'init_grid', 'PA0203', 1, 2, 0, 6, 0 ) … … 1726 1610 nzb_local = 0 1727 1611 ! 1728 !-- Define the building. 1729 IF ( index_left_bwall <= nxr .AND. index_right_bwall >= nxl .AND. &1730 index_south_bwall <= nyn .AND. index_north_bwall >= nys ) &1731 nzb_local(MAX(nys,index_south_bwall):MIN(nyn,index_north_bwall), &1612 !-- Define the building. 1613 IF ( index_left_bwall <= nxr .AND. index_right_bwall >= nxl .AND. & 1614 index_south_bwall <= nyn .AND. index_north_bwall >= nys ) & 1615 nzb_local(MAX(nys,index_south_bwall):MIN(nyn,index_north_bwall), & 1732 1616 MAX(nxl,index_left_bwall):MIN(nxr,index_right_bwall)) = bh 1733 1617 ! … … 1735 1619 DO i = nxl, nxr 1736 1620 DO j = nys, nyn 1737 topo(nzb_local(j,i)+1:nzt+1,j,i) = & 1738 IBSET( topo(nzb_local(j,i)+1:nzt+1,j,i), 0 ) 1621 topo(nzb_local(j,i)+1:nzt+1,j,i) = IBSET( topo(nzb_local(j,i)+1:nzt+1,j,i), 0 ) 1739 1622 ENDDO 1740 1623 ENDDO 1741 1624 1742 1625 DEALLOCATE( nzb_local ) 1743 1626 1744 1627 CALL exchange_horiz_int( topo, nys, nyn, nxl, nxr, nzt, nbgp ) 1745 1628 ! 1746 !-- Set boundary conditions also for flags. Can be interpreted as Neumann 1747 !-- boundary conditions for topography.1629 !-- Set boundary conditions also for flags. Can be interpreted as Neumannb oundary conditions 1630 !-- for topography. 1748 1631 IF ( .NOT. bc_ns_cyc ) THEN 1749 1632 IF ( nys == 0 ) THEN 1750 DO i = 1, nbgp 1633 DO i = 1, nbgp 1751 1634 topo(:,nys-i,:) = topo(:,nys,:) 1752 1635 ENDDO 1753 1636 ENDIF 1754 1637 IF ( nyn == ny ) THEN 1755 DO i = 1, nbgp 1638 DO i = 1, nbgp 1756 1639 topo(:,nyn+i,:) = topo(:,nyn,:) 1757 1640 ENDDO … … 1760 1643 IF ( .NOT. bc_lr_cyc ) THEN 1761 1644 IF ( nxl == 0 ) THEN 1762 DO i = 1, nbgp 1645 DO i = 1, nbgp 1763 1646 topo(:,:,nxl-i) = topo(:,:,nxl) 1764 1647 ENDDO 1765 1648 ENDIF 1766 IF ( nxr == nx ) THEN 1767 DO i = 1, nbgp 1768 topo(:,:,nxr+i) = topo(:,:,nxr) 1649 IF ( nxr == nx ) THEN 1650 DO i = 1, nbgp 1651 topo(:,:,nxr+i) = topo(:,:,nxr) 1769 1652 ENDDO 1770 ENDIF 1653 ENDIF 1771 1654 ENDIF 1772 1655 … … 1793 1676 index_south_cwall = NINT( canyon_wall_south / dy ) 1794 1677 index_north_cwall = index_south_cwall + ngp_cy 1795 1678 1796 1679 ELSE 1797 1680 1798 1681 message_string = 'no street canyon width given' 1799 1682 CALL message( 'init_grid', 'PA0204', 1, 2, 0, 6, 0 ) 1800 1683 1801 1684 ENDIF 1802 1685 1803 1686 ch = MINLOC( ABS( zw - canyon_height ), 1 ) - 1 1804 IF ( ABS( zw(ch) - canyon_height ) == & 1805 ABS( zw(ch+1) - canyon_height ) ) ch = ch + 1 1687 IF ( ABS( zw(ch) - canyon_height ) == ABS( zw(ch+1) - canyon_height ) ) ch = ch + 1 1806 1688 dp_level_ind_b = ch 1807 1689 ! 1808 1690 !-- Street canyon size has to meet some requirements 1809 1691 IF ( canyon_width_x /= 9999999.9_wp ) THEN 1810 IF ( ( index_left_cwall< 1 ) .OR. ( index_right_cwall> nx-1 ) .OR.&1692 IF ( ( index_left_cwall< 1 ) .OR. ( index_right_cwall> nx-1 ) .OR. & 1811 1693 ( ngp_cx < 3 ) ) THEN 1812 WRITE( message_string, * ) 'inconsistent canyon parameters:', & 1813 '&index_left_cwall=', index_left_cwall, & 1814 ' index_right_cwall=', index_right_cwall, & 1815 ' ngp_cx=', ngp_cx, & 1816 ' ch=', ch, ' nx=', nx, ' ny=', ny 1817 CALL message( 'init_grid', 'PA0205', 1, 2, 0, 6, 0 ) 1694 WRITE( message_string, * ) 'inconsistent canyon parameters:', & 1695 '&index_left_cwall=', index_left_cwall, & 1696 ' index_right_cwall=', index_right_cwall, & 1697 ' ngp_cx=', ngp_cx, ' ch=', ch, ' nx=', nx, ' ny=', ny 1698 CALL message( 'init_grid', 'PA0205', 1, 2, 0, 6, 0 ) 1818 1699 ENDIF 1819 1700 ELSEIF ( canyon_width_y /= 9999999.9_wp ) THEN 1820 IF ( ( index_south_cwall < 1 ) .OR. & 1821 ( index_north_cwall > ny-1 ) .OR. ( ngp_cy < 3 ) ) THEN 1822 WRITE( message_string, * ) 'inconsistent canyon parameters:', & 1823 '&index_south_cwall=', index_south_cwall, & 1824 ' index_north_cwall=', index_north_cwall, & 1825 ' ngp_cy=', ngp_cy, & 1826 ' ch=', ch, ' nx=', nx, ' ny=', ny 1827 CALL message( 'init_grid', 'PA0206', 1, 2, 0, 6, 0 ) 1828 ENDIF 1829 ENDIF 1830 IF ( canyon_width_x /= 9999999.9_wp .AND. & 1831 canyon_width_y /= 9999999.9_wp ) THEN 1832 message_string = 'inconsistent canyon parameters:' // & 1833 '&street canyon can only be oriented' // & 1701 IF ( ( index_south_cwall < 1 ) .OR. & 1702 ( index_north_cwall > ny-1 ) .OR. ( ngp_cy < 3 ) ) THEN 1703 WRITE( message_string, * ) 'inconsistent canyon parameters:', & 1704 '&index_south_cwall=', index_south_cwall, & 1705 ' index_north_cwall=', index_north_cwall, & 1706 ' ngp_cy=', ngp_cy, ' ch=', ch, ' nx=', nx, ' ny=', ny 1707 CALL message( 'init_grid', 'PA0206', 1, 2, 0, 6, 0 ) 1708 ENDIF 1709 ENDIF 1710 IF ( canyon_width_x /= 9999999.9_wp .AND. canyon_width_y /= 9999999.9_wp ) THEN 1711 message_string = 'inconsistent canyon parameters:' // & 1712 '&street canyon can only be oriented' // & 1834 1713 ' either in x- or in y-direction' 1835 1714 CALL message( 'init_grid', 'PA0207', 1, 2, 0, 6, 0 ) … … 1839 1718 nzb_local = ch 1840 1719 IF ( canyon_width_x /= 9999999.9_wp ) THEN 1841 IF ( index_left_cwall<= nxr .AND. index_right_cwall>= nxl ) &1720 IF ( index_left_cwall<= nxr .AND. index_right_cwall>= nxl ) & 1842 1721 nzb_local(:,MAX(nxl,index_left_cwall+1):MIN(nxr,index_right_cwall-1)) = 0 1843 1722 ELSEIF ( canyon_width_y /= 9999999.9_wp ) THEN 1844 IF ( index_south_cwall <= nyn .AND. index_north_cwall >= nys ) &1723 IF ( index_south_cwall <= nyn .AND. index_north_cwall >= nys ) & 1845 1724 nzb_local(MAX(nys,index_south_cwall+1):MIN(nyn,index_north_cwall-1),:) = 0 1846 1725 ENDIF … … 1849 1728 DO i = nxl, nxr 1850 1729 DO j = nys, nyn 1851 topo(nzb_local(j,i)+1:nzt+1,j,i) = & 1852 IBSET( topo(nzb_local(j,i)+1:nzt+1,j,i), 0 ) 1730 topo(nzb_local(j,i)+1:nzt+1,j,i) = IBSET( topo(nzb_local(j,i)+1:nzt+1,j,i), 0 ) 1853 1731 ENDDO 1854 1732 ENDDO … … 1857 1735 CALL exchange_horiz_int( topo, nys, nyn, nxl, nxr, nzt, nbgp ) 1858 1736 ! 1859 !-- Set boundary conditions also for flags. Can be interpreted as Neumann 1860 !-- boundary conditions for topography.1737 !-- Set boundary conditions also for flags. Can be interpreted as Neumann boundary conditions 1738 !-- for topography. 1861 1739 IF ( .NOT. bc_ns_cyc ) THEN 1862 1740 IF ( nys == 0 ) THEN 1863 DO i = 1, nbgp 1864 topo(:,nys-i,:) 1741 DO i = 1, nbgp 1742 topo(:,nys-i,:) = topo(:,nys,:) 1865 1743 ENDDO 1866 1744 ENDIF 1867 1745 IF ( nyn == ny ) THEN 1868 DO i = 1, nbgp 1746 DO i = 1, nbgp 1869 1747 topo(:,nyn+i,:) = topo(:,nyn,:) 1870 1748 ENDDO … … 1873 1751 IF ( .NOT. bc_lr_cyc ) THEN 1874 1752 IF ( nxl == 0 ) THEN 1875 DO i = 1, nbgp 1876 topo(:,:,nxl-i) 1753 DO i = 1, nbgp 1754 topo(:,:,nxl-i) = topo(:,:,nxl) 1877 1755 ENDDO 1878 1756 ENDIF 1879 IF ( nxr == nx ) THEN 1880 DO i = 1, nbgp 1881 topo(:,:,nxr+i) = topo(:,:,nxr) 1757 IF ( nxr == nx ) THEN 1758 DO i = 1, nbgp 1759 topo(:,:,nxr+i) = topo(:,:,nxr) 1882 1760 ENDDO 1883 ENDIF 1761 ENDIF 1884 1762 ENDIF 1885 1763 … … 1895 1773 ! 1896 1774 !-- Tunnel-wall depth 1897 IF ( tunnel_wall_depth == 9999999.9_wp ) THEN 1775 IF ( tunnel_wall_depth == 9999999.9_wp ) THEN 1898 1776 td = MAX ( dx, dy, dz(1) ) 1899 1777 ELSE … … 1902 1780 ! 1903 1781 !-- Check for tunnel width 1904 IF ( tunnel_width_x == 9999999.9_wp .AND. & 1905 tunnel_width_y == 9999999.9_wp ) THEN 1782 IF ( tunnel_width_x == 9999999.9_wp .AND. tunnel_width_y == 9999999.9_wp ) THEN 1906 1783 message_string = 'No tunnel width is given. ' 1907 1784 CALL message( 'init_grid', 'PA0280', 1, 2, 0, 6, 0 ) 1908 1785 ENDIF 1909 IF ( tunnel_width_x /= 9999999.9_wp .AND. & 1910 tunnel_width_y /= 9999999.9_wp ) THEN 1911 message_string = 'Inconsistent tunnel parameters:' // & 1912 'tunnel can only be oriented' // & 1786 IF ( tunnel_width_x /= 9999999.9_wp .AND. tunnel_width_y /= 9999999.9_wp ) THEN 1787 message_string = 'Inconsistent tunnel parameters:' // & 1788 'tunnel can only be oriented' // & 1913 1789 'either in x- or in y-direction.' 1914 1790 CALL message( 'init_grid', 'PA0281', 1, 2, 0, 6, 0 ) … … 1916 1792 ! 1917 1793 !-- Check for too small tunnel width in x- and y-direction 1918 IF ( tunnel_width_x /= 9999999.9_wp .AND. &1794 IF ( tunnel_width_x /= 9999999.9_wp .AND. & 1919 1795 tunnel_width_x - 2.0_wp * td <= 2.0_wp * dx ) THEN 1920 1796 message_string = 'tunnel_width_x too small' 1921 1797 CALL message( 'init_grid', 'PA0175', 1, 2, 0, 6, 0 ) 1922 1798 ENDIF 1923 IF ( tunnel_width_y /= 9999999.9_wp .AND. &1799 IF ( tunnel_width_y /= 9999999.9_wp .AND. & 1924 1800 tunnel_width_y - 2.0_wp * td <= 2.0_wp * dy ) THEN 1925 1801 message_string = 'tunnel_width_y too small' … … 1927 1803 ENDIF 1928 1804 ! 1929 !-- Check for too large tunnel width. 1805 !-- Check for too large tunnel width. 1930 1806 !-- Tunnel axis along y. 1931 1807 IF ( tunnel_width_x /= 9999999.9_wp ) THEN … … 1937 1813 txs_out = INT( ( nx + 1 ) * 0.5_wp * dx - tunnel_width_x * 0.5_wp ) 1938 1814 txe_out = INT( ( nx + 1 ) * 0.5_wp * dx + tunnel_width_x * 0.5_wp ) 1939 txs_in = INT( ( nx + 1 ) * 0.5_wp * dx - & 1940 ( tunnel_width_x * 0.5_wp - td ) ) 1941 txe_in = INT( ( nx + 1 ) * 0.5_wp * dx + & 1942 ( tunnel_width_x * 0.5_wp - td ) ) 1815 txs_in = INT( ( nx + 1 ) * 0.5_wp * dx - ( tunnel_width_x * 0.5_wp - td ) ) 1816 txe_in = INT( ( nx + 1 ) * 0.5_wp * dx + ( tunnel_width_x * 0.5_wp - td ) ) 1943 1817 1944 1818 tys_out = INT( ( ny + 1 ) * 0.5_wp * dy - tunnel_length * 0.5_wp ) … … 1962 1836 tys_out = INT( ( ny + 1 ) * 0.5_wp * dy - tunnel_width_y * 0.5_wp ) 1963 1837 tye_out = INT( ( ny + 1 ) * 0.5_wp * dy + tunnel_width_y * 0.5_wp ) 1964 tys_in = INT( ( ny + 1 ) * 0.5_wp * dy - & 1965 ( tunnel_width_y * 0.5_wp - td ) ) 1966 tye_in = INT( ( ny + 1 ) * 0.5_wp * dy + & 1967 ( tunnel_width_y * 0.5_wp - td ) ) 1838 tys_in = INT( ( ny + 1 ) * 0.5_wp * dy - ( tunnel_width_y * 0.5_wp - td ) ) 1839 tye_in = INT( ( ny + 1 ) * 0.5_wp * dy + ( tunnel_width_y * 0.5_wp - td ) ) 1968 1840 ENDIF 1969 1841 … … 1973 1845 ! 1974 1846 !-- Use heaviside function to model outer tunnel surface 1975 hv_out = th * 0.5_wp * & 1976 ( ( SIGN( 1.0_wp, i * dx - txs_out ) + 1.0_wp ) & 1977 - ( SIGN( 1.0_wp, i * dx - txe_out ) + 1.0_wp ) ) 1978 1979 hv_out = hv_out * 0.5_wp * & 1980 ( ( SIGN( 1.0_wp, j * dy - tys_out ) + 1.0_wp ) & 1981 - ( SIGN( 1.0_wp, j * dy - tye_out ) + 1.0_wp ) ) 1982 ! 1847 hv_out = th * 0.5_wp * ( ( SIGN( 1.0_wp, i * dx - txs_out ) + 1.0_wp ) & 1848 - ( SIGN( 1.0_wp, i * dx - txe_out ) + 1.0_wp ) ) 1849 1850 hv_out = hv_out * 0.5_wp * ( ( SIGN( 1.0_wp, j * dy - tys_out ) + 1.0_wp ) & 1851 - ( SIGN( 1.0_wp, j * dy - tye_out ) + 1.0_wp ) ) 1852 ! 1983 1853 !-- Use heaviside function to model inner tunnel surface 1984 hv_in = ( th - td ) * 0.5_wp * & 1985 ( ( SIGN( 1.0_wp, i * dx - txs_in ) + 1.0_wp ) & 1986 - ( SIGN( 1.0_wp, i * dx - txe_in ) + 1.0_wp ) ) 1987 1988 hv_in = hv_in * 0.5_wp * & 1989 ( ( SIGN( 1.0_wp, j * dy - tys_in ) + 1.0_wp ) & 1990 - ( SIGN( 1.0_wp, j * dy - tye_in ) + 1.0_wp ) ) 1854 hv_in = ( th - td ) * 0.5_wp * ( ( SIGN( 1.0_wp, i * dx - txs_in ) + 1.0_wp ) & 1855 - ( SIGN( 1.0_wp, i * dx - txe_in ) + 1.0_wp ) ) 1856 1857 hv_in = hv_in * 0.5_wp * ( ( SIGN( 1.0_wp, j * dy - tys_in ) + 1.0_wp ) & 1858 - ( SIGN( 1.0_wp, j * dy - tye_in ) + 1.0_wp ) ) 1991 1859 ! 1992 1860 !-- Set flags at x-y-positions without any tunnel surface … … 2009 1877 !-- Lateral tunnel walls 2010 1878 IF ( hv_out - hv_in == td ) THEN 2011 IF ( zw(k) <= hv_in ) THEN 1879 IF ( zw(k) <= hv_in ) THEN 2012 1880 topo(k,j,i) = IBSET( topo(k,j,i), 0 ) 2013 ELSEIF ( zw(k) > hv_in .AND. zw(k) <= hv_out ) THEN 1881 ELSEIF ( zw(k) > hv_in .AND. zw(k) <= hv_out ) THEN 2014 1882 topo(k,j,i) = IBCLR( topo(k,j,i), 0 ) 2015 ELSEIF ( zw(k) > hv_out ) THEN 1883 ELSEIF ( zw(k) > hv_out ) THEN 2016 1884 topo(k,j,i) = IBSET( topo(k,j,i), 0 ) 2017 1885 ENDIF … … 2024 1892 CALL exchange_horiz_int( topo, nys, nyn, nxl, nxr, nzt, nbgp ) 2025 1893 ! 2026 !-- Set boundary conditions also for flags. Can be interpreted as Neumann 2027 !-- boundary conditions for topography.1894 !-- Set boundary conditions also for flags. Can be interpreted as Neumann boundary conditions 1895 !-- for topography. 2028 1896 IF ( .NOT. bc_ns_cyc ) THEN 2029 1897 IF ( nys == 0 ) THEN 2030 DO i = 1, nbgp 2031 topo(:,nys-i,:) 1898 DO i = 1, nbgp 1899 topo(:,nys-i,:) = topo(:,nys,:) 2032 1900 ENDDO 2033 1901 ENDIF 2034 1902 IF ( nyn == ny ) THEN 2035 DO i = 1, nbgp 1903 DO i = 1, nbgp 2036 1904 topo(:,nyn+i,:) = topo(:,nyn,:) 2037 1905 ENDDO … … 2040 1908 IF ( .NOT. bc_lr_cyc ) THEN 2041 1909 IF ( nxl == 0 ) THEN 2042 DO i = 1, nbgp 2043 topo(:,:,nxl-i) 1910 DO i = 1, nbgp 1911 topo(:,:,nxl-i) = topo(:,:,nxl) 2044 1912 ENDDO 2045 1913 ENDIF 2046 IF ( nxr == nx ) THEN 2047 DO i = 1, nbgp 2048 topo(:,:,nxr+i) = topo(:,:,nxr) 1914 IF ( nxr == nx ) THEN 1915 DO i = 1, nbgp 1916 topo(:,:,nxr+i) = topo(:,:,nxr) 2049 1917 ENDDO 2050 ENDIF 1918 ENDIF 2051 1919 ENDIF 2052 1920 2053 1921 CASE ( 'read_from_file' ) 2054 1922 ! 2055 !-- Note, topography information have been already read. 2056 !-- If required, further process topography, i.e. reference buildings on 2057 !-- top of orography and set temporary 3D topography array, which is 2058 !-- used later to set grid flags. Calling of this rouinte is also 2059 !-- required in case of ASCII input, even though no distinction between 2060 !-- terrain- and building height is made in this case. 1923 !-- Note, topography information have been already read. 1924 !-- If required, further process topography, i.e. reference buildings on top of orography and 1925 !-- set temporary 3D topography array, which is used later to set grid flags. Calling of this 1926 !-- rouinte is also required in case of ASCII input, even though no distinction between 1927 !-- terrain- and building height is made in this case. 2061 1928 CALL process_topography( topo ) 2062 1929 ! … … 2064 1931 CALL filter_topography( topo ) 2065 1932 ! 2066 !-- Exchange ghost-points, as well as add cyclic or Neumann boundary 2067 !-- conditions. 1933 !-- Exchange ghost-points, as well as add cyclic or Neumann boundary conditions. 2068 1934 CALL exchange_horiz_int( topo, nys, nyn, nxl, nxr, nzt, nbgp ) 2069 1935 ! … … 2071 1937 IF ( .NOT. bc_ns_cyc ) THEN 2072 1938 IF ( nys == 0 ) THEN 2073 DO i = 1, nbgp 1939 DO i = 1, nbgp 2074 1940 topo(:,nys-i,:) = topo(:,nys,:) 2075 1941 ENDDO 2076 1942 ENDIF 2077 1943 IF ( nyn == ny ) THEN 2078 DO i = 1, nbgp 1944 DO i = 1, nbgp 2079 1945 topo(:,nyn+i,:) = topo(:,nyn,:) 2080 1946 ENDDO … … 2084 1950 IF ( .NOT. bc_lr_cyc ) THEN 2085 1951 IF ( nxl == 0 ) THEN 2086 DO i = 1, nbgp 1952 DO i = 1, nbgp 2087 1953 topo(:,:,nxl-i) = topo(:,:,nxl) 2088 1954 ENDDO 2089 1955 ENDIF 2090 1956 IF ( nxr == nx ) THEN 2091 DO i = 1, nbgp 1957 DO i = 1, nbgp 2092 1958 topo(:,:,nxr+i) = topo(:,:,nxr) 2093 1959 ENDDO … … 2097 1963 2098 1964 CASE DEFAULT 2099 ! 2100 !-- The DEFAULT case is reached either if the parameter topography 2101 !-- contains a wrong character string or if the user has defined a special 2102 !-- case in the user interface. There, the subroutine user_init_grid 2103 !-- checks which of these two conditions applies. 1965 ! 1966 !-- The DEFAULT case is reached either if the parameter topography contains a wrong character 1967 !-- string or if the user has defined a special case in the user interface. There, the 1968 !-- subroutine user_init_grid checks which of these two conditions applies. 2104 1969 CALL user_init_grid( topo ) 2105 1970 CALL filter_topography( topo ) … … 2107 1972 END SELECT 2108 1973 ! 2109 !-- Consistency checks and index array initialization are only required for 2110 !-- non-flat topography. 1974 !-- Consistency checks and index array initialization are only required for non-flat topography. 2111 1975 IF ( TRIM( topography ) /= 'flat' ) THEN 2112 1976 ! 2113 !-- In case of non-flat topography, check whether the convention how to 2114 !-- define the topography grid has been set correctly, or whether the default2115 !-- is applicable. If this is not possible,abort.1977 !-- In case of non-flat topography, check whether the convention how to define the topography 1978 !-- grid has been set correctly, or whether the default is applicable. If this is not possible, 1979 !-- abort. 2116 1980 IF ( TRIM( topography_grid_convention ) == ' ' ) THEN 2117 IF ( TRIM( topography ) /= 'closed_channel' .AND.&2118 TRIM( topography ) /= 'single_building' .AND.&2119 TRIM( topography ) /= 'single_street_canyon' .AND.&2120 TRIM( topography ) /= 'tunnel' .AND.&1981 IF ( TRIM( topography ) /= 'closed_channel' .AND. & 1982 TRIM( topography ) /= 'single_building' .AND. & 1983 TRIM( topography ) /= 'single_street_canyon' .AND. & 1984 TRIM( topography ) /= 'tunnel' .AND. & 2121 1985 TRIM( topography ) /= 'read_from_file') THEN 2122 !-- The default value is not applicable here, because it is only valid 2123 !-- for the four standard cases 'single_building', 2124 !-- 'single_street_canyon', 'tunnel' and 'read_from_file' 1986 !-- The default value is not applicable here, because it is only valid for the four 1987 !-- standard cases 'single_building', 'single_street_canyon', 'tunnel' and 'read_from_file' 2125 1988 !-- defined in init_grid. 2126 WRITE( message_string, * ) & 2127 'The value for "topography_grid_convention" ', & 2128 'is not set. Its default value is & only valid for ', & 2129 '"topography" = ''single_building'', ''tunnel'' ', & 2130 '''single_street_canyon'', ''closed_channel'' & or ', & 2131 '''read_from_file''.', & 2132 '& Choose ''cell_edge'' or ''cell_center''.' 1989 WRITE( message_string, * ) 'The value for "topography_grid_convention" ', & 1990 'is not set. Its default value is & only valid for ', & 1991 '"topography" = ''single_building'', ''tunnel'' ', & 1992 '''single_street_canyon'', ''closed_channel'' & or ', & 1993 '''read_from_file''.', & 1994 '& Choose ''cell_edge'' or ''cell_center''.' 2133 1995 CALL message( 'init_grid', 'PA0239', 1, 2, 0, 6, 0 ) 2134 1996 ELSE 2135 1997 !-- The default value is applicable here. 2136 1998 !-- Set convention according to topography. 2137 IF ( TRIM( topography ) == 'single_building' .OR.&1999 IF ( TRIM( topography ) == 'single_building' .OR. & 2138 2000 TRIM( topography ) == 'single_street_canyon' ) THEN 2139 2001 topography_grid_convention = 'cell_edge' 2140 ELSEIF ( TRIM( topography ) == 'read_from_file' .OR. &2002 ELSEIF ( TRIM( topography ) == 'read_from_file' .OR. & 2141 2003 TRIM( topography ) == 'tunnel') THEN 2142 2004 topography_grid_convention = 'cell_center' 2143 2005 ENDIF 2144 2006 ENDIF 2145 ELSEIF ( TRIM( topography_grid_convention ) /= 'cell_edge' .AND.&2007 ELSEIF ( TRIM( topography_grid_convention ) /= 'cell_edge' .AND. & 2146 2008 TRIM( topography_grid_convention ) /= 'cell_center' ) THEN 2147 WRITE( message_string, * ) & 2148 'The value for "topography_grid_convention" is ', & 2149 'not recognized.& Choose ''cell_edge'' or ''cell_center''.' 2009 WRITE( message_string, * ) 'The value for "topography_grid_convention" is ', & 2010 'not recognized.& Choose ''cell_edge'' or ''cell_center''.' 2150 2011 CALL message( 'init_grid', 'PA0240', 1, 2, 0, 6, 0 ) 2151 2012 ENDIF … … 2153 2014 2154 2015 IF ( topography_grid_convention == 'cell_edge' ) THEN 2155 ! 2156 !-- The array nzb_local as defined using the 'cell_edge' convention 2157 !-- describes the actual total size of topography which is defined at the 2158 !-- cell edges where u=0 on the topography walls in x-direction and v=0 2016 ! 2017 !-- The array nzb_local as defined using the 'cell_edge' convention 2018 !-- describes the actual total size of topography which is defined at the 2019 !-- cell edges where u=0 on the topography walls in x-direction and v=0 2159 2020 !-- on the topography walls in y-direction. However, PALM uses individual 2160 2021 !-- arrays nzb_u|v|w|s_inner|outer that are based on nzb_s_inner. 2161 !-- Therefore, the extent of topography in nzb_local is now reduced by 2162 !-- 1dx at the E topography walls and by 1dy at the N topography walls 2163 !-- to form the basis for nzb_s_inner. 2022 !-- Therefore, the extent of topography in nzb_local is now reduced by 2023 !-- 1dx at the E topography walls and by 1dy at the N topography walls 2024 !-- to form the basis for nzb_s_inner. 2164 2025 !-- Note, the reverse memory access (i-j instead of j-i) is absolutely 2165 2026 !-- required at this point. … … 2167 2028 DO i = nxl-1, nxr 2168 2029 DO k = nzb, nzt+1 2169 IF ( BTEST( topo(k,j,i), 0 ) .OR. & 2170 BTEST( topo(k,j,i+1), 0 ) ) & 2030 IF ( BTEST( topo(k,j,i), 0 ) .OR. BTEST( topo(k,j,i+1), 0 ) ) & 2171 2031 topo(k,j,i) = IBSET( topo(k,j,i), 0 ) 2172 2032 ENDDO 2173 2033 ENDDO 2174 ENDDO 2034 ENDDO 2175 2035 CALL exchange_horiz_int( topo, nys, nyn, nxl, nxr, nzt, nbgp ) 2176 2036 … … 2178 2038 DO j = nys-1, nyn 2179 2039 DO k = nzb, nzt+1 2180 IF ( BTEST( topo(k,j,i), 0 ) .OR. & 2181 BTEST( topo(k,j+1,i), 0 ) ) & 2040 IF ( BTEST( topo(k,j,i), 0 ) .OR. BTEST( topo(k,j+1,i), 0 ) ) & 2182 2041 topo(k,j,i) = IBSET( topo(k,j,i), 0 ) 2183 2042 ENDDO 2184 2043 ENDDO 2185 ENDDO 2044 ENDDO 2186 2045 CALL exchange_horiz_int( topo, nys, nyn, nxl, nxr, nzt, nbgp ) 2187 2046 2188 2047 ENDIF 2189 2048 ENDIF … … 2194 2053 SUBROUTINE set_topo_flags(topo) 2195 2054 2196 USE control_parameters, &2197 ONLY: bc_lr_cyc, bc_ns_cyc, constant_flux_layer, 2198 scalar_advec, topography,use_surface_fluxes, use_top_fluxes2199 2200 USE exchange_horiz_mod, &2055 USE control_parameters, & 2056 ONLY: bc_lr_cyc, bc_ns_cyc, constant_flux_layer, scalar_advec, topography, & 2057 use_surface_fluxes, use_top_fluxes 2058 2059 USE exchange_horiz_mod, & 2201 2060 ONLY: exchange_horiz_int 2202 2061 2203 USE indices, &2204 ONLY: nbgp, nx, nxl, nxlg, nxr, nxrg, ny, nyn, nyng, nys, nysg, nzb, &2205 nzt, topo_top_ind,wall_flags_static_0, wall_flags_total_02062 USE indices, & 2063 ONLY: nbgp, nx, nxl, nxlg, nxr, nxrg, ny, nyn, nyng, nys, nysg, nzb, nzt, topo_top_ind, & 2064 wall_flags_static_0, wall_flags_total_0 2206 2065 2207 2066 USE kinds … … 2214 2073 INTEGER(iwp) :: k !< index variable along z 2215 2074 2216 INTEGER(iwp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg) :: topo !< input array for 3D topography and dummy array for setting "outer"-flags 2075 INTEGER(iwp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg) :: topo !< input array for 3D topography and dummy array for setting 2076 !< "outer"-flags 2217 2077 2218 2078 ALLOCATE( wall_flags_static_0(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) … … 2220 2080 ! 2221 2081 !-- Set-up topography flags. First, set flags only for s, u, v and w-grid. 2222 !-- Further special flags will be set in following loops. 2082 !-- Further special flags will be set in following loops. 2223 2083 DO i = nxl, nxr 2224 2084 DO j = nys, nyn … … 2226 2086 ! 2227 2087 !-- scalar grid 2228 IF ( BTEST( topo(k,j,i), 0 ) ) &2088 IF ( BTEST( topo(k,j,i), 0 ) ) & 2229 2089 wall_flags_static_0(k,j,i) = IBSET( wall_flags_static_0(k,j,i), 0 ) 2230 2090 ! 2231 2091 !-- u grid 2232 IF ( BTEST( topo(k,j,i), 0 ) .AND. & 2233 BTEST( topo(k,j,i-1), 0 ) ) & 2092 IF ( BTEST( topo(k,j,i), 0 ) .AND. BTEST( topo(k,j,i-1), 0 ) ) & 2234 2093 wall_flags_static_0(k,j,i) = IBSET( wall_flags_static_0(k,j,i), 1 ) 2235 2094 ! 2236 2095 !-- v grid 2237 IF ( BTEST( topo(k,j,i), 0 ) .AND. & 2238 BTEST( topo(k,j-1,i), 0 ) ) & 2096 IF ( BTEST( topo(k,j,i), 0 ) .AND. BTEST( topo(k,j-1,i), 0 ) ) & 2239 2097 wall_flags_static_0(k,j,i) = IBSET( wall_flags_static_0(k,j,i), 2 ) 2240 2098 … … 2244 2102 ! 2245 2103 !-- w grid 2246 IF ( BTEST( topo(k,j,i), 0 ) .AND. & 2247 BTEST( topo(k+1,j,i), 0 ) ) & 2104 IF ( BTEST( topo(k,j,i), 0 ) .AND. BTEST( topo(k+1,j,i), 0 ) ) & 2248 2105 wall_flags_static_0(k,j,i) = IBSET( wall_flags_static_0(k,j,i), 3 ) 2249 2106 ENDDO 2250 2251 IF ( topography /= 'closed_channel' ) THEN2107 2108 IF ( topography /= 'closed_channel' ) THEN 2252 2109 wall_flags_static_0(nzt+1,j,i) = IBSET( wall_flags_static_0(nzt+1,j,i), 3 ) 2253 2110 ENDIF … … 2259 2116 2260 2117 ! 2261 !-- Set outer array for scalars to mask near-surface grid points. Note, on 2262 !-- basis of flag 24 futher flags will be derived which are used to control 2263 !-- production of subgrid TKE production near walls. 2264 2118 !-- Set outer array for scalars to mask near-surface grid points. Note, on basis of flag 24 futher 2119 !-- flags will be derived which are used to control production of subgrid TKE production near walls. 2120 2265 2121 ALLOCATE( wall_flags_total_0(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 2266 2122 wall_flags_total_0 = 0 2267 2123 2268 2124 DO i = nxl, nxr 2269 2125 DO j = nys, nyn … … 2273 2129 ENDDO 2274 2130 ENDDO 2275 2131 2276 2132 CALL exchange_horiz_int( wall_flags_total_0, nys, nyn, nxl, nxr, nzt, nbgp ) 2277 2133 2278 2134 DO i = nxl, nxr 2279 2135 DO j = nys, nyn 2280 2136 DO k = nzb, nzt+1 2281 IF ( BTEST( wall_flags_total_0(k,j-1,i), 0 ) .AND. &2282 BTEST( wall_flags_total_0(k,j+1,i), 0 ) .AND. &2283 BTEST( wall_flags_total_0(k,j,i-1), 0 ) .AND. &2284 BTEST( wall_flags_total_0(k,j,i+1), 0 ) .AND. &2285 BTEST( wall_flags_total_0(k,j-1,i-1), 0 ) .AND. &2286 BTEST( wall_flags_total_0(k,j+1,i-1), 0 ) .AND. &2287 BTEST( wall_flags_total_0(k,j-1,i+1), 0 ) .AND. &2288 BTEST( wall_flags_total_0(k,j+1,i+1), 0 ) ) &2137 IF ( BTEST( wall_flags_total_0(k,j-1,i), 0 ) .AND. & 2138 BTEST( wall_flags_total_0(k,j+1,i), 0 ) .AND. & 2139 BTEST( wall_flags_total_0(k,j,i-1), 0 ) .AND. & 2140 BTEST( wall_flags_total_0(k,j,i+1), 0 ) .AND. & 2141 BTEST( wall_flags_total_0(k,j-1,i-1), 0 ) .AND. & 2142 BTEST( wall_flags_total_0(k,j+1,i-1), 0 ) .AND. & 2143 BTEST( wall_flags_total_0(k,j-1,i+1), 0 ) .AND. & 2144 BTEST( wall_flags_total_0(k,j+1,i+1), 0 ) ) & 2289 2145 wall_flags_total_0(k,j,i) = IBSET( wall_flags_total_0(k,j,i), 24 ) 2290 2146 ENDDO … … 2298 2154 ! 2299 2155 !-- scalar grid, former nzb_diff_s_inner. 2300 !-- Note, use this flag also to mask topography in diffusion_u and 2301 !-- diffusion_v along the vertical direction. In case of 2302 !-- use_surface_fluxes, fluxes are calculated via MOST, else, simple 2303 !-- gradient approach is applied. Please note, in case of u- and v- 2304 !-- diffuison, a small error is made at edges (on the east side for u, 2305 !-- at the north side for v), since topography on scalar grid point 2306 !-- is used instead of topography on u/v-grid. As number of topography grid 2307 !-- points on uv-grid is different than s-grid, different number of 2308 !-- surface elements would be required. In order to avoid this, 2309 !-- treat edges (u(k,j,i+1)) simply by a gradient approach, i.e. these 2310 !-- points are not masked within diffusion_u. Tests had shown that the 2311 !-- effect on the flow is negligible. 2156 !-- Note, use this flag also to mask topography in diffusion_u and diffusion_v along the 2157 !-- vertical direction. In case of use_surface_fluxes, fluxes are calculated via MOST, 2158 !-- else, simple gradient approach is applied. Please note, in case of u- and v-diffuison, 2159 !-- a small error is made at edges (on the east side for u, at the north side for v), since 2160 !-- topography on scalar grid point is used instead of topography on u/v-grid. As number of 2161 !-- topography grid points on uv-grid is different than s-grid, different number of surface 2162 !-- elements would be required. In order to avoid this, treat edges (u(k,j,i+1)) simply by 2163 !-- a gradient approach, i.e. these points are not masked within diffusion_u. Tests had 2164 !-- shown that the effect on the flow is negligible. 2312 2165 IF ( constant_flux_layer .OR. use_surface_fluxes ) THEN 2313 IF ( BTEST( wall_flags_total_0(k,j,i), 0 ) ) &2166 IF ( BTEST( wall_flags_total_0(k,j,i), 0 ) ) & 2314 2167 wall_flags_total_0(k,j,i) = IBSET( wall_flags_total_0(k,j,i), 8 ) 2315 2168 ELSE … … 2319 2172 ENDDO 2320 2173 ! 2321 !-- Special flag to control vertical diffusion at model top - former 2322 !-- nzt_diff 2174 !-- Special flag to control vertical diffusion at model top - former nzt_diff 2323 2175 wall_flags_total_0(:,j,i) = IBSET( wall_flags_total_0(:,j,i), 9 ) 2324 2176 IF ( use_top_fluxes ) & … … 2328 2180 DO k = nzb+1, nzt 2329 2181 ! 2330 !-- Special flag on u grid, former nzb_u_inner + 1, required 2331 !-- for disturb_field and initialization. Do not disturb directly at 2332 !-- topography, as well as initialize u with zero one grid point outside 2333 !-- of topography. 2334 IF ( BTEST( wall_flags_total_0(k-1,j,i), 1 ) .AND. & 2335 BTEST( wall_flags_total_0(k,j,i), 1 ) .AND. & 2336 BTEST( wall_flags_total_0(k+1,j,i), 1 ) ) & 2182 !-- Special flag on u grid, former nzb_u_inner + 1, required for disturb_field and 2183 !-- initialization. Do not disturb directly at topography, as well as initialize u with 2184 !-- zero one grid point outside of topography. 2185 IF ( BTEST( wall_flags_total_0(k-1,j,i), 1 ) .AND. & 2186 BTEST( wall_flags_total_0(k,j,i), 1 ) .AND. & 2187 BTEST( wall_flags_total_0(k+1,j,i), 1 ) ) & 2337 2188 wall_flags_total_0(k,j,i) = IBSET( wall_flags_total_0(k,j,i), 20 ) 2338 2189 ! 2339 !-- Special flag on v grid, former nzb_v_inner + 1, required 2340 !-- for disturb_field and initialization. Do not disturb directly at 2341 !-- topography, as well as initialize v with zero one grid point outside 2342 !-- of topography. 2343 IF ( BTEST( wall_flags_total_0(k-1,j,i), 2 ) .AND. & 2344 BTEST( wall_flags_total_0(k,j,i), 2 ) .AND. & 2345 BTEST( wall_flags_total_0(k+1,j,i), 2 ) ) & 2190 !-- Special flag on v grid, former nzb_v_inner + 1, required for disturb_field and 2191 !-- initialization. Do not disturb directly at topography, as well as initialize v with 2192 !-- zero one grid point outside of topography. 2193 IF ( BTEST( wall_flags_total_0(k-1,j,i), 2 ) .AND. & 2194 BTEST( wall_flags_total_0(k,j,i), 2 ) .AND. & 2195 BTEST( wall_flags_total_0(k+1,j,i), 2 ) ) & 2346 2196 wall_flags_total_0(k,j,i) = IBSET( wall_flags_total_0(k,j,i), 21 ) 2347 2197 ! 2348 !-- Special flag on scalar grid, former nzb_s_inner+1. Used for 2349 !-- lpm_sgs_tke 2350 IF ( BTEST( wall_flags_total_0(k,j,i), 0 ) .AND. & 2351 BTEST( wall_flags_total_0(k-1,j,i), 0 ) .AND. & 2352 BTEST( wall_flags_total_0(k+1,j,i), 0 ) ) & 2198 !-- Special flag on scalar grid, former nzb_s_inner+1. Used for lpm_sgs_tke 2199 IF ( BTEST( wall_flags_total_0(k,j,i), 0 ) .AND. & 2200 BTEST( wall_flags_total_0(k-1,j,i), 0 ) .AND. & 2201 BTEST( wall_flags_total_0(k+1,j,i), 0 ) ) & 2353 2202 wall_flags_total_0(k,j,i) = IBSET( wall_flags_total_0(k,j,i), 25 ) 2354 2203 ! 2355 !-- Special flag on scalar grid, nzb_diff_s_outer - 1, required in 2204 !-- Special flag on scalar grid, nzb_diff_s_outer - 1, required in in production_e 2205 IF ( constant_flux_layer .OR. use_surface_fluxes ) THEN 2206 IF ( BTEST( wall_flags_total_0(k,j,i), 24 ) .AND. & 2207 BTEST( wall_flags_total_0(k-1,j,i), 24 ) .AND. & 2208 BTEST( wall_flags_total_0(k+1,j,i), 0 ) ) & 2209 wall_flags_total_0(k,j,i) = IBSET( wall_flags_total_0(k,j,i), 29 ) 2210 ELSE 2211 IF ( BTEST( wall_flags_total_0(k,j,i), 0 ) ) & 2212 wall_flags_total_0(k,j,i) = IBSET( wall_flags_total_0(k,j,i), 29 ) 2213 ENDIF 2214 ! 2215 !-- Special flag on scalar grid, nzb_diff_s_outer - 1, required in 2356 2216 !-- in production_e 2357 2217 IF ( constant_flux_layer .OR. use_surface_fluxes ) THEN 2358 IF ( BTEST( wall_flags_total_0(k,j,i), 24 ) .AND. & 2359 BTEST( wall_flags_total_0(k-1,j,i), 24 ) .AND. & 2360 BTEST( wall_flags_total_0(k+1,j,i), 0 ) ) & 2361 wall_flags_total_0(k,j,i) = IBSET( wall_flags_total_0(k,j,i), 29 ) 2362 ELSE 2363 IF ( BTEST( wall_flags_total_0(k,j,i), 0 ) ) & 2364 wall_flags_total_0(k,j,i) = IBSET( wall_flags_total_0(k,j,i), 29 ) 2365 ENDIF 2366 ! 2367 !-- Special flag on scalar grid, nzb_diff_s_outer - 1, required in 2368 !-- in production_e 2369 IF ( constant_flux_layer .OR. use_surface_fluxes ) THEN 2370 IF ( BTEST( wall_flags_total_0(k,j,i), 0 ) .AND. & 2371 BTEST( wall_flags_total_0(k-1,j,i), 0 ) .AND. & 2372 BTEST( wall_flags_total_0(k+1,j,i), 0 ) ) & 2218 IF ( BTEST( wall_flags_total_0(k,j,i), 0 ) .AND. & 2219 BTEST( wall_flags_total_0(k-1,j,i), 0 ) .AND. & 2220 BTEST( wall_flags_total_0(k+1,j,i), 0 ) ) & 2373 2221 wall_flags_total_0(k,j,i) = IBSET( wall_flags_total_0(k,j,i), 30 ) 2374 2222 ELSE 2375 IF ( BTEST( wall_flags_total_0(k,j,i), 0 ) ) &2223 IF ( BTEST( wall_flags_total_0(k,j,i), 0 ) ) & 2376 2224 wall_flags_total_0(k,j,i) = IBSET( wall_flags_total_0(k,j,i), 30 ) 2377 2225 ENDIF … … 2382 2230 ! 2383 2231 !-- Scalar grid 2384 IF ( BTEST( wall_flags_total_0(k-1,j,i), 0 ) .AND.&2385 .NOT. BTEST( wall_flags_total_0(k,j,i), 0 ) ) &2386 wall_flags_total_0(k,j,i) = IBSET( wall_flags_total_0(k,j,i), 13 ) 2232 IF ( BTEST( wall_flags_total_0(k-1,j,i), 0 ) .AND. & 2233 .NOT. BTEST( wall_flags_total_0(k,j,i), 0 ) ) & 2234 wall_flags_total_0(k,j,i) = IBSET( wall_flags_total_0(k,j,i), 13 ) 2387 2235 ! 2388 2236 !-- Downward facing wall on u grid 2389 IF ( BTEST( wall_flags_total_0(k-1,j,i), 1 ) .AND.&2390 .NOT. BTEST( wall_flags_total_0(k,j,i), 1 ) ) &2237 IF ( BTEST( wall_flags_total_0(k-1,j,i), 1 ) .AND. & 2238 .NOT. BTEST( wall_flags_total_0(k,j,i), 1 ) ) & 2391 2239 wall_flags_total_0(k,j,i) = IBSET( wall_flags_total_0(k,j,i), 15 ) 2392 2240 ! 2393 2241 !-- Downward facing wall on v grid 2394 IF ( BTEST( wall_flags_total_0(k-1,j,i), 2 ) .AND.&2395 .NOT. BTEST( wall_flags_total_0(k,j,i), 2 ) ) &2242 IF ( BTEST( wall_flags_total_0(k-1,j,i), 2 ) .AND. & 2243 .NOT. BTEST( wall_flags_total_0(k,j,i), 2 ) ) & 2396 2244 wall_flags_total_0(k,j,i) = IBSET( wall_flags_total_0(k,j,i), 17 ) 2397 2245 ! 2398 2246 !-- Downward facing wall on w grid 2399 IF ( BTEST( wall_flags_total_0(k-1,j,i), 3 ) .AND.&2400 .NOT. BTEST( wall_flags_total_0(k,j,i), 3 ) ) &2247 IF ( BTEST( wall_flags_total_0(k-1,j,i), 3 ) .AND. & 2248 .NOT. BTEST( wall_flags_total_0(k,j,i), 3 ) ) & 2401 2249 wall_flags_total_0(k,j,i) = IBSET( wall_flags_total_0(k,j,i), 19 ) 2402 2250 ENDDO … … 2406 2254 ! 2407 2255 !-- Upward facing wall on scalar grid 2408 IF ( .NOT. BTEST( wall_flags_total_0(k,j,i), 0 ) .AND. &2409 BTEST( wall_flags_total_0(k+1,j,i), 0 ) ) &2256 IF ( .NOT. BTEST( wall_flags_total_0(k,j,i), 0 ) .AND. & 2257 BTEST( wall_flags_total_0(k+1,j,i), 0 ) ) & 2410 2258 wall_flags_total_0(k,j,i) = IBSET( wall_flags_total_0(k,j,i), 12 ) 2411 2259 ! 2412 2260 !-- Upward facing wall on u grid 2413 IF ( .NOT. BTEST( wall_flags_total_0(k,j,i), 1 ) .AND. &2414 BTEST( wall_flags_total_0(k+1,j,i), 1 ) ) &2261 IF ( .NOT. BTEST( wall_flags_total_0(k,j,i), 1 ) .AND. & 2262 BTEST( wall_flags_total_0(k+1,j,i), 1 ) ) & 2415 2263 wall_flags_total_0(k,j,i) = IBSET( wall_flags_total_0(k,j,i), 14 ) 2416 2264 2417 ! 2265 ! 2418 2266 !-- Upward facing wall on v grid 2419 IF ( .NOT. BTEST( wall_flags_total_0(k,j,i), 2 ) .AND. &2420 BTEST( wall_flags_total_0(k+1,j,i), 2 ) ) &2267 IF ( .NOT. BTEST( wall_flags_total_0(k,j,i), 2 ) .AND. & 2268 BTEST( wall_flags_total_0(k+1,j,i), 2 ) ) & 2421 2269 wall_flags_total_0(k,j,i) = IBSET( wall_flags_total_0(k,j,i), 16 ) 2422 2270 2423 2271 ! 2424 2272 !-- Upward facing wall on w grid 2425 IF ( .NOT. BTEST( wall_flags_total_0(k,j,i), 3 ) .AND. &2426 BTEST( wall_flags_total_0(k+1,j,i), 3 ) ) &2273 IF ( .NOT. BTEST( wall_flags_total_0(k,j,i), 3 ) .AND. & 2274 BTEST( wall_flags_total_0(k+1,j,i), 3 ) ) & 2427 2275 wall_flags_total_0(k,j,i) = IBSET( wall_flags_total_0(k,j,i), 18 ) 2428 2276 ! 2429 2277 !-- Special flag on scalar grid, former nzb_s_inner 2430 IF ( BTEST( wall_flags_total_0(k,j,i), 0 ) .OR. &2431 BTEST( wall_flags_total_0(k,j,i), 12 ) .OR. &2432 BTEST( wall_flags_total_0(k,j,i), 13 ) ) &2278 IF ( BTEST( wall_flags_total_0(k,j,i), 0 ) .OR. & 2279 BTEST( wall_flags_total_0(k,j,i), 12 ) .OR. & 2280 BTEST( wall_flags_total_0(k,j,i), 13 ) ) & 2433 2281 wall_flags_total_0(k,j,i) = IBSET( wall_flags_total_0(k,j,i), 22 ) 2434 2282 ! 2435 !-- Special flag on scalar grid, nzb_diff_s_inner - 1, required for 2283 !-- Special flag on scalar grid, nzb_diff_s_inner - 1, required for 2436 2284 !-- flow_statistics 2437 2285 IF ( constant_flux_layer .OR. use_surface_fluxes ) THEN 2438 IF ( BTEST( wall_flags_total_0(k,j,i), 0 ) .AND. &2439 BTEST( wall_flags_total_0(k+1,j,i), 0 ) ) &2286 IF ( BTEST( wall_flags_total_0(k,j,i), 0 ) .AND. & 2287 BTEST( wall_flags_total_0(k+1,j,i), 0 ) ) & 2440 2288 wall_flags_total_0(k,j,i) = IBSET( wall_flags_total_0(k,j,i), 23 ) 2441 2289 ELSE 2442 IF ( BTEST( wall_flags_total_0(k,j,i), 22 ) ) &2290 IF ( BTEST( wall_flags_total_0(k,j,i), 22 ) ) & 2443 2291 wall_flags_total_0(k,j,i) = IBSET( wall_flags_total_0(k,j,i), 23 ) 2444 2292 ENDIF 2445 2293 2446 2294 2447 2295 ENDDO … … 2449 2297 wall_flags_total_0(nzt+1,j,i) = IBSET( wall_flags_total_0(nzt+1,j,i), 23 ) 2450 2298 ! 2451 !-- Set flags indicating that topography is close by in horizontal 2452 !-- direction, i.e. flags that infold the topography. These will be used 2453 !-- to set advection flags for passive scalars, where due to large 2454 !-- gradients near buildings stationary numerical oscillations can produce 2455 !-- unrealistically high concentrations. This is only necessary if 2456 !-- WS-scheme is applied for scalar advection. Note, these flags will be 2457 !-- only used for passive scalars such as chemical species or aerosols. 2299 !-- Set flags indicating that topography is close by in horizontal direction, i.e. flags that 2300 !-- infold the topography. These will be used to set advection flags for passive scalars, 2301 !-- where due to large gradients near buildings stationary numerical oscillations can produce 2302 !-- unrealistically high concentrations. This is only necessary if WS-scheme is applied for 2303 !-- scalar advection. Note, these flags will be only used for passive scalars such as chemical 2304 !-- species or aerosols. 2458 2305 IF ( scalar_advec == 'ws-scheme' ) THEN 2459 2306 DO k = nzb, nzt 2460 IF ( BTEST( wall_flags_total_0(k,j,i), 0 ) .AND. ( & 2461 ANY( .NOT. BTEST( wall_flags_total_0(k,j-3:j+3,i-1), 0 ) ) .OR.& 2462 ANY( .NOT. BTEST( wall_flags_total_0(k,j-3:j+3,i-2), 0 ) ) .OR.& 2463 ANY( .NOT. BTEST( wall_flags_total_0(k,j-3:j+3,i-3), 0 ) ) .OR.& 2464 ANY( .NOT. BTEST( wall_flags_total_0(k,j-3:j+3,i+1), 0 ) ) .OR.& 2465 ANY( .NOT. BTEST( wall_flags_total_0(k,j-3:j+3,i+2), 0 ) ) .OR.& 2466 ANY( .NOT. BTEST( wall_flags_total_0(k,j-3:j+3,i+3), 0 ) ) .OR.& 2467 ANY( .NOT. BTEST( wall_flags_total_0(k,j-1,i-3:i+3), 0 ) ) .OR.& 2468 ANY( .NOT. BTEST( wall_flags_total_0(k,j-2,i-3:i+3), 0 ) ) .OR.& 2469 ANY( .NOT. BTEST( wall_flags_total_0(k,j-3,i-3:i+3), 0 ) ) .OR.& 2470 ANY( .NOT. BTEST( wall_flags_total_0(k,j+1,i-3:i+3), 0 ) ) .OR.& 2471 ANY( .NOT. BTEST( wall_flags_total_0(k,j+2,i-3:i+3), 0 ) ) .OR.& 2472 ANY( .NOT. BTEST( wall_flags_total_0(k,j+3,i-3:i+3), 0 ) ) & 2473 ) ) & 2307 IF ( BTEST( wall_flags_total_0(k,j,i), 0 ) .AND. ( & 2308 ANY( .NOT. BTEST( wall_flags_total_0(k,j-3:j+3,i-1), 0 ) ) .OR. & 2309 ANY( .NOT. BTEST( wall_flags_total_0(k,j-3:j+3,i-2), 0 ) ) .OR. & 2310 ANY( .NOT. BTEST( wall_flags_total_0(k,j-3:j+3,i-3), 0 ) ) .OR. & 2311 ANY( .NOT. BTEST( wall_flags_total_0(k,j-3:j+3,i+1), 0 ) ) .OR. & 2312 ANY( .NOT. BTEST( wall_flags_total_0(k,j-3:j+3,i+2), 0 ) ) .OR. & 2313 ANY( .NOT. BTEST( wall_flags_total_0(k,j-3:j+3,i+3), 0 ) ) .OR. & 2314 ANY( .NOT. BTEST( wall_flags_total_0(k,j-1,i-3:i+3), 0 ) ) .OR. & 2315 ANY( .NOT. BTEST( wall_flags_total_0(k,j-2,i-3:i+3), 0 ) ) .OR. & 2316 ANY( .NOT. BTEST( wall_flags_total_0(k,j-3,i-3:i+3), 0 ) ) .OR. & 2317 ANY( .NOT. BTEST( wall_flags_total_0(k,j+1,i-3:i+3), 0 ) ) .OR. & 2318 ANY( .NOT. BTEST( wall_flags_total_0(k,j+2,i-3:i+3), 0 ) ) .OR. & 2319 ANY( .NOT. BTEST( wall_flags_total_0(k,j+3,i-3:i+3), 0 ) ) & 2320 ) & 2321 ) & 2474 2322 wall_flags_total_0(k,j,i) = IBSET( wall_flags_total_0(k,j,i), 31 ) 2475 2476 2323 ENDDO 2477 2324 ENDIF … … 2480 2327 ! 2481 2328 !-- Finally, set identification flags indicating natural terrain or buildings. 2482 !-- Natural terrain grid points. Information on the type of the surface is 2483 !-- stored in bit 1 of 3D Integer array topo. However, this bit is only set2484 !-- when topography is read from file. In order to run the land-surface model2485 !-- also without topography information, set bit 1 explicitely in thiscase.2486 !-- 2329 !-- Natural terrain grid points. Information on the type of the surface is stored in bit 1 of 2330 !-- 3D Integer array topo. However, this bit is only set when topography is read from file. In order 2331 !-- to run the land-surface model also without topography information, set bit 1 explicitely in this 2332 !-- case. 2333 !-- 2487 2334 !-- Natural terrain grid points 2488 2335 !-- If no topography is initialized, the land-surface is at k = nzb. … … 2493 2340 DO j = nys, nyn 2494 2341 DO k = nzb, nzt+1 2495 ! 2342 ! 2496 2343 !-- Natural terrain grid point 2497 IF ( BTEST( topo(k,j,i), 1 ) ) &2344 IF ( BTEST( topo(k,j,i), 1 ) ) & 2498 2345 wall_flags_static_0(k,j,i) = IBSET( wall_flags_static_0(k,j,i), 5 ) 2499 2346 ENDDO … … 2506 2353 DO j = nys, nyn 2507 2354 DO k = nzb, nzt+1 2508 IF ( BTEST( topo(k,j,i), 2 ) ) &2355 IF ( BTEST( topo(k,j,i), 2 ) ) & 2509 2356 wall_flags_static_0(k,j,i) = IBSET( wall_flags_static_0(k,j,i), 6 ) 2510 2357 ENDDO … … 2516 2363 DO j = nys, nyn 2517 2364 DO k = nzb, nzt+1 2518 IF ( BTEST( topo(k,j,i), 4 ) ) &2365 IF ( BTEST( topo(k,j,i), 4 ) ) & 2519 2366 wall_flags_static_0(k,j,i) = IBSET( wall_flags_static_0(k,j,i), 4 ) 2520 2367 ENDDO 2521 2368 ENDDO 2522 2369 ENDDO 2523 2370 2524 2371 CALL exchange_horiz_int( wall_flags_static_0, nys, nyn, nxl, nxr, nzt, nbgp ) 2525 2372 2526 2373 DO i = nxl, nxr 2527 2374 DO j = nys, nyn … … 2535 2382 CALL exchange_horiz_int( wall_flags_total_0, nys, nyn, nxl, nxr, nzt, nbgp ) 2536 2383 ! 2537 !-- Set boundary conditions also for flags. Can be interpreted as Neumann 2538 !-- boundary conditions for topography.2384 !-- Set boundary conditions also for flags. Can be interpreted as Neumann boundary conditions for 2385 !-- topography. 2539 2386 IF ( .NOT. bc_ns_cyc ) THEN 2540 2387 IF ( nys == 0 ) THEN 2541 DO i = 1, nbgp 2388 DO i = 1, nbgp 2542 2389 wall_flags_total_0(:,nys-i,:) = wall_flags_total_0(:,nys,:) 2543 2390 ENDDO 2544 2391 ENDIF 2545 2392 IF ( nyn == ny ) THEN 2546 DO i = 1, nbgp 2393 DO i = 1, nbgp 2547 2394 wall_flags_total_0(:,nyn+i,:) = wall_flags_total_0(:,nyn,:) 2548 2395 ENDDO … … 2551 2398 IF ( .NOT. bc_lr_cyc ) THEN 2552 2399 IF ( nxl == 0 ) THEN 2553 DO i = 1, nbgp 2400 DO i = 1, nbgp 2554 2401 wall_flags_total_0(:,:,nxl-i) = wall_flags_total_0(:,:,nxl) 2555 2402 ENDDO 2556 2403 ENDIF 2557 IF ( nxr == nx ) THEN 2558 DO i = 1, nbgp 2559 wall_flags_total_0(:,:,nxr+i) = wall_flags_total_0(:,:,nxr) 2560 ENDDO 2561 ENDIF 2404 IF ( nxr == nx ) THEN 2405 DO i = 1, nbgp 2406 wall_flags_total_0(:,:,nxr+i) = wall_flags_total_0(:,:,nxr) 2407 ENDDO 2408 ENDIF 2562 2409 ENDIF 2563 2410 ! 2564 !-- Pre-calculate topography top indices (former get_topography_top_index 2411 !-- Pre-calculate topography top indices (former get_topography_top_index 2565 2412 !-- function) 2566 2413 ALLOCATE( topo_top_ind(nysg:nyng,nxlg:nxrg,0:4) ) … … 2568 2415 !-- Uppermost topography index on scalar grid 2569 2416 ibit = 12 2570 topo_top_ind(:,:,0) = MAXLOC( & 2571 MERGE( 1, 0, & 2572 BTEST( wall_flags_total_0(:,:,:), ibit ) & 2573 ), DIM = 1 & 2574 ) - 1 2575 ! 2576 !-- Uppermost topography index on u grid 2417 topo_top_ind(:,:,0) = MAXLOC( MERGE( 1, 0, BTEST( wall_flags_total_0(:,:,:), ibit ) ), DIM=1 ) & 2418 - 1 2419 ! 2420 !-- Uppermost topography index on u grid 2577 2421 ibit = 14 2578 topo_top_ind(:,:,1) = MAXLOC( & 2579 MERGE( 1, 0, & 2580 BTEST( wall_flags_total_0(:,:,:), ibit ) & 2581 ), DIM = 1 & 2582 ) - 1 2583 ! 2584 !-- Uppermost topography index on v grid 2422 topo_top_ind(:,:,1) = MAXLOC( MERGE( 1, 0, BTEST( wall_flags_total_0(:,:,:), ibit ) ), DIM=1 ) & 2423 - 1 2424 ! 2425 !-- Uppermost topography index on v grid 2585 2426 ibit = 16 2586 topo_top_ind(:,:,2) = MAXLOC( & 2587 MERGE( 1, 0, & 2588 BTEST( wall_flags_total_0(:,:,:), ibit ) & 2589 ), DIM = 1 & 2590 ) - 1 2427 topo_top_ind(:,:,2) = MAXLOC( MERGE( 1, 0, BTEST( wall_flags_total_0(:,:,:), ibit ) ), DIM=1 ) & 2428 - 1 2591 2429 ! 2592 2430 !-- Uppermost topography index on w grid 2593 2431 ibit = 18 2594 topo_top_ind(:,:,3) = MAXLOC( & 2595 MERGE( 1, 0, & 2596 BTEST( wall_flags_total_0(:,:,:), ibit ) & 2597 ), DIM = 1 & 2598 ) - 1 2432 topo_top_ind(:,:,3) = MAXLOC( MERGE( 1, 0, BTEST( wall_flags_total_0(:,:,:), ibit ) ), DIM=1 ) & 2433 - 1 2599 2434 ! 2600 2435 !-- Uppermost topography index on scalar outer grid 2601 2436 ibit = 24 2602 topo_top_ind(:,:,4) = MAXLOC( & 2603 MERGE( 1, 0, & 2604 BTEST( wall_flags_total_0(:,:,:), ibit ) & 2605 ), DIM = 1 & 2606 ) - 1 2437 topo_top_ind(:,:,4) = MAXLOC( MERGE( 1, 0, BTEST( wall_flags_total_0(:,:,:), ibit ) ), DIM=1 ) & 2438 - 1 2607 2439 2608 2440 END SUBROUTINE set_topo_flags
Note: See TracChangeset
for help on using the changeset viewer.