- Timestamp:
- Mar 20, 2020 4:14:41 PM (5 years ago)
- Location:
- palm/trunk/SOURCE
- Files:
-
- 3 edited
-
Makefile (modified) (5 diffs)
-
advec_ws.f90 (modified) (198 diffs)
-
time_integration.f90 (modified) (40 diffs)
Legend:
- Unmodified
- Added
- Removed
-
palm/trunk/SOURCE/Makefile
r4458 r4466 25 25 # ----------------- 26 26 # $Id$ 27 # cpu measures in advec_ws added 28 # 29 # 4458 2020-03-11 15:37:31Z raasch 27 30 # bugfix for r4457: missing dependency added 28 # 31 # 29 32 # 4457 2020-03-11 14:20:43Z raasch 30 33 # exchange horiz has been modularized and exchange horiz 2d has been merged, dependencies updated 31 34 # accordingly 32 # 35 # 33 36 # 4453 2020-03-11 08:10:13Z raasch 34 37 # dependencies for exchange horiz modified 35 # 38 # 36 39 # 4434 2020-03-03 10:02:18Z oliver.maas 37 40 # Added output control for wind turbine model 38 # 41 # 39 42 # 4414 2020-02-19 20:16:04Z suehring 40 43 # Move dependencies for init grid from advection scheme and multigrid solver 41 44 # to module_interface 42 # 45 # 43 46 # 4411 2020-02-18 14:28:02Z maronga 44 47 # Added output routines for WTM 45 # 48 # 46 49 # 4400 2020-02-10 20:32:41Z suehring 47 50 # Add dependency for data-output module 48 # 51 # 49 52 # 4392 2020-01-31 16:14:57Z pavelkrc 50 53 # add dependency on fft for transpose 51 # 54 # 52 55 # 4347 2019-12-18 13:18:33Z suehring 53 56 # add dependency to basic_constants_and_equations_mod for dynamics_mod 54 # 57 # 55 58 # 4331 2019-12-10 18:25:02Z suehring 56 59 # Move diagnostic surface output to diagnostic_output_quantities 57 # 60 # 58 61 # 4309 2019-11-26 18:49:59Z suehring 59 62 # Add dependency to parallel random generator for synthetic turbulence generator 60 # 63 # 61 64 # 4286 2019-10-30 16:01:14Z resler 62 65 # delete boundary_conds, added missing dependencies 63 # 66 # 64 67 # 4270 2019-10-23 10:46:20Z monakurppa 65 68 # - Implement offline nesting for salsa and add dependency of nesting_offl_mod … … 68 71 # for salsa 69 72 # - Add dependency on basic_constants_and_equations_mod for salsa_mod 70 # 73 # 71 74 # 4258 2019-10-07 13:29:08Z suehring 72 75 # Add dependency of land-surface model on pmc_handle_communicator and cpu_log 73 # 76 # 74 77 # 4245 2019-09-30 08:40:37Z pavelkrc 75 78 # Remove no longer needed dependencies on surface_mod 76 # 79 # 77 80 # 4227 2019-09-10 18:04:34Z gronemeier 78 81 # Add palm_date_time_mod, remove date_and_time_mod … … 80 83 # 4223 2019-09-10 09:20:47Z gronemeier 81 84 # Corrected "Former revisions" section 82 # 85 # 83 86 # 4174 2019-08-20 12:41:13Z gronemeier 84 87 # bugfix: add missing dependencies for vdi_internal_controls 85 # 88 # 86 89 # 4173 2019-08-20 12:04:06Z gronemeier 87 90 # add vdi_internal_controls 88 # 91 # 89 92 # 4168 2019-08-16 13:50:17Z suehring 90 93 # Remove some dependencies on surface_mod that are no longer required without 91 94 # get_topography_top_index functions 92 # 95 # 93 96 # 4167 2019-08-16 11:01:48Z suehring 94 97 # Remove no longer needed dependencies on surface_mod 95 # 98 # 96 99 # 4127 2019-07-30 14:47:10Z suehring 97 # Add dependency of data_output_3d on plant_canopy_model_mod 100 # Add dependency of data_output_3d on plant_canopy_model_mod 98 101 # (merge from branch resler) 99 102 # 100 103 # 4106 2019-07-19 08:54:42Z gronemeier 101 104 # Remove dependency on pmc_interface for boundary_conds 102 # 105 # 103 106 # 4070 2019-07-03 13:51:40Z gronemeier 104 107 # Add new data output modules … … 358 361 modules.o 359 362 advec_ws.o: \ 363 cpulog_mod.o \ 360 364 exchange_horiz_mod.o \ 361 365 mod_kinds.o \ … … 825 829 modules.o \ 826 830 netcdf_data_input_mod.o \ 827 salsa_mod.o 831 salsa_mod.o 828 832 netcdf_data_input_mod.o: \ 829 833 chem_modules.o \ -
palm/trunk/SOURCE/advec_ws.f90
r4457 r4466 20 20 ! Current revisions: 21 21 ! ------------------ 22 ! 23 ! 22 ! 23 ! 24 24 ! Former revisions: 25 25 ! ----------------- 26 26 ! $Id$ 27 ! - vector branch further optimized (linear dependencies along z removed and 28 ! loops are splitted) 29 ! - topography closed channel flow with symmetric boundaries also implemented 30 ! in vector branch 31 ! - some formatting adjustments made and comments added 32 ! - cpu measures for vector branch added 33 ! 34 ! 4457 2020-03-11 14:20:43Z raasch 27 35 ! use statement for exchange horiz added 28 ! 36 ! 29 37 ! 4414 2020-02-19 20:16:04Z suehring 30 38 ! Move call for initialization of control flags to ws_init 31 ! 39 ! 32 40 ! 4360 2020-01-07 11:25:50Z suehring 33 41 ! Introduction of wall_flags_total_0, which currently sets bits based on static 34 42 ! topography information used in wall_flags_static_0 35 ! 43 ! 36 44 ! 4340 2019-12-16 08:17:03Z Giersch 37 ! Topography closed channel flow with symmetric boundaries implemented 38 ! 45 ! Topography closed channel flow with symmetric boundaries implemented 46 ! 39 47 ! 4330 2019-12-10 16:16:33Z knoop 40 48 ! Bugix: removed syntax error introduced by last commit 41 ! 49 ! 42 50 ! 4329 2019-12-10 15:46:36Z motisi 43 51 ! Renamed wall_flags_0 to wall_flags_static_0 44 ! 52 ! 45 53 ! 4328 2019-12-09 18:53:04Z suehring 46 54 ! Minor formatting adjustments 47 ! 55 ! 48 56 ! 4327 2019-12-06 14:48:31Z Giersch 49 57 ! Setting of advection flags for vertical fluxes of w revised, air density for 50 58 ! vertical flux calculation of w at k=1 is considered now 51 ! 59 ! 52 60 ! 4325 2019-12-06 07:14:04Z Giersch 53 ! Vertical fluxes of w are now set to zero at nzt and nzt+1, setting of 61 ! Vertical fluxes of w are now set to zero at nzt and nzt+1, setting of 54 62 ! advection flags for fluxes in z-direction revised, comments extended 55 ! 63 ! 56 64 ! 4324 2019-12-06 07:11:33Z Giersch 57 65 ! Indirect indexing for calculating vertical fluxes close to boundaries is only 58 66 ! used for loop indizes where it is really necessary 59 ! 67 ! 60 68 ! 4317 2019-12-03 12:43:22Z Giersch 61 ! Comments revised/added, formatting improved, fluxes for u,v, and scalars are 69 ! Comments revised/added, formatting improved, fluxes for u,v, and scalars are 62 70 ! explicitly set to zero at nzt+1, fluxes of w-component are now calculated only 63 71 ! until nzt-1 (Prognostic equation for w-velocity component ends at nzt-1) 64 ! 72 ! 65 73 ! 4204 2019-08-30 12:30:17Z knoop 66 74 ! Bugfix: Changed sk_num initialization default to avoid implicit SAVE-Attribut 67 ! 75 ! 68 76 ! 4182 2019-08-22 15:20:23Z scharf 69 77 ! Corrected "Former revisions" section 70 ! 78 ! 71 79 ! 4110 2019-07-22 17:05:21Z suehring 72 80 ! - Separate initialization of advection flags for momentum and scalars. In this 73 ! context, resort the bits and do some minor formatting. 74 ! - Make flag initialization for scalars more flexible, introduce an 75 ! arguemnt list to indicate non-cyclic boundaries (required for decycled 81 ! context, resort the bits and do some minor formatting. 82 ! - Make flag initialization for scalars more flexible, introduce an 83 ! arguemnt list to indicate non-cyclic boundaries (required for decycled 76 84 ! scalars such as chemical species or aerosols) 77 ! - Introduce extended 'degradation zones', where horizontal advection of 78 ! passive scalars is discretized by first-order scheme at all grid points 79 ! that in the vicinity of buildings (<= 3 grid points). Even though no 80 ! building is within the numerical stencil, first-order scheme is used. 85 ! - Introduce extended 'degradation zones', where horizontal advection of 86 ! passive scalars is discretized by first-order scheme at all grid points 87 ! that in the vicinity of buildings (<= 3 grid points). Even though no 88 ! building is within the numerical stencil, first-order scheme is used. 81 89 ! At fourth and fifth grid point the order of the horizontal advection scheme 82 90 ! is successively upgraded. 83 ! These extended degradation zones are used to avoid stationary numerical 91 ! These extended degradation zones are used to avoid stationary numerical 84 92 ! oscillations, which are responsible for high concentration maxima that may 85 ! appear under shear-free stable conditions. 86 ! - Change interface for scalar advection routine. 93 ! appear under shear-free stable conditions. 94 ! - Change interface for scalar advection routine. 87 95 ! - Bugfix, avoid uninitialized value sk_num in vector version of scalar 88 96 ! advection 89 ! 97 ! 90 98 ! 4109 2019-07-22 17:00:34Z suehring 91 ! Implementation of a flux limiter according to Skamarock (2006) for the 92 ! vertical scalar advection. Please note, this is only implemented for the 99 ! Implementation of a flux limiter according to Skamarock (2006) for the 100 ! vertical scalar advection. Please note, this is only implemented for the 93 101 ! cache-optimized version at the moment. Implementation for the vector- 94 ! optimized version will follow after critical issues concerning 102 ! optimized version will follow after critical issues concerning 95 103 ! vectorization are fixed. 96 ! 104 ! 97 105 ! 3873 2019-04-08 15:44:30Z knoop 98 106 ! Moved ocean_mode specific code to ocean_mod 99 ! 107 ! 100 108 ! 3872 2019-04-08 15:03:06Z knoop 101 109 ! Moved all USE statements to module level + removed salsa dependency 102 ! 110 ! 103 111 ! 3871 2019-04-08 14:38:39Z knoop 104 112 ! Moving initialization of bcm specific flux arrays into bulk_cloud_model_mod 105 ! 113 ! 106 114 ! 3864 2019-04-05 09:01:56Z monakurppa 107 115 ! Remove tailing white spaces 108 ! 116 ! 109 117 ! 3696 2019-01-24 16:37:35Z suehring 110 118 ! Bugfix in degradation height 111 ! 119 ! 112 120 ! 3661 2019-01-08 18:22:50Z suehring 113 ! - Minor bugfix in divergence correction (only has implications at 121 ! - Minor bugfix in divergence correction (only has implications at 114 122 ! downward-facing wall surfaces) 115 123 ! - Remove setting of Neumann condition for horizontal velocity variances 116 124 ! - Split loops for tendency calculation and divergence correction in order to 117 125 ! reduce bit queries 118 ! - Introduce new parameter nzb_max_l to better control order degradation at 126 ! - Introduce new parameter nzb_max_l to better control order degradation at 119 127 ! non-cyclic boundaries 120 ! 128 ! 121 129 ! 3655 2019-01-07 16:51:22Z knoop 122 130 ! OpenACC port for SPEC … … 133 141 ! ------------ 134 142 !> Advection scheme for scalars and momentum using the flux formulation of 135 !> Wicker and Skamarock 5th order. Additionally the module contains of a 136 !> routine using for initialisation and steering of the statical evaluation. 143 !> Wicker and Skamarock 5th order. Additionally the module contains of a 144 !> routine using for initialisation and steering of the statical evaluation. 137 145 !> The computation of turbulent fluxes takes place inside the advection 138 146 !> routines. … … 140 148 !> degraded. 141 149 !> A divergence correction is applied. It is necessary for topography, since 142 !> the divergence is not sufficiently reduced, resulting in erroneous fluxes 143 !> and could lead to numerical instabilities. 150 !> the divergence is not sufficiently reduced, resulting in erroneous fluxes 151 !> and could lead to numerical instabilities. 144 152 !> 145 153 !> @todo Implement monotonic flux limiter also for vector version. … … 154 162 u_stokes_zu, v_stokes_zu, & 155 163 diss_l_diss, diss_l_e, diss_l_pt, diss_l_q, & 156 diss_l_s, diss_l_ sa, diss_l_u, diss_l_v, diss_l_w,&164 diss_l_s, diss_l_u, diss_l_v, diss_l_w, & 157 165 flux_l_diss, flux_l_e, flux_l_pt, flux_l_q, flux_l_s, & 158 flux_l_ sa, flux_l_u, flux_l_v, flux_l_w,&166 flux_l_u, flux_l_v, flux_l_w, & 159 167 diss_s_diss, diss_s_e, diss_s_pt, diss_s_q, diss_s_s, & 160 diss_s_ sa, diss_s_u, diss_s_v, diss_s_w,&168 diss_s_u, diss_s_v, diss_s_w, & 161 169 flux_s_diss, flux_s_e, flux_s_pt, flux_s_q, flux_s_s, & 162 flux_s_ sa, flux_s_u, flux_s_v, flux_s_w170 flux_s_u, flux_s_v, flux_s_w 163 171 164 172 USE control_parameters, & 165 ONLY: air_chemistry, & 166 bc_dirichlet_l, & 173 ONLY: bc_dirichlet_l, & 167 174 bc_dirichlet_n, & 168 175 bc_dirichlet_r, & … … 176 183 passive_scalar, & 177 184 rans_tke_e, & 178 momentum_advec, &179 salsa, &180 scalar_advec, &181 185 symmetry_flag, & 182 186 intermediate_timestep_count, & … … 186 190 ws_scheme_sca, & 187 191 dt_3d 192 193 USE cpulog, & 194 ONLY: cpu_log, & 195 log_point_s 188 196 189 197 USE exchange_horiz_mod, & … … 198 206 nxlg, & 199 207 nxlu, & 200 nxr, & 201 nxrg, & 208 nxr, & 209 nxrg, & 202 210 ny, & 203 nyn, & 204 nyng, & 211 nyn, & 212 nyng, & 205 213 nys, & 206 214 nysg, & … … 242 250 INTERFACE ws_init 243 251 MODULE PROCEDURE ws_init 244 END INTERFACE ws_init 245 252 END INTERFACE ws_init 253 246 254 INTERFACE ws_init_flags_momentum 247 255 MODULE PROCEDURE ws_init_flags_momentum 248 256 END INTERFACE ws_init_flags_momentum 249 257 250 258 INTERFACE ws_init_flags_scalar 251 259 MODULE PROCEDURE ws_init_flags_scalar … … 287 295 288 296 ! 289 !-- Set the appropriatefactors for scalar and momentum advection.297 !-- Set factors for scalar and momentum advection. 290 298 adv_sca_5 = 1.0_wp / 60.0_wp 291 299 adv_sca_3 = 1.0_wp / 12.0_wp … … 294 302 adv_mom_3 = 1.0_wp / 24.0_wp 295 303 adv_mom_1 = 1.0_wp / 4.0_wp 296 ! 304 ! 297 305 !-- Arrays needed for statical evaluation of fluxes. 298 306 IF ( ws_scheme_mom ) THEN … … 330 338 331 339 ! 332 !-- Arrays needed for reasons of speed optimization for cache version. 333 !-- For the vector version the buffer arrays are not necessary, 334 !-- because the the fluxes can swapped directly inside the loops of the 335 !-- advection routines. 340 !-- Arrays needed for reasons of speed optimization 341 IF ( ws_scheme_mom ) THEN 342 343 ALLOCATE( flux_s_u(nzb+1:nzt,0:threads_per_task-1), & 344 flux_s_v(nzb+1:nzt,0:threads_per_task-1), & 345 flux_s_w(nzb+1:nzt,0:threads_per_task-1), & 346 diss_s_u(nzb+1:nzt,0:threads_per_task-1), & 347 diss_s_v(nzb+1:nzt,0:threads_per_task-1), & 348 diss_s_w(nzb+1:nzt,0:threads_per_task-1) ) 349 ALLOCATE( flux_l_u(nzb+1:nzt,nys:nyn,0:threads_per_task-1), & 350 flux_l_v(nzb+1:nzt,nys:nyn,0:threads_per_task-1), & 351 flux_l_w(nzb+1:nzt,nys:nyn,0:threads_per_task-1), & 352 diss_l_u(nzb+1:nzt,nys:nyn,0:threads_per_task-1), & 353 diss_l_v(nzb+1:nzt,nys:nyn,0:threads_per_task-1), & 354 diss_l_w(nzb+1:nzt,nys:nyn,0:threads_per_task-1) ) 355 356 ENDIF 357 ! 358 !-- For the vector version the buffer arrays for scalars are not necessary, 359 !-- since internal arrays are used in the vector version. 336 360 IF ( loop_optimization /= 'vector' ) THEN 337 338 IF ( ws_scheme_mom ) THEN339 340 ALLOCATE( flux_s_u(nzb+1:nzt,0:threads_per_task-1), &341 flux_s_v(nzb+1:nzt,0:threads_per_task-1), &342 flux_s_w(nzb+1:nzt,0:threads_per_task-1), &343 diss_s_u(nzb+1:nzt,0:threads_per_task-1), &344 diss_s_v(nzb+1:nzt,0:threads_per_task-1), &345 diss_s_w(nzb+1:nzt,0:threads_per_task-1) )346 ALLOCATE( flux_l_u(nzb+1:nzt,nys:nyn,0:threads_per_task-1), &347 flux_l_v(nzb+1:nzt,nys:nyn,0:threads_per_task-1), &348 flux_l_w(nzb+1:nzt,nys:nyn,0:threads_per_task-1), &349 diss_l_u(nzb+1:nzt,nys:nyn,0:threads_per_task-1), &350 diss_l_v(nzb+1:nzt,nys:nyn,0:threads_per_task-1), &351 diss_l_w(nzb+1:nzt,nys:nyn,0:threads_per_task-1) )352 353 ENDIF354 355 361 IF ( ws_scheme_sca ) THEN 356 362 … … 358 364 flux_s_e(nzb+1:nzt,0:threads_per_task-1), & 359 365 diss_s_pt(nzb+1:nzt,0:threads_per_task-1), & 360 diss_s_e(nzb+1:nzt,0:threads_per_task-1) ) 366 diss_s_e(nzb+1:nzt,0:threads_per_task-1) ) 361 367 ALLOCATE( flux_l_pt(nzb+1:nzt,nys:nyn,0:threads_per_task-1), & 362 368 flux_l_e(nzb+1:nzt,nys:nyn,0:threads_per_task-1), & … … 386 392 387 393 ENDIF 388 389 394 ENDIF 390 395 ! 391 !-- Initialize the flag arrays controlling degradation near walls, i.e. 396 !-- Initialize the flag arrays controlling degradation near walls, i.e. 392 397 !-- to decrease the numerical stencil appropriately. The order of the scheme 393 398 !-- is degraded near solid walls as well as near non-cyclic inflow and outflow … … 412 417 !> Initialization of flags to control the order of the advection scheme near 413 418 !> solid walls and non-cyclic inflow boundaries, where the order is sucessively 414 !> degraded. 419 !> degraded. 415 420 !------------------------------------------------------------------------------! 416 421 SUBROUTINE ws_init_flags_momentum … … 437 442 DO j = nys, nyn 438 443 DO k = nzb+1, nzt 439 ! 440 !-- At first, set flags to WS1. 441 !-- Since fluxes are swapped in advec_ws.f90, this is necessary to 444 ! 445 !-- At first, set flags to WS1. 446 !-- Since fluxes are swapped in advec_ws.f90, this is necessary to 442 447 !-- in order to handle the left/south flux. 443 !-- near vertical walls. 448 !-- near vertical walls. 444 449 advc_flags_m(k,j,i) = IBSET( advc_flags_m(k,j,i), 0 ) 445 450 advc_flags_m(k,j,i) = IBSET( advc_flags_m(k,j,i), 3 ) … … 452 457 ( ( bc_dirichlet_r .OR. bc_radiation_r ) & 453 458 .AND. i == nxr ) ) & 454 THEN 455 advc_flags_m(k,j,i) = IBSET( advc_flags_m(k,j,i), 0 ) 459 THEN 460 advc_flags_m(k,j,i) = IBSET( advc_flags_m(k,j,i), 0 ) 456 461 ELSEIF ( ( .NOT. BTEST(wall_flags_total_0(k,j,i+2),1) .AND. & 457 462 BTEST(wall_flags_total_0(k,j,i+1),1) .OR. & … … 462 467 ( ( bc_dirichlet_l .OR. bc_radiation_l ) & 463 468 .AND. i == nxlu+1) ) & 464 THEN 465 advc_flags_m(k,j,i) = IBSET( advc_flags_m(k,j,i), 1 ) 466 ! 467 !-- Clear flag for WS1 468 advc_flags_m(k,j,i) = IBCLR( advc_flags_m(k,j,i), 0 ) 469 ELSEIF ( BTEST(wall_flags_total_0(k,j,i+1),1) .AND. &470 BTEST(wall_flags_total_0(k,j,i+2),1) .AND. &471 BTEST(wall_flags_total_0(k,j,i-1),1) ) &472 THEN 473 advc_flags_m(k,j,i) = IBSET( advc_flags_m(k,j,i), 2 ) 474 ! 475 !-- Clear flag for WS1 476 advc_flags_m(k,j,i) = IBCLR( advc_flags_m(k,j,i), 0 ) 477 ENDIF 478 ! 479 !-- u component - y-direction 480 !-- WS1 (3), WS3 (4), WS5 (5) 469 THEN 470 advc_flags_m(k,j,i) = IBSET( advc_flags_m(k,j,i), 1 ) 471 ! 472 !-- Clear flag for WS1 473 advc_flags_m(k,j,i) = IBCLR( advc_flags_m(k,j,i), 0 ) 474 ELSEIF ( BTEST(wall_flags_total_0(k,j,i+1),1) .AND. & 475 BTEST(wall_flags_total_0(k,j,i+2),1) .AND. & 476 BTEST(wall_flags_total_0(k,j,i-1),1) ) & 477 THEN 478 advc_flags_m(k,j,i) = IBSET( advc_flags_m(k,j,i), 2 ) 479 ! 480 !-- Clear flag for WS1 481 advc_flags_m(k,j,i) = IBCLR( advc_flags_m(k,j,i), 0 ) 482 ENDIF 483 ! 484 !-- u component - y-direction 485 !-- WS1 (3), WS3 (4), WS5 (5) 481 486 IF ( .NOT. BTEST(wall_flags_total_0(k,j+1,i),1) .OR. & 482 487 ( ( bc_dirichlet_s .OR. bc_radiation_s ) & … … 484 489 ( ( bc_dirichlet_n .OR. bc_radiation_n ) & 485 490 .AND. j == nyn ) ) & 486 THEN 487 advc_flags_m(k,j,i) = IBSET( advc_flags_m(k,j,i), 3 ) 491 THEN 492 advc_flags_m(k,j,i) = IBSET( advc_flags_m(k,j,i), 3 ) 488 493 ELSEIF ( ( .NOT. BTEST(wall_flags_total_0(k,j+2,i),1) .AND. & 489 494 BTEST(wall_flags_total_0(k,j+1,i),1) .OR. & … … 494 499 ( ( bc_dirichlet_n .OR. bc_radiation_n ) & 495 500 .AND. j == nyn-1 ) ) & 496 THEN 497 advc_flags_m(k,j,i) = IBSET( advc_flags_m(k,j,i), 4 ) 498 ! 499 !-- Clear flag for WS1 500 advc_flags_m(k,j,i) = IBCLR( advc_flags_m(k,j,i), 3 ) 501 THEN 502 advc_flags_m(k,j,i) = IBSET( advc_flags_m(k,j,i), 4 ) 503 ! 504 !-- Clear flag for WS1 505 advc_flags_m(k,j,i) = IBCLR( advc_flags_m(k,j,i), 3 ) 501 506 ELSEIF ( BTEST(wall_flags_total_0(k,j+1,i),1) .AND. & 502 507 BTEST(wall_flags_total_0(k,j+2,i),1) .AND. & 503 508 BTEST(wall_flags_total_0(k,j-1,i),1) ) & 504 THEN 505 advc_flags_m(k,j,i) = IBSET( advc_flags_m(k,j,i), 5 ) 506 ! 507 !-- Clear flag for WS1 508 advc_flags_m(k,j,i) = IBCLR( advc_flags_m(k,j,i), 3 ) 509 ENDIF 510 ! 511 !-- u component - z-direction. Fluxes are calculated on w-grid 512 !-- level. Boundary u-values at/within walls aren't used. 513 !-- WS1 (6), WS3 (7), WS5 (8) 514 IF ( k == nzb+1 ) THEN 515 k_mm = nzb 516 ELSE 517 k_mm = k - 2 518 ENDIF 519 IF ( k > nzt-1 ) THEN 520 k_pp = nzt+1 521 ELSE 522 k_pp = k + 2 523 ENDIF 524 IF ( k > nzt-2 ) THEN 525 k_ppp = nzt+1 526 ELSE 527 k_ppp = k + 3 528 ENDIF 529 530 flag_set = .FALSE. 531 IF ( ( .NOT. BTEST(wall_flags_total_0(k-1,j,i),1) .AND. 532 BTEST(wall_flags_total_0(k,j,i),1) .AND. 533 BTEST(wall_flags_total_0(k+1,j,i),1) ) .OR. 534 ( .NOT. BTEST(wall_flags_total_0(k_pp,j,i),1) .AND. &535 BTEST(wall_flags_total_0(k+1,j,i),1) .AND. 536 BTEST(wall_flags_total_0(k,j,i),1) ) .OR. 537 ( k == nzt .AND. symmetry_flag == 0 ) ) 538 THEN 539 advc_flags_m(k,j,i) = IBSET( advc_flags_m(k,j,i), 6 ) 540 flag_set = .TRUE. 541 ELSEIF ( ( .NOT. BTEST(wall_flags_total_0(k_mm,j,i),1) .OR. 542 .NOT. BTEST(wall_flags_total_0(k_ppp,j,i),1) ) .AND. &543 BTEST(wall_flags_total_0(k-1,j,i),1) .AND. 544 BTEST(wall_flags_total_0(k,j,i),1) .AND. 545 BTEST(wall_flags_total_0(k+1,j,i),1) .AND. 546 BTEST(wall_flags_total_0(k_pp,j,i),1) .AND. 547 .NOT. flag_set .OR. &548 ( k == nzt - 1 .AND. symmetry_flag == 0 ) ) 549 THEN 550 advc_flags_m(k,j,i) = IBSET( advc_flags_m(k,j,i), 7 ) 551 flag_set = .TRUE. 552 ELSEIF ( BTEST(wall_flags_total_0(k_mm,j,i),1) .AND. 553 BTEST(wall_flags_total_0(k-1,j,i),1) .AND. 554 BTEST(wall_flags_total_0(k,j,i),1) .AND. 555 BTEST(wall_flags_total_0(k+1,j,i),1) .AND. 556 BTEST(wall_flags_total_0(k_pp,j,i),1) .AND. 557 BTEST(wall_flags_total_0(k_ppp,j,i),1) .AND. 558 .NOT. flag_set ) 509 THEN 510 advc_flags_m(k,j,i) = IBSET( advc_flags_m(k,j,i), 5 ) 511 ! 512 !-- Clear flag for WS1 513 advc_flags_m(k,j,i) = IBCLR( advc_flags_m(k,j,i), 3 ) 514 ENDIF 515 ! 516 !-- u component - z-direction. Fluxes are calculated on w-grid 517 !-- level. Boundary u-values at/within walls aren't used. 518 !-- WS1 (6), WS3 (7), WS5 (8) 519 IF ( k == nzb+1 ) THEN 520 k_mm = nzb 521 ELSE 522 k_mm = k - 2 523 ENDIF 524 IF ( k > nzt-1 ) THEN 525 k_pp = nzt+1 526 ELSE 527 k_pp = k + 2 528 ENDIF 529 IF ( k > nzt-2 ) THEN 530 k_ppp = nzt+1 531 ELSE 532 k_ppp = k + 3 533 ENDIF 534 535 flag_set = .FALSE. 536 IF ( ( .NOT. BTEST(wall_flags_total_0(k-1,j,i),1) .AND. & 537 BTEST(wall_flags_total_0(k,j,i),1) .AND. & 538 BTEST(wall_flags_total_0(k+1,j,i),1) ) .OR. & 539 ( .NOT. BTEST(wall_flags_total_0(k_pp,j,i),1) .AND. & 540 BTEST(wall_flags_total_0(k+1,j,i),1) .AND. & 541 BTEST(wall_flags_total_0(k,j,i),1) ) .OR. & 542 ( k == nzt .AND. symmetry_flag == 0 ) ) & 543 THEN 544 advc_flags_m(k,j,i) = IBSET( advc_flags_m(k,j,i), 6 ) 545 flag_set = .TRUE. 546 ELSEIF ( ( .NOT. BTEST(wall_flags_total_0(k_mm,j,i),1) .OR. & 547 .NOT. BTEST(wall_flags_total_0(k_ppp,j,i),1) ) .AND.& 548 BTEST(wall_flags_total_0(k-1,j,i),1) .AND.& 549 BTEST(wall_flags_total_0(k,j,i),1) .AND.& 550 BTEST(wall_flags_total_0(k+1,j,i),1) .AND.& 551 BTEST(wall_flags_total_0(k_pp,j,i),1) .AND.& 552 .NOT. flag_set .OR.& 553 ( k == nzt - 1 .AND. symmetry_flag == 0 ) ) & 554 THEN 555 advc_flags_m(k,j,i) = IBSET( advc_flags_m(k,j,i), 7 ) 556 flag_set = .TRUE. 557 ELSEIF ( BTEST(wall_flags_total_0(k_mm,j,i),1) .AND.& 558 BTEST(wall_flags_total_0(k-1,j,i),1) .AND.& 559 BTEST(wall_flags_total_0(k,j,i),1) .AND.& 560 BTEST(wall_flags_total_0(k+1,j,i),1) .AND.& 561 BTEST(wall_flags_total_0(k_pp,j,i),1) .AND.& 562 BTEST(wall_flags_total_0(k_ppp,j,i),1) .AND.& 563 .NOT. flag_set ) & 559 564 THEN 560 565 advc_flags_m(k,j,i) = IBSET( advc_flags_m(k,j,i), 8 ) … … 570 575 DO k = nzb+1, nzt 571 576 ! 572 !-- At first, set flags to WS1. 573 !-- Since fluxes are swapped in advec_ws.f90, this is necessary to 577 !-- At first, set flags to WS1. 578 !-- Since fluxes are swapped in advec_ws.f90, this is necessary to 574 579 !-- in order to handle the left/south flux. 575 580 advc_flags_m(k,j,i) = IBSET( advc_flags_m(k,j,i), 9 ) … … 583 588 ( ( bc_dirichlet_r .OR. bc_radiation_r ) & 584 589 .AND. i == nxr ) ) & 585 THEN 586 advc_flags_m(k,j,i) = IBSET( advc_flags_m(k,j,i), 9 ) 587 ! 588 !-- WS3 590 THEN 591 advc_flags_m(k,j,i) = IBSET( advc_flags_m(k,j,i), 9 ) 592 ! 593 !-- WS3 589 594 ELSEIF ( ( .NOT. BTEST(wall_flags_total_0(k,j,i+2),2) .AND. & 590 595 BTEST(wall_flags_total_0(k,j,i+1),2) ) .OR. & … … 595 600 ( ( bc_dirichlet_l .OR. bc_radiation_l ) & 596 601 .AND. i == nxlu ) ) & 597 THEN 598 advc_flags_m(k,j,i) = IBSET( advc_flags_m(k,j,i), 10 ) 599 ! 600 !-- Clear flag for WS1 601 advc_flags_m(k,j,i) = IBCLR( advc_flags_m(k,j,i), 9 ) 602 THEN 603 advc_flags_m(k,j,i) = IBSET( advc_flags_m(k,j,i), 10 ) 604 ! 605 !-- Clear flag for WS1 606 advc_flags_m(k,j,i) = IBCLR( advc_flags_m(k,j,i), 9 ) 602 607 ELSEIF ( BTEST(wall_flags_total_0(k,j,i+1),2) .AND. & 603 608 BTEST(wall_flags_total_0(k,j,i+2),2) .AND. & 604 609 BTEST(wall_flags_total_0(k,j,i-1),2) ) & 605 THEN 606 advc_flags_m(k,j,i) = IBSET( advc_flags_m(k,j,i), 11 ) 607 ! 608 !-- Clear flag for WS1 609 advc_flags_m(k,j,i) = IBCLR( advc_flags_m(k,j,i), 9 ) 610 ENDIF 611 ! 612 !-- v component - y-direction 613 !-- WS1 (12), WS3 (13), WS5 (14) 610 THEN 611 advc_flags_m(k,j,i) = IBSET( advc_flags_m(k,j,i), 11 ) 612 ! 613 !-- Clear flag for WS1 614 advc_flags_m(k,j,i) = IBCLR( advc_flags_m(k,j,i), 9 ) 615 ENDIF 616 ! 617 !-- v component - y-direction 618 !-- WS1 (12), WS3 (13), WS5 (14) 614 619 IF ( .NOT. BTEST(wall_flags_total_0(k,j+1,i),2) .OR. & 615 620 ( ( bc_dirichlet_s .OR. bc_radiation_s ) & … … 617 622 ( ( bc_dirichlet_n .OR. bc_radiation_n ) & 618 623 .AND. j == nyn ) ) & 619 THEN 620 advc_flags_m(k,j,i) = IBSET( advc_flags_m(k,j,i), 12 ) 624 THEN 625 advc_flags_m(k,j,i) = IBSET( advc_flags_m(k,j,i), 12 ) 621 626 ELSEIF ( ( .NOT. BTEST(wall_flags_total_0(k,j+2,i),2) .AND. & 622 627 BTEST(wall_flags_total_0(k,j+1,i),2) .OR. & … … 627 632 ( ( bc_dirichlet_n .OR. bc_radiation_n ) & 628 633 .AND. j == nyn-1 ) ) & 629 THEN 630 advc_flags_m(k,j,i) = IBSET( advc_flags_m(k,j,i), 13 ) 631 ! 632 !-- Clear flag for WS1 633 advc_flags_m(k,j,i) = IBCLR( advc_flags_m(k,j,i), 12 ) 634 THEN 635 advc_flags_m(k,j,i) = IBSET( advc_flags_m(k,j,i), 13 ) 636 ! 637 !-- Clear flag for WS1 638 advc_flags_m(k,j,i) = IBCLR( advc_flags_m(k,j,i), 12 ) 634 639 ELSEIF ( BTEST(wall_flags_total_0(k,j+1,i),2) .AND. & 635 640 BTEST(wall_flags_total_0(k,j+2,i),2) .AND. & 636 BTEST(wall_flags_total_0(k,j-1,i),2) ) & 637 THEN 641 BTEST(wall_flags_total_0(k,j-1,i),2) ) & 642 THEN 638 643 advc_flags_m(k,j,i) = IBSET( advc_flags_m(k,j,i), 14 ) 639 644 ! … … 641 646 advc_flags_m(k,j,i) = IBCLR( advc_flags_m(k,j,i), 12 ) 642 647 ENDIF 643 ! 644 !-- v component - z-direction. Fluxes are calculated on w-grid 645 !-- level. Boundary v-values at/within walls aren't used. 648 ! 649 !-- v component - z-direction. Fluxes are calculated on w-grid 650 !-- level. Boundary v-values at/within walls aren't used. 646 651 !-- WS1 (15), WS3 (16), WS5 (17) 647 652 IF ( k == nzb+1 ) THEN 648 653 k_mm = nzb 649 ELSE 654 ELSE 650 655 k_mm = k - 2 651 656 ENDIF 652 657 IF ( k > nzt-1 ) THEN 653 658 k_pp = nzt+1 654 ELSE 659 ELSE 655 660 k_pp = k + 2 656 661 ENDIF 657 662 IF ( k > nzt-2 ) THEN 658 663 k_ppp = nzt+1 659 ELSE 664 ELSE 660 665 k_ppp = k + 3 661 ENDIF 662 666 ENDIF 667 663 668 flag_set = .FALSE. 664 IF ( ( .NOT. BTEST(wall_flags_total_0(k-1,j,i),2) .AND.&665 BTEST(wall_flags_total_0(k,j,i),2) .AND.&666 BTEST(wall_flags_total_0(k+1,j,i),2) ) .OR.&667 ( .NOT. BTEST(wall_flags_total_0(k_pp,j,i),2) .AND. &668 BTEST(wall_flags_total_0(k+1,j,i),2) .AND.&669 BTEST(wall_flags_total_0(k,j,i),2) ) .OR.&670 ( k == nzt .AND. symmetry_flag == 0 ) ) 671 THEN 672 advc_flags_m(k,j,i) = IBSET( advc_flags_m(k,j,i), 15 ) 673 flag_set = .TRUE. 674 ELSEIF ( ( .NOT. BTEST(wall_flags_total_0(k_mm,j,i),2) .OR. 675 .NOT. BTEST(wall_flags_total_0(k_ppp,j,i),2) ) .AND. &676 BTEST(wall_flags_total_0(k-1,j,i),2) .AND. 677 BTEST(wall_flags_total_0(k,j,i),2) .AND. 678 BTEST(wall_flags_total_0(k+1,j,i),2) .AND. 679 BTEST(wall_flags_total_0(k_pp,j,i),2) .AND. 680 .NOT. flag_set .OR. &681 ( k == nzt - 1 .AND. symmetry_flag == 0 ) ) 682 THEN 683 advc_flags_m(k,j,i) = IBSET( advc_flags_m(k,j,i), 16 ) 684 flag_set = .TRUE. 685 ELSEIF ( BTEST(wall_flags_total_0(k_mm,j,i),2) .AND.&686 BTEST(wall_flags_total_0(k-1,j,i),2) .AND.&687 BTEST(wall_flags_total_0(k,j,i),2) .AND.&688 BTEST(wall_flags_total_0(k+1,j,i),2) .AND.&689 BTEST(wall_flags_total_0(k_pp,j,i),2) .AND.&690 BTEST(wall_flags_total_0(k_ppp,j,i),2) .AND.&691 .NOT. flag_set ) 669 IF ( ( .NOT. BTEST(wall_flags_total_0(k-1,j,i),2) .AND.& 670 BTEST(wall_flags_total_0(k,j,i),2) .AND.& 671 BTEST(wall_flags_total_0(k+1,j,i),2) ) .OR. & 672 ( .NOT. BTEST(wall_flags_total_0(k_pp,j,i),2) .AND.& 673 BTEST(wall_flags_total_0(k+1,j,i),2) .AND.& 674 BTEST(wall_flags_total_0(k,j,i),2) ) .OR. & 675 ( k == nzt .AND. symmetry_flag == 0 ) ) & 676 THEN 677 advc_flags_m(k,j,i) = IBSET( advc_flags_m(k,j,i), 15 ) 678 flag_set = .TRUE. 679 ELSEIF ( ( .NOT. BTEST(wall_flags_total_0(k_mm,j,i),2) .OR. & 680 .NOT. BTEST(wall_flags_total_0(k_ppp,j,i),2) ) .AND.& 681 BTEST(wall_flags_total_0(k-1,j,i),2) .AND.& 682 BTEST(wall_flags_total_0(k,j,i),2) .AND.& 683 BTEST(wall_flags_total_0(k+1,j,i),2) .AND.& 684 BTEST(wall_flags_total_0(k_pp,j,i),2) .AND.& 685 .NOT. flag_set .OR.& 686 ( k == nzt - 1 .AND. symmetry_flag == 0 ) ) & 687 THEN 688 advc_flags_m(k,j,i) = IBSET( advc_flags_m(k,j,i), 16 ) 689 flag_set = .TRUE. 690 ELSEIF ( BTEST(wall_flags_total_0(k_mm,j,i),2) .AND.& 691 BTEST(wall_flags_total_0(k-1,j,i),2) .AND.& 692 BTEST(wall_flags_total_0(k,j,i),2) .AND.& 693 BTEST(wall_flags_total_0(k+1,j,i),2) .AND.& 694 BTEST(wall_flags_total_0(k_pp,j,i),2) .AND.& 695 BTEST(wall_flags_total_0(k_ppp,j,i),2) .AND.& 696 .NOT. flag_set ) & 692 697 THEN 693 698 advc_flags_m(k,j,i) = IBSET( advc_flags_m(k,j,i), 17 ) … … 703 708 DO k = nzb+1, nzt 704 709 ! 705 !-- At first, set flags to WS1. 706 !-- Since fluxes are swapped in advec_ws.f90, this is necessary to 710 !-- At first, set flags to WS1. 711 !-- Since fluxes are swapped in advec_ws.f90, this is necessary to 707 712 !-- in order to handle the left/south flux. 708 713 advc_flags_m(k,j,i) = IBSET( advc_flags_m(k,j,i), 18 ) … … 716 721 ( ( bc_dirichlet_r .OR. bc_radiation_r ) & 717 722 .AND. i == nxr ) ) & 718 THEN 719 advc_flags_m(k,j,i) = IBSET( advc_flags_m(k,j,i), 18 ) 723 THEN 724 advc_flags_m(k,j,i) = IBSET( advc_flags_m(k,j,i), 18 ) 720 725 ELSEIF ( ( .NOT. BTEST(wall_flags_total_0(k,j,i+2),3) .AND. & 721 726 BTEST(wall_flags_total_0(k,j,i+1),3) .OR. & … … 726 731 ( ( bc_dirichlet_l .OR. bc_radiation_l ) & 727 732 .AND. i == nxlu ) ) & 728 THEN 729 advc_flags_m(k,j,i) = IBSET( advc_flags_m(k,j,i), 19 ) 730 ! 731 !-- Clear flag for WS1 732 advc_flags_m(k,j,i) = IBCLR( advc_flags_m(k,j,i), 18 ) 733 THEN 734 advc_flags_m(k,j,i) = IBSET( advc_flags_m(k,j,i), 19 ) 735 ! 736 !-- Clear flag for WS1 737 advc_flags_m(k,j,i) = IBCLR( advc_flags_m(k,j,i), 18 ) 733 738 ELSEIF ( BTEST(wall_flags_total_0(k,j,i+1),3) .AND. & 734 739 BTEST(wall_flags_total_0(k,j,i+2),3) .AND. & 735 740 BTEST(wall_flags_total_0(k,j,i-1),3) ) & 736 THEN 737 advc_flags_m(k,j,i) = IBSET( advc_flags_m(k,j,i),20 ) 738 ! 739 !-- Clear flag for WS1 740 advc_flags_m(k,j,i) = IBCLR( advc_flags_m(k,j,i), 18 ) 741 ENDIF 742 ! 743 !-- w component - y-direction 744 !-- WS1 (21), WS3 (22), WS5 (23) 741 THEN 742 advc_flags_m(k,j,i) = IBSET( advc_flags_m(k,j,i),20 ) 743 ! 744 !-- Clear flag for WS1 745 advc_flags_m(k,j,i) = IBCLR( advc_flags_m(k,j,i), 18 ) 746 ENDIF 747 ! 748 !-- w component - y-direction 749 !-- WS1 (21), WS3 (22), WS5 (23) 745 750 IF ( .NOT. BTEST(wall_flags_total_0(k,j+1,i),3) .OR. & 746 751 ( ( bc_dirichlet_s .OR. bc_radiation_s ) & … … 748 753 ( ( bc_dirichlet_n .OR. bc_radiation_n ) & 749 754 .AND. j == nyn ) ) & 750 THEN 751 advc_flags_m(k,j,i) = IBSET( advc_flags_m(k,j,i), 21 ) 755 THEN 756 advc_flags_m(k,j,i) = IBSET( advc_flags_m(k,j,i), 21 ) 752 757 ELSEIF ( ( .NOT. BTEST(wall_flags_total_0(k,j+2,i),3) .AND. & 753 758 BTEST(wall_flags_total_0(k,j+1,i),3) .OR. & … … 758 763 ( ( bc_dirichlet_n .OR. bc_radiation_n ) & 759 764 .AND. j == nyn-1 ) ) & 760 THEN 761 advc_flags_m(k,j,i) = IBSET( advc_flags_m(k,j,i), 22 ) 762 ! 763 !-- Clear flag for WS1 764 advc_flags_m(k,j,i) = IBCLR( advc_flags_m(k,j,i), 21 ) 765 THEN 766 advc_flags_m(k,j,i) = IBSET( advc_flags_m(k,j,i), 22 ) 767 ! 768 !-- Clear flag for WS1 769 advc_flags_m(k,j,i) = IBCLR( advc_flags_m(k,j,i), 21 ) 765 770 ELSEIF ( BTEST(wall_flags_total_0(k,j+1,i),3) .AND. & 766 771 BTEST(wall_flags_total_0(k,j+2,i),3) .AND. & 767 772 BTEST(wall_flags_total_0(k,j-1,i),3) ) & 768 THEN 773 THEN 769 774 advc_flags_m(k,j,i) = IBSET( advc_flags_m(k,j,i), 23 ) 770 775 ! … … 772 777 advc_flags_m(k,j,i) = IBCLR( advc_flags_m(k,j,i), 21 ) 773 778 ENDIF 774 ! 779 ! 775 780 !-- w component - z-direction. Fluxes are calculated on scalar grid 776 !-- level. Boundary w-values at walls are used. Flux at k=i is 777 !-- defined at scalar position k=i+1 with i being an integer. 781 !-- level. Boundary w-values at walls are used. Flux at k=i is 782 !-- defined at scalar position k=i+1 with i being an integer. 778 783 !-- WS1 (24), WS3 (25), WS5 (26) 779 784 IF ( k == nzb+1 ) THEN … … 784 789 IF ( k > nzt-1 ) THEN 785 790 k_pp = nzt+1 786 ELSE 791 ELSE 787 792 k_pp = k + 2 788 793 ENDIF 789 794 IF ( k > nzt-2 ) THEN 790 795 k_ppp = nzt+1 791 ELSE 796 ELSE 792 797 k_ppp = k + 3 793 ENDIF 794 795 flag_set = .FALSE. 796 IF ( ( .NOT. BTEST(wall_flags_total_0(k,j,i),3) .AND. 797 BTEST(wall_flags_total_0(k+1,j,i),3) ) .OR. 798 ( .NOT. BTEST(wall_flags_total_0(k+1,j,i),3) .AND. 799 BTEST(wall_flags_total_0(k,j,i),3) ) .OR. &800 k == nzt -1 ) 798 ENDIF 799 800 flag_set = .FALSE. 801 IF ( ( .NOT. BTEST(wall_flags_total_0(k,j,i),3) .AND. & 802 BTEST(wall_flags_total_0(k+1,j,i),3) ) .OR. & 803 ( .NOT. BTEST(wall_flags_total_0(k+1,j,i),3) .AND. & 804 BTEST(wall_flags_total_0(k,j,i),3) ) .OR. & 805 k == nzt -1 ) & 801 806 THEN 802 807 ! 803 808 !-- Please note, at k == nzb_w_inner(j,i) a flag is explicitly 804 !-- set, although this is not a prognostic level. However, 809 !-- set, although this is not a prognostic level. However, 805 810 !-- contrary to the advection of u,v and s this is necessary 806 811 !-- because flux_t(nzb_w_inner(j,i)) is used for the tendency … … 808 813 advc_flags_m(k,j,i) = IBSET( advc_flags_m(k,j,i), 24 ) 809 814 flag_set = .TRUE. 810 ELSEIF ( ( .NOT. BTEST(wall_flags_total_0(k-1,j,i),3) .AND. 811 BTEST(wall_flags_total_0(k,j,i),3) .AND. 812 BTEST(wall_flags_total_0(k+1,j,i),3) .AND. 813 BTEST(wall_flags_total_0(k_pp,j,i),3) ) .OR. 814 ( .NOT. BTEST(wall_flags_total_0(k_pp,j,i),3) .AND. 815 BTEST(wall_flags_total_0(k+1,j,i),3) .AND. 816 BTEST(wall_flags_total_0(k,j,i),3) .AND. 817 BTEST(wall_flags_total_0(k-1,j,i),3) ) .AND. 818 .NOT. flag_set .OR. &819 k == nzt - 2 ) 820 THEN 821 advc_flags_m(k,j,i) = IBSET( advc_flags_m(k,j,i), 25 ) 822 flag_set = .TRUE. 823 ELSEIF ( BTEST(wall_flags_total_0(k-1,j,i),3) .AND. 824 BTEST(wall_flags_total_0(k,j,i),3) .AND. 825 BTEST(wall_flags_total_0(k+1,j,i),3) .AND. 826 BTEST(wall_flags_total_0(k_pp,j,i),3) .AND. 827 .NOT. flag_set ) 828 THEN 815 ELSEIF ( ( .NOT. BTEST(wall_flags_total_0(k-1,j,i),3) .AND. & 816 BTEST(wall_flags_total_0(k,j,i),3) .AND. & 817 BTEST(wall_flags_total_0(k+1,j,i),3) .AND. & 818 BTEST(wall_flags_total_0(k_pp,j,i),3) ) .OR. & 819 ( .NOT. BTEST(wall_flags_total_0(k_pp,j,i),3) .AND. & 820 BTEST(wall_flags_total_0(k+1,j,i),3) .AND. & 821 BTEST(wall_flags_total_0(k,j,i),3) .AND. & 822 BTEST(wall_flags_total_0(k-1,j,i),3) ) .AND. & 823 .NOT. flag_set .OR. & 824 k == nzt - 2 ) & 825 THEN 826 advc_flags_m(k,j,i) = IBSET( advc_flags_m(k,j,i), 25 ) 827 flag_set = .TRUE. 828 ELSEIF ( BTEST(wall_flags_total_0(k-1,j,i),3) .AND. & 829 BTEST(wall_flags_total_0(k,j,i),3) .AND. & 830 BTEST(wall_flags_total_0(k+1,j,i),3) .AND. & 831 BTEST(wall_flags_total_0(k_pp,j,i),3) .AND. & 832 .NOT. flag_set ) & 833 THEN 829 834 advc_flags_m(k,j,i) = IBSET( advc_flags_m(k,j,i), 26 ) 830 835 ENDIF … … 837 842 CALL exchange_horiz_int( advc_flags_m, nys, nyn, nxl, nxr, nzt, nbgp ) 838 843 ! 839 !-- Set boundary flags at inflow and outflow boundary in case of 844 !-- Set boundary flags at inflow and outflow boundary in case of 840 845 !-- non-cyclic boundary conditions. 841 846 IF ( bc_dirichlet_l .OR. bc_radiation_l ) THEN … … 844 849 845 850 IF ( bc_dirichlet_r .OR. bc_radiation_r ) THEN 846 advc_flags_m(:,:,nxr+1) = advc_flags_m(:,:,nxr)851 advc_flags_m(:,:,nxr+1) = advc_flags_m(:,:,nxr) 847 852 ENDIF 848 853 … … 863 868 !> Initialization of flags to control the order of the advection scheme near 864 869 !> solid walls and non-cyclic inflow boundaries, where the order is sucessively 865 !> degraded. 870 !> degraded. 866 871 !------------------------------------------------------------------------------! 867 872 SUBROUTINE ws_init_flags_scalar( non_cyclic_l, non_cyclic_n, non_cyclic_r, & … … 885 890 LOGICAL :: non_cyclic_s !< flag that indicates non-cyclic boundary on the south 886 891 887 LOGICAL, OPTIONAL :: extensive_degrad !< flag indicating that extensive degradation is required, e.g. for 892 LOGICAL, OPTIONAL :: extensive_degrad !< flag indicating that extensive degradation is required, e.g. for 888 893 !< passive scalars nearby topography along the horizontal directions, 889 !< as no monotonic limiter can be applied there 894 !< as no monotonic limiter can be applied there 890 895 ! 891 896 !-- Set flags to steer the degradation of the advection scheme in advec_ws … … 900 905 !-- scalar - x-direction 901 906 !-- WS1 (0), WS3 (1), WS5 (2) 902 IF ( ( .NOT. BTEST(wall_flags_total_0(k,j,i+1),0) .OR. & 903 .NOT. BTEST(wall_flags_total_0(k,j,i+2),0) .OR. & 904 .NOT. BTEST(wall_flags_total_0(k,j,i-1),0) ) .OR. & 905 ( non_cyclic_l .AND. i == 0 ) .OR. & 906 ( non_cyclic_r .AND. i == nx ) ) THEN 907 advc_flag(k,j,i) = IBSET( advc_flag(k,j,i), 0 ) 908 ELSEIF ( ( .NOT. BTEST(wall_flags_total_0(k,j,i+3),0) .AND. & 909 BTEST(wall_flags_total_0(k,j,i+1),0) .AND. & 910 BTEST(wall_flags_total_0(k,j,i+2),0) .AND. & 911 BTEST(wall_flags_total_0(k,j,i-1),0) & 912 ) .OR. & 913 ( .NOT. BTEST(wall_flags_total_0(k,j,i-2),0) .AND. & 914 BTEST(wall_flags_total_0(k,j,i+1),0) .AND. & 915 BTEST(wall_flags_total_0(k,j,i+2),0) .AND. & 916 BTEST(wall_flags_total_0(k,j,i-1),0) & 917 ) & 918 .OR. & 919 ( non_cyclic_r .AND. i == nx-1 ) .OR. & 920 ( non_cyclic_l .AND. i == 1 ) ) THEN 921 advc_flag(k,j,i) = IBSET( advc_flag(k,j,i), 1 ) 922 ELSEIF ( BTEST(wall_flags_total_0(k,j,i+1),0) .AND. & 923 BTEST(wall_flags_total_0(k,j,i+2),0) .AND. & 924 BTEST(wall_flags_total_0(k,j,i+3),0) .AND. & 925 BTEST(wall_flags_total_0(k,j,i-1),0) .AND. & 926 BTEST(wall_flags_total_0(k,j,i-2),0) ) & 927 THEN 928 advc_flag(k,j,i) = IBSET( advc_flag(k,j,i), 2 ) 929 ENDIF 930 ! 931 !-- scalar - y-direction 932 !-- WS1 (3), WS3 (4), WS5 (5) 933 IF ( ( .NOT. BTEST(wall_flags_total_0(k,j+1,i),0) .OR. & 934 .NOT. BTEST(wall_flags_total_0(k,j+2,i),0) .OR. & 935 .NOT. BTEST(wall_flags_total_0(k,j-1,i),0)) .OR. & 936 ( non_cyclic_s .AND. j == 0 ) .OR. & 937 ( non_cyclic_n .AND. j == ny ) ) THEN 938 advc_flag(k,j,i) = IBSET( advc_flag(k,j,i), 3 ) 939 ! 940 !-- WS3 941 ELSEIF ( ( .NOT. BTEST(wall_flags_total_0(k,j+3,i),0) .AND. & 942 BTEST(wall_flags_total_0(k,j+1,i),0) .AND. & 943 BTEST(wall_flags_total_0(k,j+2,i),0) .AND. & 944 BTEST(wall_flags_total_0(k,j-1,i),0) & 945 ) .OR. & 946 ( .NOT. BTEST(wall_flags_total_0(k,j-2,i),0) .AND. & 947 BTEST(wall_flags_total_0(k,j+1,i),0) .AND. & 948 BTEST(wall_flags_total_0(k,j+2,i),0) .AND. & 949 BTEST(wall_flags_total_0(k,j-1,i),0) & 950 ) & 951 .OR. & 952 ( non_cyclic_s .AND. j == 1 ) .OR. & 953 ( non_cyclic_n .AND. j == ny-1 ) ) THEN 954 advc_flag(k,j,i) = IBSET( advc_flag(k,j,i), 4 ) 955 ! 956 !-- WS5 957 ELSEIF ( BTEST(wall_flags_total_0(k,j+1,i),0) .AND. & 958 BTEST(wall_flags_total_0(k,j+2,i),0) .AND. & 959 BTEST(wall_flags_total_0(k,j+3,i),0) .AND. & 960 BTEST(wall_flags_total_0(k,j-1,i),0) .AND. & 961 BTEST(wall_flags_total_0(k,j-2,i),0) ) & 962 THEN 963 advc_flag(k,j,i) = IBSET( advc_flag(k,j,i), 5 ) 907 IF ( ( .NOT. BTEST(wall_flags_total_0(k,j,i+1),0) .OR. & 908 .NOT. BTEST(wall_flags_total_0(k,j,i+2),0) .OR. & 909 .NOT. BTEST(wall_flags_total_0(k,j,i-1),0) ) .OR. & 910 ( non_cyclic_l .AND. i == 0 ) .OR. & 911 ( non_cyclic_r .AND. i == nx ) ) THEN 912 advc_flag(k,j,i) = IBSET( advc_flag(k,j,i), 0 ) 913 ELSEIF ( ( .NOT. BTEST(wall_flags_total_0(k,j,i+3),0) .AND. & 914 BTEST(wall_flags_total_0(k,j,i+1),0) .AND. & 915 BTEST(wall_flags_total_0(k,j,i+2),0) .AND. & 916 BTEST(wall_flags_total_0(k,j,i-1),0) & 917 ) .OR. & 918 ( .NOT. BTEST(wall_flags_total_0(k,j,i-2),0) .AND. & 919 BTEST(wall_flags_total_0(k,j,i+1),0) .AND. & 920 BTEST(wall_flags_total_0(k,j,i+2),0) .AND. & 921 BTEST(wall_flags_total_0(k,j,i-1),0) & 922 ) & 923 .OR. & 924 ( non_cyclic_r .AND. i == nx-1 ) .OR. & 925 ( non_cyclic_l .AND. i == 1 ) ) THEN 926 advc_flag(k,j,i) = IBSET( advc_flag(k,j,i), 1 ) 927 ELSEIF ( BTEST(wall_flags_total_0(k,j,i+1),0) .AND. & 928 BTEST(wall_flags_total_0(k,j,i+2),0) .AND. & 929 BTEST(wall_flags_total_0(k,j,i+3),0) .AND. & 930 BTEST(wall_flags_total_0(k,j,i-1),0) .AND. & 931 BTEST(wall_flags_total_0(k,j,i-2),0) ) & 932 THEN 933 advc_flag(k,j,i) = IBSET( advc_flag(k,j,i), 2 ) 964 934 ENDIF 965 935 ! 966 !-- Near topography, set horizontal advection scheme to 1st order 967 !-- for passive scalars, even if only one direction may be 936 !-- scalar - y-direction 937 !-- WS1 (3), WS3 (4), WS5 (5) 938 IF ( ( .NOT. BTEST(wall_flags_total_0(k,j+1,i),0) .OR. & 939 .NOT. BTEST(wall_flags_total_0(k,j+2,i),0) .OR. & 940 .NOT. BTEST(wall_flags_total_0(k,j-1,i),0)) .OR. & 941 ( non_cyclic_s .AND. j == 0 ) .OR. & 942 ( non_cyclic_n .AND. j == ny ) ) THEN 943 advc_flag(k,j,i) = IBSET( advc_flag(k,j,i), 3 ) 944 ! 945 !-- WS3 946 ELSEIF ( ( .NOT. BTEST(wall_flags_total_0(k,j+3,i),0) .AND. & 947 BTEST(wall_flags_total_0(k,j+1,i),0) .AND. & 948 BTEST(wall_flags_total_0(k,j+2,i),0) .AND. & 949 BTEST(wall_flags_total_0(k,j-1,i),0) & 950 ) .OR. & 951 ( .NOT. BTEST(wall_flags_total_0(k,j-2,i),0) .AND. & 952 BTEST(wall_flags_total_0(k,j+1,i),0) .AND. & 953 BTEST(wall_flags_total_0(k,j+2,i),0) .AND. & 954 BTEST(wall_flags_total_0(k,j-1,i),0) & 955 ) & 956 .OR. & 957 ( non_cyclic_s .AND. j == 1 ) .OR. & 958 ( non_cyclic_n .AND. j == ny-1 ) ) THEN 959 advc_flag(k,j,i) = IBSET( advc_flag(k,j,i), 4 ) 960 ! 961 !-- WS5 962 ELSEIF ( BTEST(wall_flags_total_0(k,j+1,i),0) .AND. & 963 BTEST(wall_flags_total_0(k,j+2,i),0) .AND. & 964 BTEST(wall_flags_total_0(k,j+3,i),0) .AND. & 965 BTEST(wall_flags_total_0(k,j-1,i),0) .AND. & 966 BTEST(wall_flags_total_0(k,j-2,i),0) ) & 967 THEN 968 advc_flag(k,j,i) = IBSET( advc_flag(k,j,i), 5 ) 969 ENDIF 970 ! 971 !-- Near topography, set horizontal advection scheme to 1st order 972 !-- for passive scalars, even if only one direction may be 968 973 !-- blocked by topography. These locations will be identified 969 !-- by wall_flags_total_0 bit 31. Note, since several modules define 970 !-- advection flags but may apply different scalar boundary 971 !-- conditions, bit 31 is temporarily stored on advc_flags. 972 !-- Moreover, note that this extended degradtion for passive 973 !-- scalars is not required for the vertical direction as there 974 !-- the monotonic limiter can be applied. 974 !-- by wall_flags_total_0 bit 31. Note, since several modules define 975 !-- advection flags but may apply different scalar boundary 976 !-- conditions, bit 31 is temporarily stored on advc_flags. 977 !-- Moreover, note that this extended degradtion for passive 978 !-- scalars is not required for the vertical direction as there 979 !-- the monotonic limiter can be applied. 975 980 IF ( PRESENT( extensive_degrad ) ) THEN 976 981 IF ( extensive_degrad ) THEN … … 980 985 IF( BTEST( advc_flag(k,j,i), 31 ) ) THEN 981 986 ! 982 !-- Clear flags that might indicate higher-order 987 !-- Clear flags that might indicate higher-order 983 988 !-- advection along x- and y-direction. 984 989 advc_flag(k,j,i) = IBCLR( advc_flag(k,j,i), 1 ) … … 990 995 !-- x- and y-direction. 991 996 advc_flag(k,j,i) = IBSET( advc_flag(k,j,i), 0 ) 992 advc_flag(k,j,i) = IBSET( advc_flag(k,j,i), 3 ) 997 advc_flag(k,j,i) = IBSET( advc_flag(k,j,i), 3 ) 993 998 ENDIF 994 999 ! 995 1000 !-- Adjacent to this extended degradation zone, successively 996 !-- upgrade the order of the scheme if this grid point isn't 997 !-- flagged with bit 31 (indicating extended degradation 998 !-- zone). 1001 !-- upgrade the order of the scheme if this grid point isn't 1002 !-- flagged with bit 31 (indicating extended degradation 1003 !-- zone). 999 1004 IF ( .NOT. BTEST( advc_flag(k,j,i), 31 ) ) THEN 1000 1005 ! 1001 1006 !-- x-direction. First, clear all previous settings, than 1002 1007 !-- set flag for 3rd-order scheme. 1003 IF ( BTEST( advc_flag(k,j,i-1), 31 ) .AND. &1008 IF ( BTEST( advc_flag(k,j,i-1), 31 ) .AND. & 1004 1009 BTEST( advc_flag(k,j,i+1), 31 ) ) THEN 1005 1010 advc_flag(k,j,i) = IBCLR( advc_flag(k,j,i), 0 ) 1006 1011 advc_flag(k,j,i) = IBCLR( advc_flag(k,j,i), 1 ) 1007 1012 advc_flag(k,j,i) = IBCLR( advc_flag(k,j,i), 2 ) 1008 1013 1009 1014 advc_flag(k,j,i) = IBSET( advc_flag(k,j,i), 1 ) 1010 1015 ENDIF … … 1012 1017 !-- x-direction. First, clear all previous settings, than 1013 1018 !-- set flag for 5rd-order scheme. 1014 IF ( .NOT. BTEST( advc_flag(k,j,i-1), 31 ) .AND. &1015 BTEST( advc_flag(k,j,i-2), 31 ) .AND. &1016 .NOT. BTEST( advc_flag(k,j,i+1), 31 ) .AND. &1019 IF ( .NOT. BTEST( advc_flag(k,j,i-1), 31 ) .AND. & 1020 BTEST( advc_flag(k,j,i-2), 31 ) .AND. & 1021 .NOT. BTEST( advc_flag(k,j,i+1), 31 ) .AND. & 1017 1022 BTEST( advc_flag(k,j,i+2), 31 ) ) THEN 1018 1023 advc_flag(k,j,i) = IBCLR( advc_flag(k,j,i), 0 ) 1019 1024 advc_flag(k,j,i) = IBCLR( advc_flag(k,j,i), 1 ) 1020 1025 advc_flag(k,j,i) = IBCLR( advc_flag(k,j,i), 2 ) 1021 1026 1022 1027 advc_flag(k,j,i) = IBSET( advc_flag(k,j,i), 2 ) 1023 1028 ENDIF … … 1025 1030 !-- y-direction. First, clear all previous settings, than 1026 1031 !-- set flag for 3rd-order scheme. 1027 IF ( BTEST( advc_flag(k,j-1,i), 31 ) .AND. &1032 IF ( BTEST( advc_flag(k,j-1,i), 31 ) .AND. & 1028 1033 BTEST( advc_flag(k,j+1,i), 31 ) ) THEN 1029 1034 advc_flag(k,j,i) = IBCLR( advc_flag(k,j,i), 3 ) 1030 1035 advc_flag(k,j,i) = IBCLR( advc_flag(k,j,i), 4 ) 1031 1036 advc_flag(k,j,i) = IBCLR( advc_flag(k,j,i), 5 ) 1032 1037 1033 1038 advc_flag(k,j,i) = IBSET( advc_flag(k,j,i), 4 ) 1034 1039 ENDIF … … 1036 1041 !-- y-direction. First, clear all previous settings, than 1037 1042 !-- set flag for 5rd-order scheme. 1038 IF ( .NOT. BTEST( advc_flag(k,j-1,i), 31 ) .AND. &1039 BTEST( advc_flag(k,j-2,i), 31 ) .AND. &1040 .NOT. BTEST( advc_flag(k,j+1,i), 31 ) .AND. &1043 IF ( .NOT. BTEST( advc_flag(k,j-1,i), 31 ) .AND. & 1044 BTEST( advc_flag(k,j-2,i), 31 ) .AND. & 1045 .NOT. BTEST( advc_flag(k,j+1,i), 31 ) .AND. & 1041 1046 BTEST( advc_flag(k,j+2,i), 31 ) ) THEN 1042 1047 advc_flag(k,j,i) = IBCLR( advc_flag(k,j,i), 3 ) 1043 1048 advc_flag(k,j,i) = IBCLR( advc_flag(k,j,i), 4 ) 1044 1049 advc_flag(k,j,i) = IBCLR( advc_flag(k,j,i), 5 ) 1045 1050 1046 1051 advc_flag(k,j,i) = IBSET( advc_flag(k,j,i), 5 ) 1047 1052 ENDIF 1048 1053 ENDIF 1049 1054 1050 1055 ENDIF 1051 1056 1052 1057 ! 1053 1058 !-- Near lateral boundary flags might be overwritten. Set 1054 !-- them again. 1059 !-- them again. 1055 1060 !-- x-direction 1056 IF ( ( non_cyclic_l .AND. i == 0 ) .OR. &1061 IF ( ( non_cyclic_l .AND. i == 0 ) .OR. & 1057 1062 ( non_cyclic_r .AND. i == nx ) ) THEN 1058 1063 advc_flag(k,j,i) = IBCLR( advc_flag(k,j,i), 0 ) 1059 1064 advc_flag(k,j,i) = IBCLR( advc_flag(k,j,i), 1 ) 1060 1065 advc_flag(k,j,i) = IBCLR( advc_flag(k,j,i), 2 ) 1061 1066 1062 1067 advc_flag(k,j,i) = IBSET( advc_flag(k,j,i), 0 ) 1063 1068 ENDIF 1064 1065 IF ( ( non_cyclic_l .AND. i == 1 ) .OR. &1069 1070 IF ( ( non_cyclic_l .AND. i == 1 ) .OR. & 1066 1071 ( non_cyclic_r .AND. i == nx-1 ) ) THEN 1067 1072 advc_flag(k,j,i) = IBCLR( advc_flag(k,j,i), 0 ) 1068 1073 advc_flag(k,j,i) = IBCLR( advc_flag(k,j,i), 1 ) 1069 1074 advc_flag(k,j,i) = IBCLR( advc_flag(k,j,i), 2 ) 1070 1075 1071 1076 advc_flag(k,j,i) = IBSET( advc_flag(k,j,i), 1 ) 1072 1077 ENDIF 1073 1078 ! 1074 1079 !-- y-direction 1075 IF ( ( non_cyclic_n .AND. j == 0 ) .OR. &1080 IF ( ( non_cyclic_n .AND. j == 0 ) .OR. & 1076 1081 ( non_cyclic_s .AND. j == ny ) ) THEN 1077 1082 advc_flag(k,j,i) = IBCLR( advc_flag(k,j,i), 3 ) 1078 1083 advc_flag(k,j,i) = IBCLR( advc_flag(k,j,i), 4 ) 1079 1084 advc_flag(k,j,i) = IBCLR( advc_flag(k,j,i), 5 ) 1080 1085 1081 1086 advc_flag(k,j,i) = IBSET( advc_flag(k,j,i), 3 ) 1082 1087 ENDIF 1083 1084 IF ( ( non_cyclic_n .AND. j == 1 ) .OR. &1088 1089 IF ( ( non_cyclic_n .AND. j == 1 ) .OR. & 1085 1090 ( non_cyclic_s .AND. j == ny-1 ) ) THEN 1086 1091 advc_flag(k,j,i) = IBCLR( advc_flag(k,j,i), 3 ) 1087 1092 advc_flag(k,j,i) = IBCLR( advc_flag(k,j,i), 4 ) 1088 1093 advc_flag(k,j,i) = IBCLR( advc_flag(k,j,i), 5 ) 1089 1094 1090 1095 advc_flag(k,j,i) = IBSET( advc_flag(k,j,i), 4 ) 1091 1096 ENDIF 1092 1097 1093 1098 ENDIF 1094 1095 1096 ! 1097 !-- scalar - z-direction. Fluxes are calculated on w-grid 1098 !-- level. Boundary values at/within walls aren't used. 1099 !-- WS1 (6), WS3 (7), WS5 (8) 1100 IF ( k == nzb+1 ) THEN 1101 k_mm = nzb 1102 ELSE 1103 k_mm = k - 2 1104 ENDIF 1105 IF ( k > nzt-1 ) THEN 1106 k_pp = nzt+1 1107 ELSE 1108 k_pp = k + 2 1109 ENDIF 1110 IF ( k > nzt-2 ) THEN 1111 k_ppp = nzt+1 1112 ELSE 1113 k_ppp = k + 3 1114 ENDIF 1115 1116 flag_set = .FALSE. 1117 IF ( ( .NOT. BTEST(wall_flags_total_0(k-1,j,i),0) 1118 BTEST(wall_flags_total_0(k,j,i),0) 1119 BTEST(wall_flags_total_0(k+1,j,i),0) ) 1120 ( .NOT. BTEST(wall_flags_total_0(k_pp,j,i),0) .AND. &1121 BTEST(wall_flags_total_0(k+1,j,i),0) 1122 BTEST(wall_flags_total_0(k,j,i),0) ) 1123 ( k == nzt .AND. symmetry_flag == 0 ) ) 1124 THEN 1125 advc_flag(k,j,i) = IBSET( advc_flag(k,j,i), 6 ) 1126 flag_set = .TRUE. 1127 ELSEIF ( ( .NOT. BTEST(wall_flags_total_0(k_mm,j,i),0) .OR. 1128 .NOT. BTEST(wall_flags_total_0(k_ppp,j,i),0) ) .AND. &1129 BTEST(wall_flags_total_0(k-1,j,i),0) .AND. 1130 BTEST(wall_flags_total_0(k,j,i),0) .AND. 1131 BTEST(wall_flags_total_0(k+1,j,i),0) .AND. 1132 BTEST(wall_flags_total_0(k_pp,j,i),0) .AND. 1133 .NOT. flag_set .OR. &1134 ( k == nzt - 1 .AND. symmetry_flag == 0 ) ) 1135 THEN 1136 advc_flag(k,j,i) = IBSET( advc_flag(k,j,i), 7 ) 1137 flag_set = .TRUE. 1138 ELSEIF ( BTEST(wall_flags_total_0(k_mm,j,i),0) 1139 BTEST(wall_flags_total_0(k-1,j,i),0) 1140 BTEST(wall_flags_total_0(k,j,i),0) 1141 BTEST(wall_flags_total_0(k+1,j,i),0) 1142 BTEST(wall_flags_total_0(k_pp,j,i),0) 1143 BTEST(wall_flags_total_0(k_ppp,j,i),0) 1144 .NOT. flag_set ) 1099 1100 1101 ! 1102 !-- scalar - z-direction. Fluxes are calculated on w-grid 1103 !-- level. Boundary values at/within walls aren't used. 1104 !-- WS1 (6), WS3 (7), WS5 (8) 1105 IF ( k == nzb+1 ) THEN 1106 k_mm = nzb 1107 ELSE 1108 k_mm = k - 2 1109 ENDIF 1110 IF ( k > nzt-1 ) THEN 1111 k_pp = nzt+1 1112 ELSE 1113 k_pp = k + 2 1114 ENDIF 1115 IF ( k > nzt-2 ) THEN 1116 k_ppp = nzt+1 1117 ELSE 1118 k_ppp = k + 3 1119 ENDIF 1120 1121 flag_set = .FALSE. 1122 IF ( ( .NOT. BTEST(wall_flags_total_0(k-1,j,i),0) .AND. & 1123 BTEST(wall_flags_total_0(k,j,i),0) .AND. & 1124 BTEST(wall_flags_total_0(k+1,j,i),0) ) .OR. & 1125 ( .NOT. BTEST(wall_flags_total_0(k_pp,j,i),0) .AND. & 1126 BTEST(wall_flags_total_0(k+1,j,i),0) .AND. & 1127 BTEST(wall_flags_total_0(k,j,i),0) ) .OR. & 1128 ( k == nzt .AND. symmetry_flag == 0 ) ) & 1129 THEN 1130 advc_flag(k,j,i) = IBSET( advc_flag(k,j,i), 6 ) 1131 flag_set = .TRUE. 1132 ELSEIF ( ( .NOT. BTEST(wall_flags_total_0(k_mm,j,i),0) .OR. & 1133 .NOT. BTEST(wall_flags_total_0(k_ppp,j,i),0) ) .AND.& 1134 BTEST(wall_flags_total_0(k-1,j,i),0) .AND.& 1135 BTEST(wall_flags_total_0(k,j,i),0) .AND.& 1136 BTEST(wall_flags_total_0(k+1,j,i),0) .AND.& 1137 BTEST(wall_flags_total_0(k_pp,j,i),0) .AND.& 1138 .NOT. flag_set .OR.& 1139 ( k == nzt - 1 .AND. symmetry_flag == 0 ) ) & 1140 THEN 1141 advc_flag(k,j,i) = IBSET( advc_flag(k,j,i), 7 ) 1142 flag_set = .TRUE. 1143 ELSEIF ( BTEST(wall_flags_total_0(k_mm,j,i),0) .AND. & 1144 BTEST(wall_flags_total_0(k-1,j,i),0) .AND. & 1145 BTEST(wall_flags_total_0(k,j,i),0) .AND. & 1146 BTEST(wall_flags_total_0(k+1,j,i),0) .AND. & 1147 BTEST(wall_flags_total_0(k_pp,j,i),0) .AND. & 1148 BTEST(wall_flags_total_0(k_ppp,j,i),0) .AND. & 1149 .NOT. flag_set ) & 1145 1150 THEN 1146 1151 advc_flag(k,j,i) = IBSET( advc_flag(k,j,i), 8 ) … … 1156 1161 CALL exchange_horiz_int( advc_flag, nys, nyn, nxl, nxr, nzt, nbgp ) 1157 1162 ! 1158 !-- Set boundary flags at inflow and outflow boundary in case of 1163 !-- Set boundary flags at inflow and outflow boundary in case of 1159 1164 !-- non-cyclic boundary conditions. 1160 1165 IF ( non_cyclic_l ) THEN … … 1173 1178 advc_flag(:,nys-1,:) = advc_flag(:,nys,:) 1174 1179 ENDIF 1175 1176 1177 1178 END SUBROUTINE ws_init_flags_scalar 1179 1180 1181 1182 1183 END SUBROUTINE ws_init_flags_scalar 1184 1180 1185 !------------------------------------------------------------------------------! 1181 1186 ! Description: … … 1187 1192 1188 1193 ! 1189 !-- The arrays needed for statistical evaluation are set to to 0 at the 1194 !-- The arrays needed for statistical evaluation are set to to 0 at the 1190 1195 !-- beginning of prognostic_equations. 1191 1196 IF ( ws_scheme_mom ) THEN … … 1225 1230 1226 1231 1227 CHARACTER (LEN = *), INTENT(IN) :: sk_char !< string identifier, used for assign fluxes to the correct dimension in the analysis array 1228 1232 CHARACTER (LEN = *), INTENT(IN) :: sk_char !< string identifier, used for assign fluxes to the 1233 !<correct dimension in the analysis array 1234 1229 1235 INTEGER(iwp) :: i !< grid index along x-direction 1230 1236 INTEGER(iwp) :: i_omp !< leftmost index on subdomain, or in case of OpenMP, on thread … … 1235 1241 INTEGER(iwp) :: k_pp !< k+2 index in disretization, can be modified to avoid segmentation faults 1236 1242 INTEGER(iwp) :: k_ppp !< k+3 index in disretization, can be modified to avoid segmentation faults 1237 INTEGER(iwp) :: nzb_max_l !< index indicating upper bound for order degradation of horizontal advection terms 1243 INTEGER(iwp) :: nzb_max_l !< index indicating upper bound for order degradation of horizontal advection terms 1238 1244 INTEGER(iwp) :: tn !< number of OpenMP thread 1239 1245 1240 1246 INTEGER(iwp), INTENT(IN), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg) :: & 1241 1247 advc_flag !< flag array to control order of scalar advection … … 1244 1250 LOGICAL :: non_cyclic_n !< flag that indicates non-cyclic boundary on the north 1245 1251 LOGICAL :: non_cyclic_r !< flag that indicates non-cyclic boundary on the right 1246 LOGICAL :: non_cyclic_s !< flag that indicates non-cyclic boundary on the south 1252 LOGICAL :: non_cyclic_s !< flag that indicates non-cyclic boundary on the south 1247 1253 LOGICAL, OPTIONAL :: flux_limitation !< flag indicating flux limitation of the vertical advection 1248 1254 LOGICAL :: limiter !< control flag indicating the application of flux limitation … … 1251 1257 REAL(wp) :: div !< velocity diverence on scalar grid 1252 1258 REAL(wp) :: div_in !< vertical flux divergence of ingoing fluxes 1253 REAL(wp) :: div_out !< vertical flux divergence of outgoing fluxes 1259 REAL(wp) :: div_out !< vertical flux divergence of outgoing fluxes 1254 1260 REAL(wp) :: f_corr_t !< correction flux at grid-cell top, i.e. the difference between high and low-order flux 1255 1261 REAL(wp) :: f_corr_d !< correction flux at grid-cell bottom, i.e. the difference between high and low-order flux … … 1272 1278 REAL(wp) :: min_val !< maximum value of the quanitity along the numerical stencil (in vertical direction) 1273 1279 REAL(wp) :: mon !< monotone solution of the advection equation using 1st-order fluxes 1274 REAL(wp) :: u_comp !< advection velocity along x-direction 1275 REAL(wp) :: v_comp !< advection velocity along y-direction 1276 ! 1277 !-- sk is an array from parameter list. It should not be a pointer, because 1278 !-- in that case the compiler can not assume a stride 1 and cannot perform 1279 !-- a strided one vector load. Adding the CONTIGUOUS keyword makes things 1280 !-- even worse, because the compiler cannot assume strided one in the 1280 REAL(wp) :: u_comp !< advection velocity along x-direction 1281 REAL(wp) :: v_comp !< advection velocity along y-direction 1282 ! 1283 !-- sk is an array from parameter list. It should not be a pointer, because 1284 !-- in that case the compiler can not assume a stride 1 and cannot perform 1285 !-- a strided one vector load. Adding the CONTIGUOUS keyword makes things 1286 !-- even worse, because the compiler cannot assume strided one in the 1281 1287 !-- caller side. 1282 1288 REAL(wp), INTENT(IN),DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg) :: sk !< advected scalar 1283 1289 1284 REAL(wp), DIMENSION(nzb:nzt+1) :: diss_n !< discretized artificial dissipation at northward-side of the grid box 1285 REAL(wp), DIMENSION(nzb:nzt+1) :: diss_r !< discretized artificial dissipation at rightward-side of the grid box 1286 REAL(wp), DIMENSION(nzb:nzt+1) :: diss_t !< discretized artificial dissipation at top of the grid box 1287 REAL(wp), DIMENSION(nzb:nzt+1) :: flux_n !< discretized 6th-order flux at northward-side of the grid box 1288 REAL(wp), DIMENSION(nzb:nzt+1) :: flux_r !< discretized 6th-order flux at rightward-side of the grid box 1289 REAL(wp), DIMENSION(nzb:nzt+1) :: flux_t !< discretized 6th-order flux at top of the grid box 1290 REAL(wp), DIMENSION(nzb:nzt+1) :: flux_t_1st !< discretized 1st-order flux at top of the grid box 1291 1292 REAL(wp), DIMENSION(nzb+1:nzt,0:threads_per_task-1) :: swap_diss_y_local !< discretized artificial dissipation at southward-side of the grid box 1293 REAL(wp), DIMENSION(nzb+1:nzt,0:threads_per_task-1) :: swap_flux_y_local !< discretized 6th-order flux at northward-side of the grid box 1294 1295 REAL(wp), DIMENSION(nzb+1:nzt,nys:nyn,0:threads_per_task-1) :: swap_diss_x_local !< discretized artificial dissipation at leftward-side of the grid box 1296 REAL(wp), DIMENSION(nzb+1:nzt,nys:nyn,0:threads_per_task-1) :: swap_flux_x_local !< discretized 6th-order flux at leftward-side of the grid box 1297 ! 1298 !-- Used local modified copy of nzb_max (used to degrade order of 1290 REAL(wp), DIMENSION(nzb:nzt+1) :: diss_n !< discretized artificial dissipation at northward-side 1291 REAL(wp), DIMENSION(nzb:nzt+1) :: diss_r !< discretized artificial dissipation at rightward-side 1292 REAL(wp), DIMENSION(nzb:nzt+1) :: diss_t !< discretized artificial dissipation at top 1293 REAL(wp), DIMENSION(nzb:nzt+1) :: flux_n !< discretized 6th-order flux at northward-side 1294 REAL(wp), DIMENSION(nzb:nzt+1) :: flux_r !< discretized 6th-order flux at rightward-side 1295 REAL(wp), DIMENSION(nzb:nzt+1) :: flux_t !< discretized 6th-order flux at top 1296 REAL(wp), DIMENSION(nzb:nzt+1) :: flux_t_1st !< discretized 1st-order flux at top 1297 1298 REAL(wp), DIMENSION(nzb+1:nzt,0:threads_per_task-1) :: swap_diss_y_local !< discretized artificial dissipation at southward-side 1299 REAL(wp), DIMENSION(nzb+1:nzt,0:threads_per_task-1) :: swap_flux_y_local !< discretized 6th-order flux at northward-side 1300 REAL(wp), DIMENSION(nzb+1:nzt,nys:nyn,0:threads_per_task-1) :: swap_diss_x_local !< discretized artificial dissipation at leftward-side 1301 REAL(wp), DIMENSION(nzb+1:nzt,nys:nyn,0:threads_per_task-1) :: swap_flux_x_local !< discretized 6th-order flux at leftward-side 1302 ! 1303 !-- Used local modified copy of nzb_max (used to degrade order of 1299 1304 !-- discretization) at non-cyclic boundaries. Modify only at relevant points 1300 !-- instead of the entire subdomain. This should lead to better 1305 !-- instead of the entire subdomain. This should lead to better 1301 1306 !-- load balance between boundary and non-boundary PEs. 1302 1307 IF( non_cyclic_l .AND. i <= nxl + 2 .OR. & … … 1309 1314 END IF 1310 1315 ! 1311 !-- Set control flag for flux limiter 1316 !-- Set control flag for flux limiter 1312 1317 limiter = .FALSE. 1313 1318 IF ( PRESENT( flux_limitation) ) limiter = flux_limitation … … 1324 1329 1325 1330 v_comp = v(k,j,i) - v_gtrans + v_stokes_zu(k) 1326 swap_flux_y_local(k,tn) = v_comp * ( &1327 ( 37.0_wp * ibit5 * adv_sca_5 &1328 + 7.0_wp * ibit4 * adv_sca_3 &1329 + ibit3 * adv_sca_1 &1330 ) * &1331 ( sk(k,j,i) + sk(k,j-1,i) ) &1332 - ( 8.0_wp * ibit5 * adv_sca_5 &1333 + ibit4 * adv_sca_3 &1334 ) * &1335 ( sk(k,j+1,i) + sk(k,j-2,i) ) &1336 + ( ibit5 * adv_sca_5 &1337 ) * &1338 ( sk(k,j+2,i) + sk(k,j-3,i) ) &1331 swap_flux_y_local(k,tn) = v_comp * ( & 1332 ( 37.0_wp * ibit5 * adv_sca_5 & 1333 + 7.0_wp * ibit4 * adv_sca_3 & 1334 + ibit3 * adv_sca_1 & 1335 ) * & 1336 ( sk(k,j,i) + sk(k,j-1,i) ) & 1337 - ( 8.0_wp * ibit5 * adv_sca_5 & 1338 + ibit4 * adv_sca_3 & 1339 ) * & 1340 ( sk(k,j+1,i) + sk(k,j-2,i) ) & 1341 + ( ibit5 * adv_sca_5 & 1342 ) * & 1343 ( sk(k,j+2,i) + sk(k,j-3,i) ) & 1339 1344 ) 1340 1345 1341 swap_diss_y_local(k,tn) = -ABS( v_comp ) * ( &1342 ( 10.0_wp * ibit5 * adv_sca_5 &1343 + 3.0_wp * ibit4 * adv_sca_3 &1344 + ibit3 * adv_sca_1 &1345 ) * &1346 ( sk(k,j,i) - sk(k,j-1,i) ) &1347 - ( 5.0_wp * ibit5 * adv_sca_5 &1348 + ibit4 * adv_sca_3 &1349 ) * &1350 ( sk(k,j+1,i) - sk(k,j-2,i) ) &1351 + ( ibit5 * adv_sca_5 &1352 ) * &1353 ( sk(k,j+2,i) - sk(k,j-3,i) ) &1346 swap_diss_y_local(k,tn) = -ABS( v_comp ) * ( & 1347 ( 10.0_wp * ibit5 * adv_sca_5 & 1348 + 3.0_wp * ibit4 * adv_sca_3 & 1349 + ibit3 * adv_sca_1 & 1350 ) * & 1351 ( sk(k,j,i) - sk(k,j-1,i) ) & 1352 - ( 5.0_wp * ibit5 * adv_sca_5 & 1353 + ibit4 * adv_sca_3 & 1354 ) * & 1355 ( sk(k,j+1,i) - sk(k,j-2,i) ) & 1356 + ( ibit5 * adv_sca_5 & 1357 ) * & 1358 ( sk(k,j+2,i) - sk(k,j-3,i) ) & 1354 1359 ) 1355 1360 … … 1360 1365 1361 1366 v_comp = v(k,j,i) - v_gtrans + v_stokes_zu(k) 1362 swap_flux_y_local(k,tn) = v_comp * ( &1363 37.0_wp * ( sk(k,j,i) + sk(k,j-1,i) ) &1364 - 8.0_wp * ( sk(k,j+1,i) + sk(k,j-2,i) ) &1365 + ( sk(k,j+2,i) + sk(k,j-3,i) ) &1367 swap_flux_y_local(k,tn) = v_comp * ( & 1368 37.0_wp * ( sk(k,j,i) + sk(k,j-1,i) ) & 1369 - 8.0_wp * ( sk(k,j+1,i) + sk(k,j-2,i) ) & 1370 + ( sk(k,j+2,i) + sk(k,j-3,i) ) & 1366 1371 ) * adv_sca_5 1367 swap_diss_y_local(k,tn) = -ABS( v_comp ) * ( &1368 10.0_wp * ( sk(k,j,i) - sk(k,j-1,i) ) &1369 - 5.0_wp * ( sk(k,j+1,i) - sk(k,j-2,i) ) &1370 + sk(k,j+2,i) - sk(k,j-3,i) &1372 swap_diss_y_local(k,tn) = -ABS( v_comp ) * ( & 1373 10.0_wp * ( sk(k,j,i) - sk(k,j-1,i) ) & 1374 - 5.0_wp * ( sk(k,j+1,i) - sk(k,j-2,i) ) & 1375 + sk(k,j+2,i) - sk(k,j-3,i) & 1371 1376 ) * adv_sca_5 1372 1377 … … 1377 1382 !-- Compute leftside fluxes of the respective PE bounds. 1378 1383 IF ( i == i_omp ) THEN 1379 1384 1380 1385 DO k = nzb+1, nzb_max_l 1381 1386 … … 1384 1389 ibit0 = REAL( IBITS(advc_flag(k,j,i-1),0,1), KIND = wp ) 1385 1390 1386 u_comp 1387 swap_flux_x_local(k,j,tn) = u_comp * ( &1388 ( 37.0_wp * ibit2 * adv_sca_5 &1389 + 7.0_wp * ibit1 * adv_sca_3 &1390 + ibit0 * adv_sca_1 &1391 ) * &1392 ( sk(k,j,i) + sk(k,j,i-1) ) &1393 - ( 8.0_wp * ibit2 * adv_sca_5 &1394 + ibit1 * adv_sca_3 &1395 ) * &1396 ( sk(k,j,i+1) + sk(k,j,i-2) ) &1397 + ( ibit2 * adv_sca_5 &1398 ) * &1399 ( sk(k,j,i+2) + sk(k,j,i-3) ) &1391 u_comp = u(k,j,i) - u_gtrans + u_stokes_zu(k) 1392 swap_flux_x_local(k,j,tn) = u_comp * ( & 1393 ( 37.0_wp * ibit2 * adv_sca_5 & 1394 + 7.0_wp * ibit1 * adv_sca_3 & 1395 + ibit0 * adv_sca_1 & 1396 ) * & 1397 ( sk(k,j,i) + sk(k,j,i-1) ) & 1398 - ( 8.0_wp * ibit2 * adv_sca_5 & 1399 + ibit1 * adv_sca_3 & 1400 ) * & 1401 ( sk(k,j,i+1) + sk(k,j,i-2) ) & 1402 + ( ibit2 * adv_sca_5 & 1403 ) * & 1404 ( sk(k,j,i+2) + sk(k,j,i-3) ) & 1400 1405 ) 1401 1406 1402 swap_diss_x_local(k,j,tn) = -ABS( u_comp ) * ( &1403 ( 10.0_wp * ibit2 * adv_sca_5 &1404 + 3.0_wp * ibit1 * adv_sca_3 &1405 + ibit0 * adv_sca_1 &1406 ) * &1407 ( sk(k,j,i) - sk(k,j,i-1) ) &1408 - ( 5.0_wp * ibit2 * adv_sca_5 &1409 + ibit1 * adv_sca_3 &1410 ) * &1411 ( sk(k,j,i+1) - sk(k,j,i-2) ) &1412 + ( ibit2 * adv_sca_5 &1413 ) * &1414 ( sk(k,j,i+2) - sk(k,j,i-3) ) &1407 swap_diss_x_local(k,j,tn) = -ABS( u_comp ) * ( & 1408 ( 10.0_wp * ibit2 * adv_sca_5 & 1409 + 3.0_wp * ibit1 * adv_sca_3 & 1410 + ibit0 * adv_sca_1 & 1411 ) * & 1412 ( sk(k,j,i) - sk(k,j,i-1) ) & 1413 - ( 5.0_wp * ibit2 * adv_sca_5 & 1414 + ibit1 * adv_sca_3 & 1415 ) * & 1416 ( sk(k,j,i+1) - sk(k,j,i-2) ) & 1417 + ( ibit2 * adv_sca_5 & 1418 ) * & 1419 ( sk(k,j,i+2) - sk(k,j,i-3) ) & 1415 1420 ) 1416 1421 … … 1419 1424 DO k = nzb_max_l+1, nzt 1420 1425 1421 u_comp = u(k,j,i) - u_gtrans + u_stokes_zu(k)1422 swap_flux_x_local(k,j,tn) = u_comp * ( &1423 37.0_wp * ( sk(k,j,i) + sk(k,j,i-1) ) &1424 - 8.0_wp * ( sk(k,j,i+1) + sk(k,j,i-2) ) &1425 + ( sk(k,j,i+2) + sk(k,j,i-3) ) &1426 u_comp = u(k,j,i) - u_gtrans + u_stokes_zu(k) 1427 swap_flux_x_local(k,j,tn) = u_comp * ( & 1428 37.0_wp * ( sk(k,j,i) + sk(k,j,i-1) ) & 1429 - 8.0_wp * ( sk(k,j,i+1) + sk(k,j,i-2) ) & 1430 + ( sk(k,j,i+2) + sk(k,j,i-3) ) & 1426 1431 ) * adv_sca_5 1427 1432 1428 swap_diss_x_local(k,j,tn) = -ABS( u_comp ) * ( &1429 10.0_wp * ( sk(k,j,i) - sk(k,j,i-1) ) &1430 - 5.0_wp * ( sk(k,j,i+1) - sk(k,j,i-2) ) &1431 + ( sk(k,j,i+2) - sk(k,j,i-3) ) &1433 swap_diss_x_local(k,j,tn) = -ABS( u_comp ) * ( & 1434 10.0_wp * ( sk(k,j,i) - sk(k,j,i-1) ) & 1435 - 5.0_wp * ( sk(k,j,i+1) - sk(k,j,i-2) ) & 1436 + ( sk(k,j,i+2) - sk(k,j,i-3) ) & 1432 1437 ) * adv_sca_5 1433 1438 1434 1439 ENDDO 1435 1440 1436 1441 ENDIF 1437 ! 1438 !-- Now compute the fluxes and tendency terms for the horizontal and1439 !-- vertical parts up to the top of the highesttopography.1442 ! 1443 !-- Now compute the fluxes for the horizontal termns up to the highest 1444 !-- topography. 1440 1445 DO k = nzb+1, nzb_max_l 1441 !1442 !-- Note: It is faster to conduct all multiplications explicitly, e.g.1443 !-- * adv_sca_5 ... than to determine a factor and multiplicate the1444 !-- flux at the end.1445 1446 1446 1447 ibit2 = REAL( IBITS(advc_flag(k,j,i),2,1), KIND = wp ) … … 1449 1450 1450 1451 u_comp = u(k,j,i+1) - u_gtrans + u_stokes_zu(k) 1451 flux_r(k) = u_comp * ( &1452 ( 37.0_wp * ibit2 * adv_sca_5 &1453 + 7.0_wp * ibit1 * adv_sca_3 &1454 + ibit0 * adv_sca_1 &1455 ) * &1456 ( sk(k,j,i+1) + sk(k,j,i) ) &1457 - ( 8.0_wp * ibit2 * adv_sca_5 &1458 + ibit1 * adv_sca_3 &1459 ) * &1460 ( sk(k,j,i+2) + sk(k,j,i-1) ) &1461 + ( ibit2 * adv_sca_5 &1462 ) * &1463 ( sk(k,j,i+3) + sk(k,j,i-2) ) &1452 flux_r(k) = u_comp * ( & 1453 ( 37.0_wp * ibit2 * adv_sca_5 & 1454 + 7.0_wp * ibit1 * adv_sca_3 & 1455 + ibit0 * adv_sca_1 & 1456 ) * & 1457 ( sk(k,j,i+1) + sk(k,j,i) ) & 1458 - ( 8.0_wp * ibit2 * adv_sca_5 & 1459 + ibit1 * adv_sca_3 & 1460 ) * & 1461 ( sk(k,j,i+2) + sk(k,j,i-1) ) & 1462 + ( ibit2 * adv_sca_5 & 1463 ) * & 1464 ( sk(k,j,i+3) + sk(k,j,i-2) ) & 1464 1465 ) 1465 1466 1466 diss_r(k) = -ABS( u_comp ) * ( &1467 ( 10.0_wp * ibit2 * adv_sca_5 &1468 + 3.0_wp * ibit1 * adv_sca_3 &1469 + ibit0 * adv_sca_1 &1470 ) * &1471 ( sk(k,j,i+1) - sk(k,j,i) ) &1472 - ( 5.0_wp * ibit2 * adv_sca_5 &1473 + ibit1 * adv_sca_3 &1474 ) * &1475 ( sk(k,j,i+2) - sk(k,j,i-1) ) &1476 + ( ibit2 * adv_sca_5 &1477 ) * &1478 ( sk(k,j,i+3) - sk(k,j,i-2) ) &1467 diss_r(k) = -ABS( u_comp ) * ( & 1468 ( 10.0_wp * ibit2 * adv_sca_5 & 1469 + 3.0_wp * ibit1 * adv_sca_3 & 1470 + ibit0 * adv_sca_1 & 1471 ) * & 1472 ( sk(k,j,i+1) - sk(k,j,i) ) & 1473 - ( 5.0_wp * ibit2 * adv_sca_5 & 1474 + ibit1 * adv_sca_3 & 1475 ) * & 1476 ( sk(k,j,i+2) - sk(k,j,i-1) ) & 1477 + ( ibit2 * adv_sca_5 & 1478 ) * & 1479 ( sk(k,j,i+3) - sk(k,j,i-2) ) & 1479 1480 ) 1480 1481 … … 1515 1516 ENDDO 1516 1517 ! 1517 !-- Now compute the fluxes and tendency terms for the horizontal and1518 !-- vertical parts above the top of the highest topography. No degradation1519 !-- for the horizontal parts, but for the vertical it is stell needed.1518 !-- Now compute the fluxes for the horizontal terms above the topography 1519 !-- where no degradation along the horizontal parts is necessary (except 1520 !-- for the non-cyclic lateral boundaries treated by nzb_max_l). 1520 1521 DO k = nzb_max_l+1, nzt 1521 1522 … … 1542 1543 ENDDO 1543 1544 ! 1544 !-- Now, compute vertical fluxes. Split loop into a part treating the 1545 !-- Now, compute vertical fluxes. Split loop into a part treating the 1545 1546 !-- lowest grid points with indirect indexing, a main loop without 1546 1547 !-- indirect indexing, and a loop for the uppermost grip points with 1547 1548 !-- indirect indexing. This allows better vectorization for the main loop. 1548 !-- First, compute the flux at model surface, which need has to be 1549 !-- First, compute the flux at model surface, which need has to be 1549 1550 !-- calculated explicetely for the tendency at 1550 1551 !-- the first w-level. For topography wall this is done implicitely by … … 1552 1553 flux_t(nzb) = 0.0_wp 1553 1554 diss_t(nzb) = 0.0_wp 1554 1555 1555 1556 DO k = nzb+1, nzb+1 1556 1557 ibit8 = REAL( IBITS(advc_flag(k,j,i),8,1), KIND = wp ) … … 1563 1564 k_pp = k + 2 * ( 1 - ibit6 ) 1564 1565 k_mm = k - 2 * ibit8 1565 1566 1567 flux_t(k) = w(k,j,i) * rho_air_zw(k) * ( &1568 ( 37.0_wp * ibit8 * adv_sca_5 &1569 + 7.0_wp * ibit7 * adv_sca_3 &1570 + ibit6 * adv_sca_1 &1571 ) * &1572 ( sk(k+1,j,i) + sk(k,j,i) ) &1573 - ( 8.0_wp * ibit8 * adv_sca_5 &1574 + ibit7 * adv_sca_3 &1575 ) * &1576 ( sk(k_pp,j,i) + sk(k-1,j,i) ) &1577 + ( ibit8 * adv_sca_5 &1578 ) * ( sk(k_ppp,j,i)+ sk(k_mm,j,i) ) &1579 )1580 1581 diss_t(k) = -ABS( w(k,j,i) ) * rho_air_zw(k) * ( &1582 ( 10.0_wp * ibit8 * adv_sca_5 &1583 + 3.0_wp * ibit7 * adv_sca_3 &1584 + ibit6 * adv_sca_1 &1585 ) * &1586 ( sk(k+1,j,i) - sk(k,j,i) ) &1587 - ( 5.0_wp * ibit8 * adv_sca_5 &1588 + ibit7 * adv_sca_3 &1589 ) * &1590 ( sk(k_pp,j,i) - sk(k-1,j,i) ) &1591 + ( ibit8 * adv_sca_5 &1592 ) * &1593 ( sk(k_ppp,j,i) - sk(k_mm,j,i) ) &1594 )1595 ENDDO1596 1597 DO k = nzb+2, nzt-21598 ibit8 = REAL( IBITS(advc_flag(k,j,i),8,1), KIND = wp )1599 ibit7 = REAL( IBITS(advc_flag(k,j,i),7,1), KIND = wp )1600 ibit6 = REAL( IBITS(advc_flag(k,j,i),6,1), KIND = wp )1601 1602 flux_t(k) = w(k,j,i) * rho_air_zw(k) * ( &1603 ( 37.0_wp * ibit8 * adv_sca_5 &1604 + 7.0_wp * ibit7 * adv_sca_3 &1605 + ibit6 * adv_sca_1 &1606 ) * &1607 ( sk(k+1,j,i) + sk(k,j,i) ) &1608 - ( 8.0_wp * ibit8 * adv_sca_5 &1609 + ibit7 * adv_sca_3 &1610 ) * &1611 ( sk(k+2,j,i) + sk(k-1,j,i) ) &1612 + ( ibit8 * adv_sca_5 &1613 ) * ( sk(k+3,j,i)+ sk(k-2,j,i) ) &1614 )1615 1616 diss_t(k) = -ABS( w(k,j,i) ) * rho_air_zw(k) * ( &1617 ( 10.0_wp * ibit8 * adv_sca_5 &1618 + 3.0_wp * ibit7 * adv_sca_3 &1619 + ibit6 * adv_sca_1 &1620 ) * &1621 ( sk(k+1,j,i) - sk(k,j,i) ) &1622 - ( 5.0_wp * ibit8 * adv_sca_5 &1623 + ibit7 * adv_sca_3 &1624 ) * &1625 ( sk(k+2,j,i) - sk(k-1,j,i) ) &1626 + ( ibit8 * adv_sca_5 &1627 ) * &1628 ( sk(k+3,j,i) - sk(k-2,j,i) ) &1629 )1630 ENDDO1631 1632 DO k = nzt-1, nzt-symmetry_flag1633 ibit8 = REAL( IBITS(advc_flag(k,j,i),8,1), KIND = wp )1634 ibit7 = REAL( IBITS(advc_flag(k,j,i),7,1), KIND = wp )1635 ibit6 = REAL( IBITS(advc_flag(k,j,i),6,1), KIND = wp )1636 !1637 !-- k index has to be modified near bottom and top, else array1638 !-- subscripts will be exceeded.1639 k_ppp = k + 3 * ibit81640 k_pp = k + 2 * ( 1 - ibit6 )1641 k_mm = k - 2 * ibit81642 1643 1566 1644 1567 flux_t(k) = w(k,j,i) * rho_air_zw(k) * ( & … … 1671 1594 ) 1672 1595 ENDDO 1673 1596 1597 DO k = nzb+2, nzt-2 1598 ibit8 = REAL( IBITS(advc_flag(k,j,i),8,1), KIND = wp ) 1599 ibit7 = REAL( IBITS(advc_flag(k,j,i),7,1), KIND = wp ) 1600 ibit6 = REAL( IBITS(advc_flag(k,j,i),6,1), KIND = wp ) 1601 1602 flux_t(k) = w(k,j,i) * rho_air_zw(k) * ( & 1603 ( 37.0_wp * ibit8 * adv_sca_5 & 1604 + 7.0_wp * ibit7 * adv_sca_3 & 1605 + ibit6 * adv_sca_1 & 1606 ) * & 1607 ( sk(k+1,j,i) + sk(k,j,i) ) & 1608 - ( 8.0_wp * ibit8 * adv_sca_5 & 1609 + ibit7 * adv_sca_3 & 1610 ) * & 1611 ( sk(k+2,j,i) + sk(k-1,j,i) ) & 1612 + ( ibit8 * adv_sca_5 & 1613 ) * ( sk(k+3,j,i)+ sk(k-2,j,i) ) & 1614 ) 1615 1616 diss_t(k) = -ABS( w(k,j,i) ) * rho_air_zw(k) * ( & 1617 ( 10.0_wp * ibit8 * adv_sca_5 & 1618 + 3.0_wp * ibit7 * adv_sca_3 & 1619 + ibit6 * adv_sca_1 & 1620 ) * & 1621 ( sk(k+1,j,i) - sk(k,j,i) ) & 1622 - ( 5.0_wp * ibit8 * adv_sca_5 & 1623 + ibit7 * adv_sca_3 & 1624 ) * & 1625 ( sk(k+2,j,i) - sk(k-1,j,i) ) & 1626 + ( ibit8 * adv_sca_5 & 1627 ) * & 1628 ( sk(k+3,j,i) - sk(k-2,j,i) ) & 1629 ) 1630 ENDDO 1631 1632 DO k = nzt-1, nzt-symmetry_flag 1633 ibit8 = REAL( IBITS(advc_flag(k,j,i),8,1), KIND = wp ) 1634 ibit7 = REAL( IBITS(advc_flag(k,j,i),7,1), KIND = wp ) 1635 ibit6 = REAL( IBITS(advc_flag(k,j,i),6,1), KIND = wp ) 1636 ! 1637 !-- k index has to be modified near bottom and top, else array 1638 !-- subscripts will be exceeded. 1639 k_ppp = k + 3 * ibit8 1640 k_pp = k + 2 * ( 1 - ibit6 ) 1641 k_mm = k - 2 * ibit8 1642 1643 1644 flux_t(k) = w(k,j,i) * rho_air_zw(k) * ( & 1645 ( 37.0_wp * ibit8 * adv_sca_5 & 1646 + 7.0_wp * ibit7 * adv_sca_3 & 1647 + ibit6 * adv_sca_1 & 1648 ) * & 1649 ( sk(k+1,j,i) + sk(k,j,i) ) & 1650 - ( 8.0_wp * ibit8 * adv_sca_5 & 1651 + ibit7 * adv_sca_3 & 1652 ) * & 1653 ( sk(k_pp,j,i) + sk(k-1,j,i) ) & 1654 + ( ibit8 * adv_sca_5 & 1655 ) * ( sk(k_ppp,j,i)+ sk(k_mm,j,i) ) & 1656 ) 1657 1658 diss_t(k) = -ABS( w(k,j,i) ) * rho_air_zw(k) * ( & 1659 ( 10.0_wp * ibit8 * adv_sca_5 & 1660 + 3.0_wp * ibit7 * adv_sca_3 & 1661 + ibit6 * adv_sca_1 & 1662 ) * & 1663 ( sk(k+1,j,i) - sk(k,j,i) ) & 1664 - ( 5.0_wp * ibit8 * adv_sca_5 & 1665 + ibit7 * adv_sca_3 & 1666 ) * & 1667 ( sk(k_pp,j,i) - sk(k-1,j,i) ) & 1668 + ( ibit8 * adv_sca_5 & 1669 ) * & 1670 ( sk(k_ppp,j,i) - sk(k_mm,j,i) ) & 1671 ) 1672 ENDDO 1673 1674 1674 ! 1675 1675 !-- Set resolved/turbulent flux at model top to zero (w-level). In case that 1676 1676 !-- a symmetric behavior between bottom and top shall be guaranteed (closed 1677 !-- channel flow), the flux at nzt is also set to zero. 1677 !-- channel flow), the flux at nzt is also set to zero. 1678 1678 IF ( symmetry_flag == 1 ) THEN 1679 1679 flux_t(nzt) = 0.0_wp … … 1682 1682 flux_t(nzt+1) = 0.0_wp 1683 1683 diss_t(nzt+1) = 0.0_wp 1684 1685 1684 1685 1686 1686 IF ( limiter ) THEN 1687 1687 ! … … 1695 1695 ! 1696 1696 !-- In flux limitation the total flux will be corrected. For the sake 1697 !-- of cleariness the higher-order advective and disspative fluxes 1698 !-- will be merged onto flux_t. 1697 !-- of cleariness the higher-order advective and disspative fluxes 1698 !-- will be merged onto flux_t. 1699 1699 flux_t(k) = flux_t(k) + diss_t(k) 1700 1700 diss_t(k) = 0.0_wp 1701 1701 ENDDO 1702 1702 ! 1703 !-- Flux limitation of vertical fluxes according to Skamarock (2006). 1703 !-- Flux limitation of vertical fluxes according to Skamarock (2006). 1704 1704 !-- Please note, as flux limitation implies linear dependencies of fluxes, 1705 1705 !-- flux limitation is only made for the vertical advection term. Limitation 1706 !-- of the horizontal terms cannot be parallelized. 1706 !-- of the horizontal terms cannot be parallelized. 1707 1707 !-- Due to the linear dependency, the following loop will not be vectorized. 1708 1708 !-- Further, note that the flux limiter is only applied within the urban 1709 !-- layer, i.e up to the topography top. 1709 !-- layer, i.e up to the topography top. 1710 1710 DO k = nzb+1, nzb_max_l 1711 1711 ! 1712 1712 !-- Compute one-dimensional divergence along the vertical direction, 1713 !-- which is used to correct the advection discretization. This is 1713 !-- which is used to correct the advection discretization. This is 1714 1714 !-- necessary as in one-dimensional space the advection velocity 1715 !-- should actually be constant. 1715 !-- should actually be constant. 1716 1716 div = ( w(k,j,i) * rho_air_zw(k) & 1717 - w(k-1,j,i) * rho_air_zw(k-1) & 1717 - w(k-1,j,i) * rho_air_zw(k-1) & 1718 1718 ) * drho_air(k) * ddzw(k) 1719 1719 ! 1720 !-- Compute monotone solution of the advection equation from 1720 !-- Compute monotone solution of the advection equation from 1721 1721 !-- 1st-order fluxes. Please note, the advection equation is corrected 1722 1722 !-- by the divergence term (in 1D the advective flow should be divergence 1723 !-- free). Moreover, please note, as time-increment the full timestep 1724 !-- is used, even though a Runge-Kutta scheme will be used. However, 1725 !-- the length of the actual time increment is not important at all 1726 !-- since it cancels out later when the fluxes are limited. 1723 !-- free). Moreover, please note, as time-increment the full timestep 1724 !-- is used, even though a Runge-Kutta scheme will be used. However, 1725 !-- the length of the actual time increment is not important at all 1726 !-- since it cancels out later when the fluxes are limited. 1727 1727 mon = sk(k,j,i) + ( - ( flux_t_1st(k) - flux_t_1st(k-1) ) & 1728 1728 * drho_air(k) * ddzw(k) & 1729 1729 + div * sk(k,j,i) & 1730 ) * dt_3d 1730 ) * dt_3d 1731 1731 ! 1732 1732 !-- Determine minimum and maximum values along the numerical stencil. 1733 1733 k_mmm = MAX( k - 3, nzb + 1 ) 1734 k_ppp = MIN( k + 3, nzt + 1 ) 1734 k_ppp = MIN( k + 3, nzt + 1 ) 1735 1735 1736 1736 min_val = MINVAL( sk(k_mmm:k_ppp,j,i) ) 1737 1737 max_val = MAXVAL( sk(k_mmm:k_ppp,j,i) ) 1738 1738 ! 1739 !-- Compute difference between high- and low-order fluxes, which may 1739 !-- Compute difference between high- and low-order fluxes, which may 1740 1740 !-- act as correction fluxes 1741 1741 f_corr_t = flux_t(k) - flux_t_1st(k) 1742 1742 f_corr_d = flux_t(k-1) - flux_t_1st(k-1) 1743 1743 ! 1744 !-- Determine outgoing fluxes, i.e. the part of the fluxes which can 1744 !-- Determine outgoing fluxes, i.e. the part of the fluxes which can 1745 1745 !-- decrease the value within the grid box 1746 1746 f_corr_t_out = MAX( 0.0_wp, f_corr_t ) 1747 1747 f_corr_d_out = MIN( 0.0_wp, f_corr_d ) 1748 1748 ! 1749 !-- Determine ingoing fluxes, i.e. the part of the fluxes which can 1750 !-- increase the value within the grid box 1749 !-- Determine ingoing fluxes, i.e. the part of the fluxes which can 1750 !-- increase the value within the grid box 1751 1751 f_corr_t_in = MIN( 0.0_wp, f_corr_t) 1752 1752 f_corr_d_in = MAX( 0.0_wp, f_corr_d) … … 1762 1762 !-- Check if outgoing fluxes can lead to undershoots, i.e. values smaller 1763 1763 !-- than the minimum value within the numerical stencil. If so, limit 1764 !-- them. 1764 !-- them. 1765 1765 IF ( mon - min_val < - div_out .AND. ABS( div_out ) > 0.0_wp ) & 1766 1766 THEN … … 1772 1772 !-- Check if ingoing fluxes can lead to overshoots, i.e. values larger 1773 1773 !-- than the maximum value within the numerical stencil. If so, limit 1774 !-- them. 1774 !-- them. 1775 1775 IF ( mon - max_val > - div_in .AND. ABS( div_in ) > 0.0_wp ) & 1776 1776 THEN … … 1780 1780 ENDIF 1781 1781 ! 1782 !-- Finally add the limited fluxes to the original ones. If no 1783 !-- flux limitation was done, the fluxes equal the original ones. 1782 !-- Finally add the limited fluxes to the original ones. If no 1783 !-- flux limitation was done, the fluxes equal the original ones. 1784 1784 flux_t(k) = flux_t_1st(k) + f_corr_t_out + f_corr_t_in 1785 1785 flux_t(k-1) = flux_t_1st(k-1) + f_corr_d_out + f_corr_d_in 1786 1786 ENDDO 1787 1787 ENDIF 1788 1788 ! 1789 !-- Now compute the tendency term including divergence correction. 1789 1790 DO k = nzb+1, nzb_max_l 1790 1791 1791 1792 flux_d = flux_t(k-1) 1792 1793 diss_d = diss_t(k-1) 1793 1794 1794 1795 ibit2 = REAL( IBITS(advc_flag(k,j,i),2,1), KIND = wp ) 1795 1796 ibit1 = REAL( IBITS(advc_flag(k,j,i),1,1), KIND = wp ) 1796 1797 ibit0 = REAL( IBITS(advc_flag(k,j,i),0,1), KIND = wp ) 1797 1798 1798 1799 ibit5 = REAL( IBITS(advc_flag(k,j,i),5,1), KIND = wp ) 1799 1800 ibit4 = REAL( IBITS(advc_flag(k,j,i),4,1), KIND = wp ) 1800 1801 ibit3 = REAL( IBITS(advc_flag(k,j,i),3,1), KIND = wp ) 1801 1802 1802 1803 ibit8 = REAL( IBITS(advc_flag(k,j,i),8,1), KIND = wp ) 1803 1804 ibit7 = REAL( IBITS(advc_flag(k,j,i),7,1), KIND = wp ) … … 1807 1808 !-- correction is needed to overcome numerical instabilities introduced 1808 1809 !-- by a not sufficient reduction of divergences near topography. 1809 div = ( u(k,j,i+1) * ( ibit0 + ibit1 + ibit2 ) &1810 - u(k,j,i) * ( &1811 REAL( IBITS(advc_flag(k,j,i-1),0,1), KIND = wp ) &1812 + REAL( IBITS(advc_flag(k,j,i-1),1,1), KIND = wp ) &1813 + REAL( IBITS(advc_flag(k,j,i-1),2,1), KIND = wp ) &1814 ) &1815 ) * ddx &1816 + ( v(k,j+1,i) * ( ibit3 + ibit4 + ibit5 ) &1817 - v(k,j,i) * ( &1818 REAL( IBITS(advc_flag(k,j-1,i),3,1), KIND = wp ) &1819 + REAL( IBITS(advc_flag(k,j-1,i),4,1), KIND = wp ) &1820 + REAL( IBITS(advc_flag(k,j-1,i),5,1), KIND = wp ) &1821 ) &1822 ) * ddy &1823 + ( w(k,j,i) * rho_air_zw(k) * &1824 ( ibit6 + ibit7 + ibit8 ) &1825 - w(k-1,j,i) * rho_air_zw(k-1) * &1826 ( &1827 REAL( IBITS(advc_flag(k-1,j,i),6,1), KIND = wp ) &1828 + REAL( IBITS(advc_flag(k-1,j,i),7,1), KIND = wp ) &1829 + REAL( IBITS(advc_flag(k-1,j,i),8,1), KIND = wp ) &1830 ) &1810 div = ( u(k,j,i+1) * ( ibit0 + ibit1 + ibit2 ) & 1811 - u(k,j,i) * ( & 1812 REAL( IBITS(advc_flag(k,j,i-1),0,1), KIND = wp ) & 1813 + REAL( IBITS(advc_flag(k,j,i-1),1,1), KIND = wp ) & 1814 + REAL( IBITS(advc_flag(k,j,i-1),2,1), KIND = wp ) & 1815 ) & 1816 ) * ddx & 1817 + ( v(k,j+1,i) * ( ibit3 + ibit4 + ibit5 ) & 1818 - v(k,j,i) * ( & 1819 REAL( IBITS(advc_flag(k,j-1,i),3,1), KIND = wp ) & 1820 + REAL( IBITS(advc_flag(k,j-1,i),4,1), KIND = wp ) & 1821 + REAL( IBITS(advc_flag(k,j-1,i),5,1), KIND = wp ) & 1822 ) & 1823 ) * ddy & 1824 + ( w(k,j,i) * rho_air_zw(k) * & 1825 ( ibit6 + ibit7 + ibit8 ) & 1826 - w(k-1,j,i) * rho_air_zw(k-1) * & 1827 ( & 1828 REAL( IBITS(advc_flag(k-1,j,i),6,1), KIND = wp ) & 1829 + REAL( IBITS(advc_flag(k-1,j,i),7,1), KIND = wp ) & 1830 + REAL( IBITS(advc_flag(k-1,j,i),8,1), KIND = wp ) & 1831 ) & 1831 1832 ) * drho_air(k) * ddzw(k) 1832 1833 1833 tend(k,j,i) = tend(k,j,i) - ( &1834 ( flux_r(k) + diss_r(k) - swap_flux_x_local(k,j,tn) - &1835 swap_diss_x_local(k,j,tn) ) * ddx &1836 + ( flux_n(k) + diss_n(k) - swap_flux_y_local(k,tn) - &1837 swap_diss_y_local(k,tn) ) * ddy &1838 + ( ( flux_t(k) + diss_t(k) ) - &1839 ( flux_d + diss_d ) &1840 ) * drho_air(k) * ddzw(k) &1834 tend(k,j,i) = tend(k,j,i) - ( & 1835 ( flux_r(k) + diss_r(k) - swap_flux_x_local(k,j,tn) - & 1836 swap_diss_x_local(k,j,tn) ) * ddx & 1837 + ( flux_n(k) + diss_n(k) - swap_flux_y_local(k,tn) - & 1838 swap_diss_y_local(k,tn) ) * ddy & 1839 + ( ( flux_t(k) + diss_t(k) ) - & 1840 ( flux_d + diss_d ) & 1841 ) * drho_air(k) * ddzw(k) & 1841 1842 ) + sk(k,j,i) * div 1842 1843 … … 1848 1849 1849 1850 ENDDO 1850 1851 1851 1852 DO k = nzb_max_l+1, nzt 1852 1853 … … 1857 1858 !-- correction is needed to overcome numerical instabilities introduced 1858 1859 !-- by a not sufficient reduction of divergences near topography. 1859 div = ( u(k,j,i+1) - u(k,j,i) ) * ddx &1860 + ( v(k,j+1,i) - v(k,j,i) ) * ddy &1861 + ( w(k,j,i) * rho_air_zw(k) &1862 - w(k-1,j,i) * rho_air_zw(k-1) &1860 div = ( u(k,j,i+1) - u(k,j,i) ) * ddx & 1861 + ( v(k,j+1,i) - v(k,j,i) ) * ddy & 1862 + ( w(k,j,i) * rho_air_zw(k) & 1863 - w(k-1,j,i) * rho_air_zw(k-1) & 1863 1864 ) * drho_air(k) * ddzw(k) 1864 1865 1865 tend(k,j,i) = tend(k,j,i) - ( &1866 ( flux_r(k) + diss_r(k) - swap_flux_x_local(k,j,tn) - &1867 swap_diss_x_local(k,j,tn) ) * ddx &1868 + ( flux_n(k) + diss_n(k) - swap_flux_y_local(k,tn) - &1869 swap_diss_y_local(k,tn) ) * ddy &1870 + ( ( flux_t(k) + diss_t(k) ) - &1871 ( flux_d + diss_d ) &1872 ) * drho_air(k) * ddzw(k) &1866 tend(k,j,i) = tend(k,j,i) - ( & 1867 ( flux_r(k) + diss_r(k) - swap_flux_x_local(k,j,tn) - & 1868 swap_diss_x_local(k,j,tn) ) * ddx & 1869 + ( flux_n(k) + diss_n(k) - swap_flux_y_local(k,tn) - & 1870 swap_diss_y_local(k,tn) ) * ddy & 1871 + ( ( flux_t(k) + diss_t(k) ) - & 1872 ( flux_d + diss_d ) & 1873 ) * drho_air(k) * ddzw(k) & 1873 1874 ) + sk(k,j,i) * div 1874 1875 … … 1895 1896 ) * weight_substep(intermediate_timestep_count) 1896 1897 ENDDO 1897 1898 1898 1899 CASE ( 'sa' ) 1899 1900 … … 1906 1907 ) * weight_substep(intermediate_timestep_count) 1907 1908 ENDDO 1908 1909 1909 1910 CASE ( 'q' ) 1910 1911 … … 1988 1989 !kk Has to be implemented for kpp chemistry 1989 1990 1990 1991 1991 END SELECT 1992 1992 … … 2011 2011 INTEGER(iwp) :: k_pp !< k+2 index in disretization, can be modified to avoid segmentation faults 2012 2012 INTEGER(iwp) :: k_ppp !< k+3 index in disretization, can be modified to avoid segmentation faults 2013 INTEGER(iwp) :: nzb_max_l !< index indicating upper bound for order degradation of horizontal advection terms 2013 INTEGER(iwp) :: nzb_max_l !< index indicating upper bound for order degradation of horizontal advection terms 2014 2014 INTEGER(iwp) :: tn !< number of OpenMP thread 2015 2015 2016 2016 REAL(wp) :: ibit0 !< flag indicating 1st-order scheme along x-direction 2017 2017 REAL(wp) :: ibit1 !< flag indicating 3rd-order scheme along x-direction … … 2029 2029 REAL(wp) :: gv !< Galilei-transformation velocity along y 2030 2030 REAL(wp) :: u_comp_l !< advection velocity along x at leftmost grid point on subdomain 2031 2031 2032 2032 REAL(wp), DIMENSION(nzb:nzt+1) :: diss_n !< discretized artificial dissipation at northward-side of the grid box 2033 2033 REAL(wp), DIMENSION(nzb:nzt+1) :: diss_r !< discretized artificial dissipation at rightward-side of the grid box … … 2040 2040 REAL(wp), DIMENSION(nzb:nzt+1) :: w_comp !< advection velocity along z 2041 2041 ! 2042 !-- Used local modified copy of nzb_max (used to degrade order of 2042 !-- Used local modified copy of nzb_max (used to degrade order of 2043 2043 !-- discretization) at non-cyclic boundaries. Modify only at relevant points 2044 !-- instead of the entire subdomain. This should lead to better 2044 !-- instead of the entire subdomain. This should lead to better 2045 2045 !-- load balance between boundary and non-boundary PEs. 2046 2046 IF( ( bc_dirichlet_l .OR. bc_radiation_l ) .AND. i <= nxl + 2 .OR. & … … 2052 2052 nzb_max_l = nzb_max 2053 2053 END IF 2054 2054 2055 2055 gu = 2.0_wp * u_gtrans 2056 2056 gv = 2.0_wp * v_gtrans … … 2058 2058 !-- Compute southside fluxes for the respective boundary of PE 2059 2059 IF ( j == nys ) THEN 2060 2060 2061 2061 DO k = nzb+1, nzb_max_l 2062 2062 … … 2104 2104 37.0_wp * ( u(k,j,i) + u(k,j-1,i) ) & 2105 2105 - 8.0_wp * ( u(k,j+1,i) + u(k,j-2,i) ) & 2106 + ( u(k,j+2,i) + u(k,j-3,i) ) ) * adv_mom_5 2106 + ( u(k,j+2,i) + u(k,j-3,i) ) ) * adv_mom_5 2107 2107 diss_s_u(k,tn) = - ABS(v_comp(k)) * ( & 2108 2108 10.0_wp * ( u(k,j,i) - u(k,j-1,i) ) & … … 2111 2111 2112 2112 ENDDO 2113 2113 2114 2114 ENDIF 2115 2115 ! 2116 2116 !-- Compute leftside fluxes for the respective boundary of PE 2117 2117 IF ( i == i_omp .OR. i == nxlu ) THEN 2118 2118 2119 2119 DO k = nzb+1, nzb_max_l 2120 2120 … … 2137 2137 ) * & 2138 2138 ( u(k,j,i+2) + u(k,j,i-3) ) & 2139 ) 2140 2139 ) 2140 2141 2141 diss_l_u(k,j,tn) = - ABS( u_comp_l ) * ( & 2142 2142 ( 10.0_wp * ibit2 * adv_mom_5 & … … 2169 2169 2170 2170 ENDDO 2171 2171 2172 2172 ENDIF 2173 2173 ! … … 2188 2188 ( u(k,j,i+1) + u(k,j,i) ) & 2189 2189 - ( 8.0_wp * ibit2 * adv_mom_5 & 2190 + ibit1 * adv_mom_3 & 2190 + ibit1 * adv_mom_3 & 2191 2191 ) * & 2192 2192 ( u(k,j,i+2) + u(k,j,i-1) ) & … … 2194 2194 ) * & 2195 2195 ( u(k,j,i+3) + u(k,j,i-2) ) & 2196 ) 2197 2196 ) 2197 2198 2198 diss_r(k) = - ABS( u_comp(k) - gu ) * ( & 2199 2199 ( 10.0_wp * ibit2 * adv_mom_5 & … … 2229 2229 ) * & 2230 2230 ( u(k,j+3,i) + u(k,j-2,i) ) & 2231 ) 2232 2231 ) 2232 2233 2233 diss_n(k) = - ABS ( v_comp(k) ) * ( & 2234 2234 ( 10.0_wp * ibit5 * adv_mom_5 & … … 2253 2253 37.0_wp * ( u(k,j,i+1) + u(k,j,i) ) & 2254 2254 - 8.0_wp * ( u(k,j,i+2) + u(k,j,i-1) ) & 2255 + ( u(k,j,i+3) + u(k,j,i-2) ) ) * adv_mom_5 2255 + ( u(k,j,i+3) + u(k,j,i-2) ) ) * adv_mom_5 2256 2256 diss_r(k) = - ABS( u_comp(k) - gu ) * ( & 2257 2257 10.0_wp * ( u(k,j,i+1) - u(k,j,i) ) & 2258 2258 - 5.0_wp * ( u(k,j,i+2) - u(k,j,i-1) ) & 2259 + ( u(k,j,i+3) - u(k,j,i-2) ) ) * adv_mom_5 2260 2261 v_comp(k) = v(k,j+1,i) + v(k,j+1,i-1) - gv 2259 + ( u(k,j,i+3) - u(k,j,i-2) ) ) * adv_mom_5 2260 2261 v_comp(k) = v(k,j+1,i) + v(k,j+1,i-1) - gv 2262 2262 flux_n(k) = v_comp(k) * ( & 2263 2263 37.0_wp * ( u(k,j+1,i) + u(k,j,i) ) & 2264 2264 - 8.0_wp * ( u(k,j+2,i) + u(k,j-1,i) ) & 2265 + ( u(k,j+3,i) + u(k,j-2,i) ) ) * adv_mom_5 2265 + ( u(k,j+3,i) + u(k,j-2,i) ) ) * adv_mom_5 2266 2266 diss_n(k) = - ABS( v_comp(k) ) * ( & 2267 2267 10.0_wp * ( u(k,j+1,i) - u(k,j,i) ) & … … 2271 2271 ENDDO 2272 2272 ! 2273 !-- Now, compute vertical fluxes. Split loop into a part treating the 2273 !-- Now, compute vertical fluxes. Split loop into a part treating the 2274 2274 !-- lowest grid points with indirect indexing, a main loop without 2275 2275 !-- indirect indexing, and a loop for the uppermost grip points with 2276 2276 !-- indirect indexing. This allows better vectorization for the main loop. 2277 !-- First, compute the flux at model surface, which need has to be 2277 !-- First, compute the flux at model surface, which need has to be 2278 2278 !-- calculated explicitly for the tendency at 2279 2279 !-- the first w-level. For topography wall this is done implicitely by … … 2282 2282 diss_t(nzb) = 0.0_wp 2283 2283 w_comp(nzb) = 0.0_wp 2284 2284 2285 2285 DO k = nzb+1, nzb+1 2286 2286 ! … … 2309 2309 ) * & 2310 2310 ( u(k_ppp,j,i) + u(k_mm,j,i) ) & 2311 ) 2312 2311 ) 2312 2313 2313 diss_t(k) = - ABS( w_comp(k) ) * rho_air_zw(k) * ( & 2314 2314 ( 10.0_wp * ibit8 * adv_mom_5 & … … 2326 2326 ) 2327 2327 ENDDO 2328 2328 2329 2329 DO k = nzb+2, nzt-2 2330 2330 … … 2344 2344 ) * & 2345 2345 ( u(k+2,j,i) + u(k-1,j,i) ) & 2346 + ( ibit8 * adv_mom_5 & 2346 + ( ibit8 * adv_mom_5 & 2347 2347 ) * & 2348 2348 ( u(k+3,j,i) + u(k-2,j,i) ) & … … 2364 2364 ) 2365 2365 ENDDO 2366 2366 2367 2367 DO k = nzt-1, nzt-symmetry_flag 2368 2368 ! … … 2408 2408 ) 2409 2409 ENDDO 2410 2410 2411 2411 ! 2412 2412 !-- Set resolved/turbulent flux at model top to zero (w-level). In case that 2413 2413 !-- a symmetric behavior between bottom and top shall be guaranteed (closed 2414 !-- channel flow), the flux at nzt is also set to zero. 2414 !-- channel flow), the flux at nzt is also set to zero. 2415 2415 IF ( symmetry_flag == 1 ) THEN 2416 2416 flux_t(nzt) = 0.0_wp … … 2421 2421 diss_t(nzt+1) = 0.0_wp 2422 2422 w_comp(nzt+1) = 0.0_wp 2423 2423 2424 2424 DO k = nzb+1, nzb_max_l 2425 2425 2426 2426 flux_d = flux_t(k-1) 2427 2427 diss_d = diss_t(k-1) 2428 2428 2429 2429 ibit2 = REAL( IBITS(advc_flags_m(k,j,i),2,1), KIND = wp ) 2430 2430 ibit1 = REAL( IBITS(advc_flags_m(k,j,i),1,1), KIND = wp ) 2431 2431 ibit0 = REAL( IBITS(advc_flags_m(k,j,i),0,1), KIND = wp ) 2432 2432 2433 2433 ibit5 = REAL( IBITS(advc_flags_m(k,j,i),5,1), KIND = wp ) 2434 2434 ibit4 = REAL( IBITS(advc_flags_m(k,j,i),4,1), KIND = wp ) 2435 2435 ibit3 = REAL( IBITS(advc_flags_m(k,j,i),3,1), KIND = wp ) 2436 2436 2437 2437 ibit8 = REAL( IBITS(advc_flags_m(k,j,i),8,1), KIND = wp ) 2438 2438 ibit7 = REAL( IBITS(advc_flags_m(k,j,i),7,1), KIND = wp ) … … 2464 2464 + REAL( IBITS(advc_flags_m(k-1,j,i),7,1), KIND = wp ) & 2465 2465 + REAL( IBITS(advc_flags_m(k-1,j,i),8,1), KIND = wp ) & 2466 ) & 2466 ) & 2467 2467 ) * drho_air(k) * ddzw(k) & 2468 ) * 0.5_wp 2469 2468 ) * 0.5_wp 2469 2470 2470 tend(k,j,i) = tend(k,j,i) - ( & 2471 2471 ( flux_r(k) + diss_r(k) & … … 2504 2504 ) * weight_substep(intermediate_timestep_count) 2505 2505 ENDDO 2506 2506 2507 2507 DO k = nzb_max_l+1, nzt 2508 2508 … … 2516 2516 + ( v_comp(k) + gv - ( v(k,j,i) + v(k,j,i-1) ) ) * ddy & 2517 2517 + ( w_comp(k) * rho_air_zw(k) & 2518 - w_comp(k-1) * rho_air_zw(k-1) & 2518 - w_comp(k-1) * rho_air_zw(k-1) & 2519 2519 ) * drho_air(k) * ddzw(k) & 2520 2520 ) * 0.5_wp … … 2528 2528 - ( flux_d + diss_d ) & 2529 2529 ) * drho_air(k) * ddzw(k) & 2530 2530 ) + div * u(k,j,i) 2531 2531 2532 2532 flux_l_u(k,j,tn) = flux_r(k) … … 2578 2578 INTEGER(iwp) :: k_pp !< k+2 index in disretization, can be modified to avoid segmentation faults 2579 2579 INTEGER(iwp) :: k_ppp !< k+3 index in disretization, can be modified to avoid segmentation faults 2580 INTEGER(iwp) :: nzb_max_l !< index indicating upper bound for order degradation of horizontal advection terms 2580 INTEGER(iwp) :: nzb_max_l !< index indicating upper bound for order degradation of horizontal advection terms 2581 2581 INTEGER(iwp) :: tn !< number of OpenMP thread 2582 2582 2583 2583 REAL(wp) :: ibit9 !< flag indicating 1st-order scheme along x-direction 2584 2584 REAL(wp) :: ibit10 !< flag indicating 3rd-order scheme along x-direction 2585 2585 REAL(wp) :: ibit11 !< flag indicating 5th-order scheme along x-direction 2586 REAL(wp) :: ibit12 !< flag indicating 1st-order scheme along y-direction 2586 REAL(wp) :: ibit12 !< flag indicating 1st-order scheme along y-direction 2587 2587 REAL(wp) :: ibit13 !< flag indicating 3rd-order scheme along y-direction 2588 2588 REAL(wp) :: ibit14 !< flag indicating 3rd-order scheme along y-direction … … 2596 2596 REAL(wp) :: gv !< Galilei-transformation velocity along y 2597 2597 REAL(wp) :: v_comp_l !< advection velocity along y on leftmost grid point on subdomain 2598 2598 2599 2599 REAL(wp), DIMENSION(nzb:nzt+1) :: diss_n !< discretized artificial dissipation at northward-side of the grid box 2600 2600 REAL(wp), DIMENSION(nzb:nzt+1) :: diss_r !< discretized artificial dissipation at rightward-side of the grid box … … 2607 2607 REAL(wp), DIMENSION(nzb:nzt+1) :: w_comp !< advection velocity along z 2608 2608 ! 2609 !-- Used local modified copy of nzb_max (used to degrade order of 2609 !-- Used local modified copy of nzb_max (used to degrade order of 2610 2610 !-- discretization) at non-cyclic boundaries. Modify only at relevant points 2611 !-- instead of the entire subdomain. This should lead to better 2611 !-- instead of the entire subdomain. This should lead to better 2612 2612 !-- load balance between boundary and non-boundary PEs. 2613 2613 IF( ( bc_dirichlet_l .OR. bc_radiation_l ) .AND. i <= nxl + 2 .OR. & … … 2619 2619 nzb_max_l = nzb_max 2620 2620 END IF 2621 2621 2622 2622 gu = 2.0_wp * u_gtrans 2623 2623 gv = 2.0_wp * v_gtrans 2624 2624 2625 ! 2625 ! 2626 2626 !-- Compute leftside fluxes for the respective boundary. 2627 2627 IF ( i == i_omp ) THEN … … 2634 2634 2635 2635 u_comp(k) = u(k,j-1,i) + u(k,j,i) - gu 2636 flux_l_v(k,j,tn) = u_comp(k) * ( &2637 ( 37.0_wp * ibit11 * adv_mom_5 &2638 + 7.0_wp * ibit10 * adv_mom_3 &2639 + ibit9 * adv_mom_1 &2640 ) * &2641 ( v(k,j,i) + v(k,j,i-1) ) &2642 - ( 8.0_wp * ibit11 * adv_mom_5 &2643 + ibit10 * adv_mom_3 &2644 ) * &2645 ( v(k,j,i+1) + v(k,j,i-2) ) &2646 + ( ibit11 * adv_mom_5 &2647 ) * &2648 ( v(k,j,i+2) + v(k,j,i-3) ) &2636 flux_l_v(k,j,tn) = u_comp(k) * ( & 2637 ( 37.0_wp * ibit11 * adv_mom_5 & 2638 + 7.0_wp * ibit10 * adv_mom_3 & 2639 + ibit9 * adv_mom_1 & 2640 ) * & 2641 ( v(k,j,i) + v(k,j,i-1) ) & 2642 - ( 8.0_wp * ibit11 * adv_mom_5 & 2643 + ibit10 * adv_mom_3 & 2644 ) * & 2645 ( v(k,j,i+1) + v(k,j,i-2) ) & 2646 + ( ibit11 * adv_mom_5 & 2647 ) * & 2648 ( v(k,j,i+2) + v(k,j,i-3) ) & 2649 2649 ) 2650 2650 2651 diss_l_v(k,j,tn) = - ABS( u_comp(k) ) * ( &2652 ( 10.0_wp * ibit11 * adv_mom_5 &2653 + 3.0_wp * ibit10 * adv_mom_3 &2654 + ibit9 * adv_mom_1 &2655 ) * &2656 ( v(k,j,i) - v(k,j,i-1) ) &2657 - ( 5.0_wp * ibit11 * adv_mom_5 &2658 + ibit10 * adv_mom_3 &2659 ) * &2660 ( v(k,j,i+1) - v(k,j,i-2) ) &2661 + ( ibit11 * adv_mom_5 &2662 ) * &2663 ( v(k,j,i+2) - v(k,j,i-3) ) &2651 diss_l_v(k,j,tn) = - ABS( u_comp(k) ) * ( & 2652 ( 10.0_wp * ibit11 * adv_mom_5 & 2653 + 3.0_wp * ibit10 * adv_mom_3 & 2654 + ibit9 * adv_mom_1 & 2655 ) * & 2656 ( v(k,j,i) - v(k,j,i-1) ) & 2657 - ( 5.0_wp * ibit11 * adv_mom_5 & 2658 + ibit10 * adv_mom_3 & 2659 ) * & 2660 ( v(k,j,i+1) - v(k,j,i-2) ) & 2661 + ( ibit11 * adv_mom_5 & 2662 ) * & 2663 ( v(k,j,i+2) - v(k,j,i-3) ) & 2664 2664 ) 2665 2665 … … 2669 2669 2670 2670 u_comp(k) = u(k,j-1,i) + u(k,j,i) - gu 2671 flux_l_v(k,j,tn) = u_comp(k) * ( &2672 37.0_wp * ( v(k,j,i) + v(k,j,i-1) ) &2673 - 8.0_wp * ( v(k,j,i+1) + v(k,j,i-2) ) &2671 flux_l_v(k,j,tn) = u_comp(k) * ( & 2672 37.0_wp * ( v(k,j,i) + v(k,j,i-1) ) & 2673 - 8.0_wp * ( v(k,j,i+1) + v(k,j,i-2) ) & 2674 2674 + ( v(k,j,i+2) + v(k,j,i-3) ) ) * adv_mom_5 2675 diss_l_v(k,j,tn) = - ABS( u_comp(k) ) * ( &2676 10.0_wp * ( v(k,j,i) - v(k,j,i-1) ) &2677 - 5.0_wp * ( v(k,j,i+1) - v(k,j,i-2) ) &2675 diss_l_v(k,j,tn) = - ABS( u_comp(k) ) * ( & 2676 10.0_wp * ( v(k,j,i) - v(k,j,i-1) ) & 2677 - 5.0_wp * ( v(k,j,i+1) - v(k,j,i-2) ) & 2678 2678 + ( v(k,j,i+2) - v(k,j,i-3) ) ) * adv_mom_5 2679 2679 2680 2680 ENDDO 2681 2681 2682 2682 ENDIF 2683 2683 ! 2684 2684 !-- Compute southside fluxes for the respective boundary. 2685 2685 IF ( j == nysv ) THEN 2686 2686 2687 2687 DO k = nzb+1, nzb_max_l 2688 2688 … … 2692 2692 2693 2693 v_comp_l = v(k,j,i) + v(k,j-1,i) - gv 2694 flux_s_v(k,tn) = v_comp_l * ( &2695 ( 37.0_wp * ibit14 * adv_mom_5 &2696 + 7.0_wp * ibit13 * adv_mom_3 &2697 + ibit12 * adv_mom_1 &2698 ) * &2699 ( v(k,j,i) + v(k,j-1,i) ) &2700 - ( 8.0_wp * ibit14 * adv_mom_5 &2701 + ibit13 * adv_mom_3 &2702 ) * &2703 ( v(k,j+1,i) + v(k,j-2,i) ) &2704 + ( ibit14 * adv_mom_5 &2705 ) * &2706 ( v(k,j+2,i) + v(k,j-3,i) ) &2694 flux_s_v(k,tn) = v_comp_l * ( & 2695 ( 37.0_wp * ibit14 * adv_mom_5 & 2696 + 7.0_wp * ibit13 * adv_mom_3 & 2697 + ibit12 * adv_mom_1 & 2698 ) * & 2699 ( v(k,j,i) + v(k,j-1,i) ) & 2700 - ( 8.0_wp * ibit14 * adv_mom_5 & 2701 + ibit13 * adv_mom_3 & 2702 ) * & 2703 ( v(k,j+1,i) + v(k,j-2,i) ) & 2704 + ( ibit14 * adv_mom_5 & 2705 ) * & 2706 ( v(k,j+2,i) + v(k,j-3,i) ) & 2707 2707 ) 2708 2708 2709 diss_s_v(k,tn) = - ABS( v_comp_l ) * ( &2710 ( 10.0_wp * ibit14 * adv_mom_5 &2711 + 3.0_wp * ibit13 * adv_mom_3 &2712 + ibit12 * adv_mom_1 &2713 ) * &2714 ( v(k,j,i) - v(k,j-1,i) ) &2715 - ( 5.0_wp * ibit14 * adv_mom_5 &2716 + ibit13 * adv_mom_3 &2717 ) * &2718 ( v(k,j+1,i) - v(k,j-2,i) ) &2719 + ( ibit14 * adv_mom_5 &2720 ) * &2721 ( v(k,j+2,i) - v(k,j-3,i) ) &2709 diss_s_v(k,tn) = - ABS( v_comp_l ) * ( & 2710 ( 10.0_wp * ibit14 * adv_mom_5 & 2711 + 3.0_wp * ibit13 * adv_mom_3 & 2712 + ibit12 * adv_mom_1 & 2713 ) * & 2714 ( v(k,j,i) - v(k,j-1,i) ) & 2715 - ( 5.0_wp * ibit14 * adv_mom_5 & 2716 + ibit13 * adv_mom_3 & 2717 ) * & 2718 ( v(k,j+1,i) - v(k,j-2,i) ) & 2719 + ( ibit14 * adv_mom_5 & 2720 ) * & 2721 ( v(k,j+2,i) - v(k,j-3,i) ) & 2722 2722 ) 2723 2723 … … 2727 2727 2728 2728 v_comp_l = v(k,j,i) + v(k,j-1,i) - gv 2729 flux_s_v(k,tn) = v_comp_l * ( &2730 37.0_wp * ( v(k,j,i) + v(k,j-1,i) ) &2731 - 8.0_wp * ( v(k,j+1,i) + v(k,j-2,i) ) &2729 flux_s_v(k,tn) = v_comp_l * ( & 2730 37.0_wp * ( v(k,j,i) + v(k,j-1,i) ) & 2731 - 8.0_wp * ( v(k,j+1,i) + v(k,j-2,i) ) & 2732 2732 + ( v(k,j+2,i) + v(k,j-3,i) ) ) * adv_mom_5 2733 diss_s_v(k,tn) = - ABS( v_comp_l ) * ( &2734 10.0_wp * ( v(k,j,i) - v(k,j-1,i) ) &2735 - 5.0_wp * ( v(k,j+1,i) - v(k,j-2,i) ) &2733 diss_s_v(k,tn) = - ABS( v_comp_l ) * ( & 2734 10.0_wp * ( v(k,j,i) - v(k,j-1,i) ) & 2735 - 5.0_wp * ( v(k,j+1,i) - v(k,j-2,i) ) & 2736 2736 + ( v(k,j+2,i) - v(k,j-3,i) ) ) * adv_mom_5 2737 2737 2738 2738 ENDDO 2739 2739 2740 2740 ENDIF 2741 2741 ! … … 2747 2747 ibit10 = REAL( IBITS(advc_flags_m(k,j,i),10,1), KIND = wp ) 2748 2748 ibit9 = REAL( IBITS(advc_flags_m(k,j,i),9,1), KIND = wp ) 2749 2749 2750 2750 u_comp(k) = u(k,j-1,i+1) + u(k,j,i+1) - gu 2751 flux_r(k) = u_comp(k) * ( &2752 ( 37.0_wp * ibit11 * adv_mom_5 &2753 + 7.0_wp * ibit10 * adv_mom_3 &2754 + ibit9 * adv_mom_1 &2755 ) * &2756 ( v(k,j,i+1) + v(k,j,i) ) &2757 - ( 8.0_wp * ibit11 * adv_mom_5 &2758 + ibit10 * adv_mom_3 &2759 ) * &2760 ( v(k,j,i+2) + v(k,j,i-1) ) &2761 + ( ibit11 * adv_mom_5 &2762 ) * &2763 ( v(k,j,i+3) + v(k,j,i-2) ) &2751 flux_r(k) = u_comp(k) * ( & 2752 ( 37.0_wp * ibit11 * adv_mom_5 & 2753 + 7.0_wp * ibit10 * adv_mom_3 & 2754 + ibit9 * adv_mom_1 & 2755 ) * & 2756 ( v(k,j,i+1) + v(k,j,i) ) & 2757 - ( 8.0_wp * ibit11 * adv_mom_5 & 2758 + ibit10 * adv_mom_3 & 2759 ) * & 2760 ( v(k,j,i+2) + v(k,j,i-1) ) & 2761 + ( ibit11 * adv_mom_5 & 2762 ) * & 2763 ( v(k,j,i+3) + v(k,j,i-2) ) & 2764 2764 ) 2765 2765 2766 diss_r(k) = - ABS( u_comp(k) ) * ( &2767 ( 10.0_wp * ibit11 * adv_mom_5 &2768 + 3.0_wp * ibit10 * adv_mom_3 &2769 + ibit9 * adv_mom_1 &2770 ) * &2771 ( v(k,j,i+1) - v(k,j,i) ) &2772 - ( 5.0_wp * ibit11 * adv_mom_5 &2773 + ibit10 * adv_mom_3 &2774 ) * &2775 ( v(k,j,i+2) - v(k,j,i-1) ) &2776 + ( ibit11 * adv_mom_5 &2777 ) * &2778 ( v(k,j,i+3) - v(k,j,i-2) ) &2766 diss_r(k) = - ABS( u_comp(k) ) * ( & 2767 ( 10.0_wp * ibit11 * adv_mom_5 & 2768 + 3.0_wp * ibit10 * adv_mom_3 & 2769 + ibit9 * adv_mom_1 & 2770 ) * & 2771 ( v(k,j,i+1) - v(k,j,i) ) & 2772 - ( 5.0_wp * ibit11 * adv_mom_5 & 2773 + ibit10 * adv_mom_3 & 2774 ) * & 2775 ( v(k,j,i+2) - v(k,j,i-1) ) & 2776 + ( ibit11 * adv_mom_5 & 2777 ) * & 2778 ( v(k,j,i+3) - v(k,j,i-2) ) & 2779 2779 ) 2780 2780 … … 2785 2785 2786 2786 v_comp(k) = v(k,j+1,i) + v(k,j,i) 2787 flux_n(k) = ( v_comp(k) - gv ) * ( &2788 ( 37.0_wp * ibit14 * adv_mom_5 &2789 + 7.0_wp * ibit13 * adv_mom_3 &2790 + ibit12 * adv_mom_1 &2791 ) * &2792 ( v(k,j+1,i) + v(k,j,i) ) &2793 - ( 8.0_wp * ibit14 * adv_mom_5 &2794 + ibit13 * adv_mom_3 &2795 ) * &2796 ( v(k,j+2,i) + v(k,j-1,i) ) &2797 + ( ibit14 * adv_mom_5 &2798 ) * &2799 ( v(k,j+3,i) + v(k,j-2,i) ) &2787 flux_n(k) = ( v_comp(k) - gv ) * ( & 2788 ( 37.0_wp * ibit14 * adv_mom_5 & 2789 + 7.0_wp * ibit13 * adv_mom_3 & 2790 + ibit12 * adv_mom_1 & 2791 ) * & 2792 ( v(k,j+1,i) + v(k,j,i) ) & 2793 - ( 8.0_wp * ibit14 * adv_mom_5 & 2794 + ibit13 * adv_mom_3 & 2795 ) * & 2796 ( v(k,j+2,i) + v(k,j-1,i) ) & 2797 + ( ibit14 * adv_mom_5 & 2798 ) * & 2799 ( v(k,j+3,i) + v(k,j-2,i) ) & 2800 2800 ) 2801 2801 2802 diss_n(k) = - ABS( v_comp(k) - gv ) * ( &2803 ( 10.0_wp * ibit14 * adv_mom_5 &2804 + 3.0_wp * ibit13 * adv_mom_3 &2805 + ibit12 * adv_mom_1 &2806 ) * &2807 ( v(k,j+1,i) - v(k,j,i) ) &2808 - ( 5.0_wp * ibit14 * adv_mom_5 &2809 + ibit13 * adv_mom_3 &2810 ) * &2811 ( v(k,j+2,i) - v(k,j-1,i) ) &2812 + ( ibit14 * adv_mom_5 &2813 ) * &2814 ( v(k,j+3,i) - v(k,j-2,i) ) &2802 diss_n(k) = - ABS( v_comp(k) - gv ) * ( & 2803 ( 10.0_wp * ibit14 * adv_mom_5 & 2804 + 3.0_wp * ibit13 * adv_mom_3 & 2805 + ibit12 * adv_mom_1 & 2806 ) * & 2807 ( v(k,j+1,i) - v(k,j,i) ) & 2808 - ( 5.0_wp * ibit14 * adv_mom_5 & 2809 + ibit13 * adv_mom_3 & 2810 ) * & 2811 ( v(k,j+2,i) - v(k,j-1,i) ) & 2812 + ( ibit14 * adv_mom_5 & 2813 ) * & 2814 ( v(k,j+3,i) - v(k,j-2,i) ) & 2815 2815 ) 2816 2816 ENDDO … … 2819 2819 2820 2820 u_comp(k) = u(k,j-1,i+1) + u(k,j,i+1) - gu 2821 flux_r(k) = u_comp(k) * ( &2822 37.0_wp * ( v(k,j,i+1) + v(k,j,i) ) &2823 - 8.0_wp * ( v(k,j,i+2) + v(k,j,i-1) ) &2821 flux_r(k) = u_comp(k) * ( & 2822 37.0_wp * ( v(k,j,i+1) + v(k,j,i) ) & 2823 - 8.0_wp * ( v(k,j,i+2) + v(k,j,i-1) ) & 2824 2824 + ( v(k,j,i+3) + v(k,j,i-2) ) ) * adv_mom_5 2825 2825 2826 diss_r(k) = - ABS( u_comp(k) ) * ( &2827 10.0_wp * ( v(k,j,i+1) - v(k,j,i) ) &2828 - 5.0_wp * ( v(k,j,i+2) - v(k,j,i-1) ) &2826 diss_r(k) = - ABS( u_comp(k) ) * ( & 2827 10.0_wp * ( v(k,j,i+1) - v(k,j,i) ) & 2828 - 5.0_wp * ( v(k,j,i+2) - v(k,j,i-1) ) & 2829 2829 + ( v(k,j,i+3) - v(k,j,i-2) ) ) * adv_mom_5 2830 2830 2831 2831 2832 2832 v_comp(k) = v(k,j+1,i) + v(k,j,i) 2833 flux_n(k) = ( v_comp(k) - gv ) * ( &2834 37.0_wp * ( v(k,j+1,i) + v(k,j,i) ) &2835 - 8.0_wp * ( v(k,j+2,i) + v(k,j-1,i) ) &2833 flux_n(k) = ( v_comp(k) - gv ) * ( & 2834 37.0_wp * ( v(k,j+1,i) + v(k,j,i) ) & 2835 - 8.0_wp * ( v(k,j+2,i) + v(k,j-1,i) ) & 2836 2836 + ( v(k,j+3,i) + v(k,j-2,i) ) ) * adv_mom_5 2837 2837 2838 diss_n(k) = - ABS( v_comp(k) - gv ) * ( &2839 10.0_wp * ( v(k,j+1,i) - v(k,j,i) ) &2840 - 5.0_wp * ( v(k,j+2,i) - v(k,j-1,i) ) &2838 diss_n(k) = - ABS( v_comp(k) - gv ) * ( & 2839 10.0_wp * ( v(k,j+1,i) - v(k,j,i) ) & 2840 - 5.0_wp * ( v(k,j+2,i) - v(k,j-1,i) ) & 2841 2841 + ( v(k,j+3,i) - v(k,j-2,i) ) ) * adv_mom_5 2842 2842 ENDDO 2843 2843 ! 2844 !-- Now, compute vertical fluxes. Split loop into a part treating the 2844 !-- Now, compute vertical fluxes. Split loop into a part treating the 2845 2845 !-- lowest grid points with indirect indexing, a main loop without 2846 2846 !-- indirect indexing, and a loop for the uppermost grip points with 2847 2847 !-- indirect indexing. This allows better vectorization for the main loop. 2848 !-- First, compute the flux at model surface, which need has to be 2848 !-- First, compute the flux at model surface, which need has to be 2849 2849 !-- calculated explicitly for the tendency at 2850 2850 !-- the first w-level. For topography wall this is done implicitely by … … 2853 2853 diss_t(nzb) = 0.0_wp 2854 2854 w_comp(nzb) = 0.0_wp 2855 2855 2856 2856 DO k = nzb+1, nzb+1 2857 2857 ! … … 2867 2867 2868 2868 w_comp(k) = w(k,j-1,i) + w(k,j,i) 2869 flux_t(k) = w_comp(k) * rho_air_zw(k) * ( &2870 ( 37.0_wp * ibit17 * adv_mom_5 &2871 + 7.0_wp * ibit16 * adv_mom_3 &2872 + ibit15 * adv_mom_1 &2873 ) * &2874 ( v(k+1,j,i) + v(k,j,i) ) &2875 - ( 8.0_wp * ibit17 * adv_mom_5 &2876 + ibit16 * adv_mom_3 &2877 ) * &2878 ( v(k_pp,j,i) + v(k-1,j,i) ) &2879 + ( ibit17 * adv_mom_5 &2880 ) * &2881 ( v(k_ppp,j,i) + v(k_mm,j,i) ) &2869 flux_t(k) = w_comp(k) * rho_air_zw(k) * ( & 2870 ( 37.0_wp * ibit17 * adv_mom_5 & 2871 + 7.0_wp * ibit16 * adv_mom_3 & 2872 + ibit15 * adv_mom_1 & 2873 ) * & 2874 ( v(k+1,j,i) + v(k,j,i) ) & 2875 - ( 8.0_wp * ibit17 * adv_mom_5 & 2876 + ibit16 * adv_mom_3 & 2877 ) * & 2878 ( v(k_pp,j,i) + v(k-1,j,i) ) & 2879 + ( ibit17 * adv_mom_5 & 2880 ) * & 2881 ( v(k_ppp,j,i) + v(k_mm,j,i) ) & 2882 2882 ) 2883 2883 2884 diss_t(k) = - ABS( w_comp(k) ) * rho_air_zw(k) * ( &2885 ( 10.0_wp * ibit17 * adv_mom_5 &2886 + 3.0_wp * ibit16 * adv_mom_3 &2887 + ibit15 * adv_mom_1 &2888 ) * &2889 ( v(k+1,j,i) - v(k,j,i) ) &2890 - ( 5.0_wp * ibit17 * adv_mom_5 &2891 + ibit16 * adv_mom_3 &2892 ) * &2893 ( v(k_pp,j,i) - v(k-1,j,i) ) &2894 + ( ibit17 * adv_mom_5 &2895 ) * &2896 ( v(k_ppp,j,i) - v(k_mm,j,i) ) &2884 diss_t(k) = - ABS( w_comp(k) ) * rho_air_zw(k) * ( & 2885 ( 10.0_wp * ibit17 * adv_mom_5 & 2886 + 3.0_wp * ibit16 * adv_mom_3 & 2887 + ibit15 * adv_mom_1 & 2888 ) * & 2889 ( v(k+1,j,i) - v(k,j,i) ) & 2890 - ( 5.0_wp * ibit17 * adv_mom_5 & 2891 + ibit16 * adv_mom_3 & 2892 ) * & 2893 ( v(k_pp,j,i) - v(k-1,j,i) ) & 2894 + ( ibit17 * adv_mom_5 & 2895 ) * & 2896 ( v(k_ppp,j,i) - v(k_mm,j,i) ) & 2897 2897 ) 2898 2898 ENDDO 2899 2899 2900 2900 DO k = nzb+2, nzt-2 2901 2901 … … 2905 2905 2906 2906 w_comp(k) = w(k,j-1,i) + w(k,j,i) 2907 flux_t(k) = w_comp(k) * rho_air_zw(k) * ( &2908 ( 37.0_wp * ibit17 * adv_mom_5 &2909 + 7.0_wp * ibit16 * adv_mom_3 &2910 + ibit15 * adv_mom_1 &2911 ) * &2912 ( v(k+1,j,i) + v(k,j,i) ) &2913 - ( 8.0_wp * ibit17 * adv_mom_5 &2914 + ibit16 * adv_mom_3 &2915 ) * &2916 ( v(k+2,j,i) + v(k-1,j,i) ) &2917 + ( ibit17 * adv_mom_5 &2918 ) * &2919 ( v(k+3,j,i) + v(k-2,j,i) ) &2907 flux_t(k) = w_comp(k) * rho_air_zw(k) * ( & 2908 ( 37.0_wp * ibit17 * adv_mom_5 & 2909 + 7.0_wp * ibit16 * adv_mom_3 & 2910 + ibit15 * adv_mom_1 & 2911 ) * & 2912 ( v(k+1,j,i) + v(k,j,i) ) & 2913 - ( 8.0_wp * ibit17 * adv_mom_5 & 2914 + ibit16 * adv_mom_3 & 2915 ) * & 2916 ( v(k+2,j,i) + v(k-1,j,i) ) & 2917 + ( ibit17 * adv_mom_5 & 2918 ) * & 2919 ( v(k+3,j,i) + v(k-2,j,i) ) & 2920 2920 ) 2921 2921 2922 diss_t(k) = - ABS( w_comp(k) ) * rho_air_zw(k) * ( &2923 ( 10.0_wp * ibit17 * adv_mom_5 &2924 + 3.0_wp * ibit16 * adv_mom_3 &2925 + ibit15 * adv_mom_1 &2926 ) * &2927 ( v(k+1,j,i) - v(k,j,i) ) &2928 - ( 5.0_wp * ibit17 * adv_mom_5 &2929 + ibit16 * adv_mom_3 &2930 ) * &2922 diss_t(k) = - ABS( w_comp(k) ) * rho_air_zw(k) * ( & 2923 ( 10.0_wp * ibit17 * adv_mom_5 & 2924 + 3.0_wp * ibit16 * adv_mom_3 & 2925 + ibit15 * adv_mom_1 & 2926 ) * & 2927 ( v(k+1,j,i) - v(k,j,i) ) & 2928 - ( 5.0_wp * ibit17 * adv_mom_5 & 2929 + ibit16 * adv_mom_3 & 2930 ) * & 2931 2931 ( v(k+2,j,i) - v(k-1,j,i) ) & 2932 + ( ibit17 * adv_mom_5 &2933 ) * &2934 ( v(k+3,j,i) - v(k-2,j,i) ) &2932 + ( ibit17 * adv_mom_5 & 2933 ) * & 2934 ( v(k+3,j,i) - v(k-2,j,i) ) & 2935 2935 ) 2936 2936 ENDDO 2937 2937 2938 2938 DO k = nzt-1, nzt-symmetry_flag 2939 2939 ! … … 2949 2949 2950 2950 w_comp(k) = w(k,j-1,i) + w(k,j,i) 2951 flux_t(k) = w_comp(k) * rho_air_zw(k) * ( &2952 ( 37.0_wp * ibit17 * adv_mom_5 &2953 + 7.0_wp * ibit16 * adv_mom_3 &2954 + ibit15 * adv_mom_1 &2955 ) * &2956 ( v(k+1,j,i) + v(k,j,i) ) &2957 - ( 8.0_wp * ibit17 * adv_mom_5 &2958 + ibit16 * adv_mom_3 &2959 ) * &2960 ( v(k_pp,j,i) + v(k-1,j,i) ) &2961 + ( ibit17 * adv_mom_5 &2962 ) * &2963 ( v(k_ppp,j,i) + v(k_mm,j,i) ) &2951 flux_t(k) = w_comp(k) * rho_air_zw(k) * ( & 2952 ( 37.0_wp * ibit17 * adv_mom_5 & 2953 + 7.0_wp * ibit16 * adv_mom_3 & 2954 + ibit15 * adv_mom_1 & 2955 ) * & 2956 ( v(k+1,j,i) + v(k,j,i) ) & 2957 - ( 8.0_wp * ibit17 * adv_mom_5 & 2958 + ibit16 * adv_mom_3 & 2959 ) * & 2960 ( v(k_pp,j,i) + v(k-1,j,i) ) & 2961 + ( ibit17 * adv_mom_5 & 2962 ) * & 2963 ( v(k_ppp,j,i) + v(k_mm,j,i) ) & 2964 2964 ) 2965 2965 2966 diss_t(k) = - ABS( w_comp(k) ) * rho_air_zw(k) * ( &2967 ( 10.0_wp * ibit17 * adv_mom_5 &2968 + 3.0_wp * ibit16 * adv_mom_3 &2969 + ibit15 * adv_mom_1 &2970 ) * &2971 ( v(k+1,j,i) - v(k,j,i) ) &2972 - ( 5.0_wp * ibit17 * adv_mom_5 &2973 + ibit16 * adv_mom_3 &2974 ) * &2975 ( v(k_pp,j,i) - v(k-1,j,i) ) &2976 + ( ibit17 * adv_mom_5 &2977 ) * &2978 ( v(k_ppp,j,i) - v(k_mm,j,i) ) &2966 diss_t(k) = - ABS( w_comp(k) ) * rho_air_zw(k) * ( & 2967 ( 10.0_wp * ibit17 * adv_mom_5 & 2968 + 3.0_wp * ibit16 * adv_mom_3 & 2969 + ibit15 * adv_mom_1 & 2970 ) * & 2971 ( v(k+1,j,i) - v(k,j,i) ) & 2972 - ( 5.0_wp * ibit17 * adv_mom_5 & 2973 + ibit16 * adv_mom_3 & 2974 ) * & 2975 ( v(k_pp,j,i) - v(k-1,j,i) ) & 2976 + ( ibit17 * adv_mom_5 & 2977 ) * & 2978 ( v(k_ppp,j,i) - v(k_mm,j,i) ) & 2979 2979 ) 2980 2980 ENDDO 2981 2981 2982 2982 ! 2983 2983 !-- Set resolved/turbulent flux at model top to zero (w-level). In case that 2984 2984 !-- a symmetric behavior between bottom and top shall be guaranteed (closed 2985 !-- channel flow), the flux at nzt is also set to zero. 2985 !-- channel flow), the flux at nzt is also set to zero. 2986 2986 IF ( symmetry_flag == 1 ) THEN 2987 2987 flux_t(nzt) = 0.0_wp … … 2992 2992 diss_t(nzt+1) = 0.0_wp 2993 2993 w_comp(nzt+1) = 0.0_wp 2994 2994 2995 2995 DO k = nzb+1, nzb_max_l 2996 2996 2997 2997 flux_d = flux_t(k-1) 2998 2998 diss_d = diss_t(k-1) 2999 2999 3000 3000 ibit11 = REAL( IBITS(advc_flags_m(k,j,i),11,1), KIND = wp ) 3001 3001 ibit10 = REAL( IBITS(advc_flags_m(k,j,i),10,1), KIND = wp ) 3002 3002 ibit9 = REAL( IBITS(advc_flags_m(k,j,i),9,1), KIND = wp ) 3003 3003 3004 3004 ibit14 = REAL( IBITS(advc_flags_m(k,j,i),14,1), KIND = wp ) 3005 3005 ibit13 = REAL( IBITS(advc_flags_m(k,j,i),13,1), KIND = wp ) 3006 3006 ibit12 = REAL( IBITS(advc_flags_m(k,j,i),12,1), KIND = wp ) 3007 3007 3008 3008 ibit17 = REAL( IBITS(advc_flags_m(k,j,i),17,1), KIND = wp ) 3009 3009 ibit16 = REAL( IBITS(advc_flags_m(k,j,i),16,1), KIND = wp ) … … 3013 3013 !-- correction is needed to overcome numerical instabilities introduced 3014 3014 !-- by a not sufficient reduction of divergences near topography. 3015 div = ( ( ( u_comp(k) + gu ) &3016 * ( ibit9 + ibit10 + ibit11 ) &3017 - ( u(k,j-1,i) + u(k,j,i) ) &3018 * ( &3019 REAL( IBITS(advc_flags_m(k,j,i-1),9,1), KIND = wp ) &3020 + REAL( IBITS(advc_flags_m(k,j,i-1),10,1), KIND = wp ) &3021 + REAL( IBITS(advc_flags_m(k,j,i-1),11,1), KIND = wp ) &3022 ) &3023 ) * ddx &3024 + ( v_comp(k) &3025 * ( ibit12 + ibit13 + ibit14 ) &3026 - ( v(k,j,i) + v(k,j-1,i) ) &3027 * ( &3028 REAL( IBITS(advc_flags_m(k,j-1,i),12,1), KIND = wp ) &3029 + REAL( IBITS(advc_flags_m(k,j-1,i),13,1), KIND = wp ) &3030 + REAL( IBITS(advc_flags_m(k,j-1,i),14,1), KIND = wp ) &3031 ) &3032 ) * ddy &3033 + ( w_comp(k) * rho_air_zw(k) * ( ibit15 + ibit16 + ibit17 ) &3034 - w_comp(k-1) * rho_air_zw(k-1) &3035 * ( &3036 REAL( IBITS(advc_flags_m(k-1,j,i),15,1), KIND = wp ) &3037 + REAL( IBITS(advc_flags_m(k-1,j,i),16,1), KIND = wp ) &3038 + REAL( IBITS(advc_flags_m(k-1,j,i),17,1), KIND = wp ) &3039 ) &3040 ) * drho_air(k) * ddzw(k) &3015 div = ( ( ( u_comp(k) + gu ) & 3016 * ( ibit9 + ibit10 + ibit11 ) & 3017 - ( u(k,j-1,i) + u(k,j,i) ) & 3018 * ( & 3019 REAL( IBITS(advc_flags_m(k,j,i-1),9,1), KIND = wp ) & 3020 + REAL( IBITS(advc_flags_m(k,j,i-1),10,1), KIND = wp ) & 3021 + REAL( IBITS(advc_flags_m(k,j,i-1),11,1), KIND = wp ) & 3022 ) & 3023 ) * ddx & 3024 + ( v_comp(k) & 3025 * ( ibit12 + ibit13 + ibit14 ) & 3026 - ( v(k,j,i) + v(k,j-1,i) ) & 3027 * ( & 3028 REAL( IBITS(advc_flags_m(k,j-1,i),12,1), KIND = wp ) & 3029 + REAL( IBITS(advc_flags_m(k,j-1,i),13,1), KIND = wp ) & 3030 + REAL( IBITS(advc_flags_m(k,j-1,i),14,1), KIND = wp ) & 3031 ) & 3032 ) * ddy & 3033 + ( w_comp(k) * rho_air_zw(k) * ( ibit15 + ibit16 + ibit17 ) & 3034 - w_comp(k-1) * rho_air_zw(k-1) & 3035 * ( & 3036 REAL( IBITS(advc_flags_m(k-1,j,i),15,1), KIND = wp ) & 3037 + REAL( IBITS(advc_flags_m(k-1,j,i),16,1), KIND = wp ) & 3038 + REAL( IBITS(advc_flags_m(k-1,j,i),17,1), KIND = wp ) & 3039 ) & 3040 ) * drho_air(k) * ddzw(k) & 3041 3041 ) * 0.5_wp 3042 3042 3043 tend(k,j,i) = tend(k,j,i) - ( &3044 ( flux_r(k) + diss_r(k) &3045 - flux_l_v(k,j,tn) - diss_l_v(k,j,tn) ) * ddx &3046 + ( flux_n(k) + diss_n(k) &3047 - flux_s_v(k,tn) - diss_s_v(k,tn) ) * ddy &3048 + ( ( flux_t(k) + diss_t(k) ) &3049 - ( flux_d + diss_d ) &3050 ) * drho_air(k) * ddzw(k) &3043 tend(k,j,i) = tend(k,j,i) - ( & 3044 ( flux_r(k) + diss_r(k) & 3045 - flux_l_v(k,j,tn) - diss_l_v(k,j,tn) ) * ddx & 3046 + ( flux_n(k) + diss_n(k) & 3047 - flux_s_v(k,tn) - diss_s_v(k,tn) ) * ddy & 3048 + ( ( flux_t(k) + diss_t(k) ) & 3049 - ( flux_d + diss_d ) & 3050 ) * drho_air(k) * ddzw(k) & 3051 3051 ) + v(k,j,i) * div 3052 3052 … … 3078 3078 3079 3079 ENDDO 3080 3080 3081 3081 DO k = nzb_max_l+1, nzt 3082 3082 … … 3152 3152 INTEGER(iwp) :: k_pp !< k+2 index in disretization, can be modified to avoid segmentation faults 3153 3153 INTEGER(iwp) :: k_ppp !< k+3 index in disretization, can be modified to avoid segmentation faults 3154 INTEGER(iwp) :: nzb_max_l !< index indicating upper bound for order degradation of horizontal advection terms 3154 INTEGER(iwp) :: nzb_max_l !< index indicating upper bound for order degradation of horizontal advection terms 3155 3155 INTEGER(iwp) :: tn !< number of OpenMP thread 3156 3156 3157 3157 REAL(wp) :: ibit18 !< flag indicating 1st-order scheme along x-direction 3158 3158 REAL(wp) :: ibit19 !< flag indicating 3rd-order scheme along x-direction … … 3169 3169 REAL(wp) :: gu !< Galilei-transformation velocity along x 3170 3170 REAL(wp) :: gv !< Galilei-transformation velocity along y 3171 3171 3172 3172 REAL(wp), DIMENSION(nzb:nzt+1) :: diss_n !< discretized artificial dissipation at northward-side of the grid box 3173 3173 REAL(wp), DIMENSION(nzb:nzt+1) :: diss_r !< discretized artificial dissipation at rightward-side of the grid box … … 3180 3180 REAL(wp), DIMENSION(nzb:nzt+1) :: w_comp !< advection velocity along z 3181 3181 ! 3182 !-- Used local modified copy of nzb_max (used to degrade order of 3182 !-- Used local modified copy of nzb_max (used to degrade order of 3183 3183 !-- discretization) at non-cyclic boundaries. Modify only at relevant points 3184 !-- instead of the entire subdomain. This should lead to better 3184 !-- instead of the entire subdomain. This should lead to better 3185 3185 !-- load balance between boundary and non-boundary PEs. 3186 3186 IF( ( bc_dirichlet_l .OR. bc_radiation_l ) .AND. i <= nxl + 2 .OR. & … … 3192 3192 nzb_max_l = nzb_max 3193 3193 END IF 3194 3194 3195 3195 gu = 2.0_wp * u_gtrans 3196 3196 gv = 2.0_wp * v_gtrans … … 3205 3205 3206 3206 v_comp(k) = v(k+1,j,i) + v(k,j,i) - gv 3207 flux_s_w(k,tn) = v_comp(k) * ( &3208 ( 37.0_wp * ibit23 * adv_mom_5 &3209 + 7.0_wp * ibit22 * adv_mom_3 &3210 + ibit21 * adv_mom_1 &3211 ) * &3212 ( w(k,j,i) + w(k,j-1,i) ) &3213 - ( 8.0_wp * ibit23 * adv_mom_5 &3214 + ibit22 * adv_mom_3 &3215 ) * &3216 ( w(k,j+1,i) + w(k,j-2,i) ) &3217 + ( ibit23 * adv_mom_5 &3218 ) * &3219 ( w(k,j+2,i) + w(k,j-3,i) ) &3207 flux_s_w(k,tn) = v_comp(k) * ( & 3208 ( 37.0_wp * ibit23 * adv_mom_5 & 3209 + 7.0_wp * ibit22 * adv_mom_3 & 3210 + ibit21 * adv_mom_1 & 3211 ) * & 3212 ( w(k,j,i) + w(k,j-1,i) ) & 3213 - ( 8.0_wp * ibit23 * adv_mom_5 & 3214 + ibit22 * adv_mom_3 & 3215 ) * & 3216 ( w(k,j+1,i) + w(k,j-2,i) ) & 3217 + ( ibit23 * adv_mom_5 & 3218 ) * & 3219 ( w(k,j+2,i) + w(k,j-3,i) ) & 3220 3220 ) 3221 3221 3222 diss_s_w(k,tn) = - ABS( v_comp(k) ) * ( &3223 ( 10.0_wp * ibit23 * adv_mom_5 &3224 + 3.0_wp * ibit22 * adv_mom_3 &3225 + ibit21 * adv_mom_1 &3226 ) * &3227 ( w(k,j,i) - w(k,j-1,i) ) &3228 - ( 5.0_wp * ibit23 * adv_mom_5 &3229 + ibit22 * adv_mom_3 &3230 ) * &3231 ( w(k,j+1,i) - w(k,j-2,i) ) &3232 + ( ibit23 * adv_mom_5 &3233 ) * &3234 ( w(k,j+2,i) - w(k,j-3,i) ) &3222 diss_s_w(k,tn) = - ABS( v_comp(k) ) * ( & 3223 ( 10.0_wp * ibit23 * adv_mom_5 & 3224 + 3.0_wp * ibit22 * adv_mom_3 & 3225 + ibit21 * adv_mom_1 & 3226 ) * & 3227 ( w(k,j,i) - w(k,j-1,i) ) & 3228 - ( 5.0_wp * ibit23 * adv_mom_5 & 3229 + ibit22 * adv_mom_3 & 3230 ) * & 3231 ( w(k,j+1,i) - w(k,j-2,i) ) & 3232 + ( ibit23 * adv_mom_5 & 3233 ) * & 3234 ( w(k,j+2,i) - w(k,j-3,i) ) & 3235 3235 ) 3236 3236 … … 3240 3240 3241 3241 v_comp(k) = v(k+1,j,i) + v(k,j,i) - gv 3242 flux_s_w(k,tn) = v_comp(k) * ( &3243 37.0_wp * ( w(k,j,i) + w(k,j-1,i) ) &3244 - 8.0_wp * ( w(k,j+1,i) + w(k,j-2,i) ) &3242 flux_s_w(k,tn) = v_comp(k) * ( & 3243 37.0_wp * ( w(k,j,i) + w(k,j-1,i) ) & 3244 - 8.0_wp * ( w(k,j+1,i) + w(k,j-2,i) ) & 3245 3245 + ( w(k,j+2,i) + w(k,j-3,i) ) ) * adv_mom_5 3246 diss_s_w(k,tn) = - ABS( v_comp(k) ) * ( &3247 10.0_wp * ( w(k,j,i) - w(k,j-1,i) ) &3248 - 5.0_wp * ( w(k,j+1,i) - w(k,j-2,i) ) &3246 diss_s_w(k,tn) = - ABS( v_comp(k) ) * ( & 3247 10.0_wp * ( w(k,j,i) - w(k,j-1,i) ) & 3248 - 5.0_wp * ( w(k,j+1,i) - w(k,j-2,i) ) & 3249 3249 + ( w(k,j+2,i) - w(k,j-3,i) ) ) * adv_mom_5 3250 3250 … … 3263 3263 3264 3264 u_comp(k) = u(k+1,j,i) + u(k,j,i) - gu 3265 flux_l_w(k,j,tn) = u_comp(k) * ( &3266 ( 37.0_wp * ibit20 * adv_mom_5 &3267 + 7.0_wp * ibit19 * adv_mom_3 &3268 + ibit18 * adv_mom_1 &3269 ) * &3270 ( w(k,j,i) + w(k,j,i-1) ) &3271 - ( 8.0_wp * ibit20 * adv_mom_5 &3272 + ibit19 * adv_mom_3 &3273 ) * &3274 ( w(k,j,i+1) + w(k,j,i-2) ) &3275 + ( ibit20 * adv_mom_5 &3276 ) * &3277 ( w(k,j,i+2) + w(k,j,i-3) ) &3265 flux_l_w(k,j,tn) = u_comp(k) * ( & 3266 ( 37.0_wp * ibit20 * adv_mom_5 & 3267 + 7.0_wp * ibit19 * adv_mom_3 & 3268 + ibit18 * adv_mom_1 & 3269 ) * & 3270 ( w(k,j,i) + w(k,j,i-1) ) & 3271 - ( 8.0_wp * ibit20 * adv_mom_5 & 3272 + ibit19 * adv_mom_3 & 3273 ) * & 3274 ( w(k,j,i+1) + w(k,j,i-2) ) & 3275 + ( ibit20 * adv_mom_5 & 3276 ) * & 3277 ( w(k,j,i+2) + w(k,j,i-3) ) & 3278 3278 ) 3279 3279 3280 diss_l_w(k,j,tn) = - ABS( u_comp(k) ) * ( &3281 ( 10.0_wp * ibit20 * adv_mom_5 &3282 + 3.0_wp * ibit19 * adv_mom_3 &3283 + ibit18 * adv_mom_1 &3284 ) * &3285 ( w(k,j,i) - w(k,j,i-1) ) &3286 - ( 5.0_wp * ibit20 * adv_mom_5 &3287 + ibit19 * adv_mom_3 &3288 ) * &3289 ( w(k,j,i+1) - w(k,j,i-2) ) &3290 + ( ibit20 * adv_mom_5 &3291 ) * &3292 ( w(k,j,i+2) - w(k,j,i-3) ) &3280 diss_l_w(k,j,tn) = - ABS( u_comp(k) ) * ( & 3281 ( 10.0_wp * ibit20 * adv_mom_5 & 3282 + 3.0_wp * ibit19 * adv_mom_3 & 3283 + ibit18 * adv_mom_1 & 3284 ) * & 3285 ( w(k,j,i) - w(k,j,i-1) ) & 3286 - ( 5.0_wp * ibit20 * adv_mom_5 & 3287 + ibit19 * adv_mom_3 & 3288 ) * & 3289 ( w(k,j,i+1) - w(k,j,i-2) ) & 3290 + ( ibit20 * adv_mom_5 & 3291 ) * & 3292 ( w(k,j,i+2) - w(k,j,i-3) ) & 3293 3293 ) 3294 3294 … … 3298 3298 3299 3299 u_comp(k) = u(k+1,j,i) + u(k,j,i) - gu 3300 flux_l_w(k,j,tn) = u_comp(k) * ( &3301 37.0_wp * ( w(k,j,i) + w(k,j,i-1) ) &3302 - 8.0_wp * ( w(k,j,i+1) + w(k,j,i-2) ) &3300 flux_l_w(k,j,tn) = u_comp(k) * ( & 3301 37.0_wp * ( w(k,j,i) + w(k,j,i-1) ) & 3302 - 8.0_wp * ( w(k,j,i+1) + w(k,j,i-2) ) & 3303 3303 + ( w(k,j,i+2) + w(k,j,i-3) ) ) * adv_mom_5 3304 diss_l_w(k,j,tn) = - ABS( u_comp(k) ) * ( &3305 10.0_wp * ( w(k,j,i) - w(k,j,i-1) ) &3306 - 5.0_wp * ( w(k,j,i+1) - w(k,j,i-2) ) &3307 + ( w(k,j,i+2) - w(k,j,i-3) ) ) * adv_mom_5 3304 diss_l_w(k,j,tn) = - ABS( u_comp(k) ) * ( & 3305 10.0_wp * ( w(k,j,i) - w(k,j,i-1) ) & 3306 - 5.0_wp * ( w(k,j,i+1) - w(k,j,i-2) ) & 3307 + ( w(k,j,i+2) - w(k,j,i-3) ) ) * adv_mom_5 3308 3308 3309 3309 ENDDO … … 3320 3320 3321 3321 u_comp(k) = u(k+1,j,i+1) + u(k,j,i+1) - gu 3322 flux_r(k) = u_comp(k) * ( &3323 ( 37.0_wp * ibit20 * adv_mom_5 &3324 + 7.0_wp * ibit19 * adv_mom_3 &3325 + ibit18 * adv_mom_1 &3326 ) * &3327 ( w(k,j,i+1) + w(k,j,i) ) &3328 - ( 8.0_wp * ibit20 * adv_mom_5 &3329 + ibit19 * adv_mom_3 &3330 ) * &3331 ( w(k,j,i+2) + w(k,j,i-1) ) &3332 + ( ibit20 * adv_mom_5 &3333 ) * &3334 ( w(k,j,i+3) + w(k,j,i-2) ) &3322 flux_r(k) = u_comp(k) * ( & 3323 ( 37.0_wp * ibit20 * adv_mom_5 & 3324 + 7.0_wp * ibit19 * adv_mom_3 & 3325 + ibit18 * adv_mom_1 & 3326 ) * & 3327 ( w(k,j,i+1) + w(k,j,i) ) & 3328 - ( 8.0_wp * ibit20 * adv_mom_5 & 3329 + ibit19 * adv_mom_3 & 3330 ) * & 3331 ( w(k,j,i+2) + w(k,j,i-1) ) & 3332 + ( ibit20 * adv_mom_5 & 3333 ) * & 3334 ( w(k,j,i+3) + w(k,j,i-2) ) & 3335 3335 ) 3336 3336 3337 diss_r(k) = - ABS( u_comp(k) ) * ( &3338 ( 10.0_wp * ibit20 * adv_mom_5 &3339 + 3.0_wp * ibit19 * adv_mom_3 &3340 + ibit18 * adv_mom_1 &3341 ) * &3342 ( w(k,j,i+1) - w(k,j,i) ) &3343 - ( 5.0_wp * ibit20 * adv_mom_5 &3344 + ibit19 * adv_mom_3 &3345 ) * &3346 ( w(k,j,i+2) - w(k,j,i-1) ) &3347 + ( ibit20 * adv_mom_5 &3348 ) * &3349 ( w(k,j,i+3) - w(k,j,i-2) ) &3337 diss_r(k) = - ABS( u_comp(k) ) * ( & 3338 ( 10.0_wp * ibit20 * adv_mom_5 & 3339 + 3.0_wp * ibit19 * adv_mom_3 & 3340 + ibit18 * adv_mom_1 & 3341 ) * & 3342 ( w(k,j,i+1) - w(k,j,i) ) & 3343 - ( 5.0_wp * ibit20 * adv_mom_5 & 3344 + ibit19 * adv_mom_3 & 3345 ) * & 3346 ( w(k,j,i+2) - w(k,j,i-1) ) & 3347 + ( ibit20 * adv_mom_5 & 3348 ) * & 3349 ( w(k,j,i+3) - w(k,j,i-2) ) & 3350 3350 ) 3351 3351 … … 3355 3355 3356 3356 v_comp(k) = v(k+1,j+1,i) + v(k,j+1,i) - gv 3357 flux_n(k) = v_comp(k) * ( &3358 ( 37.0_wp * ibit23 * adv_mom_5 &3359 + 7.0_wp * ibit22 * adv_mom_3 &3360 + ibit21 * adv_mom_1 &3361 ) * &3362 ( w(k,j+1,i) + w(k,j,i) ) &3363 - ( 8.0_wp * ibit23 * adv_mom_5 &3364 + ibit22 * adv_mom_3 &3365 ) * &3366 ( w(k,j+2,i) + w(k,j-1,i) ) &3367 + ( ibit23 * adv_mom_5 &3368 ) * &3369 ( w(k,j+3,i) + w(k,j-2,i) ) &3357 flux_n(k) = v_comp(k) * ( & 3358 ( 37.0_wp * ibit23 * adv_mom_5 & 3359 + 7.0_wp * ibit22 * adv_mom_3 & 3360 + ibit21 * adv_mom_1 & 3361 ) * & 3362 ( w(k,j+1,i) + w(k,j,i) ) & 3363 - ( 8.0_wp * ibit23 * adv_mom_5 & 3364 + ibit22 * adv_mom_3 & 3365 ) * & 3366 ( w(k,j+2,i) + w(k,j-1,i) ) & 3367 + ( ibit23 * adv_mom_5 & 3368 ) * & 3369 ( w(k,j+3,i) + w(k,j-2,i) ) & 3370 3370 ) 3371 3371 3372 diss_n(k) = - ABS( v_comp(k) ) * ( &3373 ( 10.0_wp * ibit23 * adv_mom_5 &3374 + 3.0_wp * ibit22 * adv_mom_3 &3375 + ibit21 * adv_mom_1 &3376 ) * &3377 ( w(k,j+1,i) - w(k,j,i) ) &3378 - ( 5.0_wp * ibit23 * adv_mom_5 &3379 + ibit22 * adv_mom_3 &3380 ) * &3381 ( w(k,j+2,i) - w(k,j-1,i) ) &3382 + ( ibit23 * adv_mom_5 &3383 ) * &3384 ( w(k,j+3,i) - w(k,j-2,i) ) &3372 diss_n(k) = - ABS( v_comp(k) ) * ( & 3373 ( 10.0_wp * ibit23 * adv_mom_5 & 3374 + 3.0_wp * ibit22 * adv_mom_3 & 3375 + ibit21 * adv_mom_1 & 3376 ) * & 3377 ( w(k,j+1,i) - w(k,j,i) ) & 3378 - ( 5.0_wp * ibit23 * adv_mom_5 & 3379 + ibit22 * adv_mom_3 & 3380 ) * & 3381 ( w(k,j+2,i) - w(k,j-1,i) ) & 3382 + ( ibit23 * adv_mom_5 & 3383 ) * & 3384 ( w(k,j+3,i) - w(k,j-2,i) ) & 3385 3385 ) 3386 3386 ENDDO … … 3389 3389 3390 3390 u_comp(k) = u(k+1,j,i+1) + u(k,j,i+1) - gu 3391 flux_r(k) = u_comp(k) * ( &3392 37.0_wp * ( w(k,j,i+1) + w(k,j,i) ) &3393 - 8.0_wp * ( w(k,j,i+2) + w(k,j,i-1) ) &3391 flux_r(k) = u_comp(k) * ( & 3392 37.0_wp * ( w(k,j,i+1) + w(k,j,i) ) & 3393 - 8.0_wp * ( w(k,j,i+2) + w(k,j,i-1) ) & 3394 3394 + ( w(k,j,i+3) + w(k,j,i-2) ) ) * adv_mom_5 3395 3395 3396 diss_r(k) = - ABS( u_comp(k) ) * ( &3397 10.0_wp * ( w(k,j,i+1) - w(k,j,i) ) &3398 - 5.0_wp * ( w(k,j,i+2) - w(k,j,i-1) ) &3396 diss_r(k) = - ABS( u_comp(k) ) * ( & 3397 10.0_wp * ( w(k,j,i+1) - w(k,j,i) ) & 3398 - 5.0_wp * ( w(k,j,i+2) - w(k,j,i-1) ) & 3399 3399 + ( w(k,j,i+3) - w(k,j,i-2) ) ) * adv_mom_5 3400 3400 3401 3401 v_comp(k) = v(k+1,j+1,i) + v(k,j+1,i) - gv 3402 flux_n(k) = v_comp(k) * ( &3403 37.0_wp * ( w(k,j+1,i) + w(k,j,i) ) &3404 - 8.0_wp * ( w(k,j+2,i) + w(k,j-1,i) ) &3402 flux_n(k) = v_comp(k) * ( & 3403 37.0_wp * ( w(k,j+1,i) + w(k,j,i) ) & 3404 - 8.0_wp * ( w(k,j+2,i) + w(k,j-1,i) ) & 3405 3405 + ( w(k,j+3,i) + w(k,j-2,i) ) ) * adv_mom_5 3406 3406 3407 diss_n(k) = - ABS( v_comp(k) ) * ( &3408 10.0_wp * ( w(k,j+1,i) - w(k,j,i) ) &3409 - 5.0_wp * ( w(k,j+2,i) - w(k,j-1,i) ) &3407 diss_n(k) = - ABS( v_comp(k) ) * ( & 3408 10.0_wp * ( w(k,j+1,i) - w(k,j,i) ) & 3409 - 5.0_wp * ( w(k,j+2,i) - w(k,j-1,i) ) & 3410 3410 + ( w(k,j+3,i) - w(k,j-2,i) ) ) * adv_mom_5 3411 3411 ENDDO 3412 3412 3413 3413 ! 3414 !-- Now, compute vertical fluxes. Split loop into a part treating the 3414 !-- Now, compute vertical fluxes. Split loop into a part treating the 3415 3415 !-- lowest grid points with indirect indexing, a main loop without 3416 3416 !-- indirect indexing, and a loop for the uppermost grip points with 3417 3417 !-- indirect indexing. This allows better vectorization for the main loop. 3418 !-- First, compute the flux at model surface, which need has to be 3418 !-- First, compute the flux at model surface, which need has to be 3419 3419 !-- calculated explicitly for the tendency at 3420 3420 !-- the first w-level. For topography wall this is done implicitely by 3421 !-- advc_flags_m. 3421 !-- advc_flags_m. First, compute flux at lowest level, located at z=dz/2. 3422 3422 k = nzb + 1 3423 3423 w_comp(k) = w(k,j,i) + w(k-1,j,i) … … 3426 3426 diss_t(0) = -ABS(w_comp(k)) * rho_air(k) & 3427 3427 * ( w(k,j,i) - w(k-1,j,i) ) * adv_mom_1 3428 3428 3429 3429 DO k = nzb+1, nzb+1 3430 3430 ! … … 3440 3440 3441 3441 w_comp(k) = w(k+1,j,i) + w(k,j,i) 3442 flux_t(k) = w_comp(k) * rho_air(k+1) * ( &3443 ( 37.0_wp * ibit26 * adv_mom_5 &3444 + 7.0_wp * ibit25 * adv_mom_3 &3445 + ibit24 * adv_mom_1 &3446 ) * &3447 ( w(k+1,j,i) + w(k,j,i) ) &3448 - ( 8.0_wp * ibit26 * adv_mom_5 &3449 + ibit25 * adv_mom_3 &3450 ) * &3451 ( w(k_pp,j,i) + w(k-1,j,i) ) &3452 + ( ibit26 * adv_mom_5 &3453 ) * &3454 ( w(k_ppp,j,i) + w(k_mm,j,i) ) &3442 flux_t(k) = w_comp(k) * rho_air(k+1) * ( & 3443 ( 37.0_wp * ibit26 * adv_mom_5 & 3444 + 7.0_wp * ibit25 * adv_mom_3 & 3445 + ibit24 * adv_mom_1 & 3446 ) * & 3447 ( w(k+1,j,i) + w(k,j,i) ) & 3448 - ( 8.0_wp * ibit26 * adv_mom_5 & 3449 + ibit25 * adv_mom_3 & 3450 ) * & 3451 ( w(k_pp,j,i) + w(k-1,j,i) ) & 3452 + ( ibit26 * adv_mom_5 & 3453 ) * & 3454 ( w(k_ppp,j,i) + w(k_mm,j,i) ) & 3455 3455 ) 3456 3456 3457 diss_t(k) = - ABS( w_comp(k) ) * rho_air(k+1) * ( &3458 ( 10.0_wp * ibit26 * adv_mom_5 &3459 + 3.0_wp * ibit25 * adv_mom_3 &3460 + ibit24 * adv_mom_1 &3461 ) * &3462 ( w(k+1,j,i) - w(k,j,i) ) &3463 - ( 5.0_wp * ibit26 * adv_mom_5 &3464 + ibit25 * adv_mom_3 &3465 ) * &3466 ( w(k_pp,j,i) - w(k-1,j,i) ) &3467 + ( ibit26 * adv_mom_5 &3468 ) * &3469 ( w(k_ppp,j,i) - w(k_mm,j,i) ) &3457 diss_t(k) = - ABS( w_comp(k) ) * rho_air(k+1) * ( & 3458 ( 10.0_wp * ibit26 * adv_mom_5 & 3459 + 3.0_wp * ibit25 * adv_mom_3 & 3460 + ibit24 * adv_mom_1 & 3461 ) * & 3462 ( w(k+1,j,i) - w(k,j,i) ) & 3463 - ( 5.0_wp * ibit26 * adv_mom_5 & 3464 + ibit25 * adv_mom_3 & 3465 ) * & 3466 ( w(k_pp,j,i) - w(k-1,j,i) ) & 3467 + ( ibit26 * adv_mom_5 & 3468 ) * & 3469 ( w(k_ppp,j,i) - w(k_mm,j,i) ) & 3470 3470 ) 3471 3471 ENDDO 3472 3472 3473 3473 DO k = nzb+2, nzt-2 3474 3474 3475 3475 ibit26 = REAL( IBITS(advc_flags_m(k,j,i),26,1), KIND = wp ) 3476 3476 ibit25 = REAL( IBITS(advc_flags_m(k,j,i),25,1), KIND = wp ) … … 3478 3478 3479 3479 w_comp(k) = w(k+1,j,i) + w(k,j,i) 3480 flux_t(k) = w_comp(k) * rho_air(k+1) * ( &3481 ( 37.0_wp * ibit26 * adv_mom_5 &3482 + 7.0_wp * ibit25 * adv_mom_3 &3483 + ibit24 * adv_mom_1 &3484 ) * &3485 ( w(k+1,j,i) + w(k,j,i) ) &3486 - ( 8.0_wp * ibit26 * adv_mom_5 &3487 + ibit25 * adv_mom_3 &3488 ) * &3489 ( w(k+2,j,i) + w(k-1,j,i) ) &3490 + ( ibit26 * adv_mom_5 &3491 ) * &3492 ( w(k+3,j,i) + w(k-2,j,i) ) &3480 flux_t(k) = w_comp(k) * rho_air(k+1) * ( & 3481 ( 37.0_wp * ibit26 * adv_mom_5 & 3482 + 7.0_wp * ibit25 * adv_mom_3 & 3483 + ibit24 * adv_mom_1 & 3484 ) * & 3485 ( w(k+1,j,i) + w(k,j,i) ) & 3486 - ( 8.0_wp * ibit26 * adv_mom_5 & 3487 + ibit25 * adv_mom_3 & 3488 ) * & 3489 ( w(k+2,j,i) + w(k-1,j,i) ) & 3490 + ( ibit26 * adv_mom_5 & 3491 ) * & 3492 ( w(k+3,j,i) + w(k-2,j,i) ) & 3493 3493 ) 3494 3494 3495 diss_t(k) = - ABS( w_comp(k) ) * rho_air(k+1) * ( &3496 ( 10.0_wp * ibit26 * adv_mom_5 &3497 + 3.0_wp * ibit25 * adv_mom_3 &3498 + ibit24 * adv_mom_1 &3499 ) * &3500 ( w(k+1,j,i) - w(k,j,i) ) &3501 - ( 5.0_wp * ibit26 * adv_mom_5 &3502 + ibit25 * adv_mom_3 &3503 ) * &3504 ( w(k+2,j,i) - w(k-1,j,i) ) &3505 + ( ibit26 * adv_mom_5 &3506 ) * &3507 ( w(k+3,j,i) - w(k-2,j,i) ) &3495 diss_t(k) = - ABS( w_comp(k) ) * rho_air(k+1) * ( & 3496 ( 10.0_wp * ibit26 * adv_mom_5 & 3497 + 3.0_wp * ibit25 * adv_mom_3 & 3498 + ibit24 * adv_mom_1 & 3499 ) * & 3500 ( w(k+1,j,i) - w(k,j,i) ) & 3501 - ( 5.0_wp * ibit26 * adv_mom_5 & 3502 + ibit25 * adv_mom_3 & 3503 ) * & 3504 ( w(k+2,j,i) - w(k-1,j,i) ) & 3505 + ( ibit26 * adv_mom_5 & 3506 ) * & 3507 ( w(k+3,j,i) - w(k-2,j,i) ) & 3508 3508 ) 3509 3509 ENDDO 3510 3510 3511 3511 DO k = nzt-1, nzt-1 3512 3512 ! … … 3522 3522 3523 3523 w_comp(k) = w(k+1,j,i) + w(k,j,i) 3524 flux_t(k) = w_comp(k) * rho_air(k+1) * ( &3525 ( 37.0_wp * ibit26 * adv_mom_5 &3526 + 7.0_wp * ibit25 * adv_mom_3 &3527 + ibit24 * adv_mom_1 &3528 ) * &3529 ( w(k+1,j,i) + w(k,j,i) ) &3530 - ( 8.0_wp * ibit26 * adv_mom_5 &3531 + ibit25 * adv_mom_3 &3532 ) * &3533 ( w(k_pp,j,i) + w(k-1,j,i) ) &3534 + ( ibit26 * adv_mom_5 &3535 ) * &3536 ( w(k_ppp,j,i) + w(k_mm,j,i) ) &3524 flux_t(k) = w_comp(k) * rho_air(k+1) * ( & 3525 ( 37.0_wp * ibit26 * adv_mom_5 & 3526 + 7.0_wp * ibit25 * adv_mom_3 & 3527 + ibit24 * adv_mom_1 & 3528 ) * & 3529 ( w(k+1,j,i) + w(k,j,i) ) & 3530 - ( 8.0_wp * ibit26 * adv_mom_5 & 3531 + ibit25 * adv_mom_3 & 3532 ) * & 3533 ( w(k_pp,j,i) + w(k-1,j,i) ) & 3534 + ( ibit26 * adv_mom_5 & 3535 ) * & 3536 ( w(k_ppp,j,i) + w(k_mm,j,i) ) & 3537 3537 ) 3538 3538 3539 diss_t(k) = - ABS( w_comp(k) ) * rho_air(k+1) * ( &3540 ( 10.0_wp * ibit26 * adv_mom_5 &3541 + 3.0_wp * ibit25 * adv_mom_3 &3542 + ibit24 * adv_mom_1 &3543 ) * &3544 ( w(k+1,j,i) - w(k,j,i) ) &3545 - ( 5.0_wp * ibit26 * adv_mom_5 &3546 + ibit25 * adv_mom_3 &3547 ) * &3548 ( w(k_pp,j,i) - w(k-1,j,i) ) &3549 + ( ibit26 * adv_mom_5 &3550 ) * &3551 ( w(k_ppp,j,i) - w(k_mm,j,i) ) &3539 diss_t(k) = - ABS( w_comp(k) ) * rho_air(k+1) * ( & 3540 ( 10.0_wp * ibit26 * adv_mom_5 & 3541 + 3.0_wp * ibit25 * adv_mom_3 & 3542 + ibit24 * adv_mom_1 & 3543 ) * & 3544 ( w(k+1,j,i) - w(k,j,i) ) & 3545 - ( 5.0_wp * ibit26 * adv_mom_5 & 3546 + ibit25 * adv_mom_3 & 3547 ) * & 3548 ( w(k_pp,j,i) - w(k-1,j,i) ) & 3549 + ( ibit26 * adv_mom_5 & 3550 ) * & 3551 ( w(k_ppp,j,i) - w(k_mm,j,i) ) & 3552 3552 ) 3553 3553 ENDDO 3554 3555 ! 3556 !-- Set resolved/turbulent flux at model top to zero (w-level). Hint: The 3554 3555 ! 3556 !-- Set resolved/turbulent flux at model top to zero (w-level). Hint: The 3557 3557 !-- flux at nzt is defined at the scalar grid point nzt+1. Therefore, the 3558 3558 !-- flux at nzt+1 is already outside of the model domain … … 3560 3560 diss_t(nzt) = 0.0_wp 3561 3561 w_comp(nzt) = 0.0_wp 3562 3562 3563 3563 flux_t(nzt+1) = 0.0_wp 3564 3564 diss_t(nzt+1) = 0.0_wp 3565 3565 w_comp(nzt+1) = 0.0_wp 3566 3566 3567 3567 DO k = nzb+1, nzb_max_l 3568 3568 3569 3569 flux_d = flux_t(k-1) 3570 3570 diss_d = diss_t(k-1) 3571 3571 3572 3572 ibit20 = REAL( IBITS(advc_flags_m(k,j,i),20,1), KIND = wp ) 3573 3573 ibit19 = REAL( IBITS(advc_flags_m(k,j,i),19,1), KIND = wp ) 3574 3574 ibit18 = REAL( IBITS(advc_flags_m(k,j,i),18,1), KIND = wp ) 3575 3575 3576 3576 ibit23 = REAL( IBITS(advc_flags_m(k,j,i),23,1), KIND = wp ) 3577 3577 ibit22 = REAL( IBITS(advc_flags_m(k,j,i),22,1), KIND = wp ) 3578 3578 ibit21 = REAL( IBITS(advc_flags_m(k,j,i),21,1), KIND = wp ) 3579 3579 3580 3580 ibit26 = REAL( IBITS(advc_flags_m(k,j,i),26,1), KIND = wp ) 3581 3581 ibit25 = REAL( IBITS(advc_flags_m(k,j,i),25,1), KIND = wp ) … … 3585 3585 !-- correction is needed to overcome numerical instabilities introduced 3586 3586 !-- by a not sufficient reduction of divergences near topography. 3587 div = ( ( ( u_comp(k) + gu ) * ( ibit18 + ibit19 + ibit20 ) & 3588 - ( u(k+1,j,i) + u(k,j,i) ) & 3589 * ( & 3590 REAL( IBITS(advc_flags_m(k,j,i-1),18,1), KIND = wp ) & 3591 + REAL( IBITS(advc_flags_m(k,j,i-1),19,1), KIND = wp ) & 3592 + REAL( IBITS(advc_flags_m(k,j,i-1),20,1), KIND = wp ) & 3593 ) & 3594 ) * ddx & 3595 + ( ( v_comp(k) + gv ) * ( ibit21 + ibit22 + ibit23 ) & 3596 - ( v(k+1,j,i) + v(k,j,i) ) & 3597 * ( & 3598 REAL( IBITS(advc_flags_m(k,j-1,i),21,1), KIND = wp ) & 3599 + REAL( IBITS(advc_flags_m(k,j-1,i),22,1), KIND = wp ) & 3600 + REAL( IBITS(advc_flags_m(k,j-1,i),23,1), KIND = wp ) & 3601 ) & 3602 ) * ddy & 3603 + ( w_comp(k) * rho_air(k+1) & 3604 * ( ibit24 + ibit25 + ibit26 ) & 3605 - ( w(k,j,i) + w(k-1,j,i) ) * rho_air(k) & 3606 * ( & 3607 REAL( IBITS(advc_flags_m(k-1,j,i),24,1), KIND = wp ) & 3608 + REAL( IBITS(advc_flags_m(k-1,j,i),25,1), KIND = wp ) & 3609 + REAL( IBITS(advc_flags_m(k-1,j,i),26,1), KIND = wp ) & 3610 ) & 3611 ) * drho_air_zw(k) * ddzu(k+1) & 3612 ) * 0.5_wp 3613 3614 tend(k,j,i) = tend(k,j,i) - ( & 3615 ( flux_r(k) + diss_r(k) & 3616 - flux_l_w(k,j,tn) - diss_l_w(k,j,tn) ) * ddx & 3617 + ( flux_n(k) + diss_n(k) & 3618 - flux_s_w(k,tn) - diss_s_w(k,tn) ) * ddy & 3619 + ( ( flux_t(k) + diss_t(k) ) & 3620 - ( flux_d + diss_d ) & 3621 ) * drho_air_zw(k) * ddzu(k+1) & 3622 ) + div * w(k,j,i) 3623 3624 flux_l_w(k,j,tn) = flux_r(k) 3625 diss_l_w(k,j,tn) = diss_r(k) 3626 flux_s_w(k,tn) = flux_n(k) 3627 diss_s_w(k,tn) = diss_n(k) 3628 ! 3629 !-- Statistical Evaluation of w'w'. 3630 sums_ws2_ws_l(k,tn) = sums_ws2_ws_l(k,tn) & 3631 + ( flux_t(k) & 3632 * ( w_comp(k) - 2.0_wp * hom(k,1,3,0) ) & 3633 / ( w_comp(k) + SIGN( 1.0E-20_wp, w_comp(k) ) ) & 3634 + diss_t(k) & 3635 * ABS( w_comp(k) - 2.0_wp * hom(k,1,3,0) ) & 3636 / ( ABS( w_comp(k) ) + 1.0E-20_wp ) & 3637 ) * weight_substep(intermediate_timestep_count) 3638 3639 ENDDO 3640 3641 DO k = nzb_max_l+1, nzt-1 3642 3643 flux_d = flux_t(k-1) 3644 diss_d = diss_t(k-1) 3645 ! 3646 !-- Calculate the divergence of the velocity field. A respective 3647 !-- correction is needed to overcome numerical instabilities introduced 3648 !-- by a not sufficient reduction of divergences near topography. 3649 div = ( ( u_comp(k) + gu - ( u(k+1,j,i) + u(k,j,i) ) ) * ddx & 3650 + ( v_comp(k) + gv - ( v(k+1,j,i) + v(k,j,i) ) ) * ddy & 3587 div = ( ( ( u_comp(k) + gu ) * ( ibit18 + ibit19 + ibit20 ) & 3588 - ( u(k+1,j,i) + u(k,j,i) ) & 3589 * ( & 3590 REAL( IBITS(advc_flags_m(k,j,i-1),18,1), KIND = wp ) & 3591 + REAL( IBITS(advc_flags_m(k,j,i-1),19,1), KIND = wp ) & 3592 + REAL( IBITS(advc_flags_m(k,j,i-1),20,1), KIND = wp ) & 3593 ) & 3594 ) * ddx & 3595 + ( ( v_comp(k) + gv ) * ( ibit21 + ibit22 + ibit23 ) & 3596 - ( v(k+1,j,i) + v(k,j,i) ) & 3597 * ( & 3598 REAL( IBITS(advc_flags_m(k,j-1,i),21,1), KIND = wp ) & 3599 + REAL( IBITS(advc_flags_m(k,j-1,i),22,1), KIND = wp ) & 3600 + REAL( IBITS(advc_flags_m(k,j-1,i),23,1), KIND = wp ) & 3601 ) & 3602 ) * ddy & 3651 3603 + ( w_comp(k) * rho_air(k+1) & 3652 - ( w(k,j,i) + w(k-1,j,i) ) * rho_air(k) & 3604 * ( ibit24 + ibit25 + ibit26 ) & 3605 - ( w(k,j,i) + w(k-1,j,i) ) * rho_air(k) & 3606 * ( & 3607 REAL( IBITS(advc_flags_m(k-1,j,i),24,1), KIND = wp ) & 3608 + REAL( IBITS(advc_flags_m(k-1,j,i),25,1), KIND = wp ) & 3609 + REAL( IBITS(advc_flags_m(k-1,j,i),26,1), KIND = wp ) & 3610 ) & 3653 3611 ) * drho_air_zw(k) * ddzu(k+1) & 3654 3612 ) * 0.5_wp … … 3681 3639 ENDDO 3682 3640 3641 DO k = nzb_max_l+1, nzt-1 3642 3643 flux_d = flux_t(k-1) 3644 diss_d = diss_t(k-1) 3645 ! 3646 !-- Calculate the divergence of the velocity field. A respective 3647 !-- correction is needed to overcome numerical instabilities introduced 3648 !-- by a not sufficient reduction of divergences near topography. 3649 div = ( ( u_comp(k) + gu - ( u(k+1,j,i) + u(k,j,i) ) ) * ddx & 3650 + ( v_comp(k) + gv - ( v(k+1,j,i) + v(k,j,i) ) ) * ddy & 3651 + ( w_comp(k) * rho_air(k+1) & 3652 - ( w(k,j,i) + w(k-1,j,i) ) * rho_air(k) & 3653 ) * drho_air_zw(k) * ddzu(k+1) & 3654 ) * 0.5_wp 3655 3656 tend(k,j,i) = tend(k,j,i) - ( & 3657 ( flux_r(k) + diss_r(k) & 3658 - flux_l_w(k,j,tn) - diss_l_w(k,j,tn) ) * ddx & 3659 + ( flux_n(k) + diss_n(k) & 3660 - flux_s_w(k,tn) - diss_s_w(k,tn) ) * ddy & 3661 + ( ( flux_t(k) + diss_t(k) ) & 3662 - ( flux_d + diss_d ) & 3663 ) * drho_air_zw(k) * ddzu(k+1) & 3664 ) + div * w(k,j,i) 3665 3666 flux_l_w(k,j,tn) = flux_r(k) 3667 diss_l_w(k,j,tn) = diss_r(k) 3668 flux_s_w(k,tn) = flux_n(k) 3669 diss_s_w(k,tn) = diss_n(k) 3670 ! 3671 !-- Statistical Evaluation of w'w'. 3672 sums_ws2_ws_l(k,tn) = sums_ws2_ws_l(k,tn) & 3673 + ( flux_t(k) & 3674 * ( w_comp(k) - 2.0_wp * hom(k,1,3,0) ) & 3675 / ( w_comp(k) + SIGN( 1.0E-20_wp, w_comp(k) ) ) & 3676 + diss_t(k) & 3677 * ABS( w_comp(k) - 2.0_wp * hom(k,1,3,0) ) & 3678 / ( ABS( w_comp(k) ) + 1.0E-20_wp ) & 3679 ) * weight_substep(intermediate_timestep_count) 3680 3681 ENDDO 3682 3683 3683 END SUBROUTINE advec_w_ws_ij 3684 3684 3685 3685 3686 3686 !------------------------------------------------------------------------------! … … 3694 3694 3695 3695 3696 CHARACTER (LEN = *), INTENT(IN) :: sk_char !< string identifier, used for assign fluxes to the correct dimension in the analysis array 3697 INTEGER(iwp) :: sk_num !< integer identifier, used for assign fluxes to the correct dimension in the analysis array 3698 3699 INTEGER(iwp) :: i !< grid index along x-direction 3700 INTEGER(iwp) :: j !< grid index along y-direction 3701 INTEGER(iwp) :: k !< grid index along z-direction 3702 INTEGER(iwp) :: k_mm !< k-2 index in disretization, can be modified to avoid segmentation faults 3703 INTEGER(iwp) :: k_pp !< k+2 index in disretization, can be modified to avoid segmentation faults 3704 INTEGER(iwp) :: k_ppp !< k+3 index in disretization, can be modified to avoid segmentation faults 3705 INTEGER(iwp) :: nzb_max_l !< index indicating upper bound for order degradation of horizontal advection terms 3706 INTEGER(iwp) :: tn = 0 !< number of OpenMP thread 3707 3696 CHARACTER (LEN = *), INTENT(IN) :: sk_char !< string identifier, used for assign fluxes 3697 !< to the correct dimension in the analysis array 3698 3699 INTEGER(iwp) :: i !< grid index along x-direction 3700 INTEGER(iwp) :: j !< grid index along y-direction 3701 INTEGER(iwp) :: k !< grid index along z-direction 3702 INTEGER(iwp) :: k_mm !< k-2 index in disretization, can be modified to avoid segmentation faults 3703 INTEGER(iwp) :: k_pp !< k+2 index in disretization, can be modified to avoid segmentation faults 3704 INTEGER(iwp) :: k_ppp !< k+3 index in disretization, can be modified to avoid segmentation faults 3705 INTEGER(iwp) :: nzb_max_l !< index indicating upper bound for order degradation of horizontal advection terms 3706 INTEGER(iwp) :: sk_num !< integer identifier, used for assign fluxes to the correct dimension in the analysis array 3707 INTEGER(iwp) :: tn = 0 !< number of OpenMP thread 3708 3708 3709 INTEGER(iwp), INTENT(IN), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg) :: & 3709 3710 advc_flag !< flag array to control order of scalar advection 3710 3711 LOGICAL :: non_cyclic_l !< flag that indicates non-cyclic boundary on the left 3712 LOGICAL :: non_cyclic_n !< flag that indicates non-cyclic boundary on the north 3713 LOGICAL :: non_cyclic_r !< flag that indicates non-cyclic boundary on the right 3714 LOGICAL :: non_cyclic_s !< flag that indicates non-cyclic boundary on the south 3715 ! 3716 !-- sk is an array from parameter list. It should not be a pointer, because 3717 !-- in that case the compiler can not assume a stride 1 and cannot perform 3718 !-- a strided one vector load. Adding the CONTIGUOUS keyword makes things 3719 !-- even worse, because the compiler cannot assume strided one in the 3720 !-- caller side. 3721 REAL(wp), INTENT(IN), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg) :: sk !< advected scalar 3722 3723 REAL(wp) :: ibit0 !< flag indicating 1st-order scheme along x-direction 3724 REAL(wp) :: ibit1 !< flag indicating 3rd-order scheme along x-direction 3725 REAL(wp) :: ibit2 !< flag indicating 5th-order scheme along x-direction 3711 3712 LOGICAL :: non_cyclic_l !< flag that indicates non-cyclic boundary on the left 3713 LOGICAL :: non_cyclic_n !< flag that indicates non-cyclic boundary on the north 3714 LOGICAL :: non_cyclic_r !< flag that indicates non-cyclic boundary on the right 3715 LOGICAL :: non_cyclic_s !< flag that indicates non-cyclic boundary on the south 3716 3717 REAL(wp) :: diss_d !< artificial dissipation term at grid box bottom 3718 REAL(wp) :: div !< velocity diverence on scalar grid 3719 REAL(wp) :: flux_d !< 6th-order flux at grid box bottom 3720 REAL(wp) :: ibit0 !< flag indicating 1st-order scheme along x-direction 3721 REAL(wp) :: ibit1 !< flag indicating 3rd-order scheme along x-direction 3722 REAL(wp) :: ibit2 !< flag indicating 5th-order scheme along x-direction 3723 REAL(wp) :: ibit3 !< flag indicating 1st-order scheme along y-direction 3724 REAL(wp) :: ibit4 !< flag indicating 3rd-order scheme along y-direction 3725 REAL(wp) :: ibit5 !< flag indicating 5th-order scheme along y-direction 3726 REAL(wp) :: ibit6 !< flag indicating 1st-order scheme along z-direction 3727 REAL(wp) :: ibit7 !< flag indicating 3rd-order scheme along z-direction 3728 REAL(wp) :: ibit8 !< flag indicating 5th-order scheme along z-direction 3726 3729 #ifdef _OPENACC 3727 3730 REAL(wp) :: ibit0_l !< flag indicating 1st-order scheme along x-direction 3728 3731 REAL(wp) :: ibit1_l !< flag indicating 3rd-order scheme along x-direction 3729 3732 REAL(wp) :: ibit2_l !< flag indicating 5th-order scheme along x-direction 3730 #endif3731 REAL(wp) :: ibit3 !< flag indicating 1st-order scheme along y-direction3732 REAL(wp) :: ibit4 !< flag indicating 3rd-order scheme along y-direction3733 REAL(wp) :: ibit5 !< flag indicating 5th-order scheme along y-direction3734 #ifdef _OPENACC3735 3733 REAL(wp) :: ibit3_s !< flag indicating 1st-order scheme along y-direction 3736 3734 REAL(wp) :: ibit4_s !< flag indicating 3rd-order scheme along y-direction 3737 3735 REAL(wp) :: ibit5_s !< flag indicating 5th-order scheme along y-direction 3738 3736 #endif 3739 REAL(wp) :: ibit6 !< flag indicating 1st-order scheme along z-direction 3740 REAL(wp) :: ibit7 !< flag indicating 3rd-order scheme along z-direction 3741 REAL(wp) :: ibit8 !< flag indicating 5th-order scheme along z-direction 3742 REAL(wp) :: diss_d !< artificial dissipation term at grid box bottom 3743 REAL(wp) :: div !< diverence on scalar grid 3744 REAL(wp) :: flux_d !< 6th-order flux at grid box bottom 3745 REAL(wp) :: u_comp !< advection velocity along x-direction 3737 REAL(wp) :: u_comp !< advection velocity along x-direction 3738 REAL(wp) :: v_comp !< advection velocity along y-direction 3746 3739 #ifdef _OPENACC 3747 3740 REAL(wp) :: u_comp_l !< advection velocity along x-direction 3748 #endif3749 REAL(wp) :: v_comp !< advection velocity along y-direction3750 #ifdef _OPENACC3751 3741 REAL(wp) :: v_comp_s !< advection velocity along y-direction 3752 3742 #endif 3753 3754 REAL(wp) :: diss_n !< discretized artificial dissipation at northward-side of the grid box 3755 REAL(wp) :: diss_r !< discretized artificial dissipation at rightward-side of the grid box 3756 REAL(wp) :: diss_t !< discretized artificial dissipation at rightward-side of the grid box 3757 REAL(wp) :: flux_n !< discretized 6th-order flux at northward-side of the grid box 3758 REAL(wp) :: flux_r !< discretized 6th-order flux at rightward-side of the grid box 3759 REAL(wp) :: flux_t !< discretized 6th-order flux at rightward-side of the grid box 3760 3761 REAL(wp) :: diss_s !< discretized artificial dissipation term at southward-side of the grid box 3762 REAL(wp) :: flux_s !< discretized 6th-order flux at northward-side of the grid box 3763 #ifndef _OPENACC 3764 REAL(wp), DIMENSION(nzb+1:nzt) :: swap_diss_y_local !< discretized artificial dissipation term at southward-side of the grid box 3765 REAL(wp), DIMENSION(nzb+1:nzt) :: swap_flux_y_local !< discretized 6th-order flux at northward-side of the grid box 3766 #endif 3767 3768 REAL(wp) :: diss_l !< discretized artificial dissipation term at leftward-side of the grid box 3769 REAL(wp) :: flux_l !< discretized 6th-order flux at leftward-side of the grid box 3770 #ifndef _OPENACC 3771 REAL(wp), DIMENSION(nzb+1:nzt,nys:nyn) :: swap_diss_x_local !< discretized artificial dissipation term at leftward-side of the grid box 3772 REAL(wp), DIMENSION(nzb+1:nzt,nys:nyn) :: swap_flux_x_local !< discretized 6th-order flux at leftward-side of the grid box 3773 #endif 3774 3775 ! 3776 !-- Set local version of nzb_max. At non-cyclic boundaries the order of the 3777 !-- advection need to be degraded near the boundary. Please note, in contrast 3778 !-- to the cache-optimized routines, nzb_max_l is set constantly for the 3779 !-- entire subdomain, in order to avoid unsymmetric loops which might be 3780 !-- an issue for GPUs. 3781 IF( non_cyclic_l .OR. non_cyclic_r .OR. & 3782 non_cyclic_s .OR. non_cyclic_n ) THEN 3783 nzb_max_l = nzt 3784 ELSE 3785 nzb_max_l = nzb_max 3786 END IF 3787 3743 ! 3744 !-- sk is an array from parameter list. It should not be a pointer, because 3745 !-- in that case the compiler can not assume a stride 1 and cannot perform 3746 !-- a strided one vector load. Adding the CONTIGUOUS keyword makes things 3747 !-- even worse, because the compiler cannot assume strided one in the 3748 !-- caller side. 3749 REAL(wp), INTENT(IN),DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg) :: sk !< advected scalar 3750 3751 REAL(wp), DIMENSION(nzb:nzt+1) :: diss_n !< discretized artificial dissipation at northward-side 3752 REAL(wp), DIMENSION(nzb:nzt+1) :: diss_r !< discretized artificial dissipation at rightward-side 3753 REAL(wp), DIMENSION(nzb:nzt+1) :: diss_t !< discretized artificial dissipation at top of the grid box 3754 REAL(wp), DIMENSION(nzb:nzt+1) :: flux_n !< discretized 6th-order flux at northward-side of the grid box 3755 REAL(wp), DIMENSION(nzb:nzt+1) :: flux_r !< discretized 6th-order flux at rightward-side of the grid box 3756 REAL(wp), DIMENSION(nzb:nzt+1) :: flux_t !< discretized 6th-order flux at top of the grid box 3757 3758 REAL(wp), DIMENSION(nzb+1:nzt,0:threads_per_task-1) :: swap_diss_y_local !< discretized artificial dissipation at southward-side 3759 REAL(wp), DIMENSION(nzb+1:nzt,0:threads_per_task-1) :: swap_flux_y_local !< discretized 6th-order flux at northward-side 3760 3761 REAL(wp), DIMENSION(nzb+1:nzt,nys:nyn,0:threads_per_task-1) :: swap_diss_x_local !< discretized artificial dissipation at leftward-side 3762 REAL(wp), DIMENSION(nzb+1:nzt,nys:nyn,0:threads_per_task-1) :: swap_flux_x_local !< discretized 6th-order flux at leftward-side 3763 3764 CALL cpu_log( log_point_s(49), 'advec_s_ws', 'start' ) 3765 3788 3766 SELECT CASE ( sk_char ) 3789 3767 … … 3811 3789 END SELECT 3812 3790 3813 #ifndef _OPENACC3814 !3815 !-- Compute the fluxes for the whole left boundary of the processor domain.3816 i = nxl3817 DO j = nys, nyn3818 3819 DO k = nzb+1, nzb_max_l3820 3821 ibit2 = REAL( IBITS(advc_flag(k,j,i-1),2,1), KIND = wp )3822 ibit1 = REAL( IBITS(advc_flag(k,j,i-1),1,1), KIND = wp )3823 ibit0 = REAL( IBITS(advc_flag(k,j,i-1),0,1), KIND = wp )3824 3825 u_comp = u(k,j,i) - u_gtrans + u_stokes_zu(k)3826 swap_flux_x_local(k,j) = u_comp * ( &3827 ( 37.0_wp * ibit2 * adv_sca_5 &3828 + 7.0_wp * ibit1 * adv_sca_3 &3829 + ibit0 * adv_sca_1 &3830 ) * &3831 ( sk(k,j,i) + sk(k,j,i-1) ) &3832 - ( 8.0_wp * ibit2 * adv_sca_5 &3833 + ibit1 * adv_sca_3 &3834 ) * &3835 ( sk(k,j,i+1) + sk(k,j,i-2) ) &3836 + ( ibit2 * adv_sca_5 &3837 ) * &3838 ( sk(k,j,i+2) + sk(k,j,i-3) ) &3839 )3840 3841 swap_diss_x_local(k,j) = -ABS( u_comp ) * ( &3842 ( 10.0_wp * ibit2 * adv_sca_5 &3843 + 3.0_wp * ibit1 * adv_sca_3 &3844 + ibit0 * adv_sca_1 &3845 ) * &3846 ( sk(k,j,i) - sk(k,j,i-1) ) &3847 - ( 5.0_wp * ibit2 * adv_sca_5 &3848 + ibit1 * adv_sca_3 &3849 ) * &3850 ( sk(k,j,i+1) - sk(k,j,i-2) ) &3851 + ( ibit2 * adv_sca_5 &3852 ) * &3853 ( sk(k,j,i+2) - sk(k,j,i-3) ) &3854 )3855 3856 ENDDO3857 3858 DO k = nzb_max_l+1, nzt3859 3860 u_comp = u(k,j,i) - u_gtrans + u_stokes_zu(k)3861 swap_flux_x_local(k,j) = u_comp * ( &3862 37.0_wp * ( sk(k,j,i) + sk(k,j,i-1) ) &3863 - 8.0_wp * ( sk(k,j,i+1) + sk(k,j,i-2) ) &3864 + ( sk(k,j,i+2) + sk(k,j,i-3) ) &3865 ) * adv_sca_53866 3867 swap_diss_x_local(k,j) = -ABS( u_comp ) * ( &3868 10.0_wp * ( sk(k,j,i) - sk(k,j,i-1) ) &3869 - 5.0_wp * ( sk(k,j,i+1) - sk(k,j,i-2) ) &3870 + ( sk(k,j,i+2) - sk(k,j,i-3) ) &3871 ) * adv_sca_53872 3873 ENDDO3874 3875 ENDDO3876 #endif3877 3878 3791 !$ACC PARALLEL LOOP COLLAPSE(2) FIRSTPRIVATE(tn, sk_num) & 3879 3792 !$ACC PRIVATE(i, j, k, k_mm, k_pp, k_ppp) & … … 3882 3795 !$ACC PRIVATE(ibit3_s, ibit4_s, ibit5_s) & 3883 3796 !$ACC PRIVATE(ibit6, ibit7, ibit8) & 3884 !$ACC PRIVATE(flux_r, diss_r, flux_l, diss_l) & 3885 !$ACC PRIVATE(flux_n, diss_n, flux_s, diss_s) & 3797 !$ACC PRIVATE(flux_r, diss_r) & 3798 !$ACC PRIVATE(flux_n, diss_n) & 3799 !$ACC PRIVATE(swap_diss_y_local, swap_flux_y_local) & 3886 3800 !$ACC PRIVATE(flux_t, diss_t, flux_d, diss_d) & 3887 3801 !$ACC PRIVATE(div, u_comp, u_comp_l, v_comp, v_comp_s) & … … 3890 3804 !$ACC PRESENT(drho_air, rho_air_zw, ddzw) & 3891 3805 !$ACC PRESENT(tend) & 3892 !$ACC PRESENT(hom( nzb+1:nzb_max_l,1,1:3,0)) &3806 !$ACC PRESENT(hom(:,1,1:3,0)) & 3893 3807 !$ACC PRESENT(weight_substep(intermediate_timestep_count)) & 3894 3808 !$ACC PRESENT(sums_wspts_ws_l, sums_wssas_ws_l) & … … 3898 3812 !$ACC PRESENT(sums_salsa_ws_l) 3899 3813 DO i = nxl, nxr 3900 3814 DO j = nys, nyn 3815 ! 3816 !-- Used local modified copy of nzb_max (used to degrade order of 3817 !-- discretization) at non-cyclic boundaries. Modify only at relevant points 3818 !-- instead of the entire subdomain. This should lead to better 3819 !-- load balance between boundary and non-boundary PEs. 3820 IF( non_cyclic_l .AND. i <= nxl + 2 .OR. & 3821 non_cyclic_r .AND. i >= nxr - 2 .OR. & 3822 non_cyclic_s .AND. j <= nys + 2 .OR. & 3823 non_cyclic_n .AND. j >= nyn - 2 ) THEN 3824 nzb_max_l = nzt 3825 ELSE 3826 nzb_max_l = nzb_max 3827 END IF 3901 3828 #ifndef _OPENACC 3902 j = nys 3903 DO k = nzb+1, nzb_max_l 3904 3905 ibit5 = REAL( IBITS(advc_flag(k,j-1,i),5,1), KIND = wp ) 3906 ibit4 = REAL( IBITS(advc_flag(k,j-1,i),4,1), KIND = wp ) 3907 ibit3 = REAL( IBITS(advc_flag(k,j-1,i),3,1), KIND = wp ) 3908 3909 v_comp = v(k,j,i) - v_gtrans + v_stokes_zu(k) 3910 swap_flux_y_local(k) = v_comp * ( & 3911 ( 37.0_wp * ibit5 * adv_sca_5 & 3912 + 7.0_wp * ibit4 * adv_sca_3 & 3913 + ibit3 * adv_sca_1 & 3914 ) * & 3915 ( sk(k,j,i) + sk(k,j-1,i) ) & 3916 - ( 8.0_wp * ibit5 * adv_sca_5 & 3917 + ibit4 * adv_sca_3 & 3918 ) * & 3919 ( sk(k,j+1,i) + sk(k,j-2,i) ) & 3920 + ( ibit5 * adv_sca_5 & 3921 ) * & 3922 ( sk(k,j+2,i) + sk(k,j-3,i) ) & 3923 ) 3924 3925 swap_diss_y_local(k) = -ABS( v_comp ) * ( & 3926 ( 10.0_wp * ibit5 * adv_sca_5 & 3927 + 3.0_wp * ibit4 * adv_sca_3 & 3928 + ibit3 * adv_sca_1 & 3929 ) * & 3930 ( sk(k,j,i) - sk(k,j-1,i) ) & 3931 - ( 5.0_wp * ibit5 * adv_sca_5 & 3932 + ibit4 * adv_sca_3 & 3933 ) * & 3934 ( sk(k,j+1,i) - sk(k,j-2,i) ) & 3935 + ( ibit5 * adv_sca_5 & 3936 ) * & 3937 ( sk(k,j+2,i) - sk(k,j-3,i) ) & 3938 ) 3939 3940 ENDDO 3941 ! 3942 !-- Above to the top of the highest topography. No degradation necessary. 3943 DO k = nzb_max_l+1, nzt 3944 3945 v_comp = v(k,j,i) - v_gtrans + v_stokes_zu(k) 3946 swap_flux_y_local(k) = v_comp * ( & 3947 37.0_wp * ( sk(k,j,i) + sk(k,j-1,i) ) & 3948 - 8.0_wp * ( sk(k,j+1,i) + sk(k,j-2,i) ) & 3949 + ( sk(k,j+2,i) + sk(k,j-3,i) ) & 3950 ) * adv_sca_5 3951 swap_diss_y_local(k) = -ABS( v_comp ) * ( & 3952 10.0_wp * ( sk(k,j,i) - sk(k,j-1,i) ) & 3953 - 5.0_wp * ( sk(k,j+1,i) - sk(k,j-2,i) ) & 3954 + sk(k,j+2,i) - sk(k,j-3,i) & 3829 ! 3830 !-- Compute leftside fluxes of the respective PE bounds. 3831 IF ( i == nxl ) THEN 3832 3833 DO k = nzb+1, nzb_max_l 3834 3835 ibit2 = REAL( IBITS(advc_flag(k,j,i-1),2,1), KIND = wp ) 3836 ibit1 = REAL( IBITS(advc_flag(k,j,i-1),1,1), KIND = wp ) 3837 ibit0 = REAL( IBITS(advc_flag(k,j,i-1),0,1), KIND = wp ) 3838 3839 u_comp = u(k,j,i) - u_gtrans + u_stokes_zu(k) 3840 swap_flux_x_local(k,j,tn) = u_comp * ( & 3841 ( 37.0_wp * ibit2 * adv_sca_5 & 3842 + 7.0_wp * ibit1 * adv_sca_3 & 3843 + ibit0 * adv_sca_1 & 3844 ) * & 3845 ( sk(k,j,i) + sk(k,j,i-1) ) & 3846 - ( 8.0_wp * ibit2 * adv_sca_5 & 3847 + ibit1 * adv_sca_3 & 3848 ) * & 3849 ( sk(k,j,i+1) + sk(k,j,i-2) ) & 3850 + ( ibit2 * adv_sca_5 & 3851 ) * & 3852 ( sk(k,j,i+2) + sk(k,j,i-3) )& 3853 ) 3854 3855 swap_diss_x_local(k,j,tn) = -ABS( u_comp ) * ( & 3856 ( 10.0_wp * ibit2 * adv_sca_5 & 3857 + 3.0_wp * ibit1 * adv_sca_3 & 3858 + ibit0 * adv_sca_1 & 3859 ) * & 3860 ( sk(k,j,i) - sk(k,j,i-1) ) & 3861 - ( 5.0_wp * ibit2 * adv_sca_5 & 3862 + ibit1 * adv_sca_3 & 3863 ) * & 3864 ( sk(k,j,i+1) - sk(k,j,i-2) ) & 3865 + ( ibit2 * adv_sca_5 & 3866 ) * & 3867 ( sk(k,j,i+2) - sk(k,j,i-3) ) & 3868 ) 3869 3870 ENDDO 3871 3872 DO k = nzb_max_l+1, nzt 3873 3874 u_comp = u(k,j,i) - u_gtrans + u_stokes_zu(k) 3875 swap_flux_x_local(k,j,tn) = u_comp * ( & 3876 37.0_wp * ( sk(k,j,i) + sk(k,j,i-1) )& 3877 - 8.0_wp * ( sk(k,j,i+1) + sk(k,j,i-2) )& 3878 + ( sk(k,j,i+2) + sk(k,j,i-3) )& 3879 ) * adv_sca_5 3880 3881 swap_diss_x_local(k,j,tn) = -ABS( u_comp ) * ( & 3882 10.0_wp * ( sk(k,j,i) - sk(k,j,i-1) )& 3883 - 5.0_wp * ( sk(k,j,i+1) - sk(k,j,i-2) )& 3884 + ( sk(k,j,i+2) - sk(k,j,i-3) )& 3885 ) * adv_sca_5 3886 3887 ENDDO 3888 3889 ENDIF 3890 ! 3891 !-- Compute southside fluxes of the respective PE bounds. 3892 IF ( j == nys ) THEN 3893 ! 3894 !-- Up to the top of the highest topography. 3895 DO k = nzb+1, nzb_max_l 3896 3897 ibit5 = REAL( IBITS(advc_flag(k,j-1,i),5,1), KIND = wp ) 3898 ibit4 = REAL( IBITS(advc_flag(k,j-1,i),4,1), KIND = wp ) 3899 ibit3 = REAL( IBITS(advc_flag(k,j-1,i),3,1), KIND = wp ) 3900 3901 v_comp = v(k,j,i) - v_gtrans + v_stokes_zu(k) 3902 swap_flux_y_local(k,tn) = v_comp * ( & 3903 ( 37.0_wp * ibit5 * adv_sca_5 & 3904 + 7.0_wp * ibit4 * adv_sca_3 & 3905 + ibit3 * adv_sca_1 & 3906 ) * & 3907 ( sk(k,j,i) + sk(k,j-1,i) ) & 3908 - ( 8.0_wp * ibit5 * adv_sca_5 & 3909 + ibit4 * adv_sca_3 & 3910 ) * & 3911 ( sk(k,j+1,i) + sk(k,j-2,i) ) & 3912 + ( ibit5 * adv_sca_5 & 3913 ) * & 3914 ( sk(k,j+2,i) + sk(k,j-3,i) ) & 3915 ) 3916 3917 swap_diss_y_local(k,tn) = -ABS( v_comp ) * ( & 3918 ( 10.0_wp * ibit5 * adv_sca_5 & 3919 + 3.0_wp * ibit4 * adv_sca_3 & 3920 + ibit3 * adv_sca_1 & 3921 ) * & 3922 ( sk(k,j,i) - sk(k,j-1,i) ) & 3923 - ( 5.0_wp * ibit5 * adv_sca_5 & 3924 + ibit4 * adv_sca_3 & 3925 ) * & 3926 ( sk(k,j+1,i) - sk(k,j-2,i) ) & 3927 + ( ibit5 * adv_sca_5 & 3928 ) * & 3929 ( sk(k,j+2,i) - sk(k,j-3,i) ) & 3930 ) 3931 3932 ENDDO 3933 ! 3934 !-- Above to the top of the highest topography. No degradation necessary. 3935 DO k = nzb_max_l+1, nzt 3936 3937 v_comp = v(k,j,i) - v_gtrans + v_stokes_zu(k) 3938 swap_flux_y_local(k,tn) = v_comp * ( & 3939 37.0_wp * ( sk(k,j,i) + sk(k,j-1,i) ) & 3940 - 8.0_wp * ( sk(k,j+1,i) + sk(k,j-2,i) ) & 3941 + ( sk(k,j+2,i) + sk(k,j-3,i) ) & 3955 3942 ) * adv_sca_5 3956 3957 ENDDO 3943 swap_diss_y_local(k,tn) = -ABS( v_comp ) * ( & 3944 10.0_wp * ( sk(k,j,i) - sk(k,j-1,i) ) & 3945 - 5.0_wp * ( sk(k,j+1,i) - sk(k,j-2,i) ) & 3946 + sk(k,j+2,i) - sk(k,j-3,i) & 3947 ) * adv_sca_5 3948 3949 ENDDO 3950 3951 ENDIF 3958 3952 #endif 3959 3960 DO j = nys, nyn 3961 3962 flux_d = 0.0_wp 3963 diss_d = 0.0_wp 3964 3953 ! 3954 !-- Now compute the fluxes and tendency terms for the horizontal and 3955 !-- vertical parts up to the top of the highest topography. 3965 3956 DO k = nzb+1, nzb_max_l 3966 3957 ! 3958 !-- Note: It is faster to conduct all multiplications explicitly, e.g. 3959 !-- * adv_sca_5 ... than to determine a factor and multiplicate the 3960 !-- flux at the end. 3967 3961 ibit2 = REAL( IBITS(advc_flag(k,j,i),2,1), KIND = wp ) 3968 3962 ibit1 = REAL( IBITS(advc_flag(k,j,i),1,1), KIND = wp ) 3969 3963 ibit0 = REAL( IBITS(advc_flag(k,j,i),0,1), KIND = wp ) 3970 3964 3971 u_comp = u(k,j,i+1) - u_gtrans + u_stokes_zu(k)3972 flux_r = u_comp * (&3973 ( 37.0_wp * ibit2 * adv_sca_5 &3974 +7.0_wp * ibit1 * adv_sca_3 &3975 +ibit0 * adv_sca_1 &3976 ) * &3977 ( sk(k,j,i+1) + sk(k,j,i) )&3978 - ( 8.0_wp * ibit2 * adv_sca_5 &3979 + ibit1 * adv_sca_3 &3980 ) * &3981 ( sk(k,j,i+2) + sk(k,j,i-1) )&3982 + ( ibit2 * adv_sca_5 &3983 ) * &3984 ( sk(k,j,i+3) + sk(k,j,i-2) )&3965 u_comp = u(k,j,i+1) - u_gtrans + u_stokes_zu(k) 3966 flux_r(k) = u_comp * ( & 3967 ( 37.0_wp * ibit2 * adv_sca_5 & 3968 + 7.0_wp * ibit1 * adv_sca_3 & 3969 + ibit0 * adv_sca_1 & 3970 ) * & 3971 ( sk(k,j,i+1) + sk(k,j,i) ) & 3972 - ( 8.0_wp * ibit2 * adv_sca_5 & 3973 + ibit1 * adv_sca_3 & 3974 ) * & 3975 ( sk(k,j,i+2) + sk(k,j,i-1) ) & 3976 + ( ibit2 * adv_sca_5 & 3977 ) * & 3978 ( sk(k,j,i+3) + sk(k,j,i-2) ) & 3985 3979 ) 3986 3980 3987 diss_r = -ABS( u_comp ) * (&3988 ( 10.0_wp * ibit2 * adv_sca_5 &3989 + 3.0_wp * ibit1 * adv_sca_3 &3990 + ibit0 * adv_sca_1 &3991 ) * &3992 ( sk(k,j,i+1) - sk(k,j,i) )&3993 - ( 5.0_wp * ibit2 * adv_sca_5 &3994 + ibit1 * adv_sca_3 &3995 ) * &3996 ( sk(k,j,i+2) - sk(k,j,i-1) )&3997 + ( ibit2 * adv_sca_5 &3998 ) * &3999 ( sk(k,j,i+3) - sk(k,j,i-2) )&3981 diss_r(k) = -ABS( u_comp ) * ( & 3982 ( 10.0_wp * ibit2 * adv_sca_5 & 3983 + 3.0_wp * ibit1 * adv_sca_3 & 3984 + ibit0 * adv_sca_1 & 3985 ) * & 3986 ( sk(k,j,i+1) - sk(k,j,i) ) & 3987 - ( 5.0_wp * ibit2 * adv_sca_5 & 3988 + ibit1 * adv_sca_3 & 3989 ) * & 3990 ( sk(k,j,i+2) - sk(k,j,i-1) ) & 3991 + ( ibit2 * adv_sca_5 & 3992 ) * & 3993 ( sk(k,j,i+3) - sk(k,j,i-2) ) & 4000 3994 ) 4001 4002 3995 #ifdef _OPENACC 4003 3996 ! … … 4008 4001 4009 4002 u_comp_l = u(k,j,i) - u_gtrans + u_stokes_zu(k) 4010 flux_l = u_comp_l * ( & 4011 ( 37.0_wp * ibit2_l * adv_sca_5 & 4012 + 7.0_wp * ibit1_l * adv_sca_3 & 4013 + ibit0_l * adv_sca_1 & 4014 ) * & 4015 ( sk(k,j,i) + sk(k,j,i-1) ) & 4016 - ( 8.0_wp * ibit2_l * adv_sca_5 & 4017 + ibit1_l * adv_sca_3 & 4018 ) * & 4019 ( sk(k,j,i+1) + sk(k,j,i-2) ) & 4020 + ( ibit2_l * adv_sca_5 & 4021 ) * & 4022 ( sk(k,j,i+2) + sk(k,j,i-3) ) & 4023 ) 4024 4025 diss_l = -ABS( u_comp_l ) * ( & 4026 ( 10.0_wp * ibit2_l * adv_sca_5 & 4027 + 3.0_wp * ibit1_l * adv_sca_3 & 4028 + ibit0_l * adv_sca_1 & 4029 ) * & 4030 ( sk(k,j,i) - sk(k,j,i-1) ) & 4031 - ( 5.0_wp * ibit2_l * adv_sca_5 & 4032 + ibit1_l * adv_sca_3 & 4033 ) * & 4034 ( sk(k,j,i+1) - sk(k,j,i-2) ) & 4035 + ( ibit2_l * adv_sca_5 & 4036 ) * & 4037 ( sk(k,j,i+2) - sk(k,j,i-3) ) & 4038 ) 4039 #else 4040 flux_l = swap_flux_x_local(k,j) 4041 diss_l = swap_diss_x_local(k,j) 4003 swap_flux_x_local(k,j,tn) = u_comp_l * ( & 4004 ( 37.0_wp * ibit2_l * adv_sca_5 & 4005 + 7.0_wp * ibit1_l * adv_sca_3 & 4006 + ibit0_l * adv_sca_1 & 4007 ) * & 4008 ( sk(k,j,i) + sk(k,j,i-1) ) & 4009 - ( 8.0_wp * ibit2_l * adv_sca_5 & 4010 + ibit1_l * adv_sca_3 & 4011 ) * & 4012 ( sk(k,j,i+1) + sk(k,j,i-2) ) & 4013 + ( ibit2_l * adv_sca_5 & 4014 ) * & 4015 ( sk(k,j,i+2) + sk(k,j,i-3) ) & 4016 ) 4017 4018 swap_diss_x_local(k,j,tn) = -ABS( u_comp_l ) * ( & 4019 ( 10.0_wp * ibit2_l * adv_sca_5 & 4020 + 3.0_wp * ibit1_l * adv_sca_3 & 4021 + ibit0_l * adv_sca_1 & 4022 ) * & 4023 ( sk(k,j,i) - sk(k,j,i-1) ) & 4024 - ( 5.0_wp * ibit2_l * adv_sca_5 & 4025 + ibit1_l * adv_sca_3 & 4026 ) * & 4027 ( sk(k,j,i+1) - sk(k,j,i-2) ) & 4028 + ( ibit2_l * adv_sca_5 & 4029 ) * & 4030 ( sk(k,j,i+2) - sk(k,j,i-3) ) & 4031 ) 4042 4032 #endif 4043 4044 4033 ibit5 = REAL( IBITS(advc_flag(k,j,i),5,1), KIND = wp ) 4045 4034 ibit4 = REAL( IBITS(advc_flag(k,j,i),4,1), KIND = wp ) 4046 4035 ibit3 = REAL( IBITS(advc_flag(k,j,i),3,1), KIND = wp ) 4047 4036 4048 v_comp = v(k,j+1,i) - v_gtrans + v_stokes_zu(k)4049 flux_n = v_comp * (&4050 ( 37.0_wp * ibit5 * adv_sca_5 &4051 + 7.0_wp * ibit4 * adv_sca_3 &4052 + ibit3 * adv_sca_1 &4053 ) * &4054 ( sk(k,j+1,i) + sk(k,j,i) )&4055 - ( 8.0_wp * ibit5 * adv_sca_5 &4056 + ibit4 * adv_sca_3 &4057 ) * &4058 ( sk(k,j+2,i) + sk(k,j-1,i) )&4059 + ( ibit5 * adv_sca_5 &4060 ) * &4061 ( sk(k,j+3,i) + sk(k,j-2,i) )&4037 v_comp = v(k,j+1,i) - v_gtrans + v_stokes_zu(k) 4038 flux_n(k) = v_comp * ( & 4039 ( 37.0_wp * ibit5 * adv_sca_5 & 4040 + 7.0_wp * ibit4 * adv_sca_3 & 4041 + ibit3 * adv_sca_1 & 4042 ) * & 4043 ( sk(k,j+1,i) + sk(k,j,i) ) & 4044 - ( 8.0_wp * ibit5 * adv_sca_5 & 4045 + ibit4 * adv_sca_3 & 4046 ) * & 4047 ( sk(k,j+2,i) + sk(k,j-1,i) ) & 4048 + ( ibit5 * adv_sca_5 & 4049 ) * & 4050 ( sk(k,j+3,i) + sk(k,j-2,i) ) & 4062 4051 ) 4063 4052 4064 diss_n = -ABS( v_comp ) * (&4065 ( 10.0_wp * ibit5 * adv_sca_5 &4066 + 3.0_wp * ibit4 * adv_sca_3 &4067 + ibit3 * adv_sca_1 &4068 ) * &4069 ( sk(k,j+1,i) - sk(k,j,i) )&4070 - ( 5.0_wp * ibit5 * adv_sca_5 &4071 + ibit4 * adv_sca_3 &4072 ) * &4073 ( sk(k,j+2,i) - sk(k,j-1,i) )&4074 + ( ibit5 * adv_sca_5 &4075 ) * &4076 ( sk(k,j+3,i) - sk(k,j-2,i) )&4053 diss_n(k) = -ABS( v_comp ) * ( & 4054 ( 10.0_wp * ibit5 * adv_sca_5 & 4055 + 3.0_wp * ibit4 * adv_sca_3 & 4056 + ibit3 * adv_sca_1 & 4057 ) * & 4058 ( sk(k,j+1,i) - sk(k,j,i) ) & 4059 - ( 5.0_wp * ibit5 * adv_sca_5 & 4060 + ibit4 * adv_sca_3 & 4061 ) * & 4062 ( sk(k,j+2,i) - sk(k,j-1,i) ) & 4063 + ( ibit5 * adv_sca_5 & 4064 ) * & 4065 ( sk(k,j+3,i) - sk(k,j-2,i) ) & 4077 4066 ) 4078 4079 4067 #ifdef _OPENACC 4080 4068 ! … … 4084 4072 ibit3_s = REAL( IBITS(advc_flag(k,j-1,i),3,1), KIND = wp ) 4085 4073 4086 v_comp_s = v(k,j,i) - v_gtrans + v_stokes_zu(k) 4087 flux_s = v_comp_s * ( & 4088 ( 37.0_wp * ibit5_s * adv_sca_5 & 4089 + 7.0_wp * ibit4_s * adv_sca_3 & 4090 + ibit3_s * adv_sca_1 & 4091 ) * & 4092 ( sk(k,j,i) + sk(k,j-1,i) ) & 4093 - ( 8.0_wp * ibit5_s * adv_sca_5 & 4094 + ibit4_s * adv_sca_3 & 4095 ) * & 4096 ( sk(k,j+1,i) + sk(k,j-2,i) ) & 4097 + ( ibit5_s * adv_sca_5 & 4098 ) * & 4099 ( sk(k,j+2,i) + sk(k,j-3,i) ) & 4100 ) 4101 4102 diss_s = -ABS( v_comp_s ) * ( & 4103 ( 10.0_wp * ibit5_s * adv_sca_5 & 4104 + 3.0_wp * ibit4_s * adv_sca_3 & 4105 + ibit3_s * adv_sca_1 & 4106 ) * & 4107 ( sk(k,j,i) - sk(k,j-1,i) ) & 4108 - ( 5.0_wp * ibit5_s * adv_sca_5 & 4109 + ibit4_s * adv_sca_3 & 4110 ) * & 4111 ( sk(k,j+1,i) - sk(k,j-2,i) ) & 4112 + ( ibit5_s * adv_sca_5 & 4113 ) * & 4114 ( sk(k,j+2,i) - sk(k,j-3,i) ) & 4074 v_comp_s = v(k,j,i) - v_gtrans + v_stokes_zu(k) 4075 swap_flux_y_local(k,tn) = v_comp_s * ( & 4076 ( 37.0_wp * ibit5_s * adv_sca_5 & 4077 + 7.0_wp * ibit4_s * adv_sca_3 & 4078 + ibit3_s * adv_sca_1 & 4079 ) * & 4080 ( sk(k,j,i) + sk(k,j-1,i) ) & 4081 - ( 8.0_wp * ibit5_s * adv_sca_5 & 4082 + ibit4_s * adv_sca_3 & 4083 ) * & 4084 ( sk(k,j+1,i) + sk(k,j-2,i) ) & 4085 + ( ibit5_s * adv_sca_5 & 4086 ) * & 4087 ( sk(k,j+2,i) + sk(k,j-3,i) ) & 4115 4088 ) 4116 #else 4117 flux_s = swap_flux_y_local(k) 4118 diss_s = swap_diss_y_local(k) 4089 4090 swap_flux_y_local(k,tn) = -ABS( v_comp_s ) * ( & 4091 ( 10.0_wp * ibit5_s * adv_sca_5 & 4092 + 3.0_wp * ibit4_s * adv_sca_3 & 4093 + ibit3_s * adv_sca_1 & 4094 ) * & 4095 ( sk(k,j,i) - sk(k,j-1,i) ) & 4096 - ( 5.0_wp * ibit5_s * adv_sca_5 & 4097 + ibit4_s * adv_sca_3 & 4098 ) * & 4099 ( sk(k,j+1,i) - sk(k,j-2,i) ) & 4100 + ( ibit5_s * adv_sca_5 & 4101 ) * & 4102 ( sk(k,j+2,i) - sk(k,j-3,i) ) & 4103 ) 4119 4104 #endif 4120 4121 ! 4122 !-- k index has to be modified near bottom and top, else array 4123 !-- subscripts will be exceeded. 4105 ENDDO 4106 ! 4107 !-- Now compute the fluxes and tendency terms for the horizontal and 4108 !-- vertical parts above the top of the highest topography. No degradation 4109 !-- for the horizontal parts, but for the vertical it is stell needed. 4110 DO k = nzb_max_l+1, nzt 4111 4112 u_comp = u(k,j,i+1) - u_gtrans + u_stokes_zu(k) 4113 flux_r(k) = u_comp * ( & 4114 37.0_wp * ( sk(k,j,i+1) + sk(k,j,i) ) & 4115 - 8.0_wp * ( sk(k,j,i+2) + sk(k,j,i-1) ) & 4116 + ( sk(k,j,i+3) + sk(k,j,i-2) ) ) * adv_sca_5 4117 diss_r(k) = -ABS( u_comp ) * ( & 4118 10.0_wp * ( sk(k,j,i+1) - sk(k,j,i) ) & 4119 - 5.0_wp * ( sk(k,j,i+2) - sk(k,j,i-1) ) & 4120 + ( sk(k,j,i+3) - sk(k,j,i-2) ) ) * adv_sca_5 4121 #ifdef _OPENACC 4122 ! 4123 !-- Recompute the left fluxes. 4124 u_comp_l = u(k,j,i) - u_gtrans + u_stokes_zu(k) 4125 swap_flux_x_local(k,j,tn) = u_comp_l * ( & 4126 37.0_wp * ( sk(k,j,i) + sk(k,j,i-1) ) & 4127 - 8.0_wp * ( sk(k,j,i+1) + sk(k,j,i-2) ) & 4128 + ( sk(k,j,i+2) + sk(k,j,i-3) ) & 4129 ) * adv_sca_5 4130 4131 swap_diss_x_local(k,j,tn) = -ABS( u_comp_l ) * ( & 4132 10.0_wp * ( sk(k,j,i) - sk(k,j,i-1) ) & 4133 - 5.0_wp * ( sk(k,j,i+1) - sk(k,j,i-2) ) & 4134 + ( sk(k,j,i+2) - sk(k,j,i-3) ) & 4135 ) * adv_sca_5 4136 #endif 4137 4138 v_comp = v(k,j+1,i) - v_gtrans + v_stokes_zu(k) 4139 flux_n(k) = v_comp * ( & 4140 37.0_wp * ( sk(k,j+1,i) + sk(k,j,i) ) & 4141 - 8.0_wp * ( sk(k,j+2,i) + sk(k,j-1,i) ) & 4142 + ( sk(k,j+3,i) + sk(k,j-2,i) ) ) * adv_sca_5 4143 diss_n(k) = -ABS( v_comp ) * ( & 4144 10.0_wp * ( sk(k,j+1,i) - sk(k,j,i) ) & 4145 - 5.0_wp * ( sk(k,j+2,i) - sk(k,j-1,i) ) & 4146 + ( sk(k,j+3,i) - sk(k,j-2,i) ) ) * adv_sca_5 4147 #ifdef _OPENACC 4148 ! 4149 !-- Recompute the south fluxes. 4150 v_comp_s = v(k,j,i) - v_gtrans + v_stokes_zu(k) 4151 swap_flux_y_local(k,tn) = v_comp_s * ( & 4152 37.0_wp * ( sk(k,j,i) + sk(k,j-1,i) ) & 4153 - 8.0_wp * ( sk(k,j+1,i) + sk(k,j-2,i) ) & 4154 + ( sk(k,j+2,i) + sk(k,j-3,i) ) & 4155 ) * adv_sca_5 4156 swap_diss_y_local(k,tn) = -ABS( v_comp_s ) * ( & 4157 10.0_wp * ( sk(k,j,i) - sk(k,j-1,i) ) & 4158 - 5.0_wp * ( sk(k,j+1,i) - sk(k,j-2,i) ) & 4159 + sk(k,j+2,i) - sk(k,j-3,i) & 4160 ) * adv_sca_5 4161 #endif 4162 ENDDO 4163 ! 4164 !-- Now, compute vertical fluxes. Split loop into a part treating the 4165 !-- lowest grid points with indirect indexing, a main loop without 4166 !-- indirect indexing, and a loop for the uppermost grip points with 4167 !-- indirect indexing. This allows better vectorization for the main loop. 4168 !-- First, compute the flux at model surface, which need has to be 4169 !-- calculated explicetely for the tendency at 4170 !-- the first w-level. For topography wall this is done implicitely by 4171 !-- advc_flag. 4172 flux_t(nzb) = 0.0_wp 4173 diss_t(nzb) = 0.0_wp 4174 4175 DO k = nzb+1, nzb+1 4124 4176 ibit8 = REAL( IBITS(advc_flag(k,j,i),8,1), KIND = wp ) 4125 4177 ibit7 = REAL( IBITS(advc_flag(k,j,i),7,1), KIND = wp ) 4126 4178 ibit6 = REAL( IBITS(advc_flag(k,j,i),6,1), KIND = wp ) 4127 4179 ! 4180 !-- k index has to be modified near bottom and top, else array 4181 !-- subscripts will be exceeded. 4128 4182 k_ppp = k + 3 * ibit8 4129 4183 k_pp = k + 2 * ( 1 - ibit6 ) … … 4131 4185 4132 4186 4133 flux_t = w(k,j,i) * rho_air_zw(k) * ( & 4134 ( 37.0_wp * ibit8 * adv_sca_5 & 4135 + 7.0_wp * ibit7 * adv_sca_3 & 4136 + ibit6 * adv_sca_1 & 4137 ) * & 4138 ( sk(k+1,j,i) + sk(k,j,i) ) & 4139 - ( 8.0_wp * ibit8 * adv_sca_5 & 4140 + ibit7 * adv_sca_3 & 4141 ) * & 4142 ( sk(k_pp,j,i) + sk(k-1,j,i) ) & 4143 + ( ibit8 * adv_sca_5 & 4144 ) * ( sk(k_ppp,j,i)+ sk(k_mm,j,i) ) & 4145 ) 4146 4147 diss_t = -ABS( w(k,j,i) ) * rho_air_zw(k) * ( & 4148 ( 10.0_wp * ibit8 * adv_sca_5 & 4149 + 3.0_wp * ibit7 * adv_sca_3 & 4150 + ibit6 * adv_sca_1 & 4151 ) * & 4152 ( sk(k+1,j,i) - sk(k,j,i) ) & 4153 - ( 5.0_wp * ibit8 * adv_sca_5 & 4154 + ibit7 * adv_sca_3 & 4155 ) * & 4156 ( sk(k_pp,j,i) - sk(k-1,j,i) ) & 4157 + ( ibit8 * adv_sca_5 & 4158 ) * & 4159 ( sk(k_ppp,j,i) - sk(k_mm,j,i) ) & 4160 ) 4161 ! 4162 !-- Calculate the divergence of the velocity field. A respective 4163 !-- correction is needed to overcome numerical instabilities caused 4164 !-- by a not sufficient reduction of divergences near topography. 4165 div = ( u(k,j,i+1) * ( ibit0 + ibit1 + ibit2 ) & 4166 - u(k,j,i) * ( & 4167 REAL( IBITS(advc_flag(k,j,i-1),0,1), KIND = wp ) & 4168 + REAL( IBITS(advc_flag(k,j,i-1),1,1), KIND = wp ) & 4169 + REAL( IBITS(advc_flag(k,j,i-1),2,1), KIND = wp ) & 4170 ) & 4171 ) * ddx & 4172 + ( v(k,j+1,i) * ( ibit3 + ibit4 + ibit5 ) & 4173 - v(k,j,i) * ( & 4174 REAL( IBITS(advc_flag(k,j-1,i),3,1), KIND = wp ) & 4175 + REAL( IBITS(advc_flag(k,j-1,i),4,1), KIND = wp ) & 4176 + REAL( IBITS(advc_flag(k,j-1,i),5,1), KIND = wp ) & 4177 ) & 4178 ) * ddy & 4179 + ( w(k,j,i) * rho_air_zw(k) * & 4180 ( ibit6 + ibit7 + ibit8 ) & 4181 - w(k-1,j,i) * rho_air_zw(k-1) * & 4182 ( & 4183 REAL( IBITS(advc_flag(k-1,j,i),6,1), KIND = wp ) & 4184 + REAL( IBITS(advc_flag(k-1,j,i),7,1), KIND = wp ) & 4185 + REAL( IBITS(advc_flag(k-1,j,i),8,1), KIND = wp ) & 4186 ) & 4187 ) * drho_air(k) * ddzw(k) 4188 4189 4190 tend(k,j,i) = tend(k,j,i) - ( & 4191 ( ( flux_r + diss_r ) & 4192 - ( flux_l + diss_l ) ) * ddx & 4193 + ( ( flux_n + diss_n ) & 4194 - ( flux_s + diss_s ) ) * ddy & 4195 + ( ( flux_t + diss_t ) & 4196 - ( flux_d + diss_d ) ) * drho_air(k) * ddzw(k) & 4197 ) + sk(k,j,i) * div 4198 4199 #ifndef _OPENACC 4200 swap_flux_y_local(k) = flux_n 4201 swap_diss_y_local(k) = diss_n 4202 swap_flux_x_local(k,j) = flux_r 4203 swap_diss_x_local(k,j) = diss_r 4204 #endif 4205 flux_d = flux_t 4206 diss_d = diss_t 4207 4208 ! 4209 !-- Evaluation of statistics. 4210 SELECT CASE ( sk_num ) 4211 4212 CASE ( 1 ) 4213 !$ACC ATOMIC 4214 sums_wspts_ws_l(k,tn) = sums_wspts_ws_l(k,tn) & 4215 + ( flux_t & 4216 / ( w(k,j,i) + SIGN( 1.0E-20_wp, w(k,j,i) ) ) & 4217 * ( w(k,j,i) - hom(k,1,3,0) ) & 4218 + diss_t & 4219 / ( ABS(w(k,j,i)) + 1.0E-20_wp ) & 4220 * ABS(w(k,j,i) - hom(k,1,3,0) ) & 4221 ) * weight_substep(intermediate_timestep_count) 4222 CASE ( 2 ) 4223 !$ACC ATOMIC 4224 sums_wssas_ws_l(k,tn) = sums_wssas_ws_l(k,tn) & 4225 + ( flux_t & 4226 / ( w(k,j,i) + SIGN( 1.0E-20_wp, w(k,j,i) ) ) & 4227 * ( w(k,j,i) - hom(k,1,3,0) ) & 4228 + diss_t & 4229 / ( ABS(w(k,j,i)) + 1.0E-20_wp ) & 4230 * ABS(w(k,j,i) - hom(k,1,3,0) ) & 4231 ) * weight_substep(intermediate_timestep_count) 4232 CASE ( 3 ) 4233 !$ACC ATOMIC 4234 sums_wsqs_ws_l(k,tn) = sums_wsqs_ws_l(k,tn) & 4235 + ( flux_t & 4236 / ( w(k,j,i) + SIGN( 1.0E-20_wp, w(k,j,i) ) ) & 4237 * ( w(k,j,i) - hom(k,1,3,0) ) & 4238 + diss_t & 4239 / ( ABS(w(k,j,i)) + 1.0E-20_wp ) & 4240 * ABS(w(k,j,i) - hom(k,1,3,0) ) & 4241 ) * weight_substep(intermediate_timestep_count) 4242 CASE ( 4 ) 4243 !$ACC ATOMIC 4244 sums_wsqcs_ws_l(k,tn) = sums_wsqcs_ws_l(k,tn) & 4245 + ( flux_t & 4246 / ( w(k,j,i) + SIGN( 1.0E-20_wp, w(k,j,i) ) ) & 4247 * ( w(k,j,i) - hom(k,1,3,0) ) & 4248 + diss_t & 4249 / ( ABS(w(k,j,i)) + 1.0E-20_wp ) & 4250 * ABS(w(k,j,i) - hom(k,1,3,0) ) & 4251 ) * weight_substep(intermediate_timestep_count) 4252 CASE ( 5 ) 4253 !$ACC ATOMIC 4254 sums_wsqrs_ws_l(k,tn) = sums_wsqrs_ws_l(k,tn) & 4255 + ( flux_t & 4256 / ( w(k,j,i) + SIGN( 1.0E-20_wp, w(k,j,i) ) ) & 4257 * ( w(k,j,i) - hom(k,1,3,0) ) & 4258 + diss_t & 4259 / ( ABS(w(k,j,i)) + 1.0E-20_wp ) & 4260 * ABS(w(k,j,i) - hom(k,1,3,0) ) & 4261 ) * weight_substep(intermediate_timestep_count) 4262 CASE ( 6 ) 4263 !$ACC ATOMIC 4264 sums_wsncs_ws_l(k,tn) = sums_wsncs_ws_l(k,tn) & 4265 + ( flux_t & 4266 / ( w(k,j,i) + SIGN( 1.0E-20_wp, w(k,j,i) ) ) & 4267 * ( w(k,j,i) - hom(k,1,3,0) ) & 4268 + diss_t & 4269 / ( ABS(w(k,j,i)) + 1.0E-20_wp ) & 4270 * ABS(w(k,j,i) - hom(k,1,3,0) ) & 4271 ) * weight_substep(intermediate_timestep_count) 4272 CASE ( 7 ) 4273 !$ACC ATOMIC 4274 sums_wsnrs_ws_l(k,tn) = sums_wsnrs_ws_l(k,tn) & 4275 + ( flux_t & 4276 / ( w(k,j,i) + SIGN( 1.0E-20_wp, w(k,j,i) ) ) & 4277 * ( w(k,j,i) - hom(k,1,3,0) ) & 4278 + diss_t & 4279 / ( ABS(w(k,j,i)) + 1.0E-20_wp ) & 4280 * ABS(w(k,j,i) - hom(k,1,3,0) ) & 4281 ) * weight_substep(intermediate_timestep_count) 4282 CASE ( 8 ) 4283 !$ACC ATOMIC 4284 sums_wsss_ws_l(k,tn) = sums_wsss_ws_l(k,tn) & 4285 + ( flux_t & 4286 / ( w(k,j,i) + SIGN( 1.0E-20_wp, w(k,j,i) ) ) & 4287 * ( w(k,j,i) - hom(k,1,3,0) ) & 4288 + diss_t & 4289 / ( ABS(w(k,j,i)) + 1.0E-20_wp ) & 4290 * ABS(w(k,j,i) - hom(k,1,3,0) ) & 4291 ) * weight_substep(intermediate_timestep_count) 4292 CASE ( 9 ) 4293 !$ACC ATOMIC 4294 sums_salsa_ws_l(k,tn) = sums_salsa_ws_l(k,tn) & 4295 + ( flux_t & 4296 / ( w(k,j,i) + SIGN( 1.0E-20_wp, w(k,j,i) ) ) & 4297 * ( w(k,j,i) - hom(k,1,3,0) ) & 4298 + diss_t & 4299 / ( ABS(w(k,j,i)) + 1.0E-20_wp ) & 4300 * ABS(w(k,j,i) - hom(k,1,3,0) ) & 4301 ) * weight_substep(intermediate_timestep_count) 4302 4303 END SELECT 4304 4187 flux_t(k) = w(k,j,i) * rho_air_zw(k) * ( & 4188 ( 37.0_wp * ibit8 * adv_sca_5 & 4189 + 7.0_wp * ibit7 * adv_sca_3 & 4190 + ibit6 * adv_sca_1 & 4191 ) * & 4192 ( sk(k+1,j,i) + sk(k,j,i) ) & 4193 - ( 8.0_wp * ibit8 * adv_sca_5 & 4194 + ibit7 * adv_sca_3 & 4195 ) * & 4196 ( sk(k_pp,j,i) + sk(k-1,j,i) ) & 4197 + ( ibit8 * adv_sca_5 & 4198 ) * ( sk(k_ppp,j,i)+ sk(k_mm,j,i) ) & 4199 ) 4200 4201 diss_t(k) = -ABS( w(k,j,i) ) * rho_air_zw(k) * ( & 4202 ( 10.0_wp * ibit8 * adv_sca_5 & 4203 + 3.0_wp * ibit7 * adv_sca_3 & 4204 + ibit6 * adv_sca_1 & 4205 ) * & 4206 ( sk(k+1,j,i) - sk(k,j,i) ) & 4207 - ( 5.0_wp * ibit8 * adv_sca_5 & 4208 + ibit7 * adv_sca_3 & 4209 ) * & 4210 ( sk(k_pp,j,i) - sk(k-1,j,i) ) & 4211 + ( ibit8 * adv_sca_5 & 4212 ) * & 4213 ( sk(k_ppp,j,i) - sk(k_mm,j,i) ) & 4214 ) 4305 4215 ENDDO 4306 4216 4307 DO k = nzb_max_l+1, nzt 4308 4309 u_comp = u(k,j,i+1) - u_gtrans + u_stokes_zu(k) 4310 flux_r = u_comp * ( & 4311 37.0_wp * ( sk(k,j,i+1) + sk(k,j,i) ) & 4312 - 8.0_wp * ( sk(k,j,i+2) + sk(k,j,i-1) ) & 4313 + ( sk(k,j,i+3) + sk(k,j,i-2) ) ) * adv_sca_5 4314 diss_r = -ABS( u_comp ) * ( & 4315 10.0_wp * ( sk(k,j,i+1) - sk(k,j,i) ) & 4316 - 5.0_wp * ( sk(k,j,i+2) - sk(k,j,i-1) ) & 4317 + ( sk(k,j,i+3) - sk(k,j,i-2) ) ) * adv_sca_5 4318 4319 #ifdef _OPENACC 4320 ! 4321 !-- Recompute the left fluxes. 4322 u_comp_l = u(k,j,i) - u_gtrans + u_stokes_zu(k) 4323 flux_l = u_comp_l * ( & 4324 37.0_wp * ( sk(k,j,i) + sk(k,j,i-1) ) & 4325 - 8.0_wp * ( sk(k,j,i+1) + sk(k,j,i-2) ) & 4326 + ( sk(k,j,i+2) + sk(k,j,i-3) ) & 4327 ) * adv_sca_5 4328 4329 diss_l = -ABS( u_comp_l ) * ( & 4330 10.0_wp * ( sk(k,j,i) - sk(k,j,i-1) ) & 4331 - 5.0_wp * ( sk(k,j,i+1) - sk(k,j,i-2) ) & 4332 + ( sk(k,j,i+2) - sk(k,j,i-3) ) & 4333 ) * adv_sca_5 4334 #else 4335 flux_l = swap_flux_x_local(k,j) 4336 diss_l = swap_diss_x_local(k,j) 4337 #endif 4338 4339 v_comp = v(k,j+1,i) - v_gtrans + v_stokes_zu(k) 4340 flux_n = v_comp * ( & 4341 37.0_wp * ( sk(k,j+1,i) + sk(k,j,i) ) & 4342 - 8.0_wp * ( sk(k,j+2,i) + sk(k,j-1,i) ) & 4343 + ( sk(k,j+3,i) + sk(k,j-2,i) ) ) * adv_sca_5 4344 diss_n = -ABS( v_comp ) * ( & 4345 10.0_wp * ( sk(k,j+1,i) - sk(k,j,i) ) & 4346 - 5.0_wp * ( sk(k,j+2,i) - sk(k,j-1,i) ) & 4347 + ( sk(k,j+3,i) - sk(k,j-2,i) ) ) * adv_sca_5 4348 4349 #ifdef _OPENACC 4350 ! 4351 !-- Recompute the south fluxes. 4352 v_comp_s = v(k,j,i) - v_gtrans + v_stokes_zu(k) 4353 flux_s = v_comp_s * ( & 4354 37.0_wp * ( sk(k,j,i) + sk(k,j-1,i) ) & 4355 - 8.0_wp * ( sk(k,j+1,i) + sk(k,j-2,i) ) & 4356 + ( sk(k,j+2,i) + sk(k,j-3,i) ) & 4357 ) * adv_sca_5 4358 diss_s = -ABS( v_comp_s ) * ( & 4359 10.0_wp * ( sk(k,j,i) - sk(k,j-1,i) ) & 4360 - 5.0_wp * ( sk(k,j+1,i) - sk(k,j-2,i) ) & 4361 + sk(k,j+2,i) - sk(k,j-3,i) & 4362 ) * adv_sca_5 4363 #else 4364 flux_s = swap_flux_y_local(k) 4365 diss_s = swap_diss_y_local(k) 4366 #endif 4367 4368 ! 4369 !-- k index has to be modified near bottom and top, else array 4370 !-- subscripts will be exceeded. 4217 DO k = nzb+2, nzt-2 4371 4218 ibit8 = REAL( IBITS(advc_flag(k,j,i),8,1), KIND = wp ) 4372 4219 ibit7 = REAL( IBITS(advc_flag(k,j,i),7,1), KIND = wp ) 4373 4220 ibit6 = REAL( IBITS(advc_flag(k,j,i),6,1), KIND = wp ) 4374 4221 4222 flux_t(k) = w(k,j,i) * rho_air_zw(k) * ( & 4223 ( 37.0_wp * ibit8 * adv_sca_5 & 4224 + 7.0_wp * ibit7 * adv_sca_3 & 4225 + ibit6 * adv_sca_1 & 4226 ) * & 4227 ( sk(k+1,j,i) + sk(k,j,i) ) & 4228 - ( 8.0_wp * ibit8 * adv_sca_5 & 4229 + ibit7 * adv_sca_3 & 4230 ) * & 4231 ( sk(k+2,j,i) + sk(k-1,j,i) ) & 4232 + ( ibit8 * adv_sca_5 & 4233 ) * ( sk(k+3,j,i)+ sk(k-2,j,i) ) & 4234 ) 4235 4236 diss_t(k) = -ABS( w(k,j,i) ) * rho_air_zw(k) * ( & 4237 ( 10.0_wp * ibit8 * adv_sca_5 & 4238 + 3.0_wp * ibit7 * adv_sca_3 & 4239 + ibit6 * adv_sca_1 & 4240 ) * & 4241 ( sk(k+1,j,i) - sk(k,j,i) ) & 4242 - ( 5.0_wp * ibit8 * adv_sca_5 & 4243 + ibit7 * adv_sca_3 & 4244 ) * & 4245 ( sk(k+2,j,i) - sk(k-1,j,i) ) & 4246 + ( ibit8 * adv_sca_5 & 4247 ) * & 4248 ( sk(k+3,j,i) - sk(k-2,j,i) ) & 4249 ) 4250 ENDDO 4251 4252 DO k = nzt-1, nzt-symmetry_flag 4253 ibit8 = REAL( IBITS(advc_flag(k,j,i),8,1), KIND = wp ) 4254 ibit7 = REAL( IBITS(advc_flag(k,j,i),7,1), KIND = wp ) 4255 ibit6 = REAL( IBITS(advc_flag(k,j,i),6,1), KIND = wp ) 4256 ! 4257 !-- k index has to be modified near bottom and top, else array 4258 !-- subscripts will be exceeded. 4375 4259 k_ppp = k + 3 * ibit8 4376 4260 k_pp = k + 2 * ( 1 - ibit6 ) 4377 4261 k_mm = k - 2 * ibit8 4378 4262 4379 4380 flux_t = w(k,j,i) * rho_air_zw(k) * ( & 4381 ( 37.0_wp * ibit8 * adv_sca_5 & 4382 + 7.0_wp * ibit7 * adv_sca_3 & 4383 + ibit6 * adv_sca_1 & 4384 ) * & 4385 ( sk(k+1,j,i) + sk(k,j,i) ) & 4386 - ( 8.0_wp * ibit8 * adv_sca_5 & 4387 + ibit7 * adv_sca_3 & 4388 ) * & 4389 ( sk(k_pp,j,i) + sk(k-1,j,i) ) & 4390 + ( ibit8 * adv_sca_5 & 4391 ) * ( sk(k_ppp,j,i)+ sk(k_mm,j,i) ) & 4392 ) 4393 4394 diss_t = -ABS( w(k,j,i) ) * rho_air_zw(k) * ( & 4395 ( 10.0_wp * ibit8 * adv_sca_5 & 4396 + 3.0_wp * ibit7 * adv_sca_3 & 4397 + ibit6 * adv_sca_1 & 4398 ) * & 4399 ( sk(k+1,j,i) - sk(k,j,i) ) & 4400 - ( 5.0_wp * ibit8 * adv_sca_5 & 4401 + ibit7 * adv_sca_3 & 4402 ) * & 4403 ( sk(k_pp,j,i) - sk(k-1,j,i) ) & 4404 + ( ibit8 * adv_sca_5 & 4405 ) * & 4406 ( sk(k_ppp,j,i) - sk(k_mm,j,i) ) & 4407 ) 4263 flux_t(k) = w(k,j,i) * rho_air_zw(k) * ( & 4264 ( 37.0_wp * ibit8 * adv_sca_5 & 4265 + 7.0_wp * ibit7 * adv_sca_3 & 4266 + ibit6 * adv_sca_1 & 4267 ) * & 4268 ( sk(k+1,j,i) + sk(k,j,i) ) & 4269 - ( 8.0_wp * ibit8 * adv_sca_5 & 4270 + ibit7 * adv_sca_3 & 4271 ) * & 4272 ( sk(k_pp,j,i) + sk(k-1,j,i) ) & 4273 + ( ibit8 * adv_sca_5 & 4274 ) * ( sk(k_ppp,j,i)+ sk(k_mm,j,i) ) & 4275 ) 4276 4277 diss_t(k) = -ABS( w(k,j,i) ) * rho_air_zw(k) * ( & 4278 ( 10.0_wp * ibit8 * adv_sca_5 & 4279 + 3.0_wp * ibit7 * adv_sca_3 & 4280 + ibit6 * adv_sca_1 & 4281 ) * & 4282 ( sk(k+1,j,i) - sk(k,j,i) ) & 4283 - ( 5.0_wp * ibit8 * adv_sca_5 & 4284 + ibit7 * adv_sca_3 & 4285 ) * & 4286 ( sk(k_pp,j,i) - sk(k-1,j,i) ) & 4287 + ( ibit8 * adv_sca_5 & 4288 ) * & 4289 ( sk(k_ppp,j,i) - sk(k_mm,j,i) ) & 4290 ) 4291 ENDDO 4292 4293 ! 4294 !-- Set resolved/turbulent flux at model top to zero (w-level). In case that 4295 !-- a symmetric behavior between bottom and top shall be guaranteed (closed 4296 !-- channel flow), the flux at nzt is also set to zero. 4297 IF ( symmetry_flag == 1 ) THEN 4298 flux_t(nzt) = 0.0_wp 4299 diss_t(nzt) = 0.0_wp 4300 ENDIF 4301 flux_t(nzt+1) = 0.0_wp 4302 diss_t(nzt+1) = 0.0_wp 4303 4304 DO k = nzb+1, nzb_max_l 4305 4306 flux_d = flux_t(k-1) 4307 diss_d = diss_t(k-1) 4308 4309 ibit2 = REAL( IBITS(advc_flag(k,j,i),2,1), KIND = wp ) 4310 ibit1 = REAL( IBITS(advc_flag(k,j,i),1,1), KIND = wp ) 4311 ibit0 = REAL( IBITS(advc_flag(k,j,i),0,1), KIND = wp ) 4312 4313 ibit5 = REAL( IBITS(advc_flag(k,j,i),5,1), KIND = wp ) 4314 ibit4 = REAL( IBITS(advc_flag(k,j,i),4,1), KIND = wp ) 4315 ibit3 = REAL( IBITS(advc_flag(k,j,i),3,1), KIND = wp ) 4316 4317 ibit8 = REAL( IBITS(advc_flag(k,j,i),8,1), KIND = wp ) 4318 ibit7 = REAL( IBITS(advc_flag(k,j,i),7,1), KIND = wp ) 4319 ibit6 = REAL( IBITS(advc_flag(k,j,i),6,1), KIND = wp ) 4408 4320 ! 4409 4321 !-- Calculate the divergence of the velocity field. A respective 4410 4322 !-- correction is needed to overcome numerical instabilities introduced 4411 4323 !-- by a not sufficient reduction of divergences near topography. 4412 div = ( u(k,j,i+1) - u(k,j,i) ) * ddx & 4413 + ( v(k,j+1,i) - v(k,j,i) ) * ddy & 4414 + ( w(k,j,i) * rho_air_zw(k) - & 4415 w(k-1,j,i) * rho_air_zw(k-1) & 4324 div = ( u(k,j,i+1) * ( ibit0 + ibit1 + ibit2 ) & 4325 - u(k,j,i) * ( & 4326 REAL( IBITS(advc_flag(k,j,i-1),0,1), KIND = wp ) & 4327 + REAL( IBITS(advc_flag(k,j,i-1),1,1), KIND = wp ) & 4328 + REAL( IBITS(advc_flag(k,j,i-1),2,1), KIND = wp ) & 4329 ) & 4330 ) * ddx & 4331 + ( v(k,j+1,i) * ( ibit3 + ibit4 + ibit5 ) & 4332 - v(k,j,i) * ( & 4333 REAL( IBITS(advc_flag(k,j-1,i),3,1), KIND = wp ) & 4334 + REAL( IBITS(advc_flag(k,j-1,i),4,1), KIND = wp ) & 4335 + REAL( IBITS(advc_flag(k,j-1,i),5,1), KIND = wp ) & 4336 ) & 4337 ) * ddy & 4338 + ( w(k,j,i) * rho_air_zw(k) * & 4339 ( ibit6 + ibit7 + ibit8 ) & 4340 - w(k-1,j,i) * rho_air_zw(k-1) * & 4341 ( & 4342 REAL( IBITS(advc_flag(k-1,j,i),6,1), KIND = wp ) & 4343 + REAL( IBITS(advc_flag(k-1,j,i),7,1), KIND = wp ) & 4344 + REAL( IBITS(advc_flag(k-1,j,i),8,1), KIND = wp ) & 4345 ) & 4416 4346 ) * drho_air(k) * ddzw(k) 4417 4347 4418 tend(k,j,i) = tend(k,j,i) - ( & 4419 ( ( flux_r + diss_r ) & 4420 - ( flux_l + diss_l ) ) * ddx & 4421 + ( ( flux_n + diss_n ) & 4422 - ( flux_s + diss_s ) ) * ddy & 4423 + ( ( flux_t + diss_t ) & 4424 - ( flux_d + diss_d ) ) * drho_air(k) * ddzw(k) & 4348 tend(k,j,i) = tend(k,j,i) - ( & 4349 ( flux_r(k) + diss_r(k) - swap_flux_x_local(k,j,tn) - & 4350 swap_diss_x_local(k,j,tn) ) * ddx & 4351 + ( flux_n(k) + diss_n(k) - swap_flux_y_local(k,tn) - & 4352 swap_diss_y_local(k,tn) ) * ddy & 4353 + ( ( flux_t(k) + diss_t(k) ) - & 4354 ( flux_d + diss_d ) & 4355 ) & 4356 * drho_air(k) * ddzw(k) & 4425 4357 ) + sk(k,j,i) * div 4426 4358 4427 4359 #ifndef _OPENACC 4428 swap_flux_y_local(k ) = flux_n4429 swap_diss_y_local(k ) = diss_n4430 swap_flux_x_local(k,j ) = flux_r4431 swap_diss_x_local(k,j ) = diss_r4360 swap_flux_y_local(k,tn) = flux_n(k) 4361 swap_diss_y_local(k,tn) = diss_n(k) 4362 swap_flux_x_local(k,j,tn) = flux_r(k) 4363 swap_diss_x_local(k,j,tn) = diss_r(k) 4432 4364 #endif 4433 flux_d = flux_t 4434 diss_d = diss_t 4435 4436 ! 4437 !-- Evaluation of statistics. 4438 SELECT CASE ( sk_num ) 4439 4440 CASE ( 1 ) 4365 4366 ENDDO 4367 4368 DO k = nzb_max_l+1, nzt 4369 4370 flux_d = flux_t(k-1) 4371 diss_d = diss_t(k-1) 4372 ! 4373 !-- Calculate the divergence of the velocity field. A respective 4374 !-- correction is needed to overcome numerical instabilities introduced 4375 !-- by a not sufficient reduction of divergences near topography. 4376 div = ( u(k,j,i+1) - u(k,j,i) ) * ddx & 4377 + ( v(k,j+1,i) - v(k,j,i) ) * ddy & 4378 + ( w(k,j,i) * rho_air_zw(k) & 4379 - w(k-1,j,i) * rho_air_zw(k-1) & 4380 ) * drho_air(k) * ddzw(k) 4381 4382 tend(k,j,i) = tend(k,j,i) - ( & 4383 ( flux_r(k) + diss_r(k) - swap_flux_x_local(k,j,tn) - & 4384 swap_diss_x_local(k,j,tn) ) * ddx & 4385 + ( flux_n(k) + diss_n(k) - swap_flux_y_local(k,tn) - & 4386 swap_diss_y_local(k,tn) ) * ddy & 4387 + ( ( flux_t(k) + diss_t(k) ) - & 4388 ( flux_d + diss_d ) ) & 4389 * drho_air(k) * ddzw(k) & 4390 ) + sk(k,j,i) * div 4391 4392 #ifndef _OPENACC 4393 swap_flux_y_local(k,tn) = flux_n(k) 4394 swap_diss_y_local(k,tn) = diss_n(k) 4395 swap_flux_x_local(k,j,tn) = flux_r(k) 4396 swap_diss_x_local(k,j,tn) = diss_r(k) 4397 #endif 4398 ENDDO 4399 4400 ! 4401 !-- Evaluation of statistics. 4402 DO k = nzb+1, nzt 4403 SELECT CASE ( sk_num ) 4404 4405 CASE ( 1 ) 4406 !$ACC ATOMIC 4407 sums_wspts_ws_l(k,tn) = sums_wspts_ws_l(k,tn) & 4408 + ( flux_t(k) & 4409 / ( w(k,j,i) + SIGN( 1.0E-20_wp, w(k,j,i) ) ) & 4410 * ( w(k,j,i) - hom(k,1,3,0) ) & 4411 + diss_t(k) & 4412 / ( ABS(w(k,j,i)) + 1.0E-20_wp ) & 4413 * ABS(w(k,j,i) - hom(k,1,3,0) ) & 4414 ) * weight_substep(intermediate_timestep_count) 4415 CASE ( 2 ) 4416 !$ACC ATOMIC 4417 sums_wssas_ws_l(k,tn) = sums_wssas_ws_l(k,tn) & 4418 + ( flux_t(k) & 4419 / ( w(k,j,i) + SIGN( 1.0E-20_wp, w(k,j,i) ) ) & 4420 * ( w(k,j,i) - hom(k,1,3,0) ) & 4421 + diss_t(k) & 4422 / ( ABS(w(k,j,i)) + 1.0E-20_wp ) & 4423 * ABS(w(k,j,i) - hom(k,1,3,0) ) & 4424 ) * weight_substep(intermediate_timestep_count) 4425 CASE ( 3 ) 4426 !$ACC ATOMIC 4427 sums_wsqs_ws_l(k,tn) = sums_wsqs_ws_l(k,tn) & 4428 + ( flux_t(k) & 4429 / ( w(k,j,i) + SIGN( 1.0E-20_wp, w(k,j,i) ) ) & 4430 * ( w(k,j,i) - hom(k,1,3,0) ) & 4431 + diss_t(k) & 4432 / ( ABS(w(k,j,i)) + 1.0E-20_wp ) & 4433 * ABS(w(k,j,i) - hom(k,1,3,0) ) & 4434 ) * weight_substep(intermediate_timestep_count) 4435 CASE ( 4 ) 4436 !$ACC ATOMIC 4437 sums_wsqcs_ws_l(k,tn) = sums_wsqcs_ws_l(k,tn) & 4438 + ( flux_t(k) & 4439 / ( w(k,j,i) + SIGN( 1.0E-20_wp, w(k,j,i) ) ) & 4440 * ( w(k,j,i) - hom(k,1,3,0) ) & 4441 + diss_t(k) & 4442 / ( ABS(w(k,j,i)) + 1.0E-20_wp ) & 4443 * ABS(w(k,j,i) - hom(k,1,3,0) ) & 4444 ) * weight_substep(intermediate_timestep_count) 4445 CASE ( 5 ) 4446 !$ACC ATOMIC 4447 sums_wsqrs_ws_l(k,tn) = sums_wsqrs_ws_l(k,tn) & 4448 + ( flux_t(k) & 4449 / ( w(k,j,i) + SIGN( 1.0E-20_wp, w(k,j,i) ) ) & 4450 * ( w(k,j,i) - hom(k,1,3,0) ) & 4451 + diss_t(k) & 4452 / ( ABS(w(k,j,i)) + 1.0E-20_wp ) & 4453 * ABS(w(k,j,i) - hom(k,1,3,0) ) & 4454 ) * weight_substep(intermediate_timestep_count) 4455 CASE ( 6 ) 4456 !$ACC ATOMIC 4457 sums_wsncs_ws_l(k,tn) = sums_wsncs_ws_l(k,tn) & 4458 + ( flux_t(k) & 4459 / ( w(k,j,i) + SIGN( 1.0E-20_wp, w(k,j,i) ) ) & 4460 * ( w(k,j,i) - hom(k,1,3,0) ) & 4461 + diss_t(k) & 4462 / ( ABS(w(k,j,i)) + 1.0E-20_wp ) & 4463 * ABS(w(k,j,i) - hom(k,1,3,0) ) & 4464 ) * weight_substep(intermediate_timestep_count) 4465 CASE ( 7 ) 4466 !$ACC ATOMIC 4467 sums_wsnrs_ws_l(k,tn) = sums_wsnrs_ws_l(k,tn) & 4468 + ( flux_t(k) & 4469 / ( w(k,j,i) + SIGN( 1.0E-20_wp, w(k,j,i) ) ) & 4470 * ( w(k,j,i) - hom(k,1,3,0) ) & 4471 + diss_t(k) & 4472 / ( ABS(w(k,j,i)) + 1.0E-20_wp ) & 4473 * ABS(w(k,j,i) - hom(k,1,3,0) ) & 4474 ) * weight_substep(intermediate_timestep_count) 4475 CASE ( 8 ) 4476 !$ACC ATOMIC 4477 sums_wsss_ws_l(k,tn) = sums_wsss_ws_l(k,tn) & 4478 + ( flux_t(k) & 4479 / ( w(k,j,i) + SIGN( 1.0E-20_wp, w(k,j,i) ) ) & 4480 * ( w(k,j,i) - hom(k,1,3,0) ) & 4481 + diss_t(k) & 4482 / ( ABS(w(k,j,i)) + 1.0E-20_wp ) & 4483 * ABS(w(k,j,i) - hom(k,1,3,0) ) & 4484 ) * weight_substep(intermediate_timestep_count) 4485 CASE ( 9 ) 4441 4486 !$ACC ATOMIC 4442 sums_wspts_ws_l(k,tn) = sums_wspts_ws_l(k,tn) & 4443 + ( flux_t & 4444 / ( w(k,j,i) + SIGN( 1.0E-20_wp, w(k,j,i) ) ) & 4445 * ( w(k,j,i) - hom(k,1,3,0) ) & 4446 + diss_t & 4447 / ( ABS(w(k,j,i)) + 1.0E-20_wp ) & 4448 * ABS(w(k,j,i) - hom(k,1,3,0) ) & 4449 ) * weight_substep(intermediate_timestep_count) 4450 CASE ( 2 ) 4451 !$ACC ATOMIC 4452 sums_wssas_ws_l(k,tn) = sums_wssas_ws_l(k,tn) & 4453 + ( flux_t & 4454 / ( w(k,j,i) + SIGN( 1.0E-20_wp, w(k,j,i) ) ) & 4455 * ( w(k,j,i) - hom(k,1,3,0) ) & 4456 + diss_t & 4457 / ( ABS(w(k,j,i)) + 1.0E-20_wp ) & 4458 * ABS(w(k,j,i) - hom(k,1,3,0) ) & 4459 ) * weight_substep(intermediate_timestep_count) 4460 CASE ( 3 ) 4461 !$ACC ATOMIC 4462 sums_wsqs_ws_l(k,tn) = sums_wsqs_ws_l(k,tn) & 4463 + ( flux_t & 4464 / ( w(k,j,i) + SIGN( 1.0E-20_wp, w(k,j,i) ) ) & 4465 * ( w(k,j,i) - hom(k,1,3,0) ) & 4466 + diss_t & 4467 / ( ABS(w(k,j,i)) + 1.0E-20_wp ) & 4468 * ABS(w(k,j,i) - hom(k,1,3,0) ) & 4469 ) * weight_substep(intermediate_timestep_count) 4470 CASE ( 4 ) 4471 !$ACC ATOMIC 4472 sums_wsqcs_ws_l(k,tn) = sums_wsqcs_ws_l(k,tn) & 4473 + ( flux_t & 4474 / ( w(k,j,i) + SIGN( 1.0E-20_wp, w(k,j,i) ) ) & 4475 * ( w(k,j,i) - hom(k,1,3,0) ) & 4476 + diss_t & 4477 / ( ABS(w(k,j,i)) + 1.0E-20_wp ) & 4478 * ABS(w(k,j,i) - hom(k,1,3,0) ) & 4479 ) * weight_substep(intermediate_timestep_count) 4480 CASE ( 5 ) 4481 !$ACC ATOMIC 4482 sums_wsqrs_ws_l(k,tn) = sums_wsqrs_ws_l(k,tn) & 4483 + ( flux_t & 4484 / ( w(k,j,i) + SIGN( 1.0E-20_wp, w(k,j,i) ) ) & 4485 * ( w(k,j,i) - hom(k,1,3,0) ) & 4486 + diss_t & 4487 / ( ABS(w(k,j,i)) + 1.0E-20_wp ) & 4488 * ABS(w(k,j,i) - hom(k,1,3,0) ) & 4489 ) * weight_substep(intermediate_timestep_count) 4490 CASE ( 6 ) 4491 !$ACC ATOMIC 4492 sums_wsncs_ws_l(k,tn) = sums_wsncs_ws_l(k,tn) & 4493 + ( flux_t & 4494 / ( w(k,j,i) + SIGN( 1.0E-20_wp, w(k,j,i) ) ) & 4495 * ( w(k,j,i) - hom(k,1,3,0) ) & 4496 + diss_t & 4497 / ( ABS(w(k,j,i)) + 1.0E-20_wp ) & 4498 * ABS(w(k,j,i) - hom(k,1,3,0) ) & 4499 ) * weight_substep(intermediate_timestep_count) 4500 CASE ( 7 ) 4501 !$ACC ATOMIC 4502 sums_wsnrs_ws_l(k,tn) = sums_wsnrs_ws_l(k,tn) & 4503 + ( flux_t & 4504 / ( w(k,j,i) + SIGN( 1.0E-20_wp, w(k,j,i) ) ) & 4505 * ( w(k,j,i) - hom(k,1,3,0) ) & 4506 + diss_t & 4507 / ( ABS(w(k,j,i)) + 1.0E-20_wp ) & 4508 * ABS(w(k,j,i) - hom(k,1,3,0) ) & 4509 ) * weight_substep(intermediate_timestep_count) 4510 CASE ( 8 ) 4511 !$ACC ATOMIC 4512 sums_wsss_ws_l(k,tn) = sums_wsss_ws_l(k,tn) & 4513 + ( flux_t & 4514 / ( w(k,j,i) + SIGN( 1.0E-20_wp, w(k,j,i) ) ) & 4515 * ( w(k,j,i) - hom(k,1,3,0) ) & 4516 + diss_t & 4517 / ( ABS(w(k,j,i)) + 1.0E-20_wp ) & 4518 * ABS(w(k,j,i) - hom(k,1,3,0) ) & 4519 ) * weight_substep(intermediate_timestep_count) 4520 CASE ( 9 ) 4521 !$ACC ATOMIC 4522 sums_salsa_ws_l(k,tn) = sums_salsa_ws_l(k,tn) & 4523 + ( flux_t & 4524 / ( w(k,j,i) + SIGN( 1.0E-20_wp, w(k,j,i) ) ) & 4525 * ( w(k,j,i) - hom(k,1,3,0) ) & 4526 + diss_t & 4527 / ( ABS(w(k,j,i)) + 1.0E-20_wp ) & 4528 * ABS(w(k,j,i) - hom(k,1,3,0) ) & 4529 ) * weight_substep(intermediate_timestep_count) 4487 sums_salsa_ws_l(k,tn) = sums_salsa_ws_l(k,tn) & 4488 + ( flux_t(k) & 4489 / ( w(k,j,i) + SIGN( 1.0E-20_wp, w(k,j,i) ) ) & 4490 * ( w(k,j,i) - hom(k,1,3,0) ) & 4491 + diss_t(k) & 4492 / ( ABS(w(k,j,i)) + 1.0E-20_wp ) & 4493 * ABS(w(k,j,i) - hom(k,1,3,0) ) & 4494 ) * weight_substep(intermediate_timestep_count) 4530 4495 4531 4496 END SELECT 4532 4497 4533 4498 ENDDO 4534 4535 ENDDO 4536 ENDDO 4499 ENDDO 4500 ENDDO 4501 4502 CALL cpu_log( log_point_s(49), 'advec_s_ws', 'stop' ) 4537 4503 4538 4504 END SUBROUTINE advec_s_ws … … 4553 4519 INTEGER(iwp) :: k_pp !< k+2 index in disretization, can be modified to avoid segmentation faults 4554 4520 INTEGER(iwp) :: k_ppp !< k+3 index in disretization, can be modified to avoid segmentation faults 4555 INTEGER(iwp) :: nzb_max_l !< index indicating upper bound for order degradation of horizontal advection terms 4556 INTEGER(iwp) :: tn = 0 !< number of OpenMP thread 4557 4521 INTEGER(iwp) :: nzb_max_l !< index indicating upper bound for order degradation of horizontal advection terms 4522 INTEGER(iwp) :: tn = 0 !< number of OpenMP thread (is always zero here) 4523 4558 4524 REAL(wp) :: ibit0 !< flag indicating 1st-order scheme along x-direction 4559 4525 REAL(wp) :: ibit1 !< flag indicating 3rd-order scheme along x-direction … … 4579 4545 REAL(wp) :: flux_d !< 6th-order flux at grid box bottom 4580 4546 REAL(wp) :: gu !< Galilei-transformation velocity along x 4581 REAL(wp) :: gv !< Galilei-transformation velocity along y 4582 REAL(wp) :: v_comp !< advection velocity along y 4583 #ifdef _OPENACC 4547 REAL(wp) :: gv !< Galilei-transformation velocity along y 4548 REAL(wp) :: u_comp_l !< 4584 4549 REAL(wp) :: v_comp_s !< advection velocity along y 4585 #endif 4586 REAL(wp) :: w_comp !< advection velocity along z 4587 4588 REAL(wp) :: diss_s !< discretized artificial dissipation at southward-side of the grid box 4589 REAL(wp) :: flux_s !< discretized 6th-order flux at southward-side of the grid box 4590 #ifndef _OPENACC 4591 REAL(wp), DIMENSION(nzb+1:nzt) :: swap_diss_y_local_u !< discretized artificial dissipation at southward-side of the grid box 4592 REAL(wp), DIMENSION(nzb+1:nzt) :: swap_flux_y_local_u !< discretized 6th-order flux at southward-side of the grid box 4593 #endif 4594 4595 REAL(wp) :: diss_l !< discretized artificial dissipation at leftward-side of the grid box 4596 REAL(wp) :: flux_l !< discretized 6th-order flux at leftward-side of the grid box 4597 #ifndef _OPENACC 4598 REAL(wp), DIMENSION(nzb+1:nzt,nys:nyn) :: swap_diss_x_local_u !< discretized artificial dissipation at leftward-side of the grid box 4599 REAL(wp), DIMENSION(nzb+1:nzt,nys:nyn) :: swap_flux_x_local_u !< discretized 6th-order flux at leftward-side of the grid box 4600 #endif 4601 4602 REAL(wp) :: diss_n !< discretized artificial dissipation at northward-side of the grid box 4603 REAL(wp) :: diss_r !< discretized artificial dissipation at leftward-side of the grid box 4604 REAL(wp) :: diss_t !< discretized artificial dissipation at top of the grid box 4605 REAL(wp) :: flux_n !< discretized 6th-order flux at northward-side of the grid box 4606 REAL(wp) :: flux_r !< discretized 6th-order flux at rightward-side of the grid box 4607 REAL(wp) :: flux_t !< discretized 6th-order flux at top of the grid box 4608 REAL(wp) :: u_comp !< advection velocity along x 4609 #ifdef _OPENACC 4610 REAL(wp) :: u_comp_l !< 4611 #endif 4612 ! 4613 !-- Set local version of nzb_max. At non-cyclic boundaries the order of the 4614 !-- advection need to be degraded near the boundary. Please note, in contrast 4615 !-- to the cache-optimized routines, nzb_max_l is set constantly for the 4616 !-- entire subdomain, in order to avoid unsymmetric loops which might be 4617 !-- an issue for GPUs. 4618 IF( bc_dirichlet_l .OR. bc_radiation_l .OR. & 4619 bc_dirichlet_r .OR. bc_radiation_r .OR. & 4620 bc_dirichlet_s .OR. bc_radiation_s .OR. & 4621 bc_dirichlet_n .OR. bc_radiation_n ) THEN 4622 nzb_max_l = nzt 4623 ELSE 4624 nzb_max_l = nzb_max 4625 END IF 4626 4550 4551 REAL(wp), DIMENSION(nzb:nzt+1) :: diss_n !< discretized artificial dissipation at northward-side of the grid box 4552 REAL(wp), DIMENSION(nzb:nzt+1) :: diss_r !< discretized artificial dissipation at rightward-side of the grid box 4553 REAL(wp), DIMENSION(nzb:nzt+1) :: diss_t !< discretized artificial dissipation at top of the grid box 4554 REAL(wp), DIMENSION(nzb:nzt+1) :: flux_n !< discretized 6th-order flux at northward-side of the grid box 4555 REAL(wp), DIMENSION(nzb:nzt+1) :: flux_r !< discretized 6th-order flux at rightward-side of the grid box 4556 REAL(wp), DIMENSION(nzb:nzt+1) :: flux_t !< discretized 6th-order flux at top of the grid box 4557 REAL(wp), DIMENSION(nzb:nzt+1) :: u_comp !< advection velocity along x 4558 REAL(wp), DIMENSION(nzb:nzt+1) :: v_comp !< advection velocity along y 4559 REAL(wp), DIMENSION(nzb:nzt+1) :: w_comp !< advection velocity along z 4560 4561 CALL cpu_log( log_point_s(68), 'advec_u_ws', 'start' ) 4562 4627 4563 gu = 2.0_wp * u_gtrans 4628 4564 gv = 2.0_wp * v_gtrans 4629 4630 #ifndef _OPENACC4631 !4632 !-- Compute the fluxes for the whole left boundary of the processor domain.4633 i = nxlu4634 DO j = nys, nyn4635 DO k = nzb+1, nzb_max_l4636 4637 ibit2 = REAL( IBITS(advc_flags_m(k,j,i-1),2,1), KIND = wp )4638 ibit1 = REAL( IBITS(advc_flags_m(k,j,i-1),1,1), KIND = wp )4639 ibit0 = REAL( IBITS(advc_flags_m(k,j,i-1),0,1), KIND = wp )4640 4641 u_comp = u(k,j,i) + u(k,j,i-1) - gu4642 swap_flux_x_local_u(k,j) = u_comp * ( &4643 ( 37.0_wp * ibit2 * adv_mom_5 &4644 + 7.0_wp * ibit1 * adv_mom_3 &4645 + ibit0 * adv_mom_1 &4646 ) * &4647 ( u(k,j,i) + u(k,j,i-1) ) &4648 - ( 8.0_wp * ibit2 * adv_mom_5 &4649 + ibit1 * adv_mom_3 &4650 ) * &4651 ( u(k,j,i+1) + u(k,j,i-2) ) &4652 + ( ibit2 * adv_mom_5 &4653 ) * &4654 ( u(k,j,i+2) + u(k,j,i-3) ) &4655 )4656 4657 swap_diss_x_local_u(k,j) = - ABS( u_comp ) * ( &4658 ( 10.0_wp * ibit2 * adv_mom_5 &4659 + 3.0_wp * ibit1 * adv_mom_3 &4660 + ibit0 * adv_mom_1 &4661 ) * &4662 ( u(k,j,i) - u(k,j,i-1) ) &4663 - ( 5.0_wp * ibit2 * adv_mom_5 &4664 + ibit1 * adv_mom_3 &4665 ) * &4666 ( u(k,j,i+1) - u(k,j,i-2) ) &4667 + ( ibit2 * adv_mom_5 &4668 ) * &4669 ( u(k,j,i+2) - u(k,j,i-3) ) &4670 )4671 4672 ENDDO4673 4674 DO k = nzb_max_l+1, nzt4675 4676 u_comp = u(k,j,i) + u(k,j,i-1) - gu4677 swap_flux_x_local_u(k,j) = u_comp * ( &4678 37.0_wp * ( u(k,j,i) + u(k,j,i-1) ) &4679 - 8.0_wp * ( u(k,j,i+1) + u(k,j,i-2) ) &4680 + ( u(k,j,i+2) + u(k,j,i-3) ) ) * adv_mom_54681 swap_diss_x_local_u(k,j) = - ABS(u_comp) * ( &4682 10.0_wp * ( u(k,j,i) - u(k,j,i-1) ) &4683 - 5.0_wp * ( u(k,j,i+1) - u(k,j,i-2) ) &4684 + ( u(k,j,i+2) - u(k,j,i-3) ) ) * adv_mom_54685 4686 ENDDO4687 ENDDO4688 #endif4689 4565 4690 4566 !$ACC PARALLEL LOOP COLLAPSE(2) FIRSTPRIVATE(tn, gu, gv) & … … 4694 4570 !$ACC PRIVATE(ibit3_s, ibit4_s, ibit5_s) & 4695 4571 !$ACC PRIVATE(ibit6, ibit7, ibit8) & 4696 !$ACC PRIVATE(flux_r, diss_r , flux_l, diss_l) &4697 !$ACC PRIVATE(flux_n, diss_n , flux_s, diss_s) &4572 !$ACC PRIVATE(flux_r, diss_r) & 4573 !$ACC PRIVATE(flux_n, diss_n) & 4698 4574 !$ACC PRIVATE(flux_t, diss_t, flux_d, diss_d) & 4575 !$ACC PRIVATE(flux_l_u, diss_l_u, flux_s_u, diss_s_u) & 4699 4576 !$ACC PRIVATE(div, u_comp, u_comp_l, v_comp, v_comp_s, w_comp) & 4700 4577 !$ACC PRESENT(advc_flags_m) & … … 4702 4579 !$ACC PRESENT(drho_air, rho_air_zw, ddzw) & 4703 4580 !$ACC PRESENT(tend) & 4704 !$ACC PRESENT(hom( nzb+1:nzb_max_l,1,1:3,0)) &4581 !$ACC PRESENT(hom(:,1,1:3,0)) & 4705 4582 !$ACC PRESENT(weight_substep(intermediate_timestep_count)) & 4706 4583 !$ACC PRESENT(sums_us2_ws_l, sums_wsus_ws_l) 4707 DO i = nxlu, nxr 4584 DO i = nxlu, nxr 4585 4586 DO j = nys, nyn 4587 ! 4588 !-- Used local modified copy of nzb_max (used to degrade order of 4589 !-- discretization) at non-cyclic boundaries. Modify only at relevant points 4590 !-- instead of the entire subdomain. This should lead to better 4591 !-- load balance between boundary and non-boundary PEs. 4592 IF( ( bc_dirichlet_l .OR. bc_radiation_l ) .AND. i <= nxl + 2 .OR. & 4593 ( bc_dirichlet_r .OR. bc_radiation_r ) .AND. i >= nxr - 2 .OR. & 4594 ( bc_dirichlet_s .OR. bc_radiation_s ) .AND. j <= nys + 2 .OR. & 4595 ( bc_dirichlet_n .OR. bc_radiation_n ) .AND. j >= nyn - 2 ) THEN 4596 nzb_max_l = nzt 4597 ELSE 4598 nzb_max_l = nzb_max 4599 END IF 4708 4600 #ifndef _OPENACC 4709 ! 4710 !-- The following loop computes the fluxes for the south boundary points 4711 j = nys 4712 DO k = nzb+1, nzb_max_l 4713 4714 ibit5 = REAL( IBITS(advc_flags_m(k,j-1,i),5,1), KIND = wp ) 4715 ibit4 = REAL( IBITS(advc_flags_m(k,j-1,i),4,1), KIND = wp ) 4716 ibit3 = REAL( IBITS(advc_flags_m(k,j-1,i),3,1), KIND = wp ) 4717 4718 v_comp = v(k,j,i) + v(k,j,i-1) - gv 4719 swap_flux_y_local_u(k) = v_comp * ( & 4720 ( 37.0_wp * ibit5 * adv_mom_5 & 4721 + 7.0_wp * ibit4 * adv_mom_3 & 4722 + ibit3 * adv_mom_1 & 4723 ) * & 4724 ( u(k,j,i) + u(k,j-1,i) ) & 4725 - ( 8.0_wp * ibit5 * adv_mom_5 & 4726 + ibit4 * adv_mom_3 & 4727 ) * & 4728 ( u(k,j+1,i) + u(k,j-2,i) ) & 4729 + ( ibit5 * adv_mom_5 & 4730 ) * & 4731 ( u(k,j+2,i) + u(k,j-3,i) ) & 4732 ) 4733 4734 swap_diss_y_local_u(k) = - ABS ( v_comp ) * ( & 4735 ( 10.0_wp * ibit5 * adv_mom_5 & 4736 + 3.0_wp * ibit4 * adv_mom_3 & 4737 + ibit3 * adv_mom_1 & 4738 ) * & 4739 ( u(k,j,i) - u(k,j-1,i) ) & 4740 - ( 5.0_wp * ibit5 * adv_mom_5 & 4741 + ibit4 * adv_mom_3 & 4742 ) * & 4743 ( u(k,j+1,i) - u(k,j-2,i) ) & 4744 + ( ibit5 * adv_mom_5 & 4745 ) * & 4746 ( u(k,j+2,i) - u(k,j-3,i) ) & 4747 ) 4748 4749 ENDDO 4750 4751 DO k = nzb_max_l+1, nzt 4752 4753 v_comp = v(k,j,i) + v(k,j,i-1) - gv 4754 swap_flux_y_local_u(k) = v_comp * ( & 4755 37.0_wp * ( u(k,j,i) + u(k,j-1,i) ) & 4756 - 8.0_wp * ( u(k,j+1,i) + u(k,j-2,i) ) & 4757 + ( u(k,j+2,i) + u(k,j-3,i) ) ) * adv_mom_5 4758 swap_diss_y_local_u(k) = - ABS(v_comp) * ( & 4759 10.0_wp * ( u(k,j,i) - u(k,j-1,i) ) & 4760 - 5.0_wp * ( u(k,j+1,i) - u(k,j-2,i) ) & 4761 + ( u(k,j+2,i) - u(k,j-3,i) ) ) * adv_mom_5 4762 4763 ENDDO 4601 ! 4602 !-- Compute southside fluxes for the respective boundary of PE 4603 IF ( j == nys ) THEN 4604 4605 DO k = nzb+1, nzb_max_l 4606 4607 ibit5 = REAL( IBITS(advc_flags_m(k,j-1,i),5,1), KIND = wp ) 4608 ibit4 = REAL( IBITS(advc_flags_m(k,j-1,i),4,1), KIND = wp ) 4609 ibit3 = REAL( IBITS(advc_flags_m(k,j-1,i),3,1), KIND = wp ) 4610 4611 v_comp_s = v(k,j,i) + v(k,j,i-1) - gv 4612 flux_s_u(k,tn) = v_comp_s * ( & 4613 ( 37.0_wp * ibit5 * adv_mom_5 & 4614 + 7.0_wp * ibit4 * adv_mom_3 & 4615 + ibit3 * adv_mom_1 & 4616 ) * & 4617 ( u(k,j,i) + u(k,j-1,i) ) & 4618 - ( 8.0_wp * ibit5 * adv_mom_5 & 4619 + ibit4 * adv_mom_3 & 4620 ) * & 4621 ( u(k,j+1,i) + u(k,j-2,i) ) & 4622 + ( ibit5 * adv_mom_5 & 4623 ) * & 4624 ( u(k,j+2,i) + u(k,j-3,i) ) & 4625 ) 4626 4627 diss_s_u(k,tn) = - ABS ( v_comp_s ) * ( & 4628 ( 10.0_wp * ibit5 * adv_mom_5 & 4629 + 3.0_wp * ibit4 * adv_mom_3 & 4630 + ibit3 * adv_mom_1 & 4631 ) * & 4632 ( u(k,j,i) - u(k,j-1,i) ) & 4633 - ( 5.0_wp * ibit5 * adv_mom_5 & 4634 + ibit4 * adv_mom_3 & 4635 ) * & 4636 ( u(k,j+1,i) - u(k,j-2,i) ) & 4637 + ( ibit5 * adv_mom_5 & 4638 ) * & 4639 ( u(k,j+2,i) - u(k,j-3,i) ) & 4640 ) 4641 4642 ENDDO 4643 4644 DO k = nzb_max_l+1, nzt 4645 4646 v_comp_s = v(k,j,i) + v(k,j,i-1) - gv 4647 flux_s_u(k,tn) = v_comp_s * ( & 4648 37.0_wp * ( u(k,j,i) + u(k,j-1,i) ) & 4649 - 8.0_wp * ( u(k,j+1,i) + u(k,j-2,i) ) & 4650 + ( u(k,j+2,i) + u(k,j-3,i) ) ) * adv_mom_5 4651 diss_s_u(k,tn) = - ABS( v_comp_s ) * ( & 4652 10.0_wp * ( u(k,j,i) - u(k,j-1,i) ) & 4653 - 5.0_wp * ( u(k,j+1,i) - u(k,j-2,i) ) & 4654 + ( u(k,j+2,i) - u(k,j-3,i) ) ) * adv_mom_5 4655 4656 ENDDO 4657 4658 ENDIF 4659 ! 4660 !-- Compute leftside fluxes for the respective boundary of PE 4661 IF ( i == nxlu ) THEN 4662 4663 DO k = nzb+1, nzb_max_l 4664 4665 ibit2 = REAL( IBITS(advc_flags_m(k,j,i-1),2,1), KIND = wp ) 4666 ibit1 = REAL( IBITS(advc_flags_m(k,j,i-1),1,1), KIND = wp ) 4667 ibit0 = REAL( IBITS(advc_flags_m(k,j,i-1),0,1), KIND = wp ) 4668 4669 u_comp_l = u(k,j,i) + u(k,j,i-1) - gu 4670 flux_l_u(k,j,tn) = u_comp_l * ( & 4671 ( 37.0_wp * ibit2 * adv_mom_5 & 4672 + 7.0_wp * ibit1 * adv_mom_3 & 4673 + ibit0 * adv_mom_1 & 4674 ) * & 4675 ( u(k,j,i) + u(k,j,i-1) ) & 4676 - ( 8.0_wp * ibit2 * adv_mom_5 & 4677 + ibit1 * adv_mom_3 & 4678 ) * & 4679 ( u(k,j,i+1) + u(k,j,i-2) ) & 4680 + ( ibit2 * adv_mom_5 & 4681 ) * & 4682 ( u(k,j,i+2) + u(k,j,i-3) ) & 4683 ) 4684 4685 diss_l_u(k,j,tn) = - ABS( u_comp_l ) * ( & 4686 ( 10.0_wp * ibit2 * adv_mom_5 & 4687 + 3.0_wp * ibit1 * adv_mom_3 & 4688 + ibit0 * adv_mom_1 & 4689 ) * & 4690 ( u(k,j,i) - u(k,j,i-1) ) & 4691 - ( 5.0_wp * ibit2 * adv_mom_5 & 4692 + ibit1 * adv_mom_3 & 4693 ) * & 4694 ( u(k,j,i+1) - u(k,j,i-2) ) & 4695 + ( ibit2 * adv_mom_5 & 4696 ) * & 4697 ( u(k,j,i+2) - u(k,j,i-3) ) & 4698 ) 4699 4700 ENDDO 4701 4702 DO k = nzb_max_l+1, nzt 4703 4704 u_comp_l = u(k,j,i) + u(k,j,i-1) - gu 4705 flux_l_u(k,j,tn) = u_comp_l * ( & 4706 37.0_wp * ( u(k,j,i) + u(k,j,i-1) ) & 4707 - 8.0_wp * ( u(k,j,i+1) + u(k,j,i-2) ) & 4708 + ( u(k,j,i+2) + u(k,j,i-3) ) ) * adv_mom_5 4709 diss_l_u(k,j,tn) = - ABS(u_comp_l) * ( & 4710 10.0_wp * ( u(k,j,i) - u(k,j,i-1) ) & 4711 - 5.0_wp * ( u(k,j,i+1) - u(k,j,i-2) ) & 4712 + ( u(k,j,i+2) - u(k,j,i-3) ) ) * adv_mom_5 4713 4714 ENDDO 4715 4716 ENDIF 4764 4717 #endif 4765 4718 4766 4719 ! 4767 !-- Computation of interior fluxes and tendency terms 4768 DO j = nys, nyn 4769 4770 flux_d = 0.0_wp 4771 diss_d = 0.0_wp 4772 4720 !-- Now compute the fluxes for the horizontal and parts. 4773 4721 DO k = nzb+1, nzb_max_l 4774 4722 … … 4777 4725 ibit0 = REAL( IBITS(advc_flags_m(k,j,i),0,1), KIND = wp ) 4778 4726 4779 u_comp = u(k,j,i+1) + u(k,j,i)4780 flux_r = ( u_comp - gu ) * (&4781 ( 37.0_wp * ibit2 * adv_mom_5&4782 + 7.0_wp * ibit1 * adv_mom_3&4783 + ibit0* adv_mom_1 &4784 ) *&4785 ( u(k,j,i+1) + u(k,j,i) )&4786 - ( 8.0_wp * ibit2 * adv_mom_5&4787 + ibit1 * adv_mom_3&4788 ) *&4789 ( u(k,j,i+2) + u(k,j,i-1) )&4790 + ( ibit2 * adv_mom_5&4791 ) *&4792 ( u(k,j,i+3) + u(k,j,i-2) )&4793 ) 4794 4795 diss_r = - ABS( u_comp - gu ) * (&4796 ( 10.0_wp * ibit2 * adv_mom_5&4797 + 3.0_wp * ibit1 * adv_mom_3 &4798 + ibit0* adv_mom_1 &4799 ) *&4800 ( u(k,j,i+1) - u(k,j,i) )&4801 - ( 5.0_wp * ibit2 * adv_mom_5&4802 + ibit1 * adv_mom_3&4803 ) *&4804 ( u(k,j,i+2) - u(k,j,i-1) )&4805 + ( ibit2 * adv_mom_5&4806 ) *&4807 ( u(k,j,i+3) - u(k,j,i-2) )&4808 )4727 u_comp(k) = u(k,j,i+1) + u(k,j,i) 4728 flux_r(k) = ( u_comp(k) - gu ) * ( & 4729 ( 37.0_wp * ibit2 * adv_mom_5 & 4730 + 7.0_wp * ibit1 * adv_mom_3 & 4731 + ibit0 * adv_mom_1 & 4732 ) * & 4733 ( u(k,j,i+1) + u(k,j,i) ) & 4734 - ( 8.0_wp * ibit2 * adv_mom_5 & 4735 + ibit1 * adv_mom_3 & 4736 ) * & 4737 ( u(k,j,i+2) + u(k,j,i-1) ) & 4738 + ( ibit2 * adv_mom_5 & 4739 ) * & 4740 ( u(k,j,i+3) + u(k,j,i-2) ) & 4741 ) 4742 4743 diss_r(k) = - ABS( u_comp(k) - gu ) * ( & 4744 ( 10.0_wp * ibit2 * adv_mom_5 & 4745 + 3.0_wp * ibit1 * adv_mom_3 & 4746 + ibit0 * adv_mom_1 & 4747 ) * & 4748 ( u(k,j,i+1) - u(k,j,i) ) & 4749 - ( 5.0_wp * ibit2 * adv_mom_5 & 4750 + ibit1 * adv_mom_3 & 4751 ) * & 4752 ( u(k,j,i+2) - u(k,j,i-1) ) & 4753 + ( ibit2 * adv_mom_5 & 4754 ) * & 4755 ( u(k,j,i+3) - u(k,j,i-2) ) & 4756 ) 4809 4757 4810 4758 #ifdef _OPENACC … … 4815 4763 ibit0_l = REAL( IBITS(advc_flags_m(k,j,i-1),0,1), KIND = wp ) 4816 4764 4817 u_comp_l = u(k,j,i) + u(k,j,i-1) - gu4818 flux_l = u_comp_l * (&4765 u_comp_l = u(k,j,i) + u(k,j,i-1) - gu 4766 flux_l_u(k,j,tn) = u_comp_l * ( & 4819 4767 ( 37.0_wp * ibit2_l * adv_mom_5 & 4820 4768 + 7.0_wp * ibit1_l * adv_mom_3 & 4821 + ibit0_l * adv_mom_1&4769 + ibit0_l * adv_mom_1 & 4822 4770 ) * & 4823 4771 ( u(k,j,i) + u(k,j,i-1) ) & … … 4829 4777 ) * & 4830 4778 ( u(k,j,i+2) + u(k,j,i-3) ) & 4831 4832 4833 diss_l = - ABS( u_comp_l ) * (&4779 ) 4780 4781 diss_l_u(k,j,tn) = - ABS( u_comp_l ) * ( & 4834 4782 ( 10.0_wp * ibit2_l * adv_mom_5 & 4835 4783 + 3.0_wp * ibit1_l * adv_mom_3 & … … 4844 4792 ) * & 4845 4793 ( u(k,j,i+2) - u(k,j,i-3) ) & 4846 ) 4847 #else 4848 flux_l = swap_flux_x_local_u(k,j) 4849 diss_l = swap_diss_x_local_u(k,j) 4794 ) 4850 4795 #endif 4796 4851 4797 4852 4798 ibit5 = REAL( IBITS(advc_flags_m(k,j,i),5,1), KIND = wp ) … … 4854 4800 ibit3 = REAL( IBITS(advc_flags_m(k,j,i),3,1), KIND = wp ) 4855 4801 4856 v_comp = v(k,j+1,i) + v(k,j+1,i-1) - gv4857 flux_n = v_comp * (&4858 ( 37.0_wp * ibit5 * adv_mom_5&4859 + 7.0_wp * ibit4 * adv_mom_3&4860 + ibit3 * adv_mom_1&4861 ) *&4862 ( u(k,j+1,i) + u(k,j,i) )&4863 - ( 8.0_wp * ibit5 * adv_mom_5&4864 + ibit4 * adv_mom_3&4865 ) *&4866 ( u(k,j+2,i) + u(k,j-1,i) )&4867 + ( ibit5 * adv_mom_5 &4868 ) *&4869 ( u(k,j+3,i) + u(k,j-2,i) )&4870 )4871 4872 diss_n = - ABS ( v_comp ) * (&4873 ( 10.0_wp * ibit5 * adv_mom_5&4874 + 3.0_wp * ibit4 * adv_mom_3&4875 + ibit3 * adv_mom_1&4876 ) *&4877 ( u(k,j+1,i) - u(k,j,i) )&4878 - ( 5.0_wp * ibit5 * adv_mom_5&4879 + ibit4 * adv_mom_3&4880 ) *&4881 ( u(k,j+2,i) - u(k,j-1,i) )&4882 + ( ibit5 * adv_mom_5&4883 ) *&4884 ( u(k,j+3,i) - u(k,j-2,i) )&4885 4802 v_comp(k) = v(k,j+1,i) + v(k,j+1,i-1) - gv 4803 flux_n(k) = v_comp(k) * ( & 4804 ( 37.0_wp * ibit5 * adv_mom_5 & 4805 + 7.0_wp * ibit4 * adv_mom_3 & 4806 + ibit3 * adv_mom_1 & 4807 ) * & 4808 ( u(k,j+1,i) + u(k,j,i) ) & 4809 - ( 8.0_wp * ibit5 * adv_mom_5 & 4810 + ibit4 * adv_mom_3 & 4811 ) * & 4812 ( u(k,j+2,i) + u(k,j-1,i) ) & 4813 + ( ibit5 * adv_mom_5 & 4814 ) * & 4815 ( u(k,j+3,i) + u(k,j-2,i) ) & 4816 ) 4817 4818 diss_n(k) = - ABS ( v_comp(k) ) * ( & 4819 ( 10.0_wp * ibit5 * adv_mom_5 & 4820 + 3.0_wp * ibit4 * adv_mom_3 & 4821 + ibit3 * adv_mom_1 & 4822 ) * & 4823 ( u(k,j+1,i) - u(k,j,i) ) & 4824 - ( 5.0_wp * ibit5 * adv_mom_5 & 4825 + ibit4 * adv_mom_3 & 4826 ) * & 4827 ( u(k,j+2,i) - u(k,j-1,i) ) & 4828 + ( ibit5 * adv_mom_5 & 4829 ) * & 4830 ( u(k,j+3,i) - u(k,j-2,i) ) & 4831 ) 4886 4832 4887 4833 #ifdef _OPENACC … … 4892 4838 ibit3_s = REAL( IBITS(advc_flags_m(k,j-1,i),3,1), KIND = wp ) 4893 4839 4894 v_comp_s = v(k,j,i) + v(k,j,i-1) - gv4895 flux_s = v_comp_s * (&4840 v_comp_s = v(k,j,i) + v(k,j,i-1) - gv 4841 flux_s_u(k,tn) = v_comp_s * ( & 4896 4842 ( 37.0_wp * ibit5_s * adv_mom_5 & 4897 4843 + 7.0_wp * ibit4_s * adv_mom_3 & … … 4906 4852 ) * & 4907 4853 ( u(k,j+2,i) + u(k,j-3,i) ) & 4908 4909 4910 diss_s = - ABS ( v_comp_s ) * (&4854 ) 4855 4856 diss_s_u(k,tn) = - ABS ( v_comp_s ) * ( & 4911 4857 ( 10.0_wp * ibit5_s * adv_mom_5 & 4912 4858 + 3.0_wp * ibit4_s * adv_mom_3 & … … 4921 4867 ) * & 4922 4868 ( u(k,j+2,i) - u(k,j-3,i) ) & 4923 ) 4924 #else 4925 flux_s = swap_flux_y_local_u(k) 4926 diss_s = swap_diss_y_local_u(k) 4869 ) 4927 4870 #endif 4928 4871 ENDDO 4872 4873 DO k = nzb_max_l+1, nzt 4874 4875 u_comp(k) = u(k,j,i+1) + u(k,j,i) 4876 flux_r(k) = ( u_comp(k) - gu ) * ( & 4877 37.0_wp * ( u(k,j,i+1) + u(k,j,i) ) & 4878 - 8.0_wp * ( u(k,j,i+2) + u(k,j,i-1) ) & 4879 + ( u(k,j,i+3) + u(k,j,i-2) ) ) * adv_mom_5 4880 diss_r(k) = - ABS( u_comp(k) - gu ) * ( & 4881 10.0_wp * ( u(k,j,i+1) - u(k,j,i) ) & 4882 - 5.0_wp * ( u(k,j,i+2) - u(k,j,i-1) ) & 4883 + ( u(k,j,i+3) - u(k,j,i-2) ) ) * adv_mom_5 4884 #ifdef _OPENACC 4885 ! 4886 !-- Recompute the left fluxes. 4887 u_comp_l = u(k,j,i) + u(k,j,i-1) - gu 4888 flux_l_u(k,j,tn) = u_comp_l * ( & 4889 37.0_wp * ( u(k,j,i) + u(k,j,i-1) ) & 4890 - 8.0_wp * ( u(k,j,i+1) + u(k,j,i-2) ) & 4891 + ( u(k,j,i+2) + u(k,j,i-3) ) ) * adv_mom_5 4892 diss_l_u(k,j,tn) = - ABS(u_comp_l) * ( & 4893 10.0_wp * ( u(k,j,i) - u(k,j,i-1) ) & 4894 - 5.0_wp * ( u(k,j,i+1) - u(k,j,i-2) ) & 4895 + ( u(k,j,i+2) - u(k,j,i-3) ) ) * adv_mom_5 4896 4897 #endif 4898 v_comp(k) = v(k,j+1,i) + v(k,j+1,i-1) - gv 4899 flux_n(k) = v_comp(k) * ( & 4900 37.0_wp * ( u(k,j+1,i) + u(k,j,i) ) & 4901 - 8.0_wp * ( u(k,j+2,i) + u(k,j-1,i) ) & 4902 + ( u(k,j+3,i) + u(k,j-2,i) ) ) * adv_mom_5 4903 diss_n(k) = - ABS( v_comp(k) ) * ( & 4904 10.0_wp * ( u(k,j+1,i) - u(k,j,i) ) & 4905 - 5.0_wp * ( u(k,j+2,i) - u(k,j-1,i) ) & 4906 + ( u(k,j+3,i) - u(k,j-2,i) ) ) * adv_mom_5 4907 #ifdef _OPENACC 4908 ! 4909 !-- Recompute the south fluxes. 4910 v_comp_s = v(k,j,i) + v(k,j,i-1) - gv 4911 flux_s_u(k,tn) = v_comp_s * ( & 4912 37.0_wp * ( u(k,j,i) + u(k,j-1,i) ) & 4913 - 8.0_wp * ( u(k,j+1,i) + u(k,j-2,i) ) & 4914 + ( u(k,j+2,i) + u(k,j-3,i) ) ) * adv_mom_5 4915 diss_s_u(k,tn) = - ABS( v_comp_s ) * ( & 4916 10.0_wp * ( u(k,j,i) - u(k,j-1,i) ) & 4917 - 5.0_wp * ( u(k,j+1,i) - u(k,j-2,i) ) & 4918 + ( u(k,j+2,i) - u(k,j-3,i) ) ) * adv_mom_5 4919 #endif 4920 ENDDO 4921 ! 4922 !-- Now, compute vertical fluxes. Split loop into a part treating the 4923 !-- lowest 2 grid points with indirect indexing, a main loop without 4924 !-- indirect indexing, and a loop for the uppermost 2 grip points with 4925 !-- indirect indexing. This allows better vectorization for the main loop. 4926 !-- First, compute the flux at model surface, which need has to be 4927 !-- calculated explicetely for the tendency at 4928 !-- the first w-level. For topography wall this is done implicitely by 4929 !-- advc_flags_m. 4930 flux_t(nzb) = 0.0_wp 4931 diss_t(nzb) = 0.0_wp 4932 w_comp(nzb) = 0.0_wp 4933 DO k = nzb+1, nzb+2 4929 4934 ! 4930 4935 !-- k index has to be modified near bottom and top, else array … … 4935 4940 4936 4941 k_ppp = k + 3 * ibit8 4937 k_pp = k + 2 * ( 1 - ibit6 4942 k_pp = k + 2 * ( 1 - ibit6 ) 4938 4943 k_mm = k - 2 * ibit8 4939 4944 4940 w_comp = w(k,j,i) + w(k,j,i-1) 4941 flux_t = w_comp * rho_air_zw(k) * ( & 4942 ( 37.0_wp * ibit8 * adv_mom_5 & 4943 + 7.0_wp * ibit7 * adv_mom_3 & 4944 + ibit6 * adv_mom_1 & 4945 ) * & 4946 ( u(k+1,j,i) + u(k,j,i) ) & 4947 - ( 8.0_wp * ibit8 * adv_mom_5 & 4948 + ibit7 * adv_mom_3 & 4949 ) * & 4950 ( u(k_pp,j,i) + u(k-1,j,i) ) & 4951 + ( ibit8 * adv_mom_5 & 4952 ) * & 4953 ( u(k_ppp,j,i) + u(k_mm,j,i) ) & 4954 ) 4955 4956 diss_t = - ABS( w_comp ) * rho_air_zw(k) * ( & 4957 ( 10.0_wp * ibit8 * adv_mom_5 & 4958 + 3.0_wp * ibit7 * adv_mom_3 & 4959 + ibit6 * adv_mom_1 & 4960 ) * & 4961 ( u(k+1,j,i) - u(k,j,i) ) & 4962 - ( 5.0_wp * ibit8 * adv_mom_5 & 4963 + ibit7 * adv_mom_3 & 4964 ) * & 4965 ( u(k_pp,j,i) - u(k-1,j,i) ) & 4966 + ( ibit8 * adv_mom_5 & 4967 ) * & 4968 ( u(k_ppp,j,i) - u(k_mm,j,i) ) & 4969 ) 4970 ! 4971 !-- Calculate the divergence of the velocity field. A respective 4972 !-- correction is needed to overcome numerical instabilities caused 4973 !-- by a not sufficient reduction of divergences near topography. 4974 div = ( ( u_comp * ( ibit0 + ibit1 + ibit2 ) & 4975 - ( u(k,j,i) + u(k,j,i-1) ) & 4976 * ( & 4977 REAL( IBITS(advc_flags_m(k,j,i-1),0,1), KIND = wp ) & 4978 + REAL( IBITS(advc_flags_m(k,j,i-1),1,1), KIND = wp ) & 4979 + REAL( IBITS(advc_flags_m(k,j,i-1),2,1), KIND = wp ) & 4980 ) & 4981 ) * ddx & 4982 + ( ( v_comp + gv ) * ( ibit3 + ibit4 + ibit5 ) & 4983 - ( v(k,j,i) + v(k,j,i-1 ) ) & 4984 * ( & 4985 REAL( IBITS(advc_flags_m(k,j-1,i),3,1), KIND = wp ) & 4986 + REAL( IBITS(advc_flags_m(k,j-1,i),4,1), KIND = wp ) & 4987 + REAL( IBITS(advc_flags_m(k,j-1,i),5,1), KIND = wp ) & 4988 ) & 4989 ) * ddy & 4990 + ( w_comp * rho_air_zw(k) * ( ibit6 + ibit7 + ibit8 ) & 4991 - ( w(k-1,j,i) + w(k-1,j,i-1) ) * rho_air_zw(k-1) & 4992 * ( & 4993 REAL( IBITS(advc_flags_m(k-1,j,i),6,1), KIND = wp ) & 4994 + REAL( IBITS(advc_flags_m(k-1,j,i),7,1), KIND = wp ) & 4995 + REAL( IBITS(advc_flags_m(k-1,j,i),8,1), KIND = wp ) & 4996 ) & 4997 ) * drho_air(k) * ddzw(k) & 4998 ) * 0.5_wp 4999 5000 5001 5002 tend(k,j,i) = tend(k,j,i) - ( & 5003 ( ( flux_r + diss_r ) & 5004 - ( flux_l + diss_l ) ) * ddx & 5005 + ( ( flux_n + diss_n ) & 5006 - ( flux_s + diss_s ) ) * ddy & 5007 + ( ( flux_t + diss_t ) & 5008 - ( flux_d + diss_d ) ) * drho_air(k) * ddzw(k) & 5009 ) + div * u(k,j,i) 5010 5011 #ifndef _OPENACC 5012 swap_flux_x_local_u(k,j) = flux_r 5013 swap_diss_x_local_u(k,j) = diss_r 5014 swap_flux_y_local_u(k) = flux_n 5015 swap_diss_y_local_u(k) = diss_n 5016 #endif 5017 flux_d = flux_t 5018 diss_d = diss_t 5019 ! 5020 !-- Statistical Evaluation of u'u'. The factor has to be applied 5021 !-- for right evaluation when gallilei_trans = .T. . 5022 !$ACC ATOMIC 5023 sums_us2_ws_l(k,tn) = sums_us2_ws_l(k,tn) & 5024 + ( flux_r & 5025 * ( u_comp - 2.0_wp * hom(k,1,1,0) ) & 5026 / ( u_comp - gu + SIGN( 1.0E-20_wp, u_comp - gu ) ) & 5027 + diss_r & 5028 * ABS( u_comp - 2.0_wp * hom(k,1,1,0) ) & 5029 / ( ABS( u_comp - gu ) + 1.0E-20_wp ) & 5030 ) * weight_substep(intermediate_timestep_count) 5031 ! 5032 !-- Statistical Evaluation of w'u'. 5033 !$ACC ATOMIC 5034 sums_wsus_ws_l(k,tn) = sums_wsus_ws_l(k,tn) & 5035 + ( flux_t & 5036 * ( w_comp - 2.0_wp * hom(k,1,3,0) ) & 5037 / ( w_comp + SIGN( 1.0E-20_wp, w_comp ) ) & 5038 + diss_t & 5039 * ABS( w_comp - 2.0_wp * hom(k,1,3,0) ) & 5040 / ( ABS( w_comp ) + 1.0E-20_wp ) & 5041 ) * weight_substep(intermediate_timestep_count) 5042 4945 w_comp(k) = w(k,j,i) + w(k,j,i-1) 4946 flux_t(k) = w_comp(k) * rho_air_zw(k) * ( & 4947 ( 37.0_wp * ibit8 * adv_mom_5 & 4948 + 7.0_wp * ibit7 * adv_mom_3 & 4949 + ibit6 * adv_mom_1 & 4950 ) * & 4951 ( u(k+1,j,i) + u(k,j,i) ) & 4952 - ( 8.0_wp * ibit8 * adv_mom_5 & 4953 + ibit7 * adv_mom_3 & 4954 ) * & 4955 ( u(k_pp,j,i) + u(k-1,j,i) ) & 4956 + ( ibit8 * adv_mom_5 & 4957 ) * & 4958 ( u(k_ppp,j,i) + u(k_mm,j,i) ) & 4959 ) 4960 4961 diss_t(k) = - ABS( w_comp(k) ) * rho_air_zw(k) * ( & 4962 ( 10.0_wp * ibit8 * adv_mom_5 & 4963 + 3.0_wp * ibit7 * adv_mom_3 & 4964 + ibit6 * adv_mom_1 & 4965 ) * & 4966 ( u(k+1,j,i) - u(k,j,i) ) & 4967 - ( 5.0_wp * ibit8 * adv_mom_5 & 4968 + ibit7 * adv_mom_3 & 4969 ) * & 4970 ( u(k_pp,j,i) - u(k-1,j,i) ) & 4971 + ( ibit8 * adv_mom_5 & 4972 ) * & 4973 ( u(k_ppp,j,i) - u(k_mm,j,i) ) & 4974 ) 5043 4975 ENDDO 5044 4976 5045 DO k = nzb_max_l+1, nzt 5046 5047 u_comp = u(k,j,i+1) + u(k,j,i) 5048 flux_r = ( u_comp - gu ) * ( & 5049 37.0_wp * ( u(k,j,i+1) + u(k,j,i) ) & 5050 - 8.0_wp * ( u(k,j,i+2) + u(k,j,i-1) ) & 5051 + ( u(k,j,i+3) + u(k,j,i-2) ) ) * adv_mom_5 5052 diss_r = - ABS( u_comp - gu ) * ( & 5053 10.0_wp * ( u(k,j,i+1) - u(k,j,i) ) & 5054 - 5.0_wp * ( u(k,j,i+2) - u(k,j,i-1) ) & 5055 + ( u(k,j,i+3) - u(k,j,i-2) ) ) * adv_mom_5 5056 5057 #ifdef _OPENACC 5058 ! 5059 !-- Recompute the left fluxes. 5060 u_comp_l = u(k,j,i) + u(k,j,i-1) - gu 5061 flux_l = u_comp_l * ( & 5062 37.0_wp * ( u(k,j,i) + u(k,j,i-1) ) & 5063 - 8.0_wp * ( u(k,j,i+1) + u(k,j,i-2) ) & 5064 + ( u(k,j,i+2) + u(k,j,i-3) ) ) * adv_mom_5 5065 diss_l = - ABS(u_comp_l) * ( & 5066 10.0_wp * ( u(k,j,i) - u(k,j,i-1) ) & 5067 - 5.0_wp * ( u(k,j,i+1) - u(k,j,i-2) ) & 5068 + ( u(k,j,i+2) - u(k,j,i-3) ) ) * adv_mom_5 5069 #else 5070 flux_l = swap_flux_x_local_u(k,j) 5071 diss_l = swap_diss_x_local_u(k,j) 5072 #endif 5073 5074 v_comp = v(k,j+1,i) + v(k,j+1,i-1) - gv 5075 flux_n = v_comp * ( & 5076 37.0_wp * ( u(k,j+1,i) + u(k,j,i) ) & 5077 - 8.0_wp * ( u(k,j+2,i) + u(k,j-1,i) ) & 5078 + ( u(k,j+3,i) + u(k,j-2,i) ) ) * adv_mom_5 5079 diss_n = - ABS( v_comp ) * ( & 5080 10.0_wp * ( u(k,j+1,i) - u(k,j,i) ) & 5081 - 5.0_wp * ( u(k,j+2,i) - u(k,j-1,i) ) & 5082 + ( u(k,j+3,i) - u(k,j-2,i) ) ) * adv_mom_5 5083 5084 #ifdef _OPENACC 5085 ! 5086 !-- Recompute the south fluxes. 5087 v_comp_s = v(k,j,i) + v(k,j,i-1) - gv 5088 flux_s = v_comp_s * ( & 5089 37.0_wp * ( u(k,j,i) + u(k,j-1,i) ) & 5090 - 8.0_wp * ( u(k,j+1,i) + u(k,j-2,i) ) & 5091 + ( u(k,j+2,i) + u(k,j-3,i) ) ) * adv_mom_5 5092 diss_s = - ABS( v_comp_s ) * ( & 5093 10.0_wp * ( u(k,j,i) - u(k,j-1,i) ) & 5094 - 5.0_wp * ( u(k,j+1,i) - u(k,j-2,i) ) & 5095 + ( u(k,j+2,i) - u(k,j-3,i) ) ) * adv_mom_5 5096 #else 5097 flux_s = swap_flux_y_local_u(k) 5098 diss_s = swap_diss_y_local_u(k) 5099 #endif 5100 4977 DO k = nzb+3, nzt-2 4978 4979 ibit8 = REAL( IBITS(advc_flags_m(k,j,i),8,1), KIND = wp ) 4980 ibit7 = REAL( IBITS(advc_flags_m(k,j,i),7,1), KIND = wp ) 4981 ibit6 = REAL( IBITS(advc_flags_m(k,j,i),6,1), KIND = wp ) 4982 4983 w_comp(k) = w(k,j,i) + w(k,j,i-1) 4984 flux_t(k) = w_comp(k) * rho_air_zw(k) * ( & 4985 ( 37.0_wp * ibit8 * adv_mom_5 & 4986 + 7.0_wp * ibit7 * adv_mom_3 & 4987 + ibit6 * adv_mom_1 & 4988 ) * & 4989 ( u(k+1,j,i) + u(k,j,i) ) & 4990 - ( 8.0_wp * ibit8 * adv_mom_5 & 4991 + ibit7 * adv_mom_3 & 4992 ) * & 4993 ( u(k+2,j,i) + u(k-1,j,i) ) & 4994 + ( ibit8 * adv_mom_5 & 4995 ) * & 4996 ( u(k+3,j,i) + u(k-2,j,i) ) & 4997 ) 4998 4999 diss_t(k) = - ABS( w_comp(k) ) * rho_air_zw(k) * ( & 5000 ( 10.0_wp * ibit8 * adv_mom_5 & 5001 + 3.0_wp * ibit7 * adv_mom_3 & 5002 + ibit6 * adv_mom_1 & 5003 ) * & 5004 ( u(k+1,j,i) - u(k,j,i) ) & 5005 - ( 5.0_wp * ibit8 * adv_mom_5 & 5006 + ibit7 * adv_mom_3 & 5007 ) * & 5008 ( u(k+2,j,i) - u(k-1,j,i) ) & 5009 + ( ibit8 * adv_mom_5 & 5010 ) * & 5011 ( u(k+3,j,i) - u(k-2,j,i) ) & 5012 ) 5013 ENDDO 5014 5015 DO k = nzt-1, nzt-symmetry_flag 5101 5016 ! 5102 5017 !-- k index has to be modified near bottom and top, else array … … 5107 5022 5108 5023 k_ppp = k + 3 * ibit8 5109 k_pp = k + 2 * ( 1 - ibit6 5024 k_pp = k + 2 * ( 1 - ibit6 ) 5110 5025 k_mm = k - 2 * ibit8 5111 5026 5112 w_comp = w(k,j,i) + w(k,j,i-1) 5113 flux_t = w_comp * rho_air_zw(k) * ( & 5114 ( 37.0_wp * ibit8 * adv_mom_5 & 5115 + 7.0_wp * ibit7 * adv_mom_3 & 5116 + ibit6 * adv_mom_1 & 5117 ) * & 5118 ( u(k+1,j,i) + u(k,j,i) ) & 5119 - ( 8.0_wp * ibit8 * adv_mom_5 & 5120 + ibit7 * adv_mom_3 & 5121 ) * & 5122 ( u(k_pp,j,i) + u(k-1,j,i) ) & 5123 + ( ibit8 * adv_mom_5 & 5124 ) * & 5125 ( u(k_ppp,j,i) + u(k_mm,j,i) ) & 5126 ) 5127 5128 diss_t = - ABS( w_comp ) * rho_air_zw(k) * ( & 5129 ( 10.0_wp * ibit8 * adv_mom_5 & 5130 + 3.0_wp * ibit7 * adv_mom_3 & 5131 + ibit6 * adv_mom_1 & 5132 ) * & 5133 ( u(k+1,j,i) - u(k,j,i) ) & 5134 - ( 5.0_wp * ibit8 * adv_mom_5 & 5135 + ibit7 * adv_mom_3 & 5136 ) * & 5137 ( u(k_pp,j,i) - u(k-1,j,i) ) & 5138 + ( ibit8 * adv_mom_5 & 5139 ) * & 5140 ( u(k_ppp,j,i) - u(k_mm,j,i) ) & 5141 ) 5027 w_comp(k) = w(k,j,i) + w(k,j,i-1) 5028 flux_t(k) = w_comp(k) * rho_air_zw(k) * ( & 5029 ( 37.0_wp * ibit8 * adv_mom_5 & 5030 + 7.0_wp * ibit7 * adv_mom_3 & 5031 + ibit6 * adv_mom_1 & 5032 ) * & 5033 ( u(k+1,j,i) + u(k,j,i) ) & 5034 - ( 8.0_wp * ibit8 * adv_mom_5 & 5035 + ibit7 * adv_mom_3 & 5036 ) * & 5037 ( u(k_pp,j,i) + u(k-1,j,i) ) & 5038 + ( ibit8 * adv_mom_5 & 5039 ) * & 5040 ( u(k_ppp,j,i) + u(k_mm,j,i) ) & 5041 ) 5042 5043 diss_t(k) = - ABS( w_comp(k) ) * rho_air_zw(k) * ( & 5044 ( 10.0_wp * ibit8 * adv_mom_5 & 5045 + 3.0_wp * ibit7 * adv_mom_3 & 5046 + ibit6 * adv_mom_1 & 5047 ) * & 5048 ( u(k+1,j,i) - u(k,j,i) ) & 5049 - ( 5.0_wp * ibit8 * adv_mom_5 & 5050 + ibit7 * adv_mom_3 & 5051 ) * & 5052 ( u(k_pp,j,i) - u(k-1,j,i) ) & 5053 + ( ibit8 * adv_mom_5 & 5054 ) * & 5055 ( u(k_ppp,j,i) - u(k_mm,j,i) ) & 5056 ) 5057 ENDDO 5058 ! 5059 !-- Set resolved/turbulent flux at model top to zero (w-level). In case that 5060 !-- a symmetric behavior between bottom and top shall be guaranteed (closed 5061 !-- channel flow), the flux at nzt is also set to zero. 5062 IF ( symmetry_flag == 1 ) THEN 5063 flux_t(nzt) = 0.0_wp 5064 diss_t(nzt) = 0.0_wp 5065 w_comp(nzt) = 0.0_wp 5066 ENDIF 5067 flux_t(nzt+1) = 0.0_wp 5068 diss_t(nzt+1) = 0.0_wp 5069 w_comp(nzt+1) = 0.0_wp 5070 5071 DO k = nzb+1, nzb_max_l 5072 5073 flux_d = flux_t(k-1) 5074 diss_d = diss_t(k-1) 5075 5076 ibit2 = REAL( IBITS(advc_flags_m(k,j,i),2,1), KIND = wp ) 5077 ibit1 = REAL( IBITS(advc_flags_m(k,j,i),1,1), KIND = wp ) 5078 ibit0 = REAL( IBITS(advc_flags_m(k,j,i),0,1), KIND = wp ) 5079 5080 ibit5 = REAL( IBITS(advc_flags_m(k,j,i),5,1), KIND = wp ) 5081 ibit4 = REAL( IBITS(advc_flags_m(k,j,i),4,1), KIND = wp ) 5082 ibit3 = REAL( IBITS(advc_flags_m(k,j,i),3,1), KIND = wp ) 5083 5084 ibit8 = REAL( IBITS(advc_flags_m(k,j,i),8,1), KIND = wp ) 5085 ibit7 = REAL( IBITS(advc_flags_m(k,j,i),7,1), KIND = wp ) 5086 ibit6 = REAL( IBITS(advc_flags_m(k,j,i),6,1), KIND = wp ) 5142 5087 ! 5143 5088 !-- Calculate the divergence of the velocity field. A respective 5144 !-- correction is needed to overcome numerical instabilities caused5089 !-- correction is needed to overcome numerical instabilities introduced 5145 5090 !-- by a not sufficient reduction of divergences near topography. 5146 div = ( ( u_comp - ( u(k,j,i) + u(k,j,i-1) ) ) * ddx & 5147 + ( v_comp + gv - ( v(k,j,i) + v(k,j,i-1 ) ) ) * ddy & 5148 + ( w_comp * rho_air_zw(k) - & 5149 ( w(k-1,j,i) + w(k-1,j,i-1) ) * rho_air_zw(k-1) & 5150 ) * drho_air(k) * ddzw(k) & 5091 div = ( ( u_comp(k) * ( ibit0 + ibit1 + ibit2 ) & 5092 - ( u(k,j,i) + u(k,j,i-1) ) & 5093 * ( & 5094 REAL( IBITS(advc_flags_m(k,j,i-1),0,1), KIND = wp ) & 5095 + REAL( IBITS(advc_flags_m(k,j,i-1),1,1), KIND = wp ) & 5096 + REAL( IBITS(advc_flags_m(k,j,i-1),2,1), KIND = wp ) & 5097 ) & 5098 ) * ddx & 5099 + ( ( v_comp(k) + gv ) * ( ibit3 + ibit4 + ibit5 ) & 5100 - ( v(k,j,i) + v(k,j,i-1 ) ) & 5101 * ( & 5102 REAL( IBITS(advc_flags_m(k,j-1,i),3,1), KIND = wp ) & 5103 + REAL( IBITS(advc_flags_m(k,j-1,i),4,1), KIND = wp ) & 5104 + REAL( IBITS(advc_flags_m(k,j-1,i),5,1), KIND = wp ) & 5105 ) & 5106 ) * ddy & 5107 + ( w_comp(k) * rho_air_zw(k) * ( ibit6 + ibit7 + ibit8 )& 5108 - w_comp(k-1) * rho_air_zw(k-1) & 5109 * ( & 5110 REAL( IBITS(advc_flags_m(k-1,j,i),6,1), KIND = wp ) & 5111 + REAL( IBITS(advc_flags_m(k-1,j,i),7,1), KIND = wp ) & 5112 + REAL( IBITS(advc_flags_m(k-1,j,i),8,1), KIND = wp ) & 5113 ) & 5114 ) * drho_air(k) * ddzw(k) & 5151 5115 ) * 0.5_wp 5152 5116 5153 tend(k,j,i) = tend(k,j,i) - ( &5154 ( ( flux_r + diss_r )&5155 - ( flux_l + diss_l ) ) * ddx&5156 + ( ( flux_n + diss_n )&5157 - ( flux_s + diss_s ) ) * ddy&5158 + ( ( flux_t + diss_t )&5159 - ( flux_d + diss_d ) ) * drho_air(k) * ddzw(k)&5160 ) + div * u(k,j,i)5161 5117 tend(k,j,i) = tend(k,j,i) - ( & 5118 ( flux_r(k) + diss_r(k) & 5119 - flux_l_u(k,j,tn) - diss_l_u(k,j,tn) ) * ddx & 5120 + ( flux_n(k) + diss_n(k) & 5121 - flux_s_u(k,tn) - diss_s_u(k,tn) ) * ddy & 5122 + ( ( flux_t(k) + diss_t(k) ) & 5123 - ( flux_d + diss_d ) & 5124 ) * drho_air(k) * ddzw(k) & 5125 ) + div * u(k,j,i) 5162 5126 #ifndef _OPENACC 5163 swap_flux_x_local_u(k,j) = flux_r 5164 swap_diss_x_local_u(k,j) = diss_r 5165 swap_flux_y_local_u(k) = flux_n 5166 swap_diss_y_local_u(k) = diss_n 5127 ! 5128 !-- Swap fluxes. Note, in the OPENACC case these are computed again. 5129 flux_l_u(k,j,tn) = flux_r(k) 5130 diss_l_u(k,j,tn) = diss_r(k) 5131 flux_s_u(k,tn) = flux_n(k) 5132 diss_s_u(k,tn) = diss_n(k) 5167 5133 #endif 5168 flux_d = flux_t 5169 diss_d = diss_t 5170 ! 5171 !-- Statistical Evaluation of u'u'. The factor has to be applied 5172 !-- for right evaluation when gallilei_trans = .T. . 5173 !$ACC ATOMIC 5174 sums_us2_ws_l(k,tn) = sums_us2_ws_l(k,tn) & 5175 + ( flux_r & 5176 * ( u_comp - 2.0_wp * hom(k,1,1,0) ) & 5177 / ( u_comp - gu + SIGN( 1.0E-20_wp, u_comp - gu ) ) & 5178 + diss_r & 5179 * ABS( u_comp - 2.0_wp * hom(k,1,1,0) ) & 5180 / ( ABS( u_comp - gu ) + 1.0E-20_wp ) & 5181 ) * weight_substep(intermediate_timestep_count) 5134 ! 5135 !-- Statistical Evaluation of u'u'. The factor has to be applied for 5136 !-- right evaluation when gallilei_trans = .T. . 5137 sums_us2_ws_l(k,tn) = sums_us2_ws_l(k,tn) & 5138 + ( flux_r(k) & 5139 * ( u_comp(k) - 2.0_wp * hom(k,1,1,0) ) & 5140 / ( u_comp(k) - gu + SIGN( 1.0E-20_wp, u_comp(k) - gu ) ) & 5141 + diss_r(k) & 5142 * ABS( u_comp(k) - 2.0_wp * hom(k,1,1,0) ) & 5143 / ( ABS( u_comp(k) - gu ) + 1.0E-20_wp ) & 5144 ) * weight_substep(intermediate_timestep_count) 5182 5145 ! 5183 5146 !-- Statistical Evaluation of w'u'. 5184 !$ACC ATOMIC 5185 sums_wsus_ws_l(k,tn) = sums_wsus_ws_l(k,tn) & 5186 + ( flux_t & 5187 * ( w_comp - 2.0_wp * hom(k,1,3,0) ) & 5188 / ( w_comp + SIGN( 1.0E-20_wp, w_comp ) ) & 5189 + diss_t & 5190 * ABS( w_comp - 2.0_wp * hom(k,1,3,0) ) & 5191 / ( ABS( w_comp ) + 1.0E-20_wp ) & 5192 ) * weight_substep(intermediate_timestep_count) 5147 sums_wsus_ws_l(k,tn) = sums_wsus_ws_l(k,tn) & 5148 + ( flux_t(k) & 5149 * ( w_comp(k) - 2.0_wp * hom(k,1,3,0) ) & 5150 / ( w_comp(k) + SIGN( 1.0E-20_wp, w_comp(k) ) ) & 5151 + diss_t(k) & 5152 * ABS( w_comp(k) - 2.0_wp * hom(k,1,3,0) ) & 5153 / ( ABS( w_comp(k) ) + 1.0E-20_wp ) & 5154 ) * weight_substep(intermediate_timestep_count) 5155 ENDDO 5156 5157 DO k = nzb_max_l+1, nzt 5158 5159 flux_d = flux_t(k-1) 5160 diss_d = diss_t(k-1) 5161 ! 5162 !-- Calculate the divergence of the velocity field. A respective 5163 !-- correction is needed to overcome numerical instabilities introduced 5164 !-- by a not sufficient reduction of divergences near topography. 5165 div = ( ( u_comp(k) - ( u(k,j,i) + u(k,j,i-1) ) ) * ddx & 5166 + ( v_comp(k) + gv - ( v(k,j,i) + v(k,j,i-1) ) ) * ddy & 5167 + ( w_comp(k) * rho_air_zw(k) & 5168 - w_comp(k-1) * rho_air_zw(k-1) & 5169 ) * drho_air(k) * ddzw(k) & 5170 ) * 0.5_wp 5171 5172 tend(k,j,i) = tend(k,j,i) - ( & 5173 ( flux_r(k) + diss_r(k) & 5174 - flux_l_u(k,j,tn) - diss_l_u(k,j,tn) ) * ddx & 5175 + ( flux_n(k) + diss_n(k) & 5176 - flux_s_u(k,tn) - diss_s_u(k,tn) ) * ddy & 5177 + ( ( flux_t(k) + diss_t(k) ) & 5178 - ( flux_d + diss_d ) & 5179 ) * drho_air(k) * ddzw(k) & 5180 ) + div * u(k,j,i) 5181 #ifndef _OPENACC 5182 flux_l_u(k,j,tn) = flux_r(k) 5183 diss_l_u(k,j,tn) = diss_r(k) 5184 flux_s_u(k,tn) = flux_n(k) 5185 diss_s_u(k,tn) = diss_n(k) 5186 #endif 5187 ! 5188 !-- Statistical Evaluation of u'u'. The factor has to be applied for 5189 !-- right evaluation when gallilei_trans = .T. . 5190 sums_us2_ws_l(k,tn) = sums_us2_ws_l(k,tn) & 5191 + ( flux_r(k) & 5192 * ( u_comp(k) - 2.0_wp * hom(k,1,1,0) ) & 5193 / ( u_comp(k) - gu + SIGN( 1.0E-20_wp, u_comp(k) - gu ) ) & 5194 + diss_r(k) & 5195 * ABS( u_comp(k) - 2.0_wp * hom(k,1,1,0) ) & 5196 / ( ABS( u_comp(k) - gu ) + 1.0E-20_wp ) & 5197 ) * weight_substep(intermediate_timestep_count) 5198 ! 5199 !-- Statistical Evaluation of w'u'. 5200 sums_wsus_ws_l(k,tn) = sums_wsus_ws_l(k,tn) & 5201 + ( flux_t(k) & 5202 * ( w_comp(k) - 2.0_wp * hom(k,1,3,0) ) & 5203 / ( w_comp(k) + SIGN( 1.0E-20_wp, w_comp(k) ) ) & 5204 + diss_t(k) & 5205 * ABS( w_comp(k) - 2.0_wp * hom(k,1,3,0) ) & 5206 / ( ABS( w_comp(k) ) + 1.0E-20_wp ) & 5207 ) * weight_substep(intermediate_timestep_count) 5193 5208 ENDDO 5194 5209 ENDDO 5195 5210 ENDDO 5196 5211 5212 CALL cpu_log( log_point_s(68), 'advec_u_ws', 'stop' ) 5213 5197 5214 END SUBROUTINE advec_u_ws 5198 5215 5199 5216 5200 5217 !------------------------------------------------------------------------------! … … 5212 5229 INTEGER(iwp) :: k_pp !< k+2 index in disretization, can be modified to avoid segmentation faults 5213 5230 INTEGER(iwp) :: k_ppp !< k+3 index in disretization, can be modified to avoid segmentation faults 5214 INTEGER(iwp) :: nzb_max_l !< index indicating upper bound for order degradation of horizontal advection terms 5231 INTEGER(iwp) :: nzb_max_l !< index indicating upper bound for order degradation of horizontal advection terms 5215 5232 INTEGER(iwp) :: tn = 0 !< number of OpenMP thread 5216 5233 5217 5234 REAL(wp) :: ibit9 !< flag indicating 1st-order scheme along x-direction 5218 5235 REAL(wp) :: ibit10 !< flag indicating 3rd-order scheme along x-direction … … 5231 5248 REAL(wp) :: ibit14_s !< flag indicating 5th-order scheme along y-direction 5232 5249 #endif 5233 REAL(wp) :: ibit15 !< flag indicating 1st-order scheme along z-direction 5234 REAL(wp) :: ibit16 !< flag indicating 3rd-order scheme along z-direction 5235 REAL(wp) :: ibit17 !< flag indicating 5th-order scheme along z-direction 5236 REAL(wp) :: diss_d !< artificial dissipation term at grid box bottom 5237 REAL(wp) :: div !< diverence on v-grid 5238 REAL(wp) :: flux_d !< artificial 6th-order flux at grid box bottom 5239 REAL(wp) :: gu !< Galilei-transformation velocity along x 5240 REAL(wp) :: gv !< Galilei-transformation velocity along y 5241 REAL(wp) :: u_comp !< advection velocity along x 5250 REAL(wp) :: ibit15 !< flag indicating 1st-order scheme along z-direction 5251 REAL(wp) :: ibit16 !< flag indicating 3rd-order scheme along z-direction 5252 REAL(wp) :: ibit17 !< flag indicating 5th-order scheme along z-direction 5253 REAL(wp) :: diss_d !< artificial dissipation term at grid box bottom 5254 REAL(wp) :: div !< diverence on v-grid 5255 REAL(wp) :: flux_d !< artificial 6th-order flux at grid box bottom 5256 REAL(wp) :: gu !< Galilei-transformation velocity along x 5257 REAL(wp) :: gv !< Galilei-transformation velocity along y 5242 5258 #ifdef _OPENACC 5243 REAL(wp) :: u_comp_l !< advection velocity along x 5259 REAL(wp) :: u_comp_l !< advection velocity along x at leftward side 5260 REAL(wp) :: v_comp_s !< advection velocity along y at southward side 5244 5261 #endif 5245 REAL(wp) :: w_comp !< advection velocity along z 5246 5247 REAL(wp) :: diss_s !< discretized artificial dissipation at southward-side of the grid box 5248 REAL(wp) :: flux_s !< discretized 6th-order flux at southward-side of the grid box 5249 #ifndef _OPENACC 5250 REAL(wp), DIMENSION(nzb+1:nzt) :: swap_diss_y_local_v !< discretized artificial dissipation at southward-side of the grid box 5251 REAL(wp), DIMENSION(nzb+1:nzt) :: swap_flux_y_local_v !< discretized 6th-order flux at southward-side of the grid box 5252 #endif 5253 5254 REAL(wp) :: diss_l !< discretized artificial dissipation at leftward-side of the grid box 5255 REAL(wp) :: flux_l !< discretized 6th-order flux at leftward-side of the grid box 5256 #ifndef _OPENACC 5257 REAL(wp), DIMENSION(nzb+1:nzt,nys:nyn) :: swap_diss_x_local_v !< discretized artificial dissipation at leftward-side of the grid box 5258 REAL(wp), DIMENSION(nzb+1:nzt,nys:nyn) :: swap_flux_x_local_v !< discretized 6th-order flux at leftward-side of the grid box 5259 #endif 5260 5261 REAL(wp) :: diss_n !< discretized artificial dissipation at northward-side of the grid box 5262 REAL(wp) :: diss_r !< discretized artificial dissipation at rightward-side of the grid box 5263 REAL(wp) :: diss_t !< discretized artificial dissipation at top of the grid box 5264 REAL(wp) :: flux_n !< discretized 6th-order flux at northward-side of the grid box 5265 REAL(wp) :: flux_r !< discretized 6th-order flux at rightward-side of the grid box 5266 REAL(wp) :: flux_t !< discretized 6th-order flux at top of the grid box 5267 REAL(wp) :: v_comp !< advection velocity along y 5268 #ifdef _OPENACC 5269 REAL(wp) :: v_comp_s !< 5270 #endif 5271 ! 5272 !-- Set local version of nzb_max. At non-cyclic boundaries the order of the 5273 !-- advection need to be degraded near the boundary. Please note, in contrast 5274 !-- to the cache-optimized routines, nzb_max_l is set constantly for the 5275 !-- entire subdomain, in order to avoid unsymmetric loops which might be 5276 !-- an issue for GPUs. 5277 IF( bc_dirichlet_l .OR. bc_radiation_l .OR. & 5278 bc_dirichlet_r .OR. bc_radiation_r .OR. & 5279 bc_dirichlet_s .OR. bc_radiation_s .OR. & 5280 bc_dirichlet_n .OR. bc_radiation_n ) THEN 5281 nzb_max_l = nzt 5282 ELSE 5283 nzb_max_l = nzb_max 5284 END IF 5285 5262 5263 REAL(wp), DIMENSION(nzb:nzt+1) :: diss_n !< discretized artificial dissipation at northward-side of the grid box 5264 REAL(wp), DIMENSION(nzb:nzt+1) :: diss_r !< discretized artificial dissipation at rightward-side of the grid box 5265 REAL(wp), DIMENSION(nzb:nzt+1) :: diss_t !< discretized artificial dissipation at top of the grid box 5266 REAL(wp), DIMENSION(nzb:nzt+1) :: flux_n !< discretized 6th-order flux at northward-side of the grid box 5267 REAL(wp), DIMENSION(nzb:nzt+1) :: flux_r !< discretized 6th-order flux at rightward-side of the grid box 5268 REAL(wp), DIMENSION(nzb:nzt+1) :: flux_t !< discretized 6th-order flux at top of the grid box 5269 REAL(wp), DIMENSION(nzb:nzt+1) :: u_comp !< advection velocity along x 5270 REAL(wp), DIMENSION(nzb:nzt+1) :: v_comp !< advection velocity along y 5271 REAL(wp), DIMENSION(nzb:nzt+1) :: w_comp !< advection velocity along z 5272 5273 CALL cpu_log( log_point_s(69), 'advec_v_ws', 'start' ) 5274 5286 5275 gu = 2.0_wp * u_gtrans 5287 5276 gv = 2.0_wp * v_gtrans 5288 5277 5278 !$ACC PARALLEL LOOP COLLAPSE(2) FIRSTPRIVATE(tn, gu, gv) & 5279 !$ACC PRIVATE(i, j, k, k_mm, k_pp, k_ppp) & 5280 !$ACC PRIVATE(ibit9, ibit10, ibit11, ibit12, ibit13, ibit14) & 5281 !$ACC PRIVATE(ibit15, ibit16, ibit17) & 5282 !$ACC PRIVATE(ibit9_l, ibit10_l, ibit11_l) & 5283 !$ACC PRIVATE(ibit12_s, ibit13_s, ibit14_s) & 5284 !$ACC PRIVATE(flux_r, diss_r) & 5285 !$ACC PRIVATE(flux_n, diss_n) & 5286 !$ACC PRIVATE(flux_t, diss_t, flux_d, diss_d) & 5287 !$ACC PRIVATE(flux_l_v, diss_l_v, flux_s_v, diss_s_v) & 5288 !$ACC PRIVATE(div, u_comp, u_comp_l, v_comp, v_comp_s, w_comp) & 5289 !$ACC PRESENT(advc_flags_m) & 5290 !$ACC PRESENT(u, v, w) & 5291 !$ACC PRESENT(drho_air, rho_air_zw, ddzw) & 5292 !$ACC PRESENT(tend) & 5293 !$ACC PRESENT(hom(:,1,1:3,0)) & 5294 !$ACC PRESENT(weight_substep(intermediate_timestep_count)) & 5295 !$ACC PRESENT(sums_vs2_ws_l, sums_wsvs_ws_l) 5296 DO i = nxl, nxr 5297 DO j = nysv, nyn 5298 ! 5299 !-- Used local modified copy of nzb_max (used to degrade order of 5300 !-- discretization) at non-cyclic boundaries. Modify only at relevant points 5301 !-- instead of the entire subdomain. This should lead to better 5302 !-- load balance between boundary and non-boundary PEs. 5303 IF( ( bc_dirichlet_l .OR. bc_radiation_l ) .AND. i <= nxl + 2 .OR. & 5304 ( bc_dirichlet_r .OR. bc_radiation_r ) .AND. i >= nxr - 2 .OR. & 5305 ( bc_dirichlet_s .OR. bc_radiation_s ) .AND. j <= nys + 2 .OR. & 5306 ( bc_dirichlet_n .OR. bc_radiation_n ) .AND. j >= nyn - 2 ) THEN 5307 nzb_max_l = nzt 5308 ELSE 5309 nzb_max_l = nzb_max 5310 END IF 5311 5289 5312 #ifndef _OPENACC 5290 ! 5291 !-- First compute the whole left boundary of the processor domain 5292 i = nxl 5293 DO j = nysv, nyn 5294 DO k = nzb+1, nzb_max_l 5295 5296 ibit11 = REAL( IBITS(advc_flags_m(k,j,i-1),11,1), KIND = wp ) 5297 ibit10 = REAL( IBITS(advc_flags_m(k,j,i-1),10,1), KIND = wp ) 5298 ibit9 = REAL( IBITS(advc_flags_m(k,j,i-1),9,1), KIND = wp ) 5299 5300 u_comp = u(k,j-1,i) + u(k,j,i) - gu 5301 swap_flux_x_local_v(k,j) = u_comp * ( & 5313 IF ( i == nxl ) THEN 5314 DO k = nzb+1, nzb_max_l 5315 5316 ibit11 = REAL( IBITS(advc_flags_m(k,j,i-1),11,1), KIND = wp ) 5317 ibit10 = REAL( IBITS(advc_flags_m(k,j,i-1),10,1), KIND = wp ) 5318 ibit9 = REAL( IBITS(advc_flags_m(k,j,i-1),9,1), KIND = wp ) 5319 5320 u_comp(k) = u(k,j-1,i) + u(k,j,i) - gu 5321 flux_l_v(k,j,tn) = u_comp(k) * ( & 5302 5322 ( 37.0_wp * ibit11 * adv_mom_5 & 5303 5323 + 7.0_wp * ibit10 * adv_mom_3 & … … 5314 5334 ) 5315 5335 5316 swap_diss_x_local_v(k,j) = - ABS( u_comp) * ( &5336 diss_l_v(k,j,tn) = - ABS( u_comp(k) ) * ( & 5317 5337 ( 10.0_wp * ibit11 * adv_mom_5 & 5318 5338 + 3.0_wp * ibit10 * adv_mom_3 & … … 5329 5349 ) 5330 5350 5331 ENDDO5332 5333 DO k = nzb_max_l+1, nzt5334 5335 u_comp= u(k,j-1,i) + u(k,j,i) - gu5336 swap_flux_x_local_v(k,j) = u_comp * (&5351 ENDDO 5352 5353 DO k = nzb_max_l+1, nzt 5354 5355 u_comp(k) = u(k,j-1,i) + u(k,j,i) - gu 5356 flux_l_v(k,j,tn) = u_comp(k) * ( & 5337 5357 37.0_wp * ( v(k,j,i) + v(k,j,i-1) ) & 5338 5358 - 8.0_wp * ( v(k,j,i+1) + v(k,j,i-2) ) & 5339 5359 + ( v(k,j,i+2) + v(k,j,i-3) ) ) * adv_mom_5 5340 swap_diss_x_local_v(k,j) = - ABS( u_comp ) * (&5360 diss_l_v(k,j,tn) = - ABS( u_comp(k) ) * ( & 5341 5361 10.0_wp * ( v(k,j,i) - v(k,j,i-1) ) & 5342 5362 - 5.0_wp * ( v(k,j,i+1) - v(k,j,i-2) ) & 5343 5363 + ( v(k,j,i+2) - v(k,j,i-3) ) ) * adv_mom_5 5344 5364 5345 ENDDO 5346 5347 ENDDO 5365 ENDDO 5366 ENDIF 5367 5368 IF ( j == nysv ) THEN 5369 DO k = nzb+1, nzb_max_l 5370 5371 ibit14 = REAL( IBITS(advc_flags_m(k,j-1,i),14,1), KIND = wp ) 5372 ibit13 = REAL( IBITS(advc_flags_m(k,j-1,i),13,1), KIND = wp ) 5373 ibit12 = REAL( IBITS(advc_flags_m(k,j-1,i),12,1), KIND = wp ) 5374 5375 v_comp(k) = v(k,j,i) + v(k,j-1,i) - gv 5376 flux_s_v(k,tn) = v_comp(k) * ( & 5377 ( 37.0_wp * ibit14 * adv_mom_5 & 5378 + 7.0_wp * ibit13 * adv_mom_3 & 5379 + ibit12 * adv_mom_1 & 5380 ) * & 5381 ( v(k,j,i) + v(k,j-1,i) ) & 5382 - ( 8.0_wp * ibit14 * adv_mom_5 & 5383 + ibit13 * adv_mom_3 & 5384 ) * & 5385 ( v(k,j+1,i) + v(k,j-2,i) ) & 5386 + ( ibit14 * adv_mom_5 & 5387 ) * & 5388 ( v(k,j+2,i) + v(k,j-3,i) ) & 5389 ) 5390 5391 diss_s_v(k,tn) = - ABS( v_comp(k) ) * ( & 5392 ( 10.0_wp * ibit14 * adv_mom_5 & 5393 + 3.0_wp * ibit13 * adv_mom_3 & 5394 + ibit12 * adv_mom_1 & 5395 ) * & 5396 ( v(k,j,i) - v(k,j-1,i) ) & 5397 - ( 5.0_wp * ibit14 * adv_mom_5 & 5398 + ibit13 * adv_mom_3 & 5399 ) * & 5400 ( v(k,j+1,i) - v(k,j-2,i) ) & 5401 + ( ibit14 * adv_mom_5 & 5402 ) * & 5403 ( v(k,j+2,i) - v(k,j-3,i) ) & 5404 ) 5405 5406 ENDDO 5407 5408 DO k = nzb_max_l+1, nzt 5409 5410 v_comp(k) = v(k,j,i) + v(k,j-1,i) - gv 5411 flux_s_v(k,tn) = v_comp(k) * ( & 5412 37.0_wp * ( v(k,j,i) + v(k,j-1,i) ) & 5413 - 8.0_wp * ( v(k,j+1,i) + v(k,j-2,i) ) & 5414 + ( v(k,j+2,i) + v(k,j-3,i) ) ) * adv_mom_5 5415 diss_s_v(k,tn) = - ABS( v_comp(k) ) * ( & 5416 10.0_wp * ( v(k,j,i) - v(k,j-1,i) ) & 5417 - 5.0_wp * ( v(k,j+1,i) - v(k,j-2,i) ) & 5418 + ( v(k,j+2,i) - v(k,j-3,i) ) ) * adv_mom_5 5419 5420 ENDDO 5421 ENDIF 5348 5422 #endif 5349 5350 !$ACC PARALLEL LOOP COLLAPSE(2) FIRSTPRIVATE(tn, gu, gv) &5351 !$ACC PRIVATE(i, j, k, k_mm, k_pp, k_ppp) &5352 !$ACC PRIVATE(ibit9, ibit10, ibit11, ibit12, ibit13, ibit14) &5353 !$ACC PRIVATE(ibit9_l, ibit10_l, ibit11_l) &5354 !$ACC PRIVATE(ibit12_s, ibit13_s, ibit14_s) &5355 !$ACC PRIVATE(ibit15, ibit16, ibit17) &5356 !$ACC PRIVATE(flux_r, diss_r, flux_l, diss_l) &5357 !$ACC PRIVATE(flux_n, diss_n, flux_s, diss_s) &5358 !$ACC PRIVATE(flux_t, diss_t, flux_d, diss_d) &5359 !$ACC PRIVATE(div, u_comp, u_comp_l, v_comp, v_comp_s, w_comp) &5360 !$ACC PRESENT(advc_flags_m) &5361 !$ACC PRESENT(u, v, w) &5362 !$ACC PRESENT(drho_air, rho_air_zw, ddzw) &5363 !$ACC PRESENT(tend) &5364 !$ACC PRESENT(hom(nzb+1:nzb_max_l,1,2:3,0)) &5365 !$ACC PRESENT(weight_substep(intermediate_timestep_count)) &5366 !$ACC PRESENT(sums_vs2_ws_l, sums_wsvs_ws_l)5367 DO i = nxl, nxr5368 5369 #ifndef _OPENACC5370 j = nysv5371 DO k = nzb+1, nzb_max_l5372 5373 ibit14 = REAL( IBITS(advc_flags_m(k,j-1,i),14,1), KIND = wp )5374 ibit13 = REAL( IBITS(advc_flags_m(k,j-1,i),13,1), KIND = wp )5375 ibit12 = REAL( IBITS(advc_flags_m(k,j-1,i),12,1), KIND = wp )5376 5377 v_comp = v(k,j,i) + v(k,j-1,i) - gv5378 swap_flux_y_local_v(k) = v_comp * ( &5379 ( 37.0_wp * ibit14 * adv_mom_5 &5380 + 7.0_wp * ibit13 * adv_mom_3 &5381 + ibit12 * adv_mom_1 &5382 ) * &5383 ( v(k,j,i) + v(k,j-1,i) ) &5384 - ( 8.0_wp * ibit14 * adv_mom_5 &5385 + ibit13 * adv_mom_3 &5386 ) * &5387 ( v(k,j+1,i) + v(k,j-2,i) ) &5388 + ( ibit14 * adv_mom_5 &5389 ) * &5390 ( v(k,j+2,i) + v(k,j-3,i) ) &5391 )5392 5393 swap_diss_y_local_v(k) = - ABS( v_comp ) * ( &5394 ( 10.0_wp * ibit14 * adv_mom_5 &5395 + 3.0_wp * ibit13 * adv_mom_3 &5396 + ibit12 * adv_mom_1 &5397 ) * &5398 ( v(k,j,i) - v(k,j-1,i) ) &5399 - ( 5.0_wp * ibit14 * adv_mom_5 &5400 + ibit13 * adv_mom_3 &5401 ) * &5402 ( v(k,j+1,i) - v(k,j-2,i) ) &5403 + ( ibit14 * adv_mom_5 &5404 ) * &5405 ( v(k,j+2,i) - v(k,j-3,i) ) &5406 )5407 5408 ENDDO5409 5410 DO k = nzb_max_l+1, nzt5411 5412 v_comp = v(k,j,i) + v(k,j-1,i) - gv5413 swap_flux_y_local_v(k) = v_comp * ( &5414 37.0_wp * ( v(k,j,i) + v(k,j-1,i) ) &5415 - 8.0_wp * ( v(k,j+1,i) + v(k,j-2,i) ) &5416 + ( v(k,j+2,i) + v(k,j-3,i) ) ) * adv_mom_55417 swap_diss_y_local_v(k) = - ABS( v_comp ) * ( &5418 10.0_wp * ( v(k,j,i) - v(k,j-1,i) ) &5419 - 5.0_wp * ( v(k,j+1,i) - v(k,j-2,i) ) &5420 + ( v(k,j+2,i) - v(k,j-3,i) ) ) * adv_mom_55421 5422 ENDDO5423 #endif5424 5425 DO j = nysv, nyn5426 5427 flux_d = 0.0_wp5428 diss_d = 0.0_wp5429 5423 5430 5424 DO k = nzb+1, nzb_max_l … … 5434 5428 ibit9 = REAL( IBITS(advc_flags_m(k,j,i),9,1), KIND = wp ) 5435 5429 5436 u_comp = u(k,j-1,i+1) + u(k,j,i+1) - gu5437 flux_r = u_comp * (&5430 u_comp(k) = u(k,j-1,i+1) + u(k,j,i+1) - gu 5431 flux_r(k) = u_comp(k) * ( & 5438 5432 ( 37.0_wp * ibit11 * adv_mom_5 & 5439 5433 + 7.0_wp * ibit10 * adv_mom_3 & … … 5448 5442 ) * & 5449 5443 ( v(k,j,i+3) + v(k,j,i-2) ) & 5450 )5451 5452 diss_r = - ABS( u_comp ) * (&5444 ) 5445 5446 diss_r(k) = - ABS( u_comp(k) ) * ( & 5453 5447 ( 10.0_wp * ibit11 * adv_mom_5 & 5454 5448 + 3.0_wp * ibit10 * adv_mom_3 & … … 5463 5457 ) * & 5464 5458 ( v(k,j,i+3) - v(k,j,i-2) ) & 5465 )5459 ) 5466 5460 5467 5461 #ifdef _OPENACC … … 5472 5466 ibit9_l = REAL( IBITS(advc_flags_m(k,j,i-1),9,1), KIND = wp ) 5473 5467 5474 u_comp_l = u(k,j-1,i) + u(k,j,i) - gu5475 flux_l = u_comp_l * (&5468 u_comp_l = u(k,j-1,i) + u(k,j,i) - gu 5469 flux_l_v(k,j,tn) = u_comp_l * ( & 5476 5470 ( 37.0_wp * ibit11_l * adv_mom_5 & 5477 5471 + 7.0_wp * ibit10_l * adv_mom_3 & … … 5488 5482 ) 5489 5483 5490 diss_l = - ABS( u_comp_l ) * (&5484 diss_l_v(k,j,tn) = - ABS( u_comp_l ) * ( & 5491 5485 ( 10.0_wp * ibit11_l * adv_mom_5 & 5492 5486 + 3.0_wp * ibit10_l * adv_mom_3 & … … 5502 5496 ( v(k,j,i+2) - v(k,j,i-3) ) & 5503 5497 ) 5504 #else5505 flux_l = swap_flux_x_local_v(k,j)5506 diss_l = swap_diss_x_local_v(k,j)5507 5498 #endif 5508 5499 … … 5511 5502 ibit12 = REAL( IBITS(advc_flags_m(k,j,i),12,1), KIND = wp ) 5512 5503 5513 v_comp = v(k,j+1,i) + v(k,j,i)5514 flux_n = ( v_comp - gv ) * (&5504 v_comp(k) = v(k,j+1,i) + v(k,j,i) 5505 flux_n(k) = ( v_comp(k) - gv ) * ( & 5515 5506 ( 37.0_wp * ibit14 * adv_mom_5 & 5516 5507 + 7.0_wp * ibit13 * adv_mom_3 & … … 5527 5518 ) 5528 5519 5529 diss_n = - ABS( v_comp - gv ) * (&5520 diss_n(k) = - ABS( v_comp(k) - gv ) * ( & 5530 5521 ( 10.0_wp * ibit14 * adv_mom_5 & 5531 5522 + 3.0_wp * ibit13 * adv_mom_3 & … … 5549 5540 ibit12_s = REAL( IBITS(advc_flags_m(k,j-1,i),12,1), KIND = wp ) 5550 5541 5551 v_comp_s = v(k,j,i) + v(k,j-1,i) - gv5552 flux_s = v_comp_s * (&5542 v_comp_s = v(k,j,i) + v(k,j-1,i) - gv 5543 flux_s_v(k,tn) = v_comp_s * ( & 5553 5544 ( 37.0_wp * ibit14_s * adv_mom_5 & 5554 5545 + 7.0_wp * ibit13_s * adv_mom_3 & … … 5563 5554 ) * & 5564 5555 ( v(k,j+2,i) + v(k,j-3,i) ) & 5565 5566 5567 diss_s = - ABS( v_comp_s ) * (&5556 ) 5557 5558 diss_s_v(k,tn) = - ABS( v_comp_s ) * ( & 5568 5559 ( 10.0_wp * ibit14_s * adv_mom_5 & 5569 5560 + 3.0_wp * ibit13_s * adv_mom_3 & … … 5578 5569 ) * & 5579 5570 ( v(k,j+2,i) - v(k,j-3,i) ) & 5580 ) 5581 #else 5582 flux_s = swap_flux_y_local_v(k) 5583 diss_s = swap_diss_y_local_v(k) 5571 ) 5584 5572 #endif 5585 5573 ENDDO 5574 5575 DO k = nzb_max_l+1, nzt 5576 5577 u_comp(k) = u(k,j-1,i+1) + u(k,j,i+1) - gu 5578 flux_r(k) = u_comp(k) * ( & 5579 37.0_wp * ( v(k,j,i+1) + v(k,j,i) ) & 5580 - 8.0_wp * ( v(k,j,i+2) + v(k,j,i-1) ) & 5581 + ( v(k,j,i+3) + v(k,j,i-2) ) ) * adv_mom_5 5582 5583 diss_r(k) = - ABS( u_comp(k) ) * ( & 5584 10.0_wp * ( v(k,j,i+1) - v(k,j,i) ) & 5585 - 5.0_wp * ( v(k,j,i+2) - v(k,j,i-1) ) & 5586 + ( v(k,j,i+3) - v(k,j,i-2) ) ) * adv_mom_5 5587 5588 #ifdef _OPENACC 5589 ! 5590 !-- Recompute the left fluxes. 5591 u_comp_l = u(k,j-1,i) + u(k,j,i) - gu 5592 flux_l_v(k,j,tn) = u_comp_l * ( & 5593 37.0_wp * ( v(k,j,i) + v(k,j,i-1) ) & 5594 - 8.0_wp * ( v(k,j,i+1) + v(k,j,i-2) ) & 5595 + ( v(k,j,i+2) + v(k,j,i-3) ) ) * adv_mom_5 5596 diss_l_v(k,j,tn) = - ABS( u_comp_l ) * ( & 5597 10.0_wp * ( v(k,j,i) - v(k,j,i-1) ) & 5598 - 5.0_wp * ( v(k,j,i+1) - v(k,j,i-2) ) & 5599 + ( v(k,j,i+2) - v(k,j,i-3) ) ) * adv_mom_5 5600 #endif 5601 5602 v_comp(k) = v(k,j+1,i) + v(k,j,i) 5603 flux_n(k) = ( v_comp(k) - gv ) * ( & 5604 37.0_wp * ( v(k,j+1,i) + v(k,j,i) ) & 5605 - 8.0_wp * ( v(k,j+2,i) + v(k,j-1,i) ) & 5606 + ( v(k,j+3,i) + v(k,j-2,i) ) ) * adv_mom_5 5607 5608 diss_n(k) = - ABS( v_comp(k) - gv ) * ( & 5609 10.0_wp * ( v(k,j+1,i) - v(k,j,i) ) & 5610 - 5.0_wp * ( v(k,j+2,i) - v(k,j-1,i) ) & 5611 + ( v(k,j+3,i) - v(k,j-2,i) ) ) * adv_mom_5 5612 5613 #ifdef _OPENACC 5614 ! 5615 !-- Recompute the south fluxes. 5616 v_comp_s = v(k,j,i) + v(k,j-1,i) - gv 5617 flux_s_v(k,tn) = v_comp_s * ( & 5618 37.0_wp * ( v(k,j,i) + v(k,j-1,i) ) & 5619 - 8.0_wp * ( v(k,j+1,i) + v(k,j-2,i) ) & 5620 + ( v(k,j+2,i) + v(k,j-3,i) ) ) * adv_mom_5 5621 diss_s_v(k,tn) = - ABS( v_comp_s ) * ( & 5622 10.0_wp * ( v(k,j,i) - v(k,j-1,i) ) & 5623 - 5.0_wp * ( v(k,j+1,i) - v(k,j-2,i) ) & 5624 + ( v(k,j+2,i) - v(k,j-3,i) ) ) * adv_mom_5 5625 #endif 5626 ENDDO 5627 ! 5628 !-- Now, compute vertical fluxes. Split loop into a part treating the 5629 !-- lowest 2 grid points with indirect indexing, a main loop without 5630 !-- indirect indexing, and a loop for the uppermost 2 grip points with 5631 !-- indirect indexing. This allows better vectorization for the main loop. 5632 !-- First, compute the flux at model surface, which need has to be 5633 !-- calculated explicetely for the tendency at 5634 !-- the first w-level. For topography wall this is done implicitely by 5635 !-- advc_flags_m. 5636 flux_t(nzb) = 0.0_wp 5637 diss_t(nzb) = 0.0_wp 5638 w_comp(nzb) = 0.0_wp 5639 DO k = nzb+1, nzb+2 5586 5640 ! 5587 5641 !-- k index has to be modified near bottom and top, else array … … 5595 5649 k_mm = k - 2 * ibit17 5596 5650 5597 w_comp = w(k,j-1,i) + w(k,j,i)5598 flux_t = w_comp * rho_air_zw(k) * (&5651 w_comp(k) = w(k,j-1,i) + w(k,j,i) 5652 flux_t(k) = w_comp(k) * rho_air_zw(k) * ( & 5599 5653 ( 37.0_wp * ibit17 * adv_mom_5 & 5600 5654 + 7.0_wp * ibit16 * adv_mom_3 & … … 5609 5663 ) * & 5610 5664 ( v(k_ppp,j,i) + v(k_mm,j,i) ) & 5611 )5612 5613 diss_t = - ABS( w_comp ) * rho_air_zw(k) * (&5665 ) 5666 5667 diss_t(k) = - ABS( w_comp(k) ) * rho_air_zw(k) * ( & 5614 5668 ( 10.0_wp * ibit17 * adv_mom_5 & 5615 5669 + 3.0_wp * ibit16 * adv_mom_3 & … … 5624 5678 ) * & 5625 5679 ( v(k_ppp,j,i) - v(k_mm,j,i) ) & 5626 ) 5627 ! 5628 !-- Calculate the divergence of the velocity field. A respective 5629 !-- correction is needed to overcome numerical instabilities caused 5630 !-- by a not sufficient reduction of divergences near topography. 5631 div = ( ( ( u_comp + gu ) & 5632 * ( ibit9 + ibit10 + ibit11 ) & 5633 - ( u(k,j-1,i) + u(k,j,i) ) & 5634 * ( & 5635 REAL( IBITS(advc_flags_m(k,j,i-1),9,1), KIND = wp ) & 5636 + REAL( IBITS(advc_flags_m(k,j,i-1),10,1), KIND = wp ) & 5637 + REAL( IBITS(advc_flags_m(k,j,i-1),11,1), KIND = wp ) & 5638 ) & 5639 ) * ddx & 5640 + ( v_comp & 5641 * ( ibit12 + ibit13 + ibit14 ) & 5642 - ( v(k,j,i) + v(k,j-1,i) ) & 5643 * ( & 5644 REAL( IBITS(advc_flags_m(k,j-1,i),12,1), KIND = wp ) & 5645 + REAL( IBITS(advc_flags_m(k,j-1,i),13,1), KIND = wp ) & 5646 + REAL( IBITS(advc_flags_m(k,j-1,i),14,1), KIND = wp ) & 5647 ) & 5648 ) * ddy & 5649 + ( w_comp * rho_air_zw(k) & 5650 * ( ibit15 + ibit16 + ibit17 ) & 5651 - ( w(k-1,j-1,i) + w(k-1,j,i) ) * rho_air_zw(k-1) & 5652 * ( & 5653 REAL( IBITS(advc_flags_m(k-1,j,i),15,1), KIND = wp ) & 5654 + REAL( IBITS(advc_flags_m(k-1,j,i),16,1), KIND = wp ) & 5655 + REAL( IBITS(advc_flags_m(k-1,j,i),17,1), KIND = wp ) & 5656 ) & 5657 ) * drho_air(k) * ddzw(k) & 5658 ) * 0.5_wp 5659 5660 5661 tend(k,j,i) = tend(k,j,i) - ( & 5662 ( ( flux_r + diss_r ) & 5663 - ( flux_l + diss_l ) ) * ddx & 5664 + ( ( flux_n + diss_n ) & 5665 - ( flux_s + diss_s ) ) * ddy & 5666 + ( ( flux_t + diss_t ) & 5667 - ( flux_d + diss_d ) ) * drho_air(k) * ddzw(k) & 5668 ) + v(k,j,i) * div 5669 5670 #ifndef _OPENACC 5671 swap_flux_x_local_v(k,j) = flux_r 5672 swap_diss_x_local_v(k,j) = diss_r 5673 swap_flux_y_local_v(k) = flux_n 5674 swap_diss_y_local_v(k) = diss_n 5675 #endif 5676 flux_d = flux_t 5677 diss_d = diss_t 5678 5679 ! 5680 !-- Statistical Evaluation of v'v'. The factor has to be applied 5681 !-- for right evaluation when gallilei_trans = .T. . 5682 !$ACC ATOMIC 5683 sums_vs2_ws_l(k,tn) = sums_vs2_ws_l(k,tn) & 5684 + ( flux_n & 5685 * ( v_comp - 2.0_wp * hom(k,1,2,0) ) & 5686 / ( v_comp - gv + SIGN( 1.0E-20_wp, v_comp - gv ) ) & 5687 + diss_n & 5688 * ABS( v_comp - 2.0_wp * hom(k,1,2,0) ) & 5689 / ( ABS( v_comp - gv ) + 1.0E-20_wp ) & 5690 ) * weight_substep(intermediate_timestep_count) 5691 ! 5692 !-- Statistical Evaluation of w'u'. 5693 !$ACC ATOMIC 5694 sums_wsvs_ws_l(k,tn) = sums_wsvs_ws_l(k,tn) & 5695 + ( flux_t & 5696 * ( w_comp - 2.0_wp * hom(k,1,3,0) ) & 5697 / ( w_comp + SIGN( 1.0E-20_wp, w_comp ) ) & 5698 + diss_t & 5699 * ABS( w_comp - 2.0_wp * hom(k,1,3,0) ) & 5700 / ( ABS( w_comp ) + 1.0E-20_wp ) & 5701 ) * weight_substep(intermediate_timestep_count) 5702 5680 ) 5703 5681 ENDDO 5704 5682 5705 DO k = nzb_max_l+1, nzt 5706 5707 u_comp = u(k,j-1,i+1) + u(k,j,i+1) - gu 5708 flux_r = u_comp * ( & 5709 37.0_wp * ( v(k,j,i+1) + v(k,j,i) ) & 5710 - 8.0_wp * ( v(k,j,i+2) + v(k,j,i-1) ) & 5711 + ( v(k,j,i+3) + v(k,j,i-2) ) ) * adv_mom_5 5712 5713 diss_r = - ABS( u_comp ) * ( & 5714 10.0_wp * ( v(k,j,i+1) - v(k,j,i) ) & 5715 - 5.0_wp * ( v(k,j,i+2) - v(k,j,i-1) ) & 5716 + ( v(k,j,i+3) - v(k,j,i-2) ) ) * adv_mom_5 5717 5718 #ifdef _OPENACC 5719 ! 5720 !-- Recompute the left fluxes. 5721 u_comp_l = u(k,j-1,i) + u(k,j,i) - gu 5722 flux_l = u_comp_l * ( & 5723 37.0_wp * ( v(k,j,i) + v(k,j,i-1) ) & 5724 - 8.0_wp * ( v(k,j,i+1) + v(k,j,i-2) ) & 5725 + ( v(k,j,i+2) + v(k,j,i-3) ) ) * adv_mom_5 5726 diss_l = - ABS( u_comp_l ) * ( & 5727 10.0_wp * ( v(k,j,i) - v(k,j,i-1) ) & 5728 - 5.0_wp * ( v(k,j,i+1) - v(k,j,i-2) ) & 5729 + ( v(k,j,i+2) - v(k,j,i-3) ) ) * adv_mom_5 5730 #else 5731 flux_l = swap_flux_x_local_v(k,j) 5732 diss_l = swap_diss_x_local_v(k,j) 5733 #endif 5734 5735 v_comp = v(k,j+1,i) + v(k,j,i) 5736 flux_n = ( v_comp - gv ) * ( & 5737 37.0_wp * ( v(k,j+1,i) + v(k,j,i) ) & 5738 - 8.0_wp * ( v(k,j+2,i) + v(k,j-1,i) ) & 5739 + ( v(k,j+3,i) + v(k,j-2,i) ) ) * adv_mom_5 5740 5741 diss_n = - ABS( v_comp - gv ) * ( & 5742 10.0_wp * ( v(k,j+1,i) - v(k,j,i) ) & 5743 - 5.0_wp * ( v(k,j+2,i) - v(k,j-1,i) ) & 5744 + ( v(k,j+3,i) - v(k,j-2,i) ) ) * adv_mom_5 5745 5746 #ifdef _OPENACC 5747 ! 5748 !-- Recompute the south fluxes. 5749 v_comp_s = v(k,j,i) + v(k,j-1,i) - gv 5750 flux_s = v_comp_s * ( & 5751 37.0_wp * ( v(k,j,i) + v(k,j-1,i) ) & 5752 - 8.0_wp * ( v(k,j+1,i) + v(k,j-2,i) ) & 5753 + ( v(k,j+2,i) + v(k,j-3,i) ) ) * adv_mom_5 5754 diss_s = - ABS( v_comp_s ) * ( & 5755 10.0_wp * ( v(k,j,i) - v(k,j-1,i) ) & 5756 - 5.0_wp * ( v(k,j+1,i) - v(k,j-2,i) ) & 5757 + ( v(k,j+2,i) - v(k,j-3,i) ) ) * adv_mom_5 5758 #else 5759 flux_s = swap_flux_y_local_v(k) 5760 diss_s = swap_diss_y_local_v(k) 5761 #endif 5762 5683 DO k = nzb+3, nzt-2 5684 ibit17 = REAL( IBITS(advc_flags_m(k,j,i),17,1), KIND = wp ) 5685 ibit16 = REAL( IBITS(advc_flags_m(k,j,i),16,1), KIND = wp ) 5686 ibit15 = REAL( IBITS(advc_flags_m(k,j,i),15,1), KIND = wp ) 5687 5688 w_comp(k) = w(k,j-1,i) + w(k,j,i) 5689 flux_t(k) = w_comp(k) * rho_air_zw(k) * ( & 5690 ( 37.0_wp * ibit17 * adv_mom_5 & 5691 + 7.0_wp * ibit16 * adv_mom_3 & 5692 + ibit15 * adv_mom_1 & 5693 ) * & 5694 ( v(k+1,j,i) + v(k,j,i) ) & 5695 - ( 8.0_wp * ibit17 * adv_mom_5 & 5696 + ibit16 * adv_mom_3 & 5697 ) * & 5698 ( v(k+2,j,i) + v(k-1,j,i) ) & 5699 + ( ibit17 * adv_mom_5 & 5700 ) * & 5701 ( v(k+3,j,i) + v(k-2,j,i) ) & 5702 ) 5703 5704 diss_t(k) = - ABS( w_comp(k) ) * rho_air_zw(k) * ( & 5705 ( 10.0_wp * ibit17 * adv_mom_5 & 5706 + 3.0_wp * ibit16 * adv_mom_3 & 5707 + ibit15 * adv_mom_1 & 5708 ) * & 5709 ( v(k+1,j,i) - v(k,j,i) ) & 5710 - ( 5.0_wp * ibit17 * adv_mom_5 & 5711 + ibit16 * adv_mom_3 & 5712 ) * & 5713 ( v(k+2,j,i) - v(k-1,j,i) ) & 5714 + ( ibit17 * adv_mom_5 & 5715 ) * & 5716 ( v(k+3,j,i) - v(k-2,j,i) ) & 5717 ) 5718 ENDDO 5719 5720 DO k = nzt-1, nzt-symmetry_flag 5763 5721 ! 5764 5722 !-- k index has to be modified near bottom and top, else array … … 5772 5730 k_mm = k - 2 * ibit17 5773 5731 5774 w_comp = w(k,j-1,i) + w(k,j,i)5775 flux_t = w_comp * rho_air_zw(k) * (&5732 w_comp(k) = w(k,j-1,i) + w(k,j,i) 5733 flux_t(k) = w_comp(k) * rho_air_zw(k) * ( & 5776 5734 ( 37.0_wp * ibit17 * adv_mom_5 & 5777 5735 + 7.0_wp * ibit16 * adv_mom_3 & … … 5786 5744 ) * & 5787 5745 ( v(k_ppp,j,i) + v(k_mm,j,i) ) & 5788 )5789 5790 diss_t = - ABS( w_comp ) * rho_air_zw(k) * (&5746 ) 5747 5748 diss_t(k) = - ABS( w_comp(k) ) * rho_air_zw(k) * ( & 5791 5749 ( 10.0_wp * ibit17 * adv_mom_5 & 5792 5750 + 3.0_wp * ibit16 * adv_mom_3 & … … 5801 5759 ) * & 5802 5760 ( v(k_ppp,j,i) - v(k_mm,j,i) ) & 5803 ) 5761 ) 5762 ENDDO 5763 5764 ! 5765 !-- Set resolved/turbulent flux at model top to zero (w-level). In case that 5766 !-- a symmetric behavior between bottom and top shall be guaranteed (closed 5767 !-- channel flow), the flux at nzt is also set to zero. 5768 IF ( symmetry_flag == 1 ) THEN 5769 flux_t(nzt) = 0.0_wp 5770 diss_t(nzt) = 0.0_wp 5771 w_comp(nzt) = 0.0_wp 5772 ENDIF 5773 flux_t(nzt+1) = 0.0_wp 5774 diss_t(nzt+1) = 0.0_wp 5775 w_comp(nzt+1) = 0.0_wp 5776 5777 DO k = nzb+1, nzb_max_l 5778 5779 flux_d = flux_t(k-1) 5780 diss_d = diss_t(k-1) 5781 5782 ibit11 = REAL( IBITS(advc_flags_m(k,j,i),11,1), KIND = wp ) 5783 ibit10 = REAL( IBITS(advc_flags_m(k,j,i),10,1), KIND = wp ) 5784 ibit9 = REAL( IBITS(advc_flags_m(k,j,i),9,1), KIND = wp ) 5785 5786 ibit14 = REAL( IBITS(advc_flags_m(k,j,i),14,1), KIND = wp ) 5787 ibit13 = REAL( IBITS(advc_flags_m(k,j,i),13,1), KIND = wp ) 5788 ibit12 = REAL( IBITS(advc_flags_m(k,j,i),12,1), KIND = wp ) 5789 5790 ibit17 = REAL( IBITS(advc_flags_m(k,j,i),17,1), KIND = wp ) 5791 ibit16 = REAL( IBITS(advc_flags_m(k,j,i),16,1), KIND = wp ) 5792 ibit15 = REAL( IBITS(advc_flags_m(k,j,i),15,1), KIND = wp ) 5804 5793 ! 5805 5794 !-- Calculate the divergence of the velocity field. A respective 5806 5795 !-- correction is needed to overcome numerical instabilities caused 5807 5796 !-- by a not sufficient reduction of divergences near topography. 5808 div = ( ( u_comp + gu - ( u(k,j-1,i) + u(k,j,i) ) ) * ddx & 5809 + ( v_comp - ( v(k,j,i) + v(k,j-1,i) ) ) * ddy & 5810 + ( w_comp * rho_air_zw(k) - & 5811 ( w(k-1,j-1,i) + w(k-1,j,i) ) * rho_air_zw(k-1) & 5812 ) * drho_air(k) * ddzw(k) & 5813 ) * 0.5_wp 5814 5797 div = ( ( ( u_comp(k) + gu ) & 5798 * ( ibit9 + ibit10 + ibit11 ) & 5799 - ( u(k,j-1,i) + u(k,j,i) ) & 5800 * ( & 5801 REAL( IBITS(advc_flags_m(k,j,i-1),9,1), KIND = wp ) & 5802 + REAL( IBITS(advc_flags_m(k,j,i-1),10,1), KIND = wp ) & 5803 + REAL( IBITS(advc_flags_m(k,j,i-1),11,1), KIND = wp ) & 5804 ) & 5805 ) * ddx & 5806 + ( v_comp(k) & 5807 * ( ibit12 + ibit13 + ibit14 ) & 5808 - ( v(k,j,i) + v(k,j-1,i) ) & 5809 * ( & 5810 REAL( IBITS(advc_flags_m(k,j-1,i),12,1), KIND = wp ) & 5811 + REAL( IBITS(advc_flags_m(k,j-1,i),13,1), KIND = wp ) & 5812 + REAL( IBITS(advc_flags_m(k,j-1,i),14,1), KIND = wp ) & 5813 ) & 5814 ) * ddy & 5815 + ( w_comp(k) * rho_air_zw(k) & 5816 * ( ibit15 + ibit16 + ibit17 ) & 5817 - ( w(k-1,j-1,i) + w(k-1,j,i) ) * rho_air_zw(k-1) & 5818 * ( & 5819 REAL( IBITS(advc_flags_m(k-1,j,i),15,1), KIND = wp ) & 5820 + REAL( IBITS(advc_flags_m(k-1,j,i),16,1), KIND = wp ) & 5821 + REAL( IBITS(advc_flags_m(k-1,j,i),17,1), KIND = wp ) & 5822 ) & 5823 ) * drho_air(k) * ddzw(k) & 5824 ) * 0.5_wp 5825 5826 5815 5827 tend(k,j,i) = tend(k,j,i) - ( & 5816 ( ( flux_r + diss_r )&5817 - ( flux_l + diss_l ) ) * ddx&5818 + ( ( flux_n + diss_n )&5819 - ( flux_s + diss_s ) ) * ddy&5820 + ( ( flux_t + diss_t )&5828 ( ( flux_r(k) + diss_r(k) ) & 5829 - ( flux_l_v(k,j,tn) + diss_l_v(k,j,tn) ) ) * ddx & 5830 + ( ( flux_n(k) + diss_n(k) ) & 5831 - ( flux_s_v(k,tn) + diss_s_v(k,tn) ) ) * ddy & 5832 + ( ( flux_t(k) + diss_t(k) ) & 5821 5833 - ( flux_d + diss_d ) ) * drho_air(k) * ddzw(k) & 5822 5834 ) + v(k,j,i) * div 5823 5835 5824 5836 #ifndef _OPENACC 5825 swap_flux_x_local_v(k,j) = flux_r 5826 swap_diss_x_local_v(k,j) = diss_r 5827 swap_flux_y_local_v(k) = flux_n 5828 swap_diss_y_local_v(k) = diss_n 5837 ! 5838 !-- Swap fluxes. Note, in the OPENACC case these are computed again. 5839 flux_l_v(k,j,tn) = flux_r(k) 5840 diss_l_v(k,j,tn) = diss_r(k) 5841 flux_s_v(k,tn) = flux_n(k) 5842 diss_s_v(k,tn) = diss_n(k) 5829 5843 #endif 5830 flux_d = flux_t5831 diss_d = diss_t5832 5844 5833 5845 ! … … 5836 5848 !$ACC ATOMIC 5837 5849 sums_vs2_ws_l(k,tn) = sums_vs2_ws_l(k,tn) & 5838 + ( flux_n 5839 * ( v_comp - 2.0_wp * hom(k,1,2,0) )&5840 / ( v_comp - gv + SIGN( 1.0E-20_wp, v_comp - gv ) )&5841 + diss_n 5842 * ABS( v_comp - 2.0_wp * hom(k,1,2,0) )&5843 / ( ABS( v_comp - gv ) + 1.0E-20_wp )&5850 + ( flux_n(k) & 5851 * ( v_comp(k) - 2.0_wp * hom(k,1,2,0) ) & 5852 / ( v_comp(k) - gv + SIGN( 1.0E-20_wp, v_comp(k) - gv ) ) & 5853 + diss_n(k) & 5854 * ABS( v_comp(k) - 2.0_wp * hom(k,1,2,0) ) & 5855 / ( ABS( v_comp(k) - gv ) + 1.0E-20_wp ) & 5844 5856 ) * weight_substep(intermediate_timestep_count) 5845 5857 ! … … 5847 5859 !$ACC ATOMIC 5848 5860 sums_wsvs_ws_l(k,tn) = sums_wsvs_ws_l(k,tn) & 5849 + ( flux_t 5850 * ( w_comp - 2.0_wp * hom(k,1,3,0) )&5851 / ( w_comp + SIGN( 1.0E-20_wp, w_comp ) )&5852 + diss_t 5853 * ABS( w_comp - 2.0_wp * hom(k,1,3,0) )&5854 / ( ABS( w_comp ) + 1.0E-20_wp )&5861 + ( flux_t(k) & 5862 * ( w_comp(k) - 2.0_wp * hom(k,1,3,0) ) & 5863 / ( w_comp(k) + SIGN( 1.0E-20_wp, w_comp(k) ) ) & 5864 + diss_t(k) & 5865 * ABS( w_comp(k) - 2.0_wp * hom(k,1,3,0) ) & 5866 / ( ABS( w_comp(k) ) + 1.0E-20_wp ) & 5855 5867 ) * weight_substep(intermediate_timestep_count) 5856 5868 5857 5869 ENDDO 5870 5871 DO k = nzb_max_l+1, nzt 5872 5873 flux_d = flux_t(k-1) 5874 diss_d = diss_t(k-1) 5875 ! 5876 !-- Calculate the divergence of the velocity field. A respective 5877 !-- correction is needed to overcome numerical instabilities caused 5878 !-- by a not sufficient reduction of divergences near topography. 5879 div = ( ( u_comp(k) + gu - ( u(k,j-1,i) + u(k,j,i) ) ) * ddx& 5880 + ( v_comp(k) - ( v(k,j,i) + v(k,j-1,i) ) ) * ddy& 5881 + ( w_comp(k) * rho_air_zw(k) - & 5882 ( w(k-1,j-1,i) + w(k-1,j,i) ) * rho_air_zw(k-1) & 5883 ) * drho_air(k) * ddzw(k) & 5884 ) * 0.5_wp 5885 5886 tend(k,j,i) = tend(k,j,i) - ( & 5887 ( ( flux_r(k) + diss_r(k) ) & 5888 - ( flux_l_v(k,j,tn) + diss_l_v(k,j,tn) ) ) * ddx & 5889 + ( ( flux_n(k) + diss_n(k) ) & 5890 - ( flux_s_v(k,tn) + diss_s_v(k,tn) ) ) * ddy & 5891 + ( ( flux_t(k) + diss_t(k) ) & 5892 - ( flux_d + diss_d ) ) * drho_air(k) * ddzw(k) & 5893 ) + v(k,j,i) * div 5894 5895 #ifndef _OPENACC 5896 ! 5897 !-- Swap fluxes. Note, in the OPENACC case these are computed again. 5898 flux_l_v(k,j,tn) = flux_r(k) 5899 diss_l_v(k,j,tn) = diss_r(k) 5900 flux_s_v(k,tn) = flux_n(k) 5901 diss_s_v(k,tn) = diss_n(k) 5902 #endif 5903 5904 ! 5905 !-- Statistical Evaluation of v'v'. The factor has to be applied 5906 !-- for right evaluation when gallilei_trans = .T. . 5907 !$ACC ATOMIC 5908 sums_vs2_ws_l(k,tn) = sums_vs2_ws_l(k,tn) & 5909 + ( flux_n(k) & 5910 * ( v_comp(k) - 2.0_wp * hom(k,1,2,0) ) & 5911 / ( v_comp(k) - gv + SIGN( 1.0E-20_wp, v_comp(k) - gv ) ) & 5912 + diss_n(k) & 5913 * ABS( v_comp(k) - 2.0_wp * hom(k,1,2,0) ) & 5914 / ( ABS( v_comp(k) - gv ) + 1.0E-20_wp ) & 5915 ) * weight_substep(intermediate_timestep_count) 5916 ! 5917 !-- Statistical Evaluation of w'u'. 5918 !$ACC ATOMIC 5919 sums_wsvs_ws_l(k,tn) = sums_wsvs_ws_l(k,tn) & 5920 + ( flux_t(k) & 5921 * ( w_comp(k) - 2.0_wp * hom(k,1,3,0) ) & 5922 / ( w_comp(k) + SIGN( 1.0E-20_wp, w_comp(k) ) ) & 5923 + diss_t(k) & 5924 * ABS( w_comp(k) - 2.0_wp * hom(k,1,3,0) ) & 5925 / ( ABS( w_comp(k) ) + 1.0E-20_wp ) & 5926 ) * weight_substep(intermediate_timestep_count) 5927 5928 ENDDO 5929 5858 5930 ENDDO 5859 5931 ENDDO 5860 5932 5933 CALL cpu_log( log_point_s(69), 'advec_v_ws', 'stop' ) 5934 5861 5935 END SUBROUTINE advec_v_ws 5862 5863 5936 5937 5864 5938 !------------------------------------------------------------------------------! 5865 5939 ! Description: … … 5876 5950 INTEGER(iwp) :: k_pp !< k+2 index in disretization, can be modified to avoid segmentation faults 5877 5951 INTEGER(iwp) :: k_ppp !< k+3 index in disretization, can be modified to avoid segmentation faults 5878 INTEGER(iwp) :: nzb_max_l !< index indicating upper bound for order degradation of horizontal advection terms 5952 INTEGER(iwp) :: nzb_max_l !< index indicating upper bound for order degradation of horizontal advection terms 5879 5953 INTEGER(iwp) :: tn = 0 !< number of OpenMP thread 5880 5954 5881 5955 REAL(wp) :: ibit18 !< flag indicating 1st-order scheme along x-direction 5882 5956 REAL(wp) :: ibit19 !< flag indicating 3rd-order scheme along x-direction … … 5895 5969 REAL(wp) :: ibit23_s !< flag indicating 5th-order scheme along y-direction 5896 5970 #endif 5897 REAL(wp) :: ibit24 !< flag indicating 1st-order scheme along z-direction 5898 REAL(wp) :: ibit25 !< flag indicating 3rd-order scheme along z-direction 5899 REAL(wp) :: ibit26 !< flag indicating 5th-order scheme along z-direction 5900 REAL(wp) :: diss_d !< artificial dissipation term at grid box bottom 5901 REAL(wp) :: div !< divergence on w-grid 5902 REAL(wp) :: flux_d !< 6th-order flux at grid box bottom 5903 REAL(wp) :: gu !< Galilei-transformation velocity along x 5904 REAL(wp) :: gv !< Galilei-transformation velocity along y 5905 REAL(wp) :: u_comp !< advection velocity along x 5971 REAL(wp) :: ibit24 !< flag indicating 1st-order scheme along z-direction 5972 REAL(wp) :: ibit25 !< flag indicating 3rd-order scheme along z-direction 5973 REAL(wp) :: ibit26 !< flag indicating 5th-order scheme along z-direction 5974 REAL(wp) :: diss_d !< artificial dissipation term at grid box bottom 5975 REAL(wp) :: div !< divergence on w-grid 5976 REAL(wp) :: flux_d !< 6th-order flux at grid box bottom 5977 REAL(wp) :: gu !< Galilei-transformation velocity along x 5978 REAL(wp) :: gv !< Galilei-transformation velocity along y 5906 5979 #ifdef _OPENACC 5907 5980 REAL(wp) :: u_comp_l !< advection velocity along x 5908 #endif5909 REAL(wp) :: v_comp !< advection velocity along y5910 #ifdef _OPENACC5911 5981 REAL(wp) :: v_comp_s !< advection velocity along y 5912 5982 #endif 5913 REAL(wp) :: w_comp !< advection velocity along z 5914 5915 REAL(wp) :: diss_t !< discretized artificial dissipation at top of the grid box 5916 REAL(wp) :: flux_t !< discretized 6th-order flux at top of the grid box 5917 5918 REAL(wp) :: diss_n !< discretized artificial dissipation at northward-side of the grid box 5919 REAL(wp) :: diss_r !< discretized artificial dissipation at rightward-side of the grid box 5920 REAL(wp) :: flux_n !< discretized 6th-order flux at northward-side of the grid box 5921 REAL(wp) :: flux_r !< discretized 6th-order flux at rightward-side of the grid box 5922 5923 REAL(wp) :: diss_s !< discretized artificial dissipation at southward-side of the grid box 5924 REAL(wp) :: flux_s !< discretized 6th-order flux at southward-side of the grid box 5925 #ifndef _OPENACC 5926 REAL(wp), DIMENSION(nzb+1:nzt) :: swap_diss_y_local_w !< discretized artificial dissipation at southward-side of the grid box 5927 REAL(wp), DIMENSION(nzb+1:nzt) :: swap_flux_y_local_w !< discretized 6th-order flux at southward-side of the grid box 5928 #endif 5929 5930 REAL(wp) :: diss_l !< discretized artificial dissipation at leftward-side of the grid box 5931 REAL(wp) :: flux_l !< discretized 6th-order flux at leftward-side of the grid box 5932 #ifndef _OPENACC 5933 REAL(wp), DIMENSION(nzb+1:nzt,nys:nyn) :: swap_diss_x_local_w !< discretized artificial dissipation at leftward-side of the grid box 5934 REAL(wp), DIMENSION(nzb+1:nzt,nys:nyn) :: swap_flux_x_local_w !< discretized 6th-order flux at leftward-side of the grid box 5935 #endif 5936 ! 5937 !-- Set local version of nzb_max. At non-cyclic boundaries the order of the 5938 !-- advection need to be degraded near the boundary. Please note, in contrast 5939 !-- to the cache-optimized routines, nzb_max_l is set constantly for the 5940 !-- entire subdomain, in order to avoid unsymmetric loops which might be 5941 !-- an issue for GPUs. 5942 IF( bc_dirichlet_l .OR. bc_radiation_l .OR. & 5943 bc_dirichlet_r .OR. bc_radiation_r .OR. & 5944 bc_dirichlet_s .OR. bc_radiation_s .OR. & 5945 bc_dirichlet_n .OR. bc_radiation_n ) THEN 5946 nzb_max_l = nzt 5947 ELSE 5948 nzb_max_l = nzb_max 5949 END IF 5950 5983 5984 REAL(wp), DIMENSION(nzb:nzt+1) :: diss_n !< discretized artificial dissipation at northward-side of the grid box 5985 REAL(wp), DIMENSION(nzb:nzt+1) :: diss_r !< discretized artificial dissipation at rightward-side of the grid box 5986 REAL(wp), DIMENSION(nzb:nzt+1) :: diss_t !< discretized artificial dissipation at top of the grid box 5987 REAL(wp), DIMENSION(nzb:nzt+1) :: flux_n !< discretized 6th-order flux at northward-side of the grid box 5988 REAL(wp), DIMENSION(nzb:nzt+1) :: flux_r !< discretized 6th-order flux at rightward-side of the grid box 5989 REAL(wp), DIMENSION(nzb:nzt+1) :: flux_t !< discretized 6th-order flux at top of the grid box 5990 REAL(wp), DIMENSION(nzb:nzt+1) :: u_comp !< advection velocity along x 5991 REAL(wp), DIMENSION(nzb:nzt+1) :: v_comp !< advection velocity along y 5992 REAL(wp), DIMENSION(nzb:nzt+1) :: w_comp !< advection velocity along z 5993 5994 5995 CALL cpu_log( log_point_s(87), 'advec_w_ws', 'start' ) 5996 5951 5997 gu = 2.0_wp * u_gtrans 5952 5998 gv = 2.0_wp * v_gtrans 5953 5999 6000 !$ACC PARALLEL LOOP COLLAPSE(2) FIRSTPRIVATE(tn, gu, gv) & 6001 !$ACC PRIVATE(i, j, k, k_mm, k_pp, k_ppp) & 6002 !$ACC PRIVATE(ibit18, ibit19, ibit20, ibit21, ibit22, ibit23) & 6003 !$ACC PRIVATE(ibit24, ibit25, ibit26) & 6004 !$ACC PRIVATE(ibit18_l, ibit19_l, ibit20_l) & 6005 !$ACC PRIVATE(ibit21_s, ibit22_s, ibit23_s) & 6006 !$ACC PRIVATE(flux_r, diss_r) & 6007 !$ACC PRIVATE(flux_n, diss_n) & 6008 !$ACC PRIVATE(flux_t, diss_t, flux_d, diss_d) & 6009 !$ACC PRIVATE(flux_l_w, diss_l_w, flux_s_w, diss_s_w) & 6010 !$ACC PRIVATE(div, u_comp, u_comp_l, v_comp, v_comp_s, w_comp) & 6011 !$ACC PRESENT(advc_flags_m) & 6012 !$ACC PRESENT(u, v, w) & 6013 !$ACC PRESENT(drho_air, rho_air_zw, ddzw) & 6014 !$ACC PRESENT(tend) & 6015 !$ACC PRESENT(hom(:,1,1:3,0)) & 6016 !$ACC PRESENT(weight_substep(intermediate_timestep_count)) & 6017 !$ACC PRESENT(sums_ws2_ws_l) 6018 DO i = nxl, nxr 6019 DO j = nys, nyn 6020 ! 6021 !-- Used local modified copy of nzb_max (used to degrade order of 6022 !-- discretization) at non-cyclic boundaries. Modify only at relevant points 6023 !-- instead of the entire subdomain. This should lead to better 6024 !-- load balance between boundary and non-boundary PEs. 6025 IF( ( bc_dirichlet_l .OR. bc_radiation_l ) .AND. i <= nxl + 2 .OR. & 6026 ( bc_dirichlet_r .OR. bc_radiation_r ) .AND. i >= nxr - 2 .OR. & 6027 ( bc_dirichlet_s .OR. bc_radiation_s ) .AND. j <= nys + 2 .OR. & 6028 ( bc_dirichlet_n .OR. bc_radiation_n ) .AND. j >= nyn - 2 ) THEN 6029 nzb_max_l = nzt 6030 ELSE 6031 nzb_max_l = nzb_max 6032 END IF 6033 5954 6034 #ifndef _OPENACC 5955 ! 5956 !-- compute the whole left boundary of the processor domain 5957 i = nxl 5958 DO j = nys, nyn 5959 DO k = nzb+1, nzb_max_l 5960 5961 ibit20 = REAL( IBITS(advc_flags_m(k,j,i-1),20,1), KIND = wp ) 5962 ibit19 = REAL( IBITS(advc_flags_m(k,j,i-1),19,1), KIND = wp ) 5963 ibit18 = REAL( IBITS(advc_flags_m(k,j,i-1),18,1), KIND = wp ) 5964 5965 u_comp = u(k+1,j,i) + u(k,j,i) - gu 5966 swap_flux_x_local_w(k,j) = u_comp * ( & 6035 IF ( i == nxl ) THEN 6036 DO k = nzb+1, nzb_max_l 6037 ibit20 = REAL( IBITS(advc_flags_m(k,j,i-1),20,1), KIND = wp ) 6038 ibit19 = REAL( IBITS(advc_flags_m(k,j,i-1),19,1), KIND = wp ) 6039 ibit18 = REAL( IBITS(advc_flags_m(k,j,i-1),18,1), KIND = wp ) 6040 6041 u_comp(k) = u(k+1,j,i) + u(k,j,i) - gu 6042 flux_l_w(k,j,tn) = u_comp(k) * ( & 5967 6043 ( 37.0_wp * ibit20 * adv_mom_5 & 5968 6044 + 7.0_wp * ibit19 * adv_mom_3 & … … 5977 6053 ) * & 5978 6054 ( w(k,j,i+2) + w(k,j,i-3) ) & 5979 )5980 5981 swap_diss_x_local_w(k,j) = - ABS( u_comp ) * (&6055 ) 6056 6057 diss_l_w(k,j,tn) = - ABS( u_comp(k) ) * ( & 5982 6058 ( 10.0_wp * ibit20 * adv_mom_5 & 5983 6059 + 3.0_wp * ibit19 * adv_mom_3 & … … 5992 6068 ) * & 5993 6069 ( w(k,j,i+2) - w(k,j,i-3) ) & 5994 ) 5995 5996 ENDDO 5997 5998 DO k = nzb_max_l+1, nzt-1 5999 6000 u_comp = u(k+1,j,i) + u(k,j,i) - gu 6001 swap_flux_x_local_w(k,j) = u_comp * ( & 6002 37.0_wp * ( w(k,j,i) + w(k,j,i-1) ) & 6003 - 8.0_wp * ( w(k,j,i+1) + w(k,j,i-2) ) & 6004 + ( w(k,j,i+2) + w(k,j,i-3) ) ) * adv_mom_5 6005 swap_diss_x_local_w(k,j) = - ABS( u_comp ) * ( & 6006 10.0_wp * ( w(k,j,i) - w(k,j,i-1) ) & 6007 - 5.0_wp * ( w(k,j,i+1) - w(k,j,i-2) ) & 6008 + ( w(k,j,i+2) - w(k,j,i-3) ) ) * adv_mom_5 6009 6010 ENDDO 6011 6012 ENDDO 6070 ) 6071 6072 ENDDO 6073 6074 DO k = nzb_max_l+1, nzt-1 6075 6076 u_comp(k) = u(k+1,j,i) + u(k,j,i) - gu 6077 flux_l_w(k,j,tn) = u_comp(k) * ( & 6078 37.0_wp * ( w(k,j,i) + w(k,j,i-1) ) & 6079 - 8.0_wp * ( w(k,j,i+1) + w(k,j,i-2) ) & 6080 + ( w(k,j,i+2) + w(k,j,i-3) ) ) * adv_mom_5 6081 diss_l_w(k,j,tn) = - ABS( u_comp(k) ) * ( & 6082 10.0_wp * ( w(k,j,i) - w(k,j,i-1) ) & 6083 - 5.0_wp * ( w(k,j,i+1) - w(k,j,i-2) ) & 6084 + ( w(k,j,i+2) - w(k,j,i-3) ) ) * adv_mom_5 6085 6086 ENDDO 6087 6088 ENDIF 6089 6090 IF ( j == nys ) THEN 6091 DO k = nzb+1, nzb_max_l 6092 6093 ibit23 = REAL( IBITS(advc_flags_m(k,j-1,i),23,1), KIND = wp ) 6094 ibit22 = REAL( IBITS(advc_flags_m(k,j-1,i),22,1), KIND = wp ) 6095 ibit21 = REAL( IBITS(advc_flags_m(k,j-1,i),21,1), KIND = wp ) 6096 6097 v_comp(k) = v(k+1,j,i) + v(k,j,i) - gv 6098 flux_s_w(k,tn) = v_comp(k) * ( & 6099 ( 37.0_wp * ibit23 * adv_mom_5 & 6100 + 7.0_wp * ibit22 * adv_mom_3 & 6101 + ibit21 * adv_mom_1 & 6102 ) * & 6103 ( w(k,j,i) + w(k,j-1,i) ) & 6104 - ( 8.0_wp * ibit23 * adv_mom_5 & 6105 + ibit22 * adv_mom_3 & 6106 ) * & 6107 ( w(k,j+1,i) + w(k,j-2,i) ) & 6108 + ( ibit23 * adv_mom_5 & 6109 ) * & 6110 ( w(k,j+2,i) + w(k,j-3,i) ) & 6111 ) 6112 6113 diss_s_w(k,tn) = - ABS( v_comp(k) ) * ( & 6114 ( 10.0_wp * ibit23 * adv_mom_5 & 6115 + 3.0_wp * ibit22 * adv_mom_3 & 6116 + ibit21 * adv_mom_1 & 6117 ) * & 6118 ( w(k,j,i) - w(k,j-1,i) ) & 6119 - ( 5.0_wp * ibit23 * adv_mom_5 & 6120 + ibit22 * adv_mom_3 & 6121 ) * & 6122 ( w(k,j+1,i) - w(k,j-2,i) ) & 6123 + ( ibit23 * adv_mom_5 & 6124 ) * & 6125 ( w(k,j+2,i) - w(k,j-3,i) ) & 6126 ) 6127 6128 ENDDO 6129 6130 DO k = nzb_max_l+1, nzt-1 6131 6132 v_comp(k) = v(k+1,j,i) + v(k,j,i) - gv 6133 flux_s_w(k,tn) = v_comp(k) * ( & 6134 37.0_wp * ( w(k,j,i) + w(k,j-1,i) ) & 6135 - 8.0_wp * ( w(k,j+1,i) +w(k,j-2,i) ) & 6136 + ( w(k,j+2,i) + w(k,j-3,i) ) ) * adv_mom_5 6137 diss_s_w(k,tn) = - ABS( v_comp(k) ) * ( & 6138 10.0_wp * ( w(k,j,i) - w(k,j-1,i) ) & 6139 - 5.0_wp * ( w(k,j+1,i) - w(k,j-2,i) ) & 6140 + ( w(k,j+2,i) - w(k,j-3,i) ) ) * adv_mom_5 6141 6142 ENDDO 6143 ENDIF 6013 6144 #endif 6014 6015 !$ACC PARALLEL LOOP COLLAPSE(2) FIRSTPRIVATE(tn, gu, gv) &6016 !$ACC PRIVATE(i, j, k, k_mm, k_pp, k_ppp) &6017 !$ACC PRIVATE(ibit18, ibit19, ibit20, ibit21, ibit22, ibit23) &6018 !$ACC PRIVATE(ibit18_l, ibit19_l, ibit20_l) &6019 !$ACC PRIVATE(ibit21_s, ibit22_s, ibit23_s) &6020 !$ACC PRIVATE(ibit24, ibit25, ibit26) &6021 !$ACC PRIVATE(flux_r, diss_r, flux_l, diss_l) &6022 !$ACC PRIVATE(flux_n, diss_n, flux_s, diss_s) &6023 !$ACC PRIVATE(flux_t, diss_t, flux_d, diss_d) &6024 !$ACC PRIVATE(div, u_comp, u_comp_l, v_comp, v_comp_s, w_comp) &6025 !$ACC PRESENT(advc_flags_m) &6026 !$ACC PRESENT(u, v, w) &6027 !$ACC PRESENT(rho_air, drho_air_zw, ddzu) &6028 !$ACC PRESENT(tend) &6029 !$ACC PRESENT(hom(nzb+1:nzb_max_l,1,3,0)) &6030 !$ACC PRESENT(weight_substep(intermediate_timestep_count)) &6031 !$ACC PRESENT(sums_ws2_ws_l(nzb+1:nzb_max_l,0))6032 DO i = nxl, nxr6033 6034 #ifndef _OPENACC6035 j = nys6036 DO k = nzb+1, nzb_max_l6037 6038 ibit23 = REAL( IBITS(advc_flags_m(k,j-1,i),23,1), KIND = wp )6039 ibit22 = REAL( IBITS(advc_flags_m(k,j-1,i),22,1), KIND = wp )6040 ibit21 = REAL( IBITS(advc_flags_m(k,j-1,i),21,1), KIND = wp )6041 6042 v_comp = v(k+1,j,i) + v(k,j,i) - gv6043 swap_flux_y_local_w(k) = v_comp * ( &6044 ( 37.0_wp * ibit23 * adv_mom_5 &6045 + 7.0_wp * ibit22 * adv_mom_3 &6046 + ibit21 * adv_mom_1 &6047 ) * &6048 ( w(k,j,i) + w(k,j-1,i) ) &6049 - ( 8.0_wp * ibit23 * adv_mom_5 &6050 + ibit22 * adv_mom_3 &6051 ) * &6052 ( w(k,j+1,i) + w(k,j-2,i) ) &6053 + ( ibit23 * adv_mom_5 &6054 ) * &6055 ( w(k,j+2,i) + w(k,j-3,i) ) &6056 )6057 6058 swap_diss_y_local_w(k) = - ABS( v_comp ) * ( &6059 ( 10.0_wp * ibit23 * adv_mom_5 &6060 + 3.0_wp * ibit22 * adv_mom_3 &6061 + ibit21 * adv_mom_1 &6062 ) * &6063 ( w(k,j,i) - w(k,j-1,i) ) &6064 - ( 5.0_wp * ibit23 * adv_mom_5 &6065 + ibit22 * adv_mom_3 &6066 ) * &6067 ( w(k,j+1,i) - w(k,j-2,i) ) &6068 + ( ibit23 * adv_mom_5 &6069 ) * &6070 ( w(k,j+2,i) - w(k,j-3,i) ) &6071 )6072 6073 ENDDO6074 6075 DO k = nzb_max_l+1, nzt-16076 6077 v_comp = v(k+1,j,i) + v(k,j,i) - gv6078 swap_flux_y_local_w(k) = v_comp * ( &6079 37.0_wp * ( w(k,j,i) + w(k,j-1,i) ) &6080 - 8.0_wp * ( w(k,j+1,i) +w(k,j-2,i) ) &6081 + ( w(k,j+2,i) + w(k,j-3,i) ) ) * adv_mom_56082 swap_diss_y_local_w(k) = - ABS( v_comp ) * ( &6083 10.0_wp * ( w(k,j,i) - w(k,j-1,i) ) &6084 - 5.0_wp * ( w(k,j+1,i) - w(k,j-2,i) ) &6085 + ( w(k,j+2,i) - w(k,j-3,i) ) ) * adv_mom_56086 6087 ENDDO6088 #endif6089 6090 DO j = nys, nyn6091 6092 !6093 !-- The lower flux has to be calculated explicitly for the tendency6094 !-- at the first w-level. For topography wall this is done implicitely6095 !-- by advc_flags_m.6096 k = nzb + 16097 w_comp = w(k,j,i) + w(k-1,j,i)6098 flux_d = w_comp * rho_air(k) &6099 * ( w(k,j,i) + w(k-1,j,i) ) * adv_mom_16100 diss_d = -ABS(w_comp) * rho_air(k) &6101 * ( w(k,j,i) - w(k-1,j,i) ) * adv_mom_16102 6103 6145 DO k = nzb+1, nzb_max_l 6104 6146 … … 6107 6149 ibit18 = REAL( IBITS(advc_flags_m(k,j,i),18,1), KIND = wp ) 6108 6150 6109 u_comp = u(k+1,j,i+1) + u(k,j,i+1) - gu6110 flux_r = u_comp * (&6151 u_comp(k) = u(k+1,j,i+1) + u(k,j,i+1) - gu 6152 flux_r(k) = u_comp(k) * ( & 6111 6153 ( 37.0_wp * ibit20 * adv_mom_5 & 6112 6154 + 7.0_wp * ibit19 * adv_mom_3 & … … 6121 6163 ) * & 6122 6164 ( w(k,j,i+3) + w(k,j,i-2) ) & 6123 )6124 6125 diss_r = - ABS( u_comp ) * (&6165 ) 6166 6167 diss_r(k) = - ABS( u_comp(k) ) * ( & 6126 6168 ( 10.0_wp * ibit20 * adv_mom_5 & 6127 6169 + 3.0_wp * ibit19 * adv_mom_3 & … … 6136 6178 ) * & 6137 6179 ( w(k,j,i+3) - w(k,j,i-2) ) & 6138 )6180 ) 6139 6181 6140 6182 #ifdef _OPENACC … … 6145 6187 ibit18_l = REAL( IBITS(advc_flags_m(k,j,i-1),18,1), KIND = wp ) 6146 6188 6147 u_comp_l = u(k+1,j,i) + u(k,j,i) - gu6148 flux_l = u_comp_l * (&6189 u_comp_l = u(k+1,j,i) + u(k,j,i) - gu 6190 flux_l_w(k,j,tn) = u_comp_l * ( & 6149 6191 ( 37.0_wp * ibit20_l * adv_mom_5 & 6150 6192 + 7.0_wp * ibit19_l * adv_mom_3 & … … 6159 6201 ) * & 6160 6202 ( w(k,j,i+2) + w(k,j,i-3) ) & 6161 6162 6163 diss_l = - ABS( u_comp_l ) * (&6203 ) 6204 6205 diss_l_w(k,j,tn) = - ABS( u_comp_l ) * ( & 6164 6206 ( 10.0_wp * ibit20_l * adv_mom_5 & 6165 6207 + 3.0_wp * ibit19_l * adv_mom_3 & … … 6174 6216 ) * & 6175 6217 ( w(k,j,i+2) - w(k,j,i-3) ) & 6176 ) 6177 #else 6178 flux_l = swap_flux_x_local_w(k,j) 6179 diss_l = swap_diss_x_local_w(k,j) 6218 ) 6180 6219 #endif 6181 6220 … … 6185 6224 ibit21 = REAL( IBITS(advc_flags_m(k,j,i),21,1), KIND = wp ) 6186 6225 6187 v_comp = v(k+1,j+1,i) + v(k,j+1,i) - gv6188 flux_n = v_comp * (&6226 v_comp(k) = v(k+1,j+1,i) + v(k,j+1,i) - gv 6227 flux_n(k) = v_comp(k) * ( & 6189 6228 ( 37.0_wp * ibit23 * adv_mom_5 & 6190 6229 + 7.0_wp * ibit22 * adv_mom_3 & … … 6199 6238 ) * & 6200 6239 ( w(k,j+3,i) + w(k,j-2,i) ) & 6201 )6202 6203 diss_n = - ABS( v_comp ) * (&6240 ) 6241 6242 diss_n(k) = - ABS( v_comp(k) ) * ( & 6204 6243 ( 10.0_wp * ibit23 * adv_mom_5 & 6205 6244 + 3.0_wp * ibit22 * adv_mom_3 & … … 6214 6253 ) * & 6215 6254 ( w(k,j+3,i) - w(k,j-2,i) ) & 6216 )6255 ) 6217 6256 6218 6257 #ifdef _OPENACC … … 6223 6262 ibit21_s = REAL( IBITS(advc_flags_m(k,j-1,i),21,1), KIND = wp ) 6224 6263 6225 v_comp_s = v(k+1,j,i) + v(k,j,i) - gv6226 flux_s = v_comp_s * (&6264 v_comp_s = v(k+1,j,i) + v(k,j,i) - gv 6265 flux_s_w(k,tn) = v_comp_s * ( & 6227 6266 ( 37.0_wp * ibit23_s * adv_mom_5 & 6228 6267 + 7.0_wp * ibit22_s * adv_mom_3 & … … 6237 6276 ) * & 6238 6277 ( w(k,j+2,i) + w(k,j-3,i) ) & 6239 6240 6241 diss_s = - ABS( v_comp_s ) * (&6278 ) 6279 6280 diss_s_w(k,tn) = - ABS( v_comp_s ) * ( & 6242 6281 ( 10.0_wp * ibit23_s * adv_mom_5 & 6243 6282 + 3.0_wp * ibit22_s * adv_mom_3 & … … 6253 6292 ( w(k,j+2,i) - w(k,j-3,i) ) & 6254 6293 ) 6255 #else6256 flux_s = swap_flux_y_local_w(k)6257 diss_s = swap_diss_y_local_w(k)6258 6294 #endif 6259 6295 ENDDO 6296 6297 DO k = nzb_max_l+1, nzt-1 6298 6299 u_comp(k) = u(k+1,j,i+1) + u(k,j,i+1) - gu 6300 flux_r(k) = u_comp(k) * ( & 6301 37.0_wp * ( w(k,j,i+1) + w(k,j,i) ) & 6302 - 8.0_wp * ( w(k,j,i+2) + w(k,j,i-1) ) & 6303 + ( w(k,j,i+3) + w(k,j,i-2) ) ) * adv_mom_5 6304 6305 diss_r(k) = - ABS( u_comp(k) ) * ( & 6306 10.0_wp * ( w(k,j,i+1) - w(k,j,i) ) & 6307 - 5.0_wp * ( w(k,j,i+2) - w(k,j,i-1) ) & 6308 + ( w(k,j,i+3) - w(k,j,i-2) ) ) * adv_mom_5 6309 6310 #ifdef _OPENACC 6311 ! 6312 !-- Recompute the left fluxes. 6313 u_comp_l = u(k+1,j,i) + u(k,j,i) - gu 6314 flux_l_w(k,j,tn) = u_comp_l * ( & 6315 37.0_wp * ( w(k,j,i) + w(k,j,i-1) ) & 6316 - 8.0_wp * ( w(k,j,i+1) + w(k,j,i-2) ) & 6317 + ( w(k,j,i+2) + w(k,j,i-3) ) ) * adv_mom_5 6318 diss_l_w(k,j,tn) = - ABS( u_comp_l ) * ( & 6319 10.0_wp * ( w(k,j,i) - w(k,j,i-1) ) & 6320 - 5.0_wp * ( w(k,j,i+1) - w(k,j,i-2) ) & 6321 + ( w(k,j,i+2) - w(k,j,i-3) ) ) * adv_mom_5 6322 #endif 6323 6324 v_comp(k) = v(k+1,j+1,i) + v(k,j+1,i) - gv 6325 flux_n(k) = v_comp(k) * ( & 6326 37.0_wp * ( w(k,j+1,i) + w(k,j,i) ) & 6327 - 8.0_wp * ( w(k,j+2,i) + w(k,j-1,i) ) & 6328 + ( w(k,j+3,i) + w(k,j-2,i) ) ) * adv_mom_5 6329 6330 diss_n(k) = - ABS( v_comp(k) ) * ( & 6331 10.0_wp * ( w(k,j+1,i) - w(k,j,i) ) & 6332 - 5.0_wp * ( w(k,j+2,i) - w(k,j-1,i) ) & 6333 + ( w(k,j+3,i) - w(k,j-2,i) ) ) * adv_mom_5 6334 6335 #ifdef _OPENACC 6336 ! 6337 !-- Recompute the south fluxes. 6338 v_comp_s = v(k+1,j,i) + v(k,j,i) - gv 6339 flux_s_w(k,tn) = v_comp_s * ( & 6340 37.0_wp * ( w(k,j,i) + w(k,j-1,i) ) & 6341 - 8.0_wp * ( w(k,j+1,i) + w(k,j-2,i) ) & 6342 + ( w(k,j+2,i) + w(k,j-3,i) ) ) * adv_mom_5 6343 diss_s_w(k,tn) = - ABS( v_comp_s ) * ( & 6344 10.0_wp * ( w(k,j,i) - w(k,j-1,i) ) & 6345 - 5.0_wp * ( w(k,j+1,i) - w(k,j-2,i) ) & 6346 + ( w(k,j+2,i) - w(k,j-3,i) ) ) * adv_mom_5 6347 #endif 6348 ENDDO 6349 ! 6350 !-- Now, compute vertical fluxes. Split loop into a part treating the 6351 !-- lowest grid points with indirect indexing, a main loop without 6352 !-- indirect indexing, and a loop for the uppermost grip points with 6353 !-- indirect indexing. This allows better vectorization for the main loop. 6354 !-- First, compute the flux at model surface, which need has to be 6355 !-- calculated explicitly for the tendency at 6356 !-- the first w-level. For topography wall this is done implicitely by 6357 !-- advc_flags_m. 6358 k = nzb + 1 6359 w_comp(k) = w(k,j,i) + w(k-1,j,i) 6360 flux_t(0) = w_comp(k) * rho_air(k) & 6361 * ( w(k,j,i) + w(k-1,j,i) ) * adv_mom_1 6362 diss_t(0) = -ABS(w_comp(k)) * rho_air(k) & 6363 * ( w(k,j,i) - w(k-1,j,i) ) * adv_mom_1 6364 6365 DO k = nzb+1, nzb+1 6260 6366 ! 6261 6367 !-- k index has to be modified near bottom and top, else array … … 6269 6375 k_mm = k - 2 * ibit26 6270 6376 6271 w_comp = w(k+1,j,i) + w(k,j,i) 6272 flux_t = w_comp * rho_air(k+1) * ( & 6273 ( 37.0_wp * ibit26 * adv_mom_5 & 6274 + 7.0_wp * ibit25 * adv_mom_3 & 6275 + ibit24 * adv_mom_1 & 6276 ) * & 6277 ( w(k+1,j,i) + w(k,j,i) ) & 6278 - ( 8.0_wp * ibit26 * adv_mom_5 & 6279 + ibit25 * adv_mom_3 & 6280 ) * & 6281 ( w(k_pp,j,i) + w(k-1,j,i) ) & 6282 + ( ibit26 * adv_mom_5 & 6283 ) * & 6284 ( w(k_ppp,j,i) + w(k_mm,j,i) ) & 6285 ) 6286 6287 diss_t = - ABS( w_comp ) * rho_air(k+1) * ( & 6288 ( 10.0_wp * ibit26 * adv_mom_5 & 6289 + 3.0_wp * ibit25 * adv_mom_3 & 6290 + ibit24 * adv_mom_1 & 6291 ) * & 6292 ( w(k+1,j,i) - w(k,j,i) ) & 6293 - ( 5.0_wp * ibit26 * adv_mom_5 & 6294 + ibit25 * adv_mom_3 & 6295 ) * & 6296 ( w(k_pp,j,i) - w(k-1,j,i) ) & 6297 + ( ibit26 * adv_mom_5 & 6298 ) * & 6299 ( w(k_ppp,j,i) - w(k_mm,j,i) ) & 6300 ) 6301 ! 6302 !-- Calculate the divergence of the velocity field. A respective 6303 !-- correction is needed to overcome numerical instabilities caused 6304 !-- by a not sufficient reduction of divergences near topography. 6305 div = ( ( ( u_comp + gu ) * ( ibit18 + ibit19 + ibit20 ) & 6306 - ( u(k+1,j,i) + u(k,j,i) ) & 6307 * ( & 6308 REAL( IBITS(advc_flags_m(k,j,i-1),18,1), KIND = wp ) & 6309 + REAL( IBITS(advc_flags_m(k,j,i-1),19,1), KIND = wp ) & 6310 + REAL( IBITS(advc_flags_m(k,j,i-1),20,1), KIND = wp ) & 6311 ) & 6312 ) * ddx & 6313 + ( ( v_comp + gv ) * ( ibit21 + ibit22 + ibit23 ) & 6314 - ( v(k+1,j,i) + v(k,j,i) ) & 6315 * ( & 6316 REAL( IBITS(advc_flags_m(k,j-1,i),21,1), KIND = wp ) & 6317 + REAL( IBITS(advc_flags_m(k,j-1,i),22,1), KIND = wp ) & 6318 + REAL( IBITS(advc_flags_m(k,j-1,i),23,1), KIND = wp ) & 6319 ) & 6320 ) * ddy & 6321 + ( w_comp * rho_air(k+1) * ( ibit24 + ibit25 + ibit26 ) & 6322 - ( w(k,j,i) + w(k-1,j,i) ) * rho_air(k) & 6323 * ( & 6324 REAL( IBITS(advc_flags_m(k-1,j,i),24,1), KIND = wp ) & 6325 + REAL( IBITS(advc_flags_m(k-1,j,i),25,1), KIND = wp ) & 6326 + REAL( IBITS(advc_flags_m(k-1,j,i),26,1), KIND = wp ) & 6327 ) & 6328 ) * drho_air_zw(k) * ddzu(k+1) & 6329 ) * 0.5_wp 6330 6331 6332 6333 tend(k,j,i) = tend(k,j,i) - ( & 6334 ( ( flux_r + diss_r ) & 6335 - ( flux_l + diss_l ) ) * ddx & 6336 + ( ( flux_n + diss_n ) & 6337 - ( flux_s + diss_s ) ) * ddy & 6338 + ( ( flux_t + diss_t ) & 6339 - ( flux_d + diss_d ) ) * drho_air_zw(k) * ddzu(k+1) & 6340 ) + div * w(k,j,i) 6341 6342 #ifndef _OPENACC 6343 swap_flux_x_local_w(k,j) = flux_r 6344 swap_diss_x_local_w(k,j) = diss_r 6345 swap_flux_y_local_w(k) = flux_n 6346 swap_diss_y_local_w(k) = diss_n 6347 #endif 6348 flux_d = flux_t 6349 diss_d = diss_t 6350 6351 !$ACC ATOMIC 6352 sums_ws2_ws_l(k,tn) = sums_ws2_ws_l(k,tn) & 6353 + ( flux_t & 6354 * ( w_comp - 2.0_wp * hom(k,1,3,0) ) & 6355 / ( w_comp + SIGN( 1.0E-20_wp, w_comp ) ) & 6356 + diss_t & 6357 * ABS( w_comp - 2.0_wp * hom(k,1,3,0) ) & 6358 / ( ABS( w_comp ) + 1.0E-20_wp ) & 6359 ) * weight_substep(intermediate_timestep_count) 6360 6377 w_comp(k) = w(k+1,j,i) + w(k,j,i) 6378 flux_t(k) = w_comp(k) * rho_air(k+1) * ( & 6379 ( 37.0_wp * ibit26 * adv_mom_5 & 6380 + 7.0_wp * ibit25 * adv_mom_3 & 6381 + ibit24 * adv_mom_1 & 6382 ) * & 6383 ( w(k+1,j,i) + w(k,j,i) ) & 6384 - ( 8.0_wp * ibit26 * adv_mom_5 & 6385 + ibit25 * adv_mom_3 & 6386 ) * & 6387 ( w(k_pp,j,i) + w(k-1,j,i) ) & 6388 + ( ibit26 * adv_mom_5 & 6389 ) * & 6390 ( w(k_ppp,j,i) + w(k_mm,j,i) ) & 6391 ) 6392 6393 diss_t(k) = - ABS( w_comp(k) ) * rho_air(k+1) * ( & 6394 ( 10.0_wp * ibit26 * adv_mom_5 & 6395 + 3.0_wp * ibit25 * adv_mom_3 & 6396 + ibit24 * adv_mom_1 & 6397 ) * & 6398 ( w(k+1,j,i) - w(k,j,i) ) & 6399 - ( 5.0_wp * ibit26 * adv_mom_5 & 6400 + ibit25 * adv_mom_3 & 6401 ) * & 6402 ( w(k_pp,j,i) - w(k-1,j,i) ) & 6403 + ( ibit26 * adv_mom_5 & 6404 ) * & 6405 ( w(k_ppp,j,i) - w(k_mm,j,i) ) & 6406 ) 6361 6407 ENDDO 6362 6408 6363 DO k = nzb_max_l+1, nzt-1 6364 6365 u_comp = u(k+1,j,i+1) + u(k,j,i+1) - gu 6366 flux_r = u_comp * ( & 6367 37.0_wp * ( w(k,j,i+1) + w(k,j,i) ) & 6368 - 8.0_wp * ( w(k,j,i+2) + w(k,j,i-1) ) & 6369 + ( w(k,j,i+3) + w(k,j,i-2) ) ) * adv_mom_5 6370 6371 diss_r = - ABS( u_comp ) * ( & 6372 10.0_wp * ( w(k,j,i+1) - w(k,j,i) ) & 6373 - 5.0_wp * ( w(k,j,i+2) - w(k,j,i-1) ) & 6374 + ( w(k,j,i+3) - w(k,j,i-2) ) ) * adv_mom_5 6375 6376 #ifdef _OPENACC 6377 ! 6378 !-- Recompute the left fluxes. 6379 u_comp_l = u(k+1,j,i) + u(k,j,i) - gu 6380 flux_l = u_comp_l * ( & 6381 37.0_wp * ( w(k,j,i) + w(k,j,i-1) ) & 6382 - 8.0_wp * ( w(k,j,i+1) + w(k,j,i-2) ) & 6383 + ( w(k,j,i+2) + w(k,j,i-3) ) ) * adv_mom_5 6384 diss_l = - ABS( u_comp_l ) * ( & 6385 10.0_wp * ( w(k,j,i) - w(k,j,i-1) ) & 6386 - 5.0_wp * ( w(k,j,i+1) - w(k,j,i-2) ) & 6387 + ( w(k,j,i+2) - w(k,j,i-3) ) ) * adv_mom_5 6388 #else 6389 flux_l = swap_flux_x_local_w(k,j) 6390 diss_l = swap_diss_x_local_w(k,j) 6391 #endif 6392 6393 v_comp = v(k+1,j+1,i) + v(k,j+1,i) - gv 6394 flux_n = v_comp * ( & 6395 37.0_wp * ( w(k,j+1,i) + w(k,j,i) ) & 6396 - 8.0_wp * ( w(k,j+2,i) + w(k,j-1,i) ) & 6397 + ( w(k,j+3,i) + w(k,j-2,i) ) ) * adv_mom_5 6398 6399 diss_n = - ABS( v_comp ) * ( & 6400 10.0_wp * ( w(k,j+1,i) - w(k,j,i) ) & 6401 - 5.0_wp * ( w(k,j+2,i) - w(k,j-1,i) ) & 6402 + ( w(k,j+3,i) - w(k,j-2,i) ) ) * adv_mom_5 6403 6404 #ifdef _OPENACC 6405 ! 6406 !-- Recompute the south fluxes. 6407 v_comp_s = v(k+1,j,i) + v(k,j,i) - gv 6408 flux_s = v_comp_s * ( & 6409 37.0_wp * ( w(k,j,i) + w(k,j-1,i) ) & 6410 - 8.0_wp * ( w(k,j+1,i) +w(k,j-2,i) ) & 6411 + ( w(k,j+2,i) + w(k,j-3,i) ) ) * adv_mom_5 6412 diss_s = - ABS( v_comp_s ) * ( & 6413 10.0_wp * ( w(k,j,i) - w(k,j-1,i) ) & 6414 - 5.0_wp * ( w(k,j+1,i) - w(k,j-2,i) ) & 6415 + ( w(k,j+2,i) - w(k,j-3,i) ) ) * adv_mom_5 6416 #else 6417 flux_s = swap_flux_y_local_w(k) 6418 diss_s = swap_diss_y_local_w(k) 6419 #endif 6420 6409 DO k = nzb+2, nzt-2 6410 6411 ibit26 = REAL( IBITS(advc_flags_m(k,j,i),26,1), KIND = wp ) 6412 ibit25 = REAL( IBITS(advc_flags_m(k,j,i),25,1), KIND = wp ) 6413 ibit24 = REAL( IBITS(advc_flags_m(k,j,i),24,1), KIND = wp ) 6414 6415 w_comp(k) = w(k+1,j,i) + w(k,j,i) 6416 flux_t(k) = w_comp(k) * rho_air(k+1) * ( & 6417 ( 37.0_wp * ibit26 * adv_mom_5 & 6418 + 7.0_wp * ibit25 * adv_mom_3 & 6419 + ibit24 * adv_mom_1 & 6420 ) * & 6421 ( w(k+1,j,i) + w(k,j,i) ) & 6422 - ( 8.0_wp * ibit26 * adv_mom_5 & 6423 + ibit25 * adv_mom_3 & 6424 ) * & 6425 ( w(k+2,j,i) + w(k-1,j,i) ) & 6426 + ( ibit26 * adv_mom_5 & 6427 ) * & 6428 ( w(k+3,j,i) + w(k-2,j,i) ) & 6429 ) 6430 6431 diss_t(k) = - ABS( w_comp(k) ) * rho_air(k+1) * ( & 6432 ( 10.0_wp * ibit26 * adv_mom_5 & 6433 + 3.0_wp * ibit25 * adv_mom_3 & 6434 + ibit24 * adv_mom_1 & 6435 ) * & 6436 ( w(k+1,j,i) - w(k,j,i) ) & 6437 - ( 5.0_wp * ibit26 * adv_mom_5 & 6438 + ibit25 * adv_mom_3 & 6439 ) * & 6440 ( w(k+2,j,i) - w(k-1,j,i) ) & 6441 + ( ibit26 * adv_mom_5 & 6442 ) * & 6443 ( w(k+3,j,i) - w(k-2,j,i) ) & 6444 ) 6445 ENDDO 6446 6447 DO k = nzt-1, nzt-1 6421 6448 ! 6422 6449 !-- k index has to be modified near bottom and top, else array … … 6430 6457 k_mm = k - 2 * ibit26 6431 6458 6432 w_comp = w(k+1,j,i) + w(k,j,i) 6433 flux_t = w_comp * rho_air(k+1) * ( & 6434 ( 37.0_wp * ibit26 * adv_mom_5 & 6435 + 7.0_wp * ibit25 * adv_mom_3 & 6436 + ibit24 * adv_mom_1 & 6437 ) * & 6438 ( w(k+1,j,i) + w(k,j,i) ) & 6439 - ( 8.0_wp * ibit26 * adv_mom_5 & 6440 + ibit25 * adv_mom_3 & 6441 ) * & 6442 ( w(k_pp,j,i) + w(k-1,j,i) ) & 6443 + ( ibit26 * adv_mom_5 & 6444 ) * & 6445 ( w(k_ppp,j,i) + w(k_mm,j,i) ) & 6446 ) 6447 6448 diss_t = - ABS( w_comp ) * rho_air(k+1) * ( & 6449 ( 10.0_wp * ibit26 * adv_mom_5 & 6450 + 3.0_wp * ibit25 * adv_mom_3 & 6451 + ibit24 * adv_mom_1 & 6452 ) * & 6453 ( w(k+1,j,i) - w(k,j,i) ) & 6454 - ( 5.0_wp * ibit26 * adv_mom_5 & 6455 + ibit25 * adv_mom_3 & 6456 ) * & 6457 ( w(k_pp,j,i) - w(k-1,j,i) ) & 6458 + ( ibit26 * adv_mom_5 & 6459 ) * & 6460 ( w(k_ppp,j,i) - w(k_mm,j,i) ) & 6461 ) 6459 w_comp(k) = w(k+1,j,i) + w(k,j,i) 6460 flux_t(k) = w_comp(k) * rho_air(k+1) * ( & 6461 ( 37.0_wp * ibit26 * adv_mom_5 & 6462 + 7.0_wp * ibit25 * adv_mom_3 & 6463 + ibit24 * adv_mom_1 & 6464 ) * & 6465 ( w(k+1,j,i) + w(k,j,i) ) & 6466 - ( 8.0_wp * ibit26 * adv_mom_5 & 6467 + ibit25 * adv_mom_3 & 6468 ) * & 6469 ( w(k_pp,j,i) + w(k-1,j,i) ) & 6470 + ( ibit26 * adv_mom_5 & 6471 ) * & 6472 ( w(k_ppp,j,i) + w(k_mm,j,i) ) & 6473 ) 6474 6475 diss_t(k) = - ABS( w_comp(k) ) * rho_air(k+1) * ( & 6476 ( 10.0_wp * ibit26 * adv_mom_5 & 6477 + 3.0_wp * ibit25 * adv_mom_3 & 6478 + ibit24 * adv_mom_1 & 6479 ) * & 6480 ( w(k+1,j,i) - w(k,j,i) ) & 6481 - ( 5.0_wp * ibit26 * adv_mom_5 & 6482 + ibit25 * adv_mom_3 & 6483 ) * & 6484 ( w(k_pp,j,i) - w(k-1,j,i) ) & 6485 + ( ibit26 * adv_mom_5 & 6486 ) * & 6487 ( w(k_ppp,j,i) - w(k_mm,j,i) ) & 6488 ) 6489 ENDDO 6490 6491 ! 6492 !-- Set resolved/turbulent flux at model top to zero (w-level). Hint: The 6493 !-- flux at nzt is defined at the scalar grid point nzt+1. Therefore, the 6494 !-- flux at nzt+1 is already outside of the model domain 6495 flux_t(nzt) = 0.0_wp 6496 diss_t(nzt) = 0.0_wp 6497 w_comp(nzt) = 0.0_wp 6498 6499 flux_t(nzt+1) = 0.0_wp 6500 diss_t(nzt+1) = 0.0_wp 6501 w_comp(nzt+1) = 0.0_wp 6502 6503 DO k = nzb+1, nzb_max_l 6504 6505 flux_d = flux_t(k-1) 6506 diss_d = diss_t(k-1) 6507 6508 ibit20 = REAL( IBITS(advc_flags_m(k,j,i),20,1), KIND = wp ) 6509 ibit19 = REAL( IBITS(advc_flags_m(k,j,i),19,1), KIND = wp ) 6510 ibit18 = REAL( IBITS(advc_flags_m(k,j,i),18,1), KIND = wp ) 6511 6512 ibit23 = REAL( IBITS(advc_flags_m(k,j,i),23,1), KIND = wp ) 6513 ibit22 = REAL( IBITS(advc_flags_m(k,j,i),22,1), KIND = wp ) 6514 ibit21 = REAL( IBITS(advc_flags_m(k,j,i),21,1), KIND = wp ) 6515 6516 ibit26 = REAL( IBITS(advc_flags_m(k,j,i),26,1), KIND = wp ) 6517 ibit25 = REAL( IBITS(advc_flags_m(k,j,i),25,1), KIND = wp ) 6518 ibit24 = REAL( IBITS(advc_flags_m(k,j,i),24,1), KIND = wp ) 6462 6519 ! 6463 6520 !-- Calculate the divergence of the velocity field. A respective 6464 !-- correction is needed to overcome numerical instabilities caused6521 !-- correction is needed to overcome numerical instabilities introduced 6465 6522 !-- by a not sufficient reduction of divergences near topography. 6466 div = ( ( u_comp + gu - ( u(k+1,j,i) + u(k,j,i) ) ) * ddx & 6467 + ( v_comp + gv - ( v(k+1,j,i) + v(k,j,i) ) ) * ddy & 6468 + ( w_comp * rho_air(k+1) - & 6469 ( w(k,j,i) + w(k-1,j,i) ) * rho_air(k) & 6470 ) * drho_air_zw(k) * ddzu(k+1) & 6523 div = ( ( ( u_comp(k) + gu ) * ( ibit18 + ibit19 + ibit20 ) & 6524 - ( u(k+1,j,i) + u(k,j,i) ) & 6525 * ( & 6526 REAL( IBITS(advc_flags_m(k,j,i-1),18,1), KIND = wp ) & 6527 + REAL( IBITS(advc_flags_m(k,j,i-1),19,1), KIND = wp ) & 6528 + REAL( IBITS(advc_flags_m(k,j,i-1),20,1), KIND = wp ) & 6529 ) & 6530 ) * ddx & 6531 + ( ( v_comp(k) + gv ) * ( ibit21 + ibit22 + ibit23 ) & 6532 - ( v(k+1,j,i) + v(k,j,i) ) & 6533 * ( & 6534 REAL( IBITS(advc_flags_m(k,j-1,i),21,1), KIND = wp ) & 6535 + REAL( IBITS(advc_flags_m(k,j-1,i),22,1), KIND = wp ) & 6536 + REAL( IBITS(advc_flags_m(k,j-1,i),23,1), KIND = wp ) & 6537 ) & 6538 ) * ddy & 6539 + ( w_comp(k) * rho_air(k+1) & 6540 * ( ibit24 + ibit25 + ibit26 )& 6541 - ( w(k,j,i) + w(k-1,j,i) ) * rho_air(k) & 6542 * ( & 6543 REAL( IBITS(advc_flags_m(k-1,j,i),24,1), KIND = wp ) & 6544 + REAL( IBITS(advc_flags_m(k-1,j,i),25,1), KIND = wp ) & 6545 + REAL( IBITS(advc_flags_m(k-1,j,i),26,1), KIND = wp ) & 6546 ) & 6547 ) * drho_air_zw(k) * ddzu(k+1) & 6471 6548 ) * 0.5_wp 6472 6549 6473 tend(k,j,i) = tend(k,j,i) - ( &6474 ( ( flux_r + diss_r )&6475 - ( flux_l + diss_l ) ) * ddx&6476 + ( ( flux_n + diss_n )&6477 - ( flux_s + diss_s ) ) * ddy&6478 + ( ( flux_t + diss_t )&6479 - ( flux_d + diss_d ) ) * drho_air_zw(k) * ddzu(k+1)&6480 ) + div * w(k,j,i)6481 6550 tend(k,j,i) = tend(k,j,i) - ( & 6551 ( flux_r(k) + diss_r(k) & 6552 - flux_l_w(k,j,tn) - diss_l_w(k,j,tn) ) * ddx & 6553 + ( flux_n(k) + diss_n(k) & 6554 - flux_s_w(k,tn) - diss_s_w(k,tn) ) * ddy & 6555 + ( ( flux_t(k) + diss_t(k) ) & 6556 - ( flux_d + diss_d ) & 6557 ) * drho_air_zw(k) * ddzu(k+1) & 6558 ) + div * w(k,j,i) 6482 6559 #ifndef _OPENACC 6483 swap_flux_x_local_w(k,j) = flux_r6484 swap_diss_x_local_w(k,j) = diss_r6485 swap_flux_y_local_w(k) = flux_n6486 swap_diss_y_local_w(k) = diss_n6560 flux_l_w(k,j,tn) = flux_r(k) 6561 diss_l_w(k,j,tn) = diss_r(k) 6562 flux_s_w(k,tn) = flux_n(k) 6563 diss_s_w(k,tn) = diss_n(k) 6487 6564 #endif 6488 flux_d = flux_t 6489 diss_d = diss_t 6490 6491 !$ACC ATOMIC 6492 sums_ws2_ws_l(k,tn) = sums_ws2_ws_l(k,tn) & 6493 + ( flux_t & 6494 * ( w_comp - 2.0_wp * hom(k,1,3,0) ) & 6495 / ( w_comp + SIGN( 1.0E-20_wp, w_comp ) ) & 6496 + diss_t & 6497 * ABS( w_comp - 2.0_wp * hom(k,1,3,0) ) & 6498 / ( ABS( w_comp ) + 1.0E-20_wp ) & 6499 ) * weight_substep(intermediate_timestep_count) 6565 ! 6566 !-- Statistical Evaluation of w'w'. 6567 sums_ws2_ws_l(k,tn) = sums_ws2_ws_l(k,tn) & 6568 + ( flux_t(k) & 6569 * ( w_comp(k) - 2.0_wp * hom(k,1,3,0) ) & 6570 / ( w_comp(k) + SIGN( 1.0E-20_wp, w_comp(k) ) ) & 6571 + diss_t(k) & 6572 * ABS( w_comp(k) - 2.0_wp * hom(k,1,3,0) ) & 6573 / ( ABS( w_comp(k) ) + 1.0E-20_wp ) & 6574 ) * weight_substep(intermediate_timestep_count) 6500 6575 6501 6576 ENDDO 6577 6578 DO k = nzb_max_l+1, nzt-1 6579 6580 flux_d = flux_t(k-1) 6581 diss_d = diss_t(k-1) 6582 ! 6583 !-- Calculate the divergence of the velocity field. A respective 6584 !-- correction is needed to overcome numerical instabilities introduced 6585 !-- by a not sufficient reduction of divergences near topography. 6586 div = ( ( u_comp(k) + gu - ( u(k+1,j,i) + u(k,j,i) ) ) * ddx & 6587 + ( v_comp(k) + gv - ( v(k+1,j,i) + v(k,j,i) ) ) * ddy & 6588 + ( w_comp(k) * rho_air(k+1) & 6589 - ( w(k,j,i) + w(k-1,j,i) ) * rho_air(k) & 6590 ) * drho_air_zw(k) * ddzu(k+1) & 6591 ) * 0.5_wp 6592 6593 tend(k,j,i) = tend(k,j,i) - ( & 6594 ( flux_r(k) + diss_r(k) & 6595 - flux_l_w(k,j,tn) - diss_l_w(k,j,tn) ) * ddx & 6596 + ( flux_n(k) + diss_n(k) & 6597 - flux_s_w(k,tn) - diss_s_w(k,tn) ) * ddy & 6598 + ( ( flux_t(k) + diss_t(k) ) & 6599 - ( flux_d + diss_d ) & 6600 ) * drho_air_zw(k) * ddzu(k+1) & 6601 ) + div * w(k,j,i) 6602 #ifndef _OPENACC 6603 flux_l_w(k,j,tn) = flux_r(k) 6604 diss_l_w(k,j,tn) = diss_r(k) 6605 flux_s_w(k,tn) = flux_n(k) 6606 diss_s_w(k,tn) = diss_n(k) 6607 #endif 6608 ! 6609 !-- Statistical Evaluation of w'w'. 6610 sums_ws2_ws_l(k,tn) = sums_ws2_ws_l(k,tn) & 6611 + ( flux_t(k) & 6612 * ( w_comp(k) - 2.0_wp * hom(k,1,3,0) ) & 6613 / ( w_comp(k) + SIGN( 1.0E-20_wp, w_comp(k) ) ) & 6614 + diss_t(k) & 6615 * ABS( w_comp(k) - 2.0_wp * hom(k,1,3,0) ) & 6616 / ( ABS( w_comp(k) ) + 1.0E-20_wp ) & 6617 ) * weight_substep(intermediate_timestep_count) 6618 6619 ENDDO 6620 6502 6621 ENDDO 6503 6622 ENDDO 6504 6623 6624 CALL cpu_log( log_point_s(87), 'advec_w_ws', 'stop' ) 6625 6505 6626 END SUBROUTINE advec_w_ws 6506 6627 -
palm/trunk/SOURCE/time_integration.f90
r4457 r4466 25 25 ! ----------------- 26 26 ! $Id$ 27 ! Add advection fluxes to ACC copyin 28 ! 29 ! 4457 2020-03-11 14:20:43Z raasch 27 30 ! use statement for exchange horiz added 28 ! 31 ! 29 32 ! 4444 2020-03-05 15:59:50Z raasch 30 33 ! bugfix: cpp-directives for serial mode added 31 ! 34 ! 32 35 ! 4420 2020-02-24 14:13:56Z maronga 33 36 ! Added output control for wind turbine model 34 ! 37 ! 35 38 ! 4403 2020-02-12 13:08:46Z banzhafs 36 39 ! Allowing both existing and on-demand emission read modes … … 38 41 ! 4360 2020-01-07 11:25:50Z suehring 39 42 ! Bugfix, hour_call_emis uninitialized at first call of time_integration 40 ! 43 ! 41 44 ! 4346 2019-12-18 11:55:56Z motisi 42 45 ! Introduction of wall_flags_total_0, which currently sets bits based on static 43 46 ! topography information used in wall_flags_static_0 44 ! 47 ! 45 48 ! 4329 2019-12-10 15:46:36Z motisi 46 49 ! Renamed wall_flags_0 to wall_flags_static_0 47 ! 50 ! 48 51 ! 4281 2019-10-29 15:15:39Z schwenkel 49 52 ! Moved boundary conditions to module interface 50 ! 53 ! 51 54 ! 4276 2019-10-28 16:03:29Z schwenkel 52 55 ! Further modularization of lpm code components 53 ! 56 ! 54 57 ! 4275 2019-10-28 15:34:55Z schwenkel 55 58 ! Move call oft lpm to the end of intermediate timestep loop … … 60 63 ! 4227 2019-09-10 18:04:34Z gronemeier 61 64 ! implement new palm_date_time_mod 62 ! 65 ! 63 66 ! 4226 2019-09-10 17:03:24Z suehring 64 67 ! Changes in interface for the offline nesting 65 ! 68 ! 66 69 ! 4182 2019-08-22 15:20:23Z scharf 67 70 ! Corrected "Former revisions" section 68 ! 71 ! 69 72 ! 4170 2019-08-19 17:12:31Z gronemeier 70 73 ! copy diss, diss_p, tdiss_m to GPU 71 ! 74 ! 72 75 ! 4144 2019-08-06 09:11:47Z raasch 73 76 ! relational operators .EQ., .NE., etc. replaced by ==, /=, etc. 74 ! 77 ! 75 78 ! 4126 2019-07-30 11:09:11Z gronemeier 76 79 ! renamed routine to calculate uv exposure 77 ! 80 ! 78 81 ! 4111 2019-07-22 18:16:57Z suehring 79 82 ! advc_flags_1 / advc_flags_2 renamed to advc_flags_m / advc_flags_s 80 ! 83 ! 81 84 ! 4069 2019-07-01 14:05:51Z Giersch 82 ! Masked output running index mid has been introduced as a local variable to 85 ! Masked output running index mid has been introduced as a local variable to 83 86 ! avoid runtime error (Loop variable has been modified) in time_integration 84 ! 87 ! 85 88 ! 4064 2019-07-01 05:33:33Z gronemeier 86 89 ! Moved call to radiation module out of intermediate time loop 87 ! 90 ! 88 91 ! 4048 2019-06-21 21:00:21Z knoop 89 92 ! Moved production_e_init call into turbulence_closure_mod 90 ! 93 ! 91 94 ! 4047 2019-06-21 18:58:09Z knoop 92 95 ! Added remainings of swap_timelevel upon its dissolution 93 ! 96 ! 94 97 ! 4043 2019-06-18 16:59:00Z schwenkel 95 98 ! Further LPM modularization … … 97 100 ! 4039 2019-06-18 10:32:41Z suehring 98 101 ! Rename subroutines in module for diagnostic quantities 99 ! 102 ! 100 103 ! 4029 2019-06-14 14:04:35Z raasch 101 104 ! exchange of ghost points and boundary conditions separated for chemical species and SALSA module, 102 105 ! bugfix: decycling of chemistry species after nesting data transfer 103 ! 106 ! 104 107 ! 4022 2019-06-12 11:52:39Z suehring 105 108 ! Call synthetic turbulence generator at last RK3 substep right after boundary 106 ! conditions are updated in offline nesting in order to assure that 107 ! perturbations are always imposed 108 ! 109 ! conditions are updated in offline nesting in order to assure that 110 ! perturbations are always imposed 111 ! 109 112 ! 4017 2019-06-06 12:16:46Z schwenkel 110 113 ! Mass (volume) flux correction included to ensure global mass conservation for child domains. 111 ! 114 ! 112 115 ! 3994 2019-05-22 18:08:09Z suehring 113 116 ! output of turbulence intensity added 114 ! 117 ! 115 118 ! 3988 2019-05-22 11:32:37Z kanani 116 119 ! Implement steerable output interval for virtual measurements 117 ! 120 ! 118 121 ! 3968 2019-05-13 11:04:01Z suehring 119 122 ! replace nspec_out with n_matched_vars 120 ! 123 ! 121 124 ! 3929 2019-04-24 12:52:08Z banzhafs 122 125 ! Reverse changes back from revision 3878: use chem_boundary_conds instead of 123 126 ! chem_boundary_conds_decycle 124 ! 125 ! 127 ! 128 ! 126 129 ! 3885 2019-04-11 11:29:34Z kanani 127 ! Changes related to global restructuring of location messages and introduction 130 ! Changes related to global restructuring of location messages and introduction 128 131 ! of additional debug messages 129 132 ! 130 133 ! 3879 2019-04-08 20:25:23Z knoop 131 134 ! Moved wtm_forces to module_interface_actions 132 ! 135 ! 133 136 ! 3872 2019-04-08 15:03:06Z knoop 134 137 ! Modifications made for salsa: … … 136 139 ! salsa_emission_update (i.e. skip_time_do_salsa >= time_since_reference_point 137 140 ! and next_aero_emission_update <= time_since_reference_point ). 138 ! - Renamed nbins --> nbins_aerosol, ncc_tot --> ncomponents_mass and 141 ! - Renamed nbins --> nbins_aerosol, ncc_tot --> ncomponents_mass and 139 142 ! ngast --> ngases_salsa and loop indices b, c and sg to ib, ic and ig 140 143 ! - Apply nesting for salsa variables 141 144 ! - Removed cpu_log calls speciffic for salsa. 142 ! 145 ! 143 146 ! 3833 2019-03-28 15:04:04Z forkel 144 147 ! added USE chem_gasphase_mod, replaced nspec by nspec since fixed compounds are not integrated 145 ! 148 ! 146 149 ! 3820 2019-03-27 11:53:41Z forkel 147 150 ! renamed do_emiss to emissions_anthropogenic (ecc) 148 ! 149 ! 151 ! 152 ! 150 153 ! 3774 2019-03-04 10:52:49Z moh.hefny 151 154 ! rephrase if statement to avoid unallocated array in case of … … 155 158 ! module section re-formatted and openacc required variables moved to separate section, 156 159 ! re-formatting to 100 char line width 157 ! 160 ! 158 161 ! 3745 2019-02-15 18:57:56Z suehring 159 162 ! Call indoor model after first timestep 160 ! 163 ! 161 164 ! 3744 2019-02-15 18:38:58Z suehring 162 165 ! - Moved call of bio_calculate_thermal_index_maps from biometeorology module to 163 166 ! time_integration to make sure averaged input is updated before calculating. 164 ! 167 ! 165 168 ! 3739 2019-02-13 08:05:17Z dom_dwd_user 166 169 ! Removed everything related to "time_bio_results" as this is never used. 167 ! 170 ! 168 171 ! 3724 2019-02-06 16:28:23Z kanani 169 ! Correct double-used log_point_s unit 170 ! 172 ! Correct double-used log_point_s unit 173 ! 171 174 ! 3719 2019-02-06 13:10:18Z kanani 172 175 ! - removed wind_turbine cpu measurement, since same time is measured inside … … 176 179 ! moved radiation_interactions cpulog to special measures 177 180 ! - moved some cpu_log calls to this routine for better overview 178 ! 181 ! 179 182 ! 3705 2019-01-29 19:56:39Z suehring 180 183 ! Data output for virtual measurements added 181 ! 184 ! 182 185 ! 3704 2019-01-29 19:51:41Z suehring 183 186 ! Rename subroutines for surface-data output 184 ! 187 ! 185 188 ! 3647 2019-01-02 14:10:44Z kanani 186 189 ! Bugfix: add time_since_reference_point to IF clause for data_output calls … … 198 201 !------------------------------------------------------------------------------! 199 202 SUBROUTINE time_integration 200 203 201 204 202 205 USE advec_ws, & … … 400 403 vm_time_start 401 404 402 405 403 406 USE wind_turbine_model_mod, & 404 407 ONLY: dt_data_output_wtm, time_wtm, wind_turbine, wtm_data_output … … 406 409 #if defined( _OPENACC ) 407 410 USE arrays_3d, & 408 ONLY: d, dd2zu, ddzu, ddzw, drho_air, drho_air_zw, dzw, e, heatflux_output_conversion, & 411 ONLY: d, dd2zu, ddzu, ddzw, & 412 diss_l_u, & 413 diss_l_v, & 414 diss_l_w, & 415 diss_s_u, & 416 diss_s_v, & 417 diss_s_w, & 418 drho_air, drho_air_zw, dzw, e, & 419 flux_l_u, & 420 flux_l_v, & 421 flux_l_w, & 422 flux_s_u, & 423 flux_s_v, & 424 flux_s_w, & 425 heatflux_output_conversion, & 409 426 kh, km, momentumflux_output_conversion, nc, nr, p, ptdf_x, ptdf_y, qc, qr, rdf, & 410 427 rdf_sc, rho_air, rho_air_zw, s, tdiss_m, te_m, tpt_m, tu_m, tv_m, tw_m, ug, u_init, & … … 453 470 ! 454 471 !-- Copy data from arrays_3d 455 !$ACC DATA & 472 !$ACC DATA & 456 473 !$ACC COPY(d(nzb+1:nzt,nys:nyn,nxl:nxr)) & 457 474 !$ACC COPY(diss(nzb:nzt+1,nysg:nyng,nxlg:nxrg)) & … … 466 483 467 484 !$ACC DATA & 485 !$ACC COPYIN(diss_l_u(0:nz+1,nys:nyn,0), flux_l_u(0:nz+1,nys:nyn,0)) & 486 !$ACC COPYIN(diss_l_v(0:nz+1,nys:nyn,0), flux_l_v(0:nz+1,nys:nyn,0)) & 487 !$ACC COPYIN(diss_l_w(0:nz+1,nys:nyn,0), flux_l_w(0:nz+1,nys:nyn,0)) & 488 !$ACC COPYIN(diss_s_u(0:nz+1,0), flux_s_u(0:nz+1,0)) & 489 !$ACC COPYIN(diss_s_v(0:nz+1,0), flux_s_v(0:nz+1,0)) & 490 !$ACC COPYIN(diss_s_w(0:nz+1,0), flux_s_w(0:nz+1,0)) & 468 491 !$ACC COPY(diss_p(nzb:nzt+1,nysg:nyng,nxlg:nxrg)) & 469 492 !$ACC COPY(e_p(nzb:nzt+1,nysg:nyng,nxlg:nxrg)) & … … 569 592 CALL run_control 570 593 ! 571 !-- Data exchange between coupled models in case that a call has been omitted 594 !-- Data exchange between coupled models in case that a call has been omitted 572 595 !-- at the end of the previous run of a job chain. 573 596 IF ( coupling_mode /= 'uncoupled' .AND. run_coupled .AND. .NOT. vnested ) THEN 574 597 ! 575 !-- In case of model termination initiated by the local model the coupler 576 !-- must not be called because this would again cause an MPI hang. 598 !-- In case of model termination initiated by the local model the coupler 599 !-- must not be called because this would again cause an MPI hang. 577 600 DO WHILE ( time_coupling >= dt_coupling .AND. terminate_coupled == 0 ) 578 601 CALL surface_coupler … … 606 629 607 630 ! 608 !-- Determine ug, vg and w_subs in dependence on data from external file 631 !-- Determine ug, vg and w_subs in dependence on data from external file 609 632 !-- LSF_DATA 610 633 IF ( large_scale_forcing .AND. lsf_vert ) THEN … … 614 637 615 638 ! 616 !-- Set pt_init and q_init to the current profiles taken from 617 !-- NUDGING_DATA 639 !-- Set pt_init and q_init to the current profiles taken from 640 !-- NUDGING_DATA 618 641 IF ( nudging ) THEN 619 642 CALL nudge_ref ( simulated_time ) … … 649 672 ENDIF 650 673 ! 651 !-- Input of boundary data. 674 !-- Input of boundary data. 652 675 IF ( nesting_offline ) CALL nesting_offl_input 653 676 ! 654 677 !-- Execute all other module actions routines 655 678 CALL module_interface_actions( 'before_timestep' ) 656 679 657 680 !-- Start of intermediate step loop 658 681 intermediate_timestep_count = 0 … … 689 712 ! 690 713 !-- Assure that ref_state does not become zero at any level 691 !-- ( might be the case if a vertical level is completely occupied 714 !-- ( might be the case if a vertical level is completely occupied 692 715 !-- with topography ). 693 716 ref_state = MERGE( MAXVAL(ref_state), ref_state, ref_state == 0.0_wp ) … … 856 879 ENDIF 857 880 858 IF ( passive_scalar ) CALL exchange_horiz( s, nbgp ) 881 IF ( passive_scalar ) CALL exchange_horiz( s, nbgp ) 859 882 860 883 IF ( .NOT. constant_diffusion ) CALL exchange_horiz( e, nbgp ) … … 866 889 IF ( air_chemistry ) THEN 867 890 DO n = 1, nvar 868 CALL exchange_horiz( chem_species(n)%conc, nbgp ) 891 CALL exchange_horiz( chem_species(n)%conc, nbgp ) 869 892 ENDDO 870 893 ENDIF … … 973 996 974 997 ! 975 !-- Map forcing data derived from larger scale model onto domain 998 !-- Map forcing data derived from larger scale model onto domain 976 999 !-- boundaries. Further, update geostrophic wind components. 977 1000 IF ( nesting_offline .AND. intermediate_timestep_count == & 978 1001 intermediate_timestep_count_max ) THEN 979 !-- Determine interpolation factor before boundary conditions and geostrophic wind 1002 !-- Determine interpolation factor before boundary conditions and geostrophic wind 980 1003 !-- is updated. 981 1004 CALL nesting_offl_interpolation_factor … … 994 1017 !-- Ensure mass conservation. This need to be done after imposing 995 1018 !-- synthetic turbulence and top boundary condition for pressure is set to 996 !-- Neumann conditions. 1019 !-- Neumann conditions. 997 1020 !-- Is this also required in case of Dirichlet? 998 1021 IF ( nesting_offline ) CALL nesting_offl_mass_conservation … … 1013 1036 CALL vnest_boundary_conds 1014 1037 CALL cpu_log( log_point_s(30), 'vnest_bc', 'stop' ) 1015 1038 1016 1039 IF ( coupling_mode == 'vnested_fine' ) CALL pres 1017 1040 … … 1058 1081 ENDIF 1059 1082 ! 1060 !-- If required, compute virtual potential temperature 1061 IF ( humidity ) THEN 1062 CALL compute_vpt 1063 ENDIF 1083 !-- If required, compute virtual potential temperature 1084 IF ( humidity ) THEN 1085 CALL compute_vpt 1086 ENDIF 1064 1087 1065 1088 ! … … 1068 1091 1069 1092 ! 1070 !-- Determine surface fluxes shf and qsws and surface values 1071 !-- pt_surface and q_surface in dependence on data from external 1093 !-- Determine surface fluxes shf and qsws and surface values 1094 !-- pt_surface and q_surface in dependence on data from external 1072 1095 !-- file LSF_DATA respectively 1073 1096 IF ( ( large_scale_forcing .AND. lsf_surf ) .AND. & … … 1078 1101 1079 1102 ! 1080 !-- First the vertical (and horizontal) fluxes in the surface 1103 !-- First the vertical (and horizontal) fluxes in the surface 1081 1104 !-- (constant flux) layer are computed 1082 1105 IF ( constant_flux_layer ) THEN … … 1086 1109 ENDIF 1087 1110 ! 1088 !-- If required, solve the energy balance for the surface and run soil 1111 !-- If required, solve the energy balance for the surface and run soil 1089 1112 !-- model. Call for horizontal as well as vertical surfaces 1090 1113 IF ( land_surface .AND. time_since_reference_point >= skip_time_do_lsm) THEN … … 1114 1137 ! 1115 1138 !-- At the end, set boundary conditons for potential temperature 1116 !-- and humidity after running the land-surface model. This 1139 !-- and humidity after running the land-surface model. This 1117 1140 !-- might be important for the nesting, where arrays are transfered. 1118 1141 CALL lsm_boundary_condition … … 1122 1145 ENDIF 1123 1146 ! 1124 !-- If required, solve the energy balance for urban surfaces and run 1147 !-- If required, solve the energy balance for urban surfaces and run 1125 1148 !-- the material heat model 1126 1149 IF (urban_surface) THEN … … 1135 1158 ! 1136 1159 !-- At the end, set boundary conditons for potential temperature 1137 !-- and humidity after running the urban-surface model. This 1160 !-- and humidity after running the urban-surface model. This 1138 1161 !-- might be important for the nesting, where arrays are transfered. 1139 1162 CALL usm_boundary_condition … … 1200 1223 ! 1201 1224 !-- Adjust the current time to the time step of the radiation model. 1202 !-- Needed since radiation is pre-calculated and stored only on apparent 1225 !-- Needed since radiation is pre-calculated and stored only on apparent 1203 1226 !-- solar positions 1204 1227 time_since_reference_point_save = time_since_reference_point … … 1213 1236 CALL cpu_log( log_point_s(46), 'radiation_interaction', 'stop' ) 1214 1237 ENDIF 1215 1238 1216 1239 ! 1217 1240 !-- Return the current time to its original value … … 1223 1246 ENDIF 1224 1247 1225 1248 1226 1249 ! 1227 1250 !-- 20200203 (ECC) … … 1271 1294 !-- dt_indoor steers the frequency of the indoor model calculations. 1272 1295 !-- Note, at first timestep indoor model is called, in order to provide 1273 !-- a waste heat flux. 1296 !-- a waste heat flux. 1274 1297 IF ( indoor_model ) THEN 1275 1298 … … 1342 1365 time_virtual_measurement = time_virtual_measurement + dt_3d 1343 1366 ENDIF 1344 1367 1345 1368 ! 1346 1369 !-- Increment time-counter for wind turbine data output … … 1348 1371 time_wtm = time_wtm + dt_3d 1349 1372 ENDIF 1350 1373 1351 1374 ! 1352 1375 !-- In case of synthetic turbulence generation and parametrized turbulence 1353 !-- information, update the time counter and if required, adjust the 1376 !-- information, update the time counter and if required, adjust the 1354 1377 !-- STG to new atmospheric conditions. 1355 1378 IF ( use_syn_turb_gen ) THEN … … 1371 1394 1372 1395 ! 1373 !-- In case of model termination initiated by the local model 1374 !-- (terminate_coupled > 0), the coupler must be skipped because it would 1396 !-- In case of model termination initiated by the local model 1397 !-- (terminate_coupled > 0), the coupler must be skipped because it would 1375 1398 !-- cause an MPI intercomminucation hang. 1376 !-- If necessary, the coupler will be called at the beginning of the 1399 !-- If necessary, the coupler will be called at the beginning of the 1377 1400 !-- next restart run. 1378 1401 DO WHILE ( time_coupling >= dt_coupling .AND. terminate_coupled == 0 ) … … 1469 1492 .AND. ( dt_dosurf_av - time_dosurf_av ) <= averaging_interval_surf & 1470 1493 .AND. time_since_reference_point >= skip_time_dosurf_av ) THEN 1471 IF ( time_dosurf_av >= dt_averaging_input ) THEN 1494 IF ( time_dosurf_av >= dt_averaging_input ) THEN 1472 1495 CALL surface_data_output_averaging 1473 1496 average_count_surf = average_count_surf + 1 … … 1502 1525 MAX( dt_virtual_measurement, dt_3d ) ) 1503 1526 ENDIF 1504 1527 1505 1528 ! 1506 1529 !-- Output wind turbine data … … 1509 1532 time_wtm = MOD( time_wtm, MAX( dt_data_output_wtm, dt_3d ) ) 1510 1533 ENDIF 1511 1534 1512 1535 ! 1513 1536 !-- Profile output (ASCII) on file … … 1707 1730 #if defined( __parallel ) 1708 1731 ! 1709 !-- Vertical nesting: Deallocate variables initialized for vertical nesting 1732 !-- Vertical nesting: Deallocate variables initialized for vertical nesting 1710 1733 IF ( vnest_init ) CALL vnest_deallocate 1711 1734 #endif
Note: See TracChangeset
for help on using the changeset viewer.
