- Timestamp:
- Mar 26, 2012 2:18:34 PM (13 years ago)
- Location:
- palm/trunk/SOURCE
- Files:
-
- 6 edited
-
advec_ws.f90 (modified) (25 diffs)
-
check_parameters.f90 (modified) (5 diffs)
-
init_grid.f90 (modified) (7 diffs)
-
init_pt_anomaly.f90 (modified) (2 diffs)
-
modules.f90 (modified) (4 diffs)
-
palm.f90 (modified) (1 diff)
Legend:
- Unmodified
- Added
- Removed
-
palm/trunk/SOURCE/advec_ws.f90
r857 r861 4 4 ! Current revisions: 5 5 ! ------------------ 6 ! ws-scheme also work with topography in combination with vector version. 7 ! ws-scheme also work with outflow boundaries in combination with 8 ! vector version. 9 10 ! Degradation of the applied order of scheme is now steered by multiplying with 11 ! Integer wall_flags_0. 2nd order scheme, WS3 and WS5 are calculated on each 12 ! grid point and mulitplied with the appropriate flag. 13 ! 2nd order numerical dissipation term changed. Now the appropriate 2nd order 14 ! term derived according to the 4th and 6th order terms is applied. It turns 15 ! out that diss_2nd does not provide sufficient dissipation near walls. 16 ! Therefore, the function diss_2nd is removed. 17 18 ! Near walls a divergence correction is necessary to overcome numerical 19 ! instabilities due to too less divergence reduction of the velocity field. 20 ! 21 ! boundary_flags and logicals steering the degradation are removed. 22 ! Empty SUBROUTINE local_diss removed. 6 23 ! 7 24 ! Former revisions: 8 25 ! ----------------- 9 26 ! $Id$ 10 !11 ! 856 2012-03-20 18:29:17Z suehring12 ! Bug concerning numerical dissipation at the first grid level. Function13 ! diss_2nd always returns zero. Because diss_2nd will be replaced by numerical14 ! dissipation which is more consistent to the WS-schemes, the return value15 ! is set to zero for now.16 27 ! 17 28 ! 801 2012-01-10 17:30:36Z suehring … … 61 72 ! routine using for initialisation and steering of the statical evaluation. 62 73 ! The computation of turbulent fluxes takes place inside the advection 63 ! routines. 64 ! In case of vector architectures Dirichlet and Radiation boundary conditions 65 ! are outstanding and not available. 66 ! A further routine local_diss_ij is available (next weeks) and is used if a 67 ! control of dissipative fluxes is desired. 68 ! 69 ! OUTSTANDING: - Dirichlet and Radiation boundary conditions for 70 ! vector architectures 71 ! - dissipation control for cache architectures ( next weeks ) 72 ! - Topography ( next weeks ) 74 ! routines. 75 ! Near non-cyclic boundaries the order of the applied advection scheme is 76 ! degraded. 77 ! A divergence correction is applied. It is necessary for topography, since 78 ! the divergence is not sufficiently reduced, resulting in erroneous fluxes and 79 ! partly numerical instabilities. 73 80 !-----------------------------------------------------------------------------! 74 81 75 82 PRIVATE 76 83 PUBLIC advec_s_ws, advec_u_ws, advec_v_ws, advec_w_ws, & 77 local_diss,ws_init, ws_statistics84 ws_init, ws_statistics 78 85 79 86 INTERFACE ws_init … … 104 111 MODULE PROCEDURE advec_w_ws_ij 105 112 END INTERFACE advec_w_ws 106 107 INTERFACE local_diss108 MODULE PROCEDURE local_diss109 MODULE PROCEDURE local_diss_ij110 END INTERFACE local_diss111 113 112 114 CONTAINS … … 126 128 127 129 ! 128 !-- Allocate arrays needed for dissipation control.129 IF ( dissipation_control ) THEN130 ! ALLOCATE(var_x(nzb+1:nzt,nys:nyn,nxl:nxr), &131 ! var_y(nzb+1:nzt,nys:nyn,nxl:nxr), &132 ! var_z(nzb+1:nzt,nys:nyn,nxl:nxr), &133 ! gamma_x(nzb:nzt+1,nysg:nyng,nxlg:nxrg), &134 ! gamma_y(nzb:nzt+1,nysg:nyng,nxlg:nxrg), &135 ! gamma_z(nzb:nzt+1,nysg:nyng,nxlg:nxrg))136 ENDIF137 138 !139 130 !-- Set the appropriate factors for scalar and momentum advection. 140 131 adv_sca_5 = 1./60. 141 132 adv_sca_3 = 1./12. 133 adv_sca_1 = 1./2. 142 134 adv_mom_5 = 1./120. 143 135 adv_mom_3 = 1./24. 144 136 adv_mom_1 = 1./4. 145 137 ! 146 138 !-- Arrays needed for statical evaluation of fluxes. … … 231 223 ENDIF 232 224 233 !234 !-- Determine the flags where the order of the scheme for horizontal235 !-- advection has to be degraded.236 ALLOCATE( boundary_flags(nys:nyn,nxl:nxr) )237 DO i = nxl, nxr238 DO j = nys, nyn239 240 boundary_flags(j,i) = 0241 IF ( outflow_l ) THEN242 IF ( i == nxlu ) boundary_flags(j,i) = 5243 IF ( i == nxl ) boundary_flags(j,i) = 6244 ELSEIF ( outflow_r ) THEN245 IF ( i == nxr-1 ) boundary_flags(j,i) = 1246 IF ( i == nxr ) boundary_flags(j,i) = 2247 ELSEIF ( outflow_n ) THEN248 IF ( j == nyn-1 ) boundary_flags(j,i) = 3249 IF ( j == nyn ) boundary_flags(j,i) = 4250 ELSEIF ( outflow_s ) THEN251 IF ( j == nysv ) boundary_flags(j,i) = 7252 IF ( j == nys ) boundary_flags(j,i) = 8253 ENDIF254 255 ENDDO256 ENDDO257 258 225 END SUBROUTINE ws_init 259 226 … … 271 238 ! 272 239 !-- The arrays needed for statistical evaluation are set to to 0 at the 273 !-- begin of prognostic_equations.240 !-- beginning of prognostic_equations. 274 241 IF ( ws_scheme_mom ) THEN 275 242 sums_wsus_ws_l = 0.0 … … 307 274 IMPLICIT NONE 308 275 309 INTEGER :: i, i_omp, j, k, tn 310 LOGICAL :: degraded_l, degraded_s 311 REAL :: flux_d, diss_d, u_comp, v_comp 276 INTEGER :: i, i_omp, j, k, tn, k_ppp, k_pp, k_mm 277 REAL :: flux_d, diss_d, u_comp, v_comp, div 312 278 REAL, DIMENSION(:,:,:), POINTER :: sk 313 279 REAL, DIMENSION(nzb:nzt+1) :: flux_t, diss_t, flux_r, diss_r, & … … 320 286 CHARACTER (LEN = *), INTENT(IN) :: sk_char 321 287 322 323 degraded_l = .FALSE. 324 degraded_s = .FALSE. 325 326 IF ( boundary_flags(j,i) /= 0 ) THEN 327 ! 328 !-- Degrade the order for Dirichlet bc. at the outflow boundary 329 SELECT CASE ( boundary_flags(j,i) ) 330 331 CASE ( 1 ) 332 333 DO k = nzb_s_inner(j,i)+1, nzt 334 u_comp = u(k,j,i+1) - u_gtrans 335 flux_r(k) = u_comp * ( & 336 7.0 * ( sk(k,j,i+1) + sk(k,j,i) ) & 337 - ( sk(k,j,i+2) + sk(k,j,i-1) ) ) * adv_sca_3 338 diss_r(k) = -ABS( u_comp ) * ( & 339 3.0 * ( sk(k,j,i+1) - sk(k,j,i) ) & 340 - ( sk(k,j,i+2) - sk(k,j,i-1) ) ) * adv_sca_3 341 ENDDO 342 343 CASE ( 2 ) 344 345 DO k = nzb_s_inner(j,i)+1, nzt 346 u_comp = u(k,j,i+1) - u_gtrans 347 flux_r(k) = u_comp * ( sk(k,j,i+1) + sk(k,j,i) ) * 0.5 348 diss_r(k) = diss_2nd( sk(k,j,i+1), sk(k,j,i+1), sk(k,j,i), & 349 sk(k,j,i-1), sk(k,j,i-2), u_comp, & 350 0.5, ddx ) 351 ENDDO 352 353 CASE ( 3 ) 354 355 DO k = nzb_s_inner(j,i)+1, nzt 356 v_comp = v(k,j+1,i) - v_gtrans 357 flux_n(k) = v_comp * ( & 358 7.0 * ( sk(k,j+1,i) + sk(k,j,i) ) & 359 - ( sk(k,j+2,i) + sk(k,j-1,i) ) ) * adv_sca_3 360 diss_n(k) = -ABS( v_comp ) * ( & 361 3.0 * ( sk(k,j+1,i) - sk(k,j,i) ) & 362 - ( sk(k,j+2,i) - sk(k,j-1,i) ) ) * adv_sca_3 363 ENDDO 364 365 CASE ( 4 ) 366 367 DO k = nzb_s_inner(j,i)+1, nzt 368 v_comp = v(k,j+1,i) - v_gtrans 369 flux_n(k) = v_comp* ( sk(k,j+1,i) + sk(k,j,i) ) * 0.5 370 diss_n(k) = diss_2nd( sk(k,j+1,i), sk(k,j+1,i), sk(k,j,i), & 371 sk(k,j-1,i), sk(k,j-2,i), v_comp, & 372 0.5, ddy ) 373 ENDDO 374 375 CASE ( 5 ) 376 377 DO k = nzb_w_inner(j,i)+1, nzt 378 u_comp = u(k,j,i+1) - u_gtrans 379 flux_r(k) = u_comp * ( & 380 7.0 * ( sk(k,j,i+1) + sk(k,j,i) ) & 381 - ( sk(k,j,i+2) + sk(k,j,i-1) ) ) * adv_sca_3 382 diss_r(k) = -ABS( u_comp ) * ( & 383 3.0 * ( sk(k,j,i+1) - sk(k,j,i) ) & 384 - ( sk(k,j,i+2) - sk(k,j,i-1) ) ) * adv_sca_3 385 ENDDO 386 387 CASE ( 6 ) 388 389 DO k = nzb_s_inner(j,i)+1, nzt 390 u_comp = u(k,j,i+1) - u_gtrans 391 flux_r(k) = u_comp * ( & 392 7.0 * ( sk(k,j,i+1) + sk(k,j,i) ) & 393 - ( sk(k,j,i+2) + sk(k,j,i-1) ) ) * adv_sca_3 394 diss_r(k) = -ABS( u_comp ) * ( & 395 3.0 * ( sk(k,j,i+1) - sk(k,j,i) ) & 396 - ( sk(k,j,i+2) - sk(k,j,i-1) ) ) * adv_sca_3 397 ! 398 !-- Compute leftside fluxes for the left boundary of PE domain 399 u_comp = u(k,j,i) - u_gtrans 400 swap_flux_x_local(k,j,tn) = u_comp * ( & 401 sk(k,j,i) + sk(k,j,i-1) ) * 0.5 402 swap_diss_x_local(k,j,tn) = diss_2nd( sk(k,j,i+2),sk(k,j,i+1), & 403 sk(k,j,i), sk(k,j,i-1), & 404 sk(k,j,i-1), u_comp, & 405 0.5, ddx ) 406 ENDDO 407 degraded_l = .TRUE. 408 409 CASE ( 7 ) 410 411 DO k = nzb_s_inner(j,i)+1, nzt 412 v_comp = v(k,j+1,i)-v_gtrans 413 flux_n(k) = v_comp * ( & 414 7.0 * ( sk(k,j+1,i) + sk(k,j,i) ) & 415 - ( sk(k,j+2,i) + sk(k,j-1,i) ) ) * adv_sca_3 416 diss_n(k) = -ABS( v_comp ) * ( & 417 3.0 * ( sk(k,j+1,i) - sk(k,j,i) ) & 418 - ( sk(k,j+2,i) - sk(k,j-1,i) ) ) * adv_sca_3 419 ENDDO 420 421 CASE ( 8 ) 422 423 DO k = nzb_s_inner(j,i)+1, nzt 424 v_comp = v(k,j+1,i) - v_gtrans 425 flux_n(k) = v_comp * ( & 426 7.0 * ( sk(k,j+1,i) + sk(k,j,i) ) & 427 - ( sk(k,j+2,i) + sk(k,j-1,i) ) ) * adv_sca_3 428 diss_n(k) = -ABS( v_comp ) * ( & 429 3.0 * ( sk(k,j+1,i) - sk(k,j,i) ) & 430 - ( sk(k,j+2,i) - sk(k,j-1,i) ) ) * adv_sca_3 431 ! 432 !-- Compute southside fluxes for the south boundary of PE domain 433 v_comp = v(k,j,i) - v_gtrans 434 swap_flux_y_local(k,tn) = v_comp * & 435 ( sk(k,j,i) + sk(k,j-1,i) ) * 0.5 436 swap_diss_y_local(k,tn) = diss_2nd( sk(k,j+2,i), sk(k,j+1,i), & 437 sk(k,j,i), sk(k,j-1,i), & 438 sk(k,j-1,i), v_comp, & 439 0.5, ddy ) 440 ENDDO 441 degraded_s = .TRUE. 442 443 CASE DEFAULT 444 445 END SELECT 446 447 ! 448 !-- Compute the crosswise 5th order fluxes at the outflow 449 IF ( boundary_flags(j,i) == 1 .OR. boundary_flags(j,i) == 2 .OR. & 450 boundary_flags(j,i) == 5 .OR. boundary_flags(j,i) == 6 ) THEN 451 452 DO k = nzb_s_inner(j,i)+1, nzt 453 v_comp = v(k,j+1,i) - v_gtrans 454 flux_n(k) = v_comp * ( & 455 37.0 * ( sk(k,j+1,i) + sk(k,j,i) ) & 456 - 8.0 * ( sk(k,j+2,i) + sk(k,j-1,i) ) & 457 + ( sk(k,j+3,i) + sk(k,j-2,i) ) ) * adv_sca_5 458 diss_n(k) = -ABS( v_comp ) * ( & 459 10.0 * ( sk(k,j+1,i) - sk(k,j,i) ) & 460 - 5.0 * ( sk(k,j+2,i) - sk(k,j-1,i) ) & 461 + ( sk(k,j+3,i) - sk(k,j-2,i) ) ) * adv_sca_5 462 ENDDO 463 464 ELSE 465 466 DO k = nzb_s_inner(j,i)+1, nzt 467 u_comp = u(k,j,i+1) - u_gtrans 468 flux_r(k) = u_comp * ( & 469 37.0 * ( sk(k,j,i+1) + sk(k,j,i) ) & 470 - 8.0 * ( sk(k,j,i+2) + sk(k,j,i-1) ) & 471 + ( sk(k,j,i+3) + sk(k,j,i-2) ) ) * adv_sca_5 472 diss_r(k) = -ABS( u_comp ) * ( & 473 10.0 * ( sk(k,j,i+1) - sk(k,j,i) ) & 474 - 5.0 * ( sk(k,j,i+2) - sk(k,j,i-1) ) & 475 + ( sk(k,j,i+3) - sk(k,j,i-2) ) ) * adv_sca_5 476 ENDDO 477 478 ENDIF 479 480 ELSE 481 482 ! 483 !-- Compute the fifth order fluxes for the interior of PE domain. 484 DO k = nzb_u_inner(j,i)+1, nzt 485 u_comp = u(k,j,i+1) - u_gtrans 486 flux_r(k) = u_comp * ( & 487 37.0 * ( sk(k,j,i+1) + sk(k,j,i) ) & 488 - 8.0 * ( sk(k,j,i+2) + sk(k,j,i-1) ) & 489 + ( sk(k,j,i+3) + sk(k,j,i-2) ) ) * adv_sca_5 490 diss_r(k) = -ABS( u_comp ) * ( & 491 10.0 * ( sk(k,j,i+1) - sk(k,j,i) ) & 492 - 5.0 * ( sk(k,j,i+2) - sk(k,j,i-1) ) & 493 + ( sk(k,j,i+3) - sk(k,j,i-2) ) ) * adv_sca_5 494 495 v_comp = v(k,j+1,i) - v_gtrans 496 flux_n(k) = v_comp * ( & 497 37.0 * ( sk(k,j+1,i) + sk(k,j,i) ) & 498 - 8.0 * ( sk(k,j+2,i) + sk(k,j-1,i) ) & 499 + ( sk(k,j+3,i) + sk(k,j-2,i) ) ) * adv_sca_5 500 diss_n(k) = -ABS( v_comp ) * ( & 501 10.0 * ( sk(k,j+1,i) - sk(k,j,i) ) & 502 - 5.0 * ( sk(k,j+2,i) - sk(k,j-1,i) ) & 503 + ( sk(k,j+3,i) - sk(k,j-2,i) ) ) * adv_sca_5 504 ENDDO 505 288 ! 289 !-- Compute southside fluxes of the respective PE bounds. 290 IF ( j == nys ) THEN 291 ! 292 !-- Up to the top of the highest topography. 293 DO k = nzb+1, nzb_max 294 295 v_comp = v(k,j,i) - v_gtrans 296 swap_flux_y_local(k,tn) = v_comp * ( & 297 ( 37.0 * IBITS(wall_flags_0(k,j,i),5,1) * adv_sca_5 & 298 + 7.0 * IBITS(wall_flags_0(k,j,i),4,1) * adv_sca_3 & 299 + IBITS(wall_flags_0(k,j,i),3,1) * adv_sca_1 & 300 ) * & 301 ( sk(k,j,i) + sk(k,j-1,i) ) & 302 - ( 8.0 * IBITS(wall_flags_0(k,j,i),5,1) * adv_sca_5 & 303 + IBITS(wall_flags_0(k,j,i),4,1) * adv_sca_3 & 304 ) * & 305 ( sk(k,j+1,i) + sk(k,j-2,i) ) & 306 + ( IBITS(wall_flags_0(k,j,i),5,1) * adv_sca_5 & 307 ) * & 308 ( sk(k,j+2,i) + sk(k,j-3,i) ) & 309 ) 310 311 swap_diss_y_local(k,tn) = -ABS( v_comp ) * ( & 312 ( 10.0 * IBITS(wall_flags_0(k,j,i),5,1) * adv_sca_5 & 313 + 3.0 * IBITS(wall_flags_0(k,j,i),4,1) * adv_sca_3 & 314 + IBITS(wall_flags_0(k,j,i),3,1) * adv_sca_1 & 315 ) * & 316 ( sk(k,j,i) - sk(k,j-1,i) ) & 317 - ( 5.0 * IBITS(wall_flags_0(k,j,i),5,1) * adv_sca_5 & 318 + IBITS(wall_flags_0(k,j,i),4,1) * adv_sca_3 & 319 ) * & 320 ( sk(k,j+1,i) - sk(k,j-2,i) ) & 321 + ( IBITS(wall_flags_0(k,j,i),5,1) * adv_sca_5 & 322 ) * & 323 ( sk(k,j+2,i) - sk(k,j-3,i) ) & 324 ) 325 326 ENDDO 327 ! 328 !-- Above to the top of the highest topography. No degradation necessary. 329 DO k = nzb_max+1, nzt 330 331 v_comp = v(k,j,i) - v_gtrans 332 swap_flux_y_local(k,tn) = v_comp * ( & 333 37.0 * ( sk(k,j,i) + sk(k,j-1,i) ) & 334 - 8.0 * ( sk(k,j+1,i) + sk(k,j-2,i) ) & 335 + ( sk(k,j+2,i) + sk(k,j-3,i) ) & 336 ) * adv_sca_5 337 swap_diss_y_local(k,tn) = -ABS( v_comp ) * ( & 338 10.0 * ( sk(k,j,i) - sk(k,j-1,i) ) & 339 - 5.0 * ( sk(k,j+1,i) - sk(k,j-2,i) ) & 340 + sk(k,j+2,i) - sk(k,j-3,i) & 341 ) * adv_sca_5 342 343 ENDDO 344 506 345 ENDIF 507 ! 508 !-- Compute left- and southside fluxes of the respective PE bounds. 509 IF ( j == nys .AND. .NOT. degraded_s ) THEN 510 511 DO k = nzb_s_inner(j,i)+1, nzt 512 v_comp = v(k,j,i) - v_gtrans 513 swap_flux_y_local(k,tn) = v_comp * ( & 514 37.0 * ( sk(k,j,i) + sk(k,j-1,i) ) & 515 - 8.0 * ( sk(k,j+1,i) + sk(k,j-2,i) ) & 516 + ( sk(k,j+2,i) + sk(k,j-3,i) ) & 517 ) * adv_sca_5 518 swap_diss_y_local(k,tn) = -ABS( v_comp ) * ( & 519 10.0 * ( sk(k,j,i) - sk(k,j-1,i) ) & 520 - 5.0 * ( sk(k,j+1,i) - sk(k,j-2,i) ) & 521 + sk(k,j+2,i) - sk(k,j-3,i) & 522 ) * adv_sca_5 523 ENDDO 524 525 ENDIF 346 ! 347 !-- Compute leftside fluxes of the respective PE bounds. 348 IF ( i == i_omp ) THEN 526 349 527 IF ( i == i_omp .AND. .NOT. degraded_l ) THEN 528 529 DO k = nzb_s_inner(j,i)+1, nzt 530 u_comp = u(k,j,i) - u_gtrans 531 swap_flux_x_local(k,j,tn) = u_comp * ( & 532 37.0 * ( sk(k,j,i) + sk(k,j,i-1) ) & 533 - 8.0 * ( sk(k,j,i+1) + sk(k,j,i-2) ) & 534 + ( sk(k,j,i+2) + sk(k,j,i-3) ) & 535 ) * adv_sca_5 536 swap_diss_x_local(k,j,tn) = -ABS( u_comp ) * ( & 537 10.0 * ( sk(k,j,i) - sk(k,j,i-1) ) & 538 - 5.0 * ( sk(k,j,i+1) - sk(k,j,i-2) ) & 539 + ( sk(k,j,i+2) - sk(k,j,i-3) ) & 540 ) * adv_sca_5 541 ENDDO 350 DO k = nzb+1, nzb_max 351 352 u_comp = u(k,j,i) - u_gtrans 353 swap_flux_x_local(k,j,tn) = u_comp * ( & 354 ( 37.0 * IBITS(wall_flags_0(k,j,i),2,1) * adv_sca_5 & 355 + 7.0 * IBITS(wall_flags_0(k,j,i),1,1) * adv_sca_3 & 356 + IBITS(wall_flags_0(k,j,i),0,1) * adv_sca_1 & 357 ) * & 358 ( sk(k,j,i) + sk(k,j,i-1) ) & 359 - ( 8.0 * IBITS(wall_flags_0(k,j,i),2,1) * adv_sca_5 & 360 + IBITS(wall_flags_0(k,j,i),1,1) * adv_sca_3 & 361 ) * & 362 ( sk(k,j,i+1) + sk(k,j,i-2) ) & 363 + ( IBITS(wall_flags_0(k,j,i),2,1) * adv_sca_5 & 364 ) * ( sk(k,j,i+2) + sk(k,j,i-3) ) & 365 ) 366 367 swap_diss_x_local(k,j,tn) = -ABS( u_comp ) * ( & 368 ( 10.0 * IBITS(wall_flags_0(k,j,i),2,1) * adv_sca_5 & 369 + 3.0 * IBITS(wall_flags_0(k,j,i),1,1) * adv_sca_3 & 370 + IBITS(wall_flags_0(k,j,i),0,1) * adv_sca_1 & 371 ) * & 372 ( sk(k,j,i) - sk(k,j,i-1) ) & 373 - ( 5.0 * IBITS(wall_flags_0(k,j,i),2,1) * adv_sca_5 & 374 + IBITS(wall_flags_0(k,j,i),1,1) * adv_sca_3 & 375 ) * & 376 ( sk(k,j,i+1) - sk(k,j,i-2) ) & 377 + ( IBITS(wall_flags_0(k,j,i),2,1) * adv_sca_5 & 378 ) * & 379 ( sk(k,j,i+2) - sk(k,j,i-3) ) & 380 ) 381 382 ENDDO 383 384 DO k = nzb_max+1, nzt 385 386 u_comp = u(k,j,i) - u_gtrans 387 swap_flux_x_local(k,j,tn) = u_comp * ( & 388 37.0 * ( sk(k,j,i) + sk(k,j,i-1) ) & 389 - 8.0 * ( sk(k,j,i+1) + sk(k,j,i-2) ) & 390 + ( sk(k,j,i+2) + sk(k,j,i-3) ) & 391 ) * adv_sca_5 392 393 swap_diss_x_local(k,j,tn) = -ABS( u_comp ) * ( & 394 10.0 * ( sk(k,j,i) - sk(k,j,i-1) ) & 395 - 5.0 * ( sk(k,j,i+1) - sk(k,j,i-2) ) & 396 + ( sk(k,j,i+2) - sk(k,j,i-3) ) & 397 ) * adv_sca_5 398 399 ENDDO 542 400 543 ENDIF 544 401 ENDIF 402 403 flux_t(0) = 0.0 404 diss_t(0) = 0.0 405 flux_d = 0.0 406 diss_d = 0.0 545 407 ! 546 !-- Now compute the tendency terms for the horizontal parts 547 DO k = nzb_s_inner(j,i)+1, nzt 548 549 tend(k,j,i) = tend(k,j,i) - ( & 550 ( flux_r(k) + diss_r(k) - swap_flux_x_local(k,j,tn) - & 551 swap_diss_x_local(k,j,tn) ) * ddx & 552 + ( flux_n(k) + diss_n(k) - swap_flux_y_local(k,tn) - & 553 swap_diss_y_local(k,tn) ) * ddy & 554 ) 408 !-- Now compute the fluxes and tendency terms for the horizontal and 409 !-- vertical parts up to the top of the highest topography. 410 DO k = nzb+1, nzb_max 411 ! 412 !-- Note: It is faster to conduct all multiplications explicitly, e.g. 413 !-- * adv_sca_5 ... than to determine a factor and multiplicate the 414 !-- flux at the end. Indeed, per loop the first requires 6 415 !-- multiplications more, but the the second requires 9 more internal 416 !-- calls of IBITS(). 417 u_comp = u(k,j,i+1) - u_gtrans 418 flux_r(k) = u_comp * ( & 419 ( 37.0 * IBITS(wall_flags_0(k,j,i),2,1) * adv_sca_5 & 420 + 7.0 * IBITS(wall_flags_0(k,j,i),1,1) * adv_sca_3 & 421 + IBITS(wall_flags_0(k,j,i),0,1) * adv_sca_1 & 422 ) * & 423 ( sk(k,j,i+1) + sk(k,j,i) ) & 424 - ( 8.0 * IBITS(wall_flags_0(k,j,i),2,1) * adv_sca_5 & 425 + IBITS(wall_flags_0(k,j,i),1,1) * adv_sca_3 & 426 ) * & 427 ( sk(k,j,i+2) + sk(k,j,i-1) ) & 428 + ( IBITS(wall_flags_0(k,j,i),2,1) * adv_sca_5 & 429 ) * ( sk(k,j,i+3) + sk(k,j,i-2) ) & 430 ) 431 432 diss_r(k) = -ABS( u_comp ) * ( & 433 ( 10.0 * IBITS(wall_flags_0(k,j,i),2,1) * adv_sca_5 & 434 + 3.0 * IBITS(wall_flags_0(k,j,i),1,1) * adv_sca_3 & 435 + IBITS(wall_flags_0(k,j,i),0,1) * adv_sca_1 & 436 ) * & 437 ( sk(k,j,i+1) - sk(k,j,i) ) & 438 - ( 5.0 * IBITS(wall_flags_0(k,j,i),2,1) * adv_sca_5 & 439 + IBITS(wall_flags_0(k,j,i),1,1) * adv_sca_3 & 440 ) * & 441 ( sk(k,j,i+2) - sk(k,j,i-1) ) & 442 + ( IBITS(wall_flags_0(k,j,i),2,1) * adv_sca_5 & 443 ) * & 444 ( sk(k,j,i+3) - sk(k,j,i-2) ) & 445 ) 446 447 v_comp = v(k,j+1,i) - v_gtrans 448 flux_n(k) = v_comp * ( & 449 ( 37.0 * IBITS(wall_flags_0(k,j,i),5,1) * adv_sca_5 & 450 + 7.0 * IBITS(wall_flags_0(k,j,i),4,1) * adv_sca_3 & 451 + IBITS(wall_flags_0(k,j,i),3,1) * adv_sca_1 & 452 ) * & 453 ( sk(k,j+1,i) + sk(k,j,i) ) & 454 - ( 8.0 * IBITS(wall_flags_0(k,j,i),5,1) * adv_sca_5 & 455 + IBITS(wall_flags_0(k,j,i),4,1) * adv_sca_3 & 456 ) * & 457 ( sk(k,j+2,i) + sk(k,j-1,i) ) & 458 + ( IBITS(wall_flags_0(k,j,i),5,1) * adv_sca_5 & 459 ) * & 460 ( sk(k,j+3,i) + sk(k,j-2,i) ) & 461 ) 462 463 diss_n(k) = -ABS( v_comp ) * ( & 464 ( 10.0 * IBITS(wall_flags_0(k,j,i),5,1) * adv_sca_5 & 465 + 3.0 * IBITS(wall_flags_0(k,j,i),4,1) * adv_sca_3 & 466 + IBITS(wall_flags_0(k,j,i),3,1) * adv_sca_1 & 467 ) * & 468 ( sk(k,j+1,i) - sk(k,j,i) ) & 469 - ( 5.0 * IBITS(wall_flags_0(k,j,i),5,1) * adv_sca_5 & 470 + IBITS(wall_flags_0(k,j,i),4,1) * adv_sca_3 & 471 ) * & 472 ( sk(k,j+2,i) - sk(k,j-1,i) ) & 473 + ( IBITS(wall_flags_0(k,j,i),5,1) * adv_sca_5 & 474 ) * & 475 ( sk(k,j+3,i) - sk(k,j-2,i) ) & 476 ) 477 ! 478 !-- k index has to be modified near bottom and top, else array 479 !-- subscripts will be exceeded. 480 k_ppp = k + 3 * IBITS(wall_flags_0(k,j,i),8,1) 481 k_pp = k + 2 * ( 1 - IBITS(wall_flags_0(k,j,i),6,1) ) 482 k_mm = k - 2 * IBITS(wall_flags_0(k,j,i),8,1) 483 484 485 flux_t(k) = w(k,j,i) * ( & 486 ( 37.0 * IBITS(wall_flags_0(k,j,i),8,1) * adv_sca_5 & 487 + 7.0 * IBITS(wall_flags_0(k,j,i),7,1) * adv_sca_3 & 488 + IBITS(wall_flags_0(k,j,i),6,1) * adv_sca_1 & 489 ) * & 490 ( sk(k+1,j,i) + sk(k,j,i) ) & 491 - ( 8.0 * IBITS(wall_flags_0(k,j,i),8,1) * adv_sca_5 & 492 + IBITS(wall_flags_0(k,j,i),7,1) * adv_sca_3 & 493 ) * & 494 ( sk(k_pp,j,i) + sk(k-1,j,i) ) & 495 + ( IBITS(wall_flags_0(k,j,i),8,1) * adv_sca_5 & 496 ) * ( sk(k_ppp,j,i)+ sk(k_mm,j,i) ) & 497 ) 498 499 diss_t(k) = -ABS( w(k,j,i) ) * ( & 500 ( 10.0 * IBITS(wall_flags_0(k,j,i),8,1) * adv_sca_5 & 501 + 3.0 * IBITS(wall_flags_0(k,j,i),7,1) * adv_sca_3 & 502 + IBITS(wall_flags_0(k,j,i),6,1) * adv_sca_1 & 503 ) * & 504 ( sk(k+1,j,i) - sk(k,j,i) ) & 505 - ( 5.0 * IBITS(wall_flags_0(k,j,i),8,1) * adv_sca_5 & 506 + IBITS(wall_flags_0(k,j,i),7,1) * adv_sca_3 & 507 ) * & 508 ( sk(k_pp,j,i) - sk(k-1,j,i) ) & 509 + ( IBITS(wall_flags_0(k,j,i),8,1) * adv_sca_5 & 510 ) * & 511 ( sk(k_ppp,j,i) - sk(k_mm,j,i) ) & 512 ) 513 ! 514 !-- Calculate the divergence of the velocity field. A respective 515 !-- correction is needed to overcome numerical instabilities caused 516 !-- by a not sufficient reduction of divergences near topography. 517 div = ( u(k,j,i+1) - u(k,j,i) ) * ddx & 518 + ( v(k,j+1,i) - v(k,j,i) ) * ddy & 519 + ( w(k,j,i) - w(k-1,j,i) ) * ddzw(k) 520 521 tend(k,j,i) = tend(k,j,i) - ( & 522 ( flux_r(k) + diss_r(k) - swap_flux_x_local(k,j,tn) - & 523 swap_diss_x_local(k,j,tn) ) * ddx & 524 + ( flux_n(k) + diss_n(k) - swap_flux_y_local(k,tn) - & 525 swap_diss_y_local(k,tn) ) * ddy & 526 + ( flux_t(k) + diss_t(k) - flux_d - diss_d & 527 ) * ddzw(k) & 528 ) + sk(k,j,i) * div 555 529 556 530 swap_flux_y_local(k,tn) = flux_n(k) … … 558 532 swap_flux_x_local(k,j,tn) = flux_r(k) 559 533 swap_diss_x_local(k,j,tn) = diss_r(k) 560 534 flux_d = flux_t(k) 535 diss_d = diss_t(k) 536 561 537 ENDDO 562 563 ! 564 !-- Vertical advection, degradation of order near bottom and top. 565 !-- The fluxes flux_d and diss_d at the surface are 0. Due to later 566 !-- calculation of statistics the top flux at the surface should be 0. 567 flux_t(nzb_s_inner(j,i)) = 0.0 568 diss_t(nzb_s_inner(j,i)) = 0.0 569 570 ! 571 !-- 2nd-order scheme (bottom) 572 k = nzb_s_inner(j,i)+1 573 flux_d = flux_t(k-1) 574 diss_d = diss_t(k-1) 575 flux_t(k) = w(k,j,i) * ( sk(k+1,j,i) + sk(k,j,i) ) * 0.5 576 577 ! 578 !-- sk(k,j,i) is referenced three times to avoid an access below surface 579 diss_t(k) = diss_2nd( sk(k+2,j,i), sk(k+1,j,i), sk(k,j,i), sk(k,j,i), & 580 sk(k,j,i), w(k,j,i), 0.5, ddzw(k) ) 581 582 tend(k,j,i) = tend(k,j,i) - ( flux_t(k) + diss_t(k) - flux_d - diss_d ) & 583 * ddzw(k) 584 ! 585 !-- WS3 as an intermediate step (bottom) 586 k = nzb_s_inner(j,i) + 2 587 flux_d = flux_t(k-1) 588 diss_d = diss_t(k-1) 589 flux_t(k) = w(k,j,i) * ( & 590 7.0 * ( sk(k+1,j,i) + sk(k,j,i) ) & 591 - ( sk(k+2,j,i) + sk(k-1,j,i) ) & 592 ) * adv_sca_3 593 diss_t(k) = -ABS( w(k,j,i) ) * ( & 594 3.0 * ( sk(k+1,j,i) - sk(k,j,i) ) & 595 - ( sk(k+2,j,i) - sk(k-1,j,i) ) & 596 ) * adv_sca_3 597 598 tend(k,j,i) = tend(k,j,i) - ( flux_t(k) + diss_t(k) - flux_d - diss_d ) & 599 * ddzw(k) 600 ! 601 !-- WS5 602 DO k = nzb_s_inner(j,i)+3, nzt-2 603 604 flux_d = flux_t(k-1) 605 diss_d = diss_t(k-1) 606 flux_t(k) = w(k,j,i) * ( & 607 37.0 * ( sk(k+1,j,i) + sk(k,j,i) ) & 608 - 8.0 * ( sk(k+2,j,i) + sk(k-1,j,i) ) & 609 + ( sk(k+3,j,i) + sk(k-2,j,i) ) & 610 ) * adv_sca_5 611 diss_t(k) = -ABS( w(k,j,i) ) * ( & 612 10.0 * ( sk(k+1,j,i) - sk(k,j,i) )& 613 - 5.0 * ( sk(k+2,j,i) - sk(k-1,j,i) )& 614 + ( sk(k+3,j,i) - sk(k-2,j,i) )& 615 ) * adv_sca_5 616 617 tend(k,j,i) = tend(k,j,i) - ( flux_t(k) + diss_t(k) & 618 - ( flux_d + diss_d ) ) * ddzw(k) 538 ! 539 !-- Now compute the fluxes and tendency terms for the horizontal and 540 !-- vertical parts above the top of the highest topography. No degradation 541 !-- for the horizontal parts, but for the vertical it is stell needed. 542 DO k = nzb_max+1, nzt 543 544 u_comp = u(k,j,i+1) - u_gtrans 545 flux_r(k) = u_comp * ( & 546 37.0 * ( sk(k,j,i+1) + sk(k,j,i) ) & 547 - 8.0 * ( sk(k,j,i+2) + sk(k,j,i-1) ) & 548 + ( sk(k,j,i+3) + sk(k,j,i-2) ) ) * adv_sca_5 549 diss_r(k) = -ABS( u_comp ) * ( & 550 10.0 * ( sk(k,j,i+1) - sk(k,j,i) ) & 551 - 5.0 * ( sk(k,j,i+2) - sk(k,j,i-1) ) & 552 + ( sk(k,j,i+3) - sk(k,j,i-2) ) ) * adv_sca_5 553 554 v_comp = v(k,j+1,i) - v_gtrans 555 flux_n(k) = v_comp * ( & 556 37.0 * ( sk(k,j+1,i) + sk(k,j,i) ) & 557 - 8.0 * ( sk(k,j+2,i) + sk(k,j-1,i) ) & 558 + ( sk(k,j+3,i) + sk(k,j-2,i) ) ) * adv_sca_5 559 diss_n(k) = -ABS( v_comp ) * ( & 560 10.0 * ( sk(k,j+1,i) - sk(k,j,i) ) & 561 - 5.0 * ( sk(k,j+2,i) - sk(k,j-1,i) ) & 562 + ( sk(k,j+3,i) - sk(k,j-2,i) ) ) * adv_sca_5 563 ! 564 !-- k index has to be modified near bottom and top, else array 565 !-- subscripts will be exceeded. 566 k_ppp = k + 3 * IBITS(wall_flags_0(k,j,i),8,1) 567 k_pp = k + 2 * ( 1 - IBITS(wall_flags_0(k,j,i),6,1) ) 568 k_mm = k - 2 * IBITS(wall_flags_0(k,j,i),8,1) 569 570 flux_t(k) = w(k,j,i) * ( & 571 ( 37.0 * IBITS(wall_flags_0(k,j,i),8,1) * adv_sca_5 & 572 + 7.0 * IBITS(wall_flags_0(k,j,i),7,1) * adv_sca_3 & 573 + IBITS(wall_flags_0(k,j,i),6,1) * adv_sca_1 & 574 ) * & 575 ( sk(k+1,j,i) + sk(k,j,i) ) & 576 - ( 8.0 * IBITS(wall_flags_0(k,j,i),8,1) * adv_sca_5 & 577 + IBITS(wall_flags_0(k,j,i),7,1) * adv_sca_3 & 578 ) * & 579 ( sk(k_pp,j,i) + sk(k-1,j,i) ) & 580 + ( IBITS(wall_flags_0(k,j,i),8,1) * adv_sca_5 & 581 ) * ( sk(k_ppp,j,i)+ sk(k_mm,j,i) ) & 582 ) 583 584 diss_t(k) = -ABS( w(k,j,i) ) * ( & 585 ( 10.0 * IBITS(wall_flags_0(k,j,i),8,1) * adv_sca_5 & 586 + 3.0 * IBITS(wall_flags_0(k,j,i),7,1) * adv_sca_3 & 587 + IBITS(wall_flags_0(k,j,i),6,1) * adv_sca_1 & 588 ) * & 589 ( sk(k+1,j,i) - sk(k,j,i) ) & 590 - ( 5.0 * IBITS(wall_flags_0(k,j,i),8,1) * adv_sca_5 & 591 + IBITS(wall_flags_0(k,j,i),7,1) * adv_sca_3 & 592 ) * & 593 ( sk(k_pp,j,i) - sk(k-1,j,i) ) & 594 + ( IBITS(wall_flags_0(k,j,i),8,1) * adv_sca_5 & 595 ) * & 596 ( sk(k_ppp,j,i) - sk(k_mm,j,i) ) & 597 ) 598 ! 599 !-- Calculate the divergence of the velocity field. A respective 600 !-- correction is needed to overcome numerical instabilities introduced 601 !-- by a not sufficient reduction of divergences near topography. 602 div = ( u(k,j,i+1) - u(k,j,i) ) * ddx & 603 + ( v(k,j+1,i) - v(k,j,i) ) * ddy & 604 + ( w(k,j,i) - w(k-1,j,i) ) * ddzw(k) 605 606 tend(k,j,i) = tend(k,j,i) - ( & 607 ( flux_r(k) + diss_r(k) - swap_flux_x_local(k,j,tn) - & 608 swap_diss_x_local(k,j,tn) ) * ddx & 609 + ( flux_n(k) + diss_n(k) - swap_flux_y_local(k,tn) - & 610 swap_diss_y_local(k,tn) ) * ddy & 611 + ( flux_t(k) + diss_t(k) - flux_d - diss_d & 612 ) * ddzw(k) & 613 ) + sk(k,j,i) * div 614 615 swap_flux_y_local(k,tn) = flux_n(k) 616 swap_diss_y_local(k,tn) = diss_n(k) 617 swap_flux_x_local(k,j,tn) = flux_r(k) 618 swap_diss_x_local(k,j,tn) = diss_r(k) 619 flux_d = flux_t(k) 620 diss_d = diss_t(k) 619 621 620 622 ENDDO 621 623 622 624 ! 623 !-- WS3 as an intermediate step (top)624 k = nzt - 1625 flux_d = flux_t(k-1)626 diss_d = diss_t(k-1)627 flux_t(k) = w(k,j,i) * ( &628 7.0 * ( sk(k+1,j,i) + sk(k,j,i) ) &629 - ( sk(k+2,j,i) + sk(k-1,j,i) ) &630 ) * adv_sca_3631 diss_t(k) = -ABS( w(k,j,i) ) * ( &632 3.0 * ( sk(k+1,j,i) - sk(k,j,i) ) &633 - ( sk(k+2,j,i) - sk(k-1,j,i) ) &634 ) * adv_sca_3635 636 tend(k,j,i) = tend(k,j,i) - ( flux_t(k) + diss_t(k) - flux_d - diss_d ) &637 * ddzw(k)638 !639 !-- 2nd-order scheme (top)640 k = nzt641 flux_d = flux_t(k-1)642 diss_d = diss_t(k-1)643 flux_t(k) = w(k,j,i) * ( sk(k+1,j,i) + sk(k,j,i) ) * 0.5644 645 !646 !-- sk(k+1) is referenced two times to avoid a segmentation fault at top647 diss_t(k) = diss_2nd( sk(k+1,j,i), sk(k+1,j,i), sk(k,j,i), sk(k-1,j,i), &648 sk(k-2,j,i), w(k,j,i), 0.5, ddzw(k) )649 650 tend(k,j,i) = tend(k,j,i) - ( flux_t(k) + diss_t(k) - flux_d - diss_d ) &651 * ddzw(k)652 !653 625 !-- Evaluation of statistics 654 626 SELECT CASE ( sk_char ) … … 656 628 CASE ( 'pt' ) 657 629 658 DO k = nzb _s_inner(j,i), nzt659 sums_wspts_ws_l(k,tn) = sums_wspts_ws_l(k,tn) + 630 DO k = nzb, nzt 631 sums_wspts_ws_l(k,tn) = sums_wspts_ws_l(k,tn) + & 660 632 ( flux_t(k) + diss_t(k) ) & 661 633 * weight_substep(intermediate_timestep_count) … … 664 636 CASE ( 'sa' ) 665 637 666 DO k = nzb _s_inner(j,i), nzt667 sums_wssas_ws_l(k,tn) = sums_wssas_ws_l(k,tn) + 638 DO k = nzb, nzt 639 sums_wssas_ws_l(k,tn) = sums_wssas_ws_l(k,tn) + & 668 640 ( flux_t(k) + diss_t(k) ) & 669 641 * weight_substep(intermediate_timestep_count) … … 672 644 CASE ( 'q' ) 673 645 674 DO k = nzb _s_inner(j,i), nzt675 sums_wsqs_ws_l(k,tn) = sums_wsqs_ws_l(k,tn) + 646 DO k = nzb, nzt 647 sums_wsqs_ws_l(k,tn) = sums_wsqs_ws_l(k,tn) + & 676 648 ( flux_t(k) + diss_t(k) ) & 677 649 * weight_substep(intermediate_timestep_count) … … 699 671 IMPLICIT NONE 700 672 701 INTEGER :: i, i_omp, j, k, tn 702 LOGICAL :: degraded_l, degraded_s 703 REAL :: gu, gv, flux_d, diss_d, u_comp_l, v_comp, w_comp 673 INTEGER :: i, i_omp, j, k, tn, k_ppp, k_pp, k_mm 674 REAL :: gu, gv, flux_d, diss_d, u_comp_l, v_comp, w_comp, div 704 675 REAL, DIMENSION(nzb:nzt+1) :: flux_t, diss_t, flux_r, diss_r, & 705 676 flux_n, diss_n, u_comp 706 707 degraded_l = .FALSE.708 degraded_s = .FALSE.709 677 710 678 gu = 2.0 * u_gtrans 711 679 gv = 2.0 * v_gtrans 712 713 IF ( boundary_flags(j,i) /= 0 ) THEN 714 ! 715 !-- Degrade the order for Dirichlet bc. at the outflow boundary 716 SELECT CASE ( boundary_flags(j,i) ) 717 718 CASE ( 1 ) 719 DO k = nzb_u_inner(j,i)+1, nzt 720 u_comp(k) = u(k,j,i+1) + u(k,j,i) 721 flux_r(k) = ( u_comp(k) - gu ) * ( & 722 7.0 * ( u(k,j,i+1) + u(k,j,i) ) & 723 - ( u(k,j,i+2) + u(k,j,i-1) ) ) * adv_mom_3 724 diss_r(k) = - ABS( u_comp(k) - gu ) * ( & 725 3.0 * ( u(k,j,i+1) - u(k,j,i) ) & 726 - ( u(k,j,i+2) - u(k,j,i-1) ) ) * adv_mom_3 727 ENDDO 728 729 CASE ( 2 ) 730 DO k = nzb_u_inner(j,i)+1, nzt 731 u_comp(k) = u(k,j,i+1) + u(k,j,i) 732 flux_r(k) = ( u_comp(k) - gu ) * ( & 733 u(k,j,i+1) + u(k,j,i) ) * 0.25 734 diss_r(k) = diss_2nd( u(k,j,i+1) ,u(k,j,i+1), u(k,j,i), & 735 u(k,j,i-1), u(k,j,i-2), u_comp(k), & 736 0.25, ddx ) 737 ENDDO 738 739 CASE ( 3 ) 740 DO k = nzb_u_inner(j,i)+1, nzt 741 v_comp = v(k,j+1,i) + v(k,j+1,i-1) - gv 742 flux_n(k) = v_comp * ( & 743 7.0 * ( u(k,j+1,i) + u(k,j,i) ) & 744 - ( u(k,j+2,i) + u(k,j-1,i) ) ) * adv_mom_3 745 diss_n(k) = - ABS( v_comp ) * ( & 746 3.0 * ( u(k,j+1,i) - u(k,j,i) ) & 747 - ( u(k,j+2,i) - u(k,j-1,i) ) ) * adv_mom_3 748 ENDDO 749 750 CASE ( 4 ) 751 DO k = nzb_u_inner(j,i)+1, nzt 752 v_comp = v(k,j+1,i) + v(k,j+1,i-1) - gv 753 flux_n(k) = v_comp * ( u(k,j+1,i) + u(k,j,i) ) * 0.25 754 diss_n(k) = diss_2nd( u(k,j+1,i), u(k,j+1,i), u(k,j,i), & 755 u(k,j-1,i), u(k,j-2,i), v_comp, & 756 0.25, ddy ) 757 ENDDO 758 759 CASE ( 5 ) 760 DO k = nzb_u_inner(j,i)+1, nzt 761 ! 762 !-- Compute leftside fluxes for the left boundary of PE domain 763 u_comp(k) = u(k,j,i) + u(k,j,i-1) - gu 764 flux_l_u(k,j,tn) = u_comp(k) * ( u(k,j,i) + u(k,j,i-1) ) * 0.25 765 diss_l_u(k,j,tn) = diss_2nd( u(k,j,i+2), u(k,j,i+1), u(k,j,i), & 766 u(k,j,i-1), u(k,j,i-1), u_comp(k),& 767 0.25, ddx ) 768 769 u_comp(k) = u(k,j,i+1) + u(k,j,i) 770 flux_r(k) = ( u_comp(k) - gu ) * ( & 771 7.0 * ( u(k,j,i+1) + u(k,j,i) ) & 772 - ( u(k,j,i+2) + u(k,j,i-1) ) ) * adv_mom_3 773 diss_r(k) = - ABS( u_comp(k) -gu ) * ( & 774 3.0 * ( u(k,j,i+1) - u(k,j,i) ) & 775 - ( u(k,j,i+2) - u(k,j,i-1) ) ) * adv_mom_3 776 ENDDO 777 degraded_l = .TRUE. 778 779 CASE ( 7 ) 780 DO k = nzb_u_inner(j,i)+1, nzt 781 v_comp = v(k,j+1,i) + v(k,j+1,i-1) - gv 782 flux_n(k) = v_comp * ( & 783 7.0 * ( u(k,j+1,i) + u(k,j,i) ) & 784 - ( u(k,j+2,i) + u(k,j-1,i) ) ) * adv_mom_3 785 diss_n(k) = - ABS( v_comp ) * ( & 786 3.0 * ( u(k,j+1,i) - u(k,j,i) ) & 787 - ( u(k,j+2,i) - u(k,j-1,i) ) ) * adv_mom_3 788 ENDDO 789 790 CASE ( 8 ) 791 DO k = nzb_u_inner(j,i)+1, nzt 792 ! 793 !-- Compute southside fluxes for the south boundary of PE domain 794 v_comp = v(k,j,i) + v(k,j,i-1) - gv 795 flux_s_u(k,tn) = v_comp * ( u(k,j,i) + u(k,j-1,i) ) * 0.25 796 diss_s_u(k,tn) = diss_2nd( u(k,j+2,i), u(k,j+1,i), u(k,j,i), & 797 u(k,j-1,i), u(k,j-1,i), v_comp, & 798 0.25, ddy ) 799 800 v_comp = v(k,j+1,i) + v(k,j+1,i-1) - gv 801 flux_n(k) = v_comp * ( & 802 7.0 * ( u(k,j+1,i) + u(k,j,i) ) & 803 - ( u(k,j+2,i) + u(k,j-1,i) ) ) * adv_mom_3 804 diss_n(k) = - ABS( v_comp ) * ( & 805 3.0 * ( u(k,j+1,i) - u(k,j,i) ) & 806 - ( u(k,j+2,i) - u(k,j-1,i) ) ) * adv_mom_3 807 ENDDO 808 degraded_s = .TRUE. 809 810 CASE DEFAULT 811 812 END SELECT 813 ! 814 !-- Compute the crosswise 5th order fluxes at the outflow 815 IF ( boundary_flags(j,i) == 1 .OR. boundary_flags(j,i) == 2 .OR. & 816 boundary_flags(j,i) == 5 ) THEN 817 818 DO k = nzb_u_inner(j,i)+1, nzt 819 v_comp = v(k,j+1,i) + v(k,j+1,i-1) - gv 820 flux_n(k) = v_comp * ( & 821 37.0 * ( u(k,j+1,i) + u(k,j,i) ) & 822 - 8.0 * ( u(k,j+2,i) + u(k,j-1,i) ) & 823 + ( u(k,j+3,i) + u(k,j-2,i) ) ) * adv_mom_5 824 diss_n(k) = - ABS ( v_comp ) * ( & 825 10.0 * ( u(k,j+1,i) - u(k,j,i) ) & 826 - 5.0 * ( u(k,j+2,i) - u(k,j-1,i) ) & 827 + ( u(k,j+3,i) - u(k,j-2,i) ) ) * adv_mom_5 828 ENDDO 829 830 ELSE 831 832 DO k = nzb_u_inner(j,i)+1, nzt 833 u_comp(k) = u(k,j,i+1) + u(k,j,i) 834 flux_r(k) = ( u_comp(k) - gu ) * ( & 835 37.0 * ( u(k,j,i+1) + u(k,j,i) ) & 836 - 8.0 * ( u(k,j,i+2) + u(k,j,i-1) ) & 837 + ( u(k,j,i+3) + u(k,j,i-2) ) ) * adv_mom_5 838 diss_r(k) = - ABS( u_comp(k) - gu ) * ( & 839 10.0 * ( u(k,j,i+1) - u(k,j,i) ) & 840 - 5.0 * ( u(k,j,i+2) - u(k,j,i-1) ) & 841 + ( u(k,j,i+3) - u(k,j,i-2) ) ) * adv_mom_5 842 ENDDO 843 844 ENDIF 845 846 ELSE 847 ! 848 !-- Compute the fifth order fluxes for the interior of PE domain. 849 DO k = nzb_u_inner(j,i)+1, nzt 850 u_comp(k) = u(k,j,i+1) + u(k,j,i) 851 flux_r(k) = ( u_comp(k) - gu ) * ( & 680 ! 681 !-- Compute southside fluxes for the respective boundary of PE 682 IF ( j == nys ) THEN 683 684 DO k = nzb+1, nzb_max 685 686 v_comp = v(k,j,i) + v(k,j,i-1) - gv 687 flux_s_u(k,tn) = v_comp * ( & 688 ( 37.0 * IBITS(wall_flags_0(k,j,i),14,1) * adv_mom_5 & 689 + 7.0 * IBITS(wall_flags_0(k,j,i),13,1) * adv_mom_3 & 690 + IBITS(wall_flags_0(k,j,i),12,1) * adv_mom_1 & 691 ) * & 692 ( u(k,j,i) + u(k,j-1,i) ) & 693 - ( 8.0 * IBITS(wall_flags_0(k,j,i),14,1) * adv_mom_5 & 694 + IBITS(wall_flags_0(k,j,i),13,1) * adv_mom_3 & 695 ) * & 696 ( u(k,j+1,i) + u(k,j-2,i) ) & 697 + ( IBITS(wall_flags_0(k,j,i),14,1) * adv_mom_5 & 698 ) * & 699 ( u(k,j+2,i) + u(k,j-3,i) ) & 700 ) 701 702 diss_s_u(k,tn) = - ABS ( v_comp ) * ( & 703 ( 10.0 * IBITS(wall_flags_0(k,j,i),14,1) * adv_mom_5 & 704 + 3.0 * IBITS(wall_flags_0(k,j,i),13,1) * adv_mom_3 & 705 + IBITS(wall_flags_0(k,j,i),12,1) * adv_mom_1 & 706 ) * & 707 ( u(k,j,i) - u(k,j-1,i) ) & 708 - ( 5.0 * IBITS(wall_flags_0(k,j,i),14,1) * adv_mom_5 & 709 + IBITS(wall_flags_0(k,j,i),13,1) * adv_mom_3 & 710 ) * & 711 ( u(k,j+1,i) - u(k,j-2,i) ) & 712 + ( IBITS(wall_flags_0(k,j,i),14,1) * adv_mom_5 & 713 ) * & 714 ( u(k,j+2,i) - u(k,j-3,i) ) & 715 ) 716 717 ENDDO 718 719 DO k = nzb_max+1, nzt 720 721 v_comp = v(k,j,i) + v(k,j,i-1) - gv 722 flux_s_u(k,tn) = v_comp * ( & 723 37.0 * ( u(k,j,i) + u(k,j-1,i) ) & 724 - 8.0 * ( u(k,j+1,i) + u(k,j-2,i) ) & 725 + ( u(k,j+2,i) + u(k,j-3,i) ) ) * adv_mom_5 726 diss_s_u(k,tn) = - ABS(v_comp) * ( & 727 10.0 * ( u(k,j,i) - u(k,j-1,i) ) & 728 - 5.0 * ( u(k,j+1,i) - u(k,j-2,i) ) & 729 + ( u(k,j+2,i) - u(k,j-3,i) ) ) * adv_mom_5 730 731 ENDDO 732 733 ENDIF 734 ! 735 !-- Compute leftside fluxes for the respective boundary of PE 736 IF ( i == i_omp ) THEN 737 738 DO k = nzb+1, nzb_max 739 740 u_comp_l = u(k,j,i) + u(k,j,i-1) - gu 741 flux_l_u(k,j,tn) = u_comp_l * ( & 742 ( 37.0 * IBITS(wall_flags_0(k,j,i),11,1) * adv_mom_5 & 743 + 7.0 * IBITS(wall_flags_0(k,j,i),10,1) * adv_mom_3 & 744 + IBITS(wall_flags_0(k,j,i),9,1) * adv_mom_1 & 745 ) * & 746 ( u(k,j,i) + u(k,j,i-1) ) & 747 - ( 8.0 * IBITS(wall_flags_0(k,j,i),11,1) * adv_mom_5 & 748 + IBITS(wall_flags_0(k,j,i),10,1) * adv_mom_3 & 749 ) * & 750 ( u(k,j,i+1) + u(k,j,i-2) ) & 751 + ( IBITS(wall_flags_0(k,j,i),11,1) * adv_mom_5 & 752 ) * & 753 ( u(k,j,i+2) + u(k,j,i-3) ) & 754 ) 755 756 diss_l_u(k,j,tn) = - ABS( u_comp_l ) * ( & 757 ( 10.0 * IBITS(wall_flags_0(k,j,i),11,1) * adv_mom_5 & 758 + 3.0 * IBITS(wall_flags_0(k,j,i),10,1) * adv_mom_3 & 759 + IBITS(wall_flags_0(k,j,i),9,1) * adv_mom_1 & 760 ) * & 761 ( u(k,j,i) - u(k,j,i-1) ) & 762 - ( 5.0 * IBITS(wall_flags_0(k,j,i),11,1) * adv_mom_5 & 763 + IBITS(wall_flags_0(k,j,i),10,1) * adv_mom_3 & 764 ) * & 765 ( u(k,j,i+1) - u(k,j,i-2) ) & 766 + ( IBITS(wall_flags_0(k,j,i),11,1) * adv_mom_5 & 767 ) * & 768 ( u(k,j,i+2) - u(k,j,i-3) ) & 769 ) 770 771 ENDDO 772 773 DO k = nzb_max+1, nzt 774 775 u_comp_l = u(k,j,i) + u(k,j,i-1) - gu 776 flux_l_u(k,j,tn) = u_comp_l * ( & 777 37.0 * ( u(k,j,i) + u(k,j,i-1) ) & 778 - 8.0 * ( u(k,j,i+1) + u(k,j,i-2) ) & 779 + ( u(k,j,i+2) + u(k,j,i-3) ) ) * adv_mom_5 780 diss_l_u(k,j,tn) = - ABS(u_comp_l) * ( & 781 10.0 * ( u(k,j,i) - u(k,j,i-1) ) & 782 - 5.0 * ( u(k,j,i+1) - u(k,j,i-2) ) & 783 + ( u(k,j,i+2) - u(k,j,i-3) ) ) * adv_mom_5 784 785 ENDDO 786 787 ENDIF 788 789 flux_t(0) = 0.0 790 diss_t(0) = 0.0 791 flux_d = 0.0 792 diss_d = 0.0 793 ! 794 !-- Now compute the fluxes tendency terms for the horizontal and 795 !-- vertical parts. 796 DO k = nzb+1, nzb_max 797 798 u_comp(k) = u(k,j,i+1) + u(k,j,i) 799 flux_r(k) = ( u_comp(k) - gu ) * ( & 800 ( 37.0 * IBITS(wall_flags_0(k,j,i),11,1) * adv_mom_5 & 801 + 7.0 * IBITS(wall_flags_0(k,j,i),10,1) * adv_mom_3 & 802 + IBITS(wall_flags_0(k,j,i),9,1) * adv_mom_1 & 803 ) * & 804 ( u(k,j,i+1) + u(k,j,i) ) & 805 - ( 8.0 * IBITS(wall_flags_0(k,j,i),11,1) * adv_mom_5 & 806 + IBITS(wall_flags_0(k,j,i),10,1) * adv_mom_3 & 807 ) * & 808 ( u(k,j,i+2) + u(k,j,i-1) ) & 809 + ( IBITS(wall_flags_0(k,j,i),11,1) * adv_mom_5 & 810 ) * & 811 ( u(k,j,i+3) + u(k,j,i-2) ) & 812 ) 813 814 diss_r(k) = - ABS( u_comp(k) - gu ) * ( & 815 ( 10.0 * IBITS(wall_flags_0(k,j,i),11,1) * adv_mom_5 & 816 + 3.0 * IBITS(wall_flags_0(k,j,i),10,1) * adv_mom_3 & 817 + IBITS(wall_flags_0(k,j,i),9,1) * adv_mom_1 & 818 ) * & 819 ( u(k,j,i+1) - u(k,j,i) ) & 820 - ( 5.0 * IBITS(wall_flags_0(k,j,i),11,1) * adv_mom_5 & 821 + IBITS(wall_flags_0(k,j,i),10,1) * adv_mom_3 & 822 ) * & 823 ( u(k,j,i+2) - u(k,j,i-1) ) & 824 + ( IBITS(wall_flags_0(k,j,i),11,1) * adv_mom_5 & 825 ) * & 826 ( u(k,j,i+3) - u(k,j,i-2) ) & 827 ) 828 829 v_comp = v(k,j+1,i) + v(k,j+1,i-1) - gv 830 flux_n(k) = v_comp * ( & 831 ( 37.0 * IBITS(wall_flags_0(k,j,i),14,1) * adv_mom_5 & 832 + 7.0 * IBITS(wall_flags_0(k,j,i),13,1) * adv_mom_3 & 833 + IBITS(wall_flags_0(k,j,i),12,1) * adv_mom_1 & 834 ) * & 835 ( u(k,j+1,i) + u(k,j,i) ) & 836 - ( 8.0 * IBITS(wall_flags_0(k,j,i),14,1) * adv_mom_5 & 837 + IBITS(wall_flags_0(k,j,i),13,1) * adv_mom_3 & 838 ) * & 839 ( u(k,j+2,i) + u(k,j-1,i) ) & 840 + ( IBITS(wall_flags_0(k,j,i),14,1) * adv_mom_5 & 841 ) * & 842 ( u(k,j+3,i) + u(k,j-2,i) ) & 843 ) 844 845 diss_n(k) = - ABS ( v_comp ) * ( & 846 ( 10.0 * IBITS(wall_flags_0(k,j,i),14,1) * adv_mom_5 & 847 + 3.0 * IBITS(wall_flags_0(k,j,i),13,1) * adv_mom_3 & 848 + IBITS(wall_flags_0(k,j,i),12,1) * adv_mom_1 & 849 ) * & 850 ( u(k,j+1,i) - u(k,j,i) ) & 851 - ( 5.0 * IBITS(wall_flags_0(k,j,i),14,1) * adv_mom_5 & 852 + IBITS(wall_flags_0(k,j,i),13,1) * adv_mom_3 & 853 ) * & 854 ( u(k,j+2,i) - u(k,j-1,i) ) & 855 + ( IBITS(wall_flags_0(k,j,i),14,1) * adv_mom_5 & 856 ) * & 857 ( u(k,j+3,i) - u(k,j-2,i) ) & 858 ) 859 ! 860 !-- k index has to be modified near bottom and top, else array 861 !-- subscripts will be exceeded. 862 k_ppp = k + 3 * IBITS(wall_flags_0(k,j,i),17,1) 863 k_pp = k + 2 * ( 1 - IBITS(wall_flags_0(k,j,i),15,1) ) 864 k_mm = k - 2 * IBITS(wall_flags_0(k,j,i),17,1) 865 866 w_comp = w(k,j,i) + w(k,j,i-1) 867 flux_t(k) = w_comp * ( & 868 ( 37.0 * IBITS(wall_flags_0(k,j,i),17,1) * adv_mom_5 & 869 + 7.0 * IBITS(wall_flags_0(k,j,i),16,1) * adv_mom_3 & 870 + IBITS(wall_flags_0(k,j,i),15,1) * adv_mom_1 & 871 ) * & 872 ( u(k+1,j,i) + u(k,j,i) ) & 873 - ( 8.0 * IBITS(wall_flags_0(k,j,i),17,1) * adv_mom_5 & 874 + IBITS(wall_flags_0(k,j,i),16,1) * adv_mom_3 & 875 ) * & 876 ( u(k_pp,j,i) + u(k-1,j,i) ) & 877 + ( IBITS(wall_flags_0(k,j,i),17,1) * adv_mom_5 & 878 ) * & 879 ( u(k_ppp,j,i) + u(k_mm,j,i) ) & 880 ) 881 882 diss_t(k) = - ABS( w_comp ) * ( & 883 ( 10.0 * IBITS(wall_flags_0(k,j,i),17,1) * adv_mom_5 & 884 + 3.0 * IBITS(wall_flags_0(k,j,i),16,1) * adv_mom_3 & 885 + IBITS(wall_flags_0(k,j,i),15,1) * adv_mom_1 & 886 ) * & 887 ( u(k+1,j,i) - u(k,j,i) ) & 888 - ( 5.0 * IBITS(wall_flags_0(k,j,i),17,1) * adv_mom_5 & 889 + IBITS(wall_flags_0(k,j,i),16,1) * adv_mom_3 & 890 ) * & 891 ( u(k_pp,j,i) - u(k-1,j,i) ) & 892 + ( IBITS(wall_flags_0(k,j,i),17,1) * adv_mom_5 & 893 ) * & 894 ( u(k_ppp,j,i) - u(k_mm,j,i) ) & 895 ) 896 ! 897 !-- Calculate the divergence of the velocity field. A respective 898 !-- correction is needed to overcome numerical instabilities introduced 899 !-- by a not sufficient reduction of divergences near topography. 900 div = ( ( u_comp(k) - ( u(k,j,i) + u(k,j,i-1) ) ) * ddx & 901 + ( v_comp + gv - ( v(k,j,i) + v(k,j,i-1 ) ) ) * ddy & 902 + ( w_comp - ( w(k-1,j,i) + w(k-1,j,i-1) ) ) * ddzw(k) & 903 ) * 0.5 904 905 tend(k,j,i) = tend(k,j,i) - ( & 906 ( flux_r(k) + diss_r(k) & 907 - flux_l_u(k,j,tn) - diss_l_u(k,j,tn) ) * ddx & 908 + ( flux_n(k) + diss_n(k) & 909 - flux_s_u(k,tn) - diss_s_u(k,tn) ) * ddy & 910 + ( flux_t(k) + diss_t(k) & 911 - flux_d - diss_d ) * ddzw(k) & 912 ) + div * u(k,j,i) 913 914 flux_l_u(k,j,tn) = flux_r(k) 915 diss_l_u(k,j,tn) = diss_r(k) 916 flux_s_u(k,tn) = flux_n(k) 917 diss_s_u(k,tn) = diss_n(k) 918 flux_d = flux_t(k) 919 diss_d = diss_t(k) 920 ! 921 !-- Statistical Evaluation of u'u'. The factor has to be applied for 922 !-- right evaluation when gallilei_trans = .T. . 923 sums_us2_ws_l(k,tn) = sums_us2_ws_l(k,tn) & 924 + ( flux_r(k) * & 925 ( u_comp(k) - 2.0 * hom(k,1,1,0) ) & 926 / ( u_comp(k) - gu + 1.0E-20 ) & 927 + diss_r(k) * & 928 ABS( u_comp(k) - 2.0 * hom(k,1,1,0) ) & 929 / ( ABS( u_comp(k) - gu ) + 1.0E-20 ) ) & 930 * weight_substep(intermediate_timestep_count) 931 ! 932 !-- Statistical Evaluation of w'u'. 933 sums_wsus_ws_l(k,tn) = sums_wsus_ws_l(k,tn) & 934 + ( flux_t(k) + diss_t(k) ) & 935 * weight_substep(intermediate_timestep_count) 936 ENDDO 937 938 DO k = nzb_max+1, nzt 939 940 u_comp(k) = u(k,j,i+1) + u(k,j,i) 941 flux_r(k) = ( u_comp(k) - gu ) * ( & 852 942 37.0 * ( u(k,j,i+1) + u(k,j,i) ) & 853 943 - 8.0 * ( u(k,j,i+2) + u(k,j,i-1) ) & … … 867 957 - 5.0 * ( u(k,j+2,i) - u(k,j-1,i) ) & 868 958 + ( u(k,j+3,i) - u(k,j-2,i) ) ) * adv_mom_5 869 ENDDO 870 871 ENDIF 872 ! 873 !-- Compute left- and southside fluxes for the respective boundary of PE 874 IF ( j == nys .AND. ( .NOT. degraded_s ) ) THEN 875 876 DO k = nzb_u_inner(j,i)+1, nzt 877 v_comp = v(k,j,i) + v(k,j,i-1) - gv 878 flux_s_u(k,tn) = v_comp * ( & 879 37.0 * ( u(k,j,i) + u(k,j-1,i) ) & 880 - 8.0 * ( u(k,j+1,i) + u(k,j-2,i) ) & 881 + ( u(k,j+2,i) + u(k,j-3,i) ) ) * adv_mom_5 882 diss_s_u(k,tn) = - ABS(v_comp) * ( & 883 10.0 * ( u(k,j,i) - u(k,j-1,i) ) & 884 - 5.0 * ( u(k,j+1,i) - u(k,j-2,i) ) & 885 + ( u(k,j+2,i) - u(k,j-3,i) ) ) * adv_mom_5 886 ENDDO 887 888 ENDIF 889 890 IF ( i == i_omp .AND. ( .NOT. degraded_l ) ) THEN 891 892 DO k = nzb_u_inner(j,i)+1, nzt 893 u_comp_l = u(k,j,i)+u(k,j,i-1)-gu 894 flux_l_u(k,j,tn) = u_comp_l * ( & 895 37.0 * ( u(k,j,i) + u(k,j,i-1) ) & 896 - 8.0 * ( u(k,j,i+1) + u(k,j,i-2) ) & 897 + ( u(k,j,i+2) + u(k,j,i-3) ) ) * adv_mom_5 898 diss_l_u(k,j,tn) = - ABS(u_comp_l) * ( & 899 10.0 * ( u(k,j,i) - u(k,j,i-1) ) & 900 - 5.0 * ( u(k,j,i+1) - u(k,j,i-2) ) & 901 + ( u(k,j,i+2) - u(k,j,i-3) ) ) * adv_mom_5 902 ENDDO 903 904 ENDIF 905 ! 906 !-- Now compute the tendency terms for the horizontal parts. 907 DO k = nzb_u_inner(j,i)+1, nzt 959 ! 960 !-- k index has to be modified near bottom and top, else array 961 !-- subscripts will be exceeded. 962 k_ppp = k + 3 * IBITS(wall_flags_0(k,j,i),17,1) 963 k_pp = k + 2 * ( 1 - IBITS(wall_flags_0(k,j,i),15,1) ) 964 k_mm = k - 2 * IBITS(wall_flags_0(k,j,i),17,1) 965 966 w_comp = w(k,j,i) + w(k,j,i-1) 967 flux_t(k) = w_comp * ( & 968 ( 37.0 * IBITS(wall_flags_0(k,j,i),17,1) * adv_mom_5 & 969 + 7.0 * IBITS(wall_flags_0(k,j,i),16,1) * adv_mom_3 & 970 + IBITS(wall_flags_0(k,j,i),15,1) * adv_mom_1 & 971 ) * & 972 ( u(k+1,j,i) + u(k,j,i) ) & 973 - ( 8.0 * IBITS(wall_flags_0(k,j,i),17,1) * adv_mom_5 & 974 + IBITS(wall_flags_0(k,j,i),16,1) * adv_mom_3 & 975 ) * & 976 ( u(k_pp,j,i) + u(k-1,j,i) ) & 977 + ( IBITS(wall_flags_0(k,j,i),17,1) * adv_mom_5 & 978 ) * & 979 ( u(k_ppp,j,i) + u(k_mm,j,i) ) & 980 ) 981 982 diss_t(k) = - ABS( w_comp ) * ( & 983 ( 10.0 * IBITS(wall_flags_0(k,j,i),17,1) * adv_mom_5 & 984 + 3.0 * IBITS(wall_flags_0(k,j,i),16,1) * adv_mom_3 & 985 + IBITS(wall_flags_0(k,j,i),15,1) * adv_mom_1 & 986 ) * & 987 ( u(k+1,j,i) - u(k,j,i) ) & 988 - ( 5.0 * IBITS(wall_flags_0(k,j,i),17,1) * adv_mom_5 & 989 + IBITS(wall_flags_0(k,j,i),16,1) * adv_mom_3 & 990 ) * & 991 ( u(k_pp,j,i) - u(k-1,j,i) ) & 992 + ( IBITS(wall_flags_0(k,j,i),17,1) * adv_mom_5 & 993 ) * & 994 ( u(k_ppp,j,i) - u(k_mm,j,i) ) & 995 ) 996 ! 997 !-- Calculate the divergence of the velocity field. A respective 998 !-- correction is needed to overcome numerical instabilities introduced 999 !-- by a not sufficient reduction of divergences near topography. 1000 div = ( ( u_comp(k) - ( u(k,j,i) + u(k,j,i-1) ) ) * ddx & 1001 + ( v_comp + gv - ( v(k,j,i) + v(k,j,i-1 ) ) ) * ddy & 1002 + ( w_comp - ( w(k-1,j,i) + w(k-1,j,i-1) ) ) * ddzw(k) & 1003 ) * 0.5 1004 908 1005 tend(k,j,i) = tend(k,j,i) - ( & 909 1006 ( flux_r(k) + diss_r(k) & 910 - flux_l_u(k,j,tn) - diss_l_u(k,j,tn) ) * ddx 1007 - flux_l_u(k,j,tn) - diss_l_u(k,j,tn) ) * ddx & 911 1008 + ( flux_n(k) + diss_n(k) & 912 - flux_s_u(k,tn) - diss_s_u(k,tn) ) * ddy ) 1009 - flux_s_u(k,tn) - diss_s_u(k,tn) ) * ddy & 1010 + ( flux_t(k) + diss_t(k) & 1011 - flux_d - diss_d ) * ddzw(k) & 1012 ) + div * u(k,j,i) 913 1013 914 1014 flux_l_u(k,j,tn) = flux_r(k) … … 916 1016 flux_s_u(k,tn) = flux_n(k) 917 1017 diss_s_u(k,tn) = diss_n(k) 918 ! 919 !-- Statistical Evaluation of u'u'. The factor has to be applied for 1018 flux_d = flux_t(k) 1019 diss_d = diss_t(k) 1020 ! 1021 !-- Statistical Evaluation of u'u'. The factor has to be applied for 920 1022 !-- right evaluation when gallilei_trans = .T. . 921 sums_us2_ws_l(k,tn) = sums_us2_ws_l(k,tn) & 922 + ( flux_r(k) * & 923 ( u_comp(k) - 2.0 * hom(k,1,1,0) ) & 924 / ( u_comp(k) - gu + 1.0E-20 ) & 925 + diss_r(k) * & 926 ABS( u_comp(k) - 2.0 * hom(k,1,1,0) ) & 927 / ( ABS( u_comp(k) - gu ) + 1.0E-20 ) ) & 928 * weight_substep(intermediate_timestep_count) 929 ENDDO 930 sums_us2_ws_l(nzb_u_inner(j,i),tn) = sums_us2_ws_l(nzb_u_inner(j,i)+1,tn) 931 932 933 ! 934 !-- Vertical advection, degradation of order near surface and top. 935 !-- The fluxes flux_d and diss_d at the surface are 0. Due to reasons of 936 !-- statistical evaluation the top flux at the surface should be 0 937 flux_t(nzb_u_inner(j,i)) = 0. !statistical reasons 938 diss_t(nzb_u_inner(j,i)) = 0. 939 ! 940 !-- 2nd order scheme (bottom) 941 k = nzb_u_inner(j,i)+1 942 flux_d = flux_t(k-1) 943 diss_d = diss_t(k-1) 944 w_comp = w(k,j,i) + w(k,j,i-1) 945 flux_t(k) = w_comp * ( u(k+1,j,i) + u(k,j,i) ) *0.25 946 diss_t(k) = diss_2nd( u(k+2,j,i), u(k+1,j,i), u(k,j,i), 0., 0., & 947 w_comp, 0.25, ddzw(k) ) 948 949 tend(k,j,i) = tend(k,j,i) - ( flux_t(k) + diss_t(k) & 950 - flux_d - diss_d ) * ddzw(k) 951 ! 952 !-- WS3 as an intermediate step (bottom) 953 k = nzb_u_inner(j,i)+2 954 flux_d = flux_t(k-1) 955 diss_d = diss_t(k-1) 956 w_comp = w(k,j,i) + w(k,j,i-1) 957 flux_t(k) = w_comp * ( & 958 7.0 * ( u(k+1,j,i) + u(k,j,i) ) & 959 - ( u(k+2,j,i) + u(k-1,j,i) ) ) * adv_mom_3 960 diss_t(k) = -ABS( w_comp) * ( & 961 3.0 * ( u(k+1,j,i) - u(k,j,i) ) & 962 - ( u(k+2,j,i) - u(k-1,j,i) ) ) * adv_mom_3 963 964 tend(k,j,i) = tend(k,j,i) - ( flux_t(k) + diss_t(k) & 965 - flux_d - diss_d ) * ddzw(k) 966 ! 967 !-- WS5 968 DO k = nzb_u_inner(j,i)+3, nzt-2 969 flux_d = flux_t(k-1) 970 diss_d = diss_t(k-1) 971 w_comp = w(k,j,i) + w(k,j,i-1) 972 flux_t(k) = w_comp * ( & 973 37.0 * ( u(k+1,j,i) + u(k,j,i) ) & 974 - 8.0 * ( u(k+2,j,i) + u(k-1,j,i) ) & 975 + ( u(k+3,j,i) + u(k-2,j,i) ) ) * adv_mom_5 976 diss_t(k) = - ABS( w_comp ) * ( & 977 10.0 * ( u(k+1,j,i) - u(k,j,i) ) & 978 - 5.0 * ( u(k+2,j,i) - u(k-1,j,i) ) & 979 + ( u(k+3,j,i) - u(k-2,j,i) ) ) * adv_mom_5 980 981 tend(k,j,i) = tend(k,j,i) - ( flux_t(k) + diss_t(k) & 982 - flux_d - diss_d ) * ddzw(k) 1023 sums_us2_ws_l(k,tn) = sums_us2_ws_l(k,tn) & 1024 + ( flux_r(k) * & 1025 ( u_comp(k) - 2.0 * hom(k,1,1,0) ) & 1026 / ( u_comp(k) - gu + 1.0E-20 ) & 1027 + diss_r(k) * & 1028 ABS( u_comp(k) - 2.0 * hom(k,1,1,0) ) & 1029 / ( ABS( u_comp(k) - gu ) + 1.0E-20 ) ) & 1030 * weight_substep(intermediate_timestep_count) 1031 ! 1032 !-- Statistical Evaluation of w'u'. 1033 sums_wsus_ws_l(k,tn) = sums_wsus_ws_l(k,tn) & 1034 + ( flux_t(k) + diss_t(k) ) & 1035 * weight_substep(intermediate_timestep_count) 983 1036 ENDDO 984 ! 985 !-- WS3 as an intermediate step (top) 986 k = nzt - 1 987 flux_d = flux_t(k-1) 988 diss_d = diss_t(k-1) 989 w_comp = w(k,j,i) + w(k,j,i-1) 990 flux_t(k) = w_comp * ( & 991 7.0 * ( u(k+1,j,i) + u(k,j,i) ) & 992 - ( u(k+2,j,i) + u(k-1,j,i) ) ) * adv_mom_3 993 diss_t(k) = - ABS( w_comp ) * ( & 994 3.0 * ( u(k+1,j,i) - u(k,j,i) ) & 995 - ( u(k+2,j,i) - u(k-1,j,i) ) ) * adv_mom_3 996 997 tend(k,j,i) = tend(k,j,i) - ( flux_t(k) + diss_t(k) & 998 - flux_d - diss_d ) * ddzw(k) 999 1000 ! 1001 !-- 2nd order scheme (top) 1002 k = nzt 1003 flux_d = flux_t(k-1) 1004 diss_d = diss_t(k-1) 1005 w_comp = w(k,j,i)+w(k,j,i-1) 1006 flux_t(k) = w_comp * ( u(k+1,j,i) + u(k,j,i) ) * 0.25 1007 diss_t(k) = diss_2nd( u(k+1,j,i), u(k+1,j,i), u(k,j,i), u(k-1,j,i), & 1008 u(k-2,j,i), w_comp, 0.25, ddzw(k) ) 1009 1010 tend(k,j,i) = tend(k,j,i) - ( flux_t(k) + diss_t(k) & 1011 - flux_d - diss_d ) * ddzw(k) 1012 1013 ! 1014 !-- sum up the vertical momentum fluxes 1015 DO k = nzb_u_inner(j,i), nzt 1016 sums_wsus_ws_l(k,tn) = sums_wsus_ws_l(k,tn) & 1017 + ( flux_t(k) + diss_t(k) ) & 1018 * weight_substep(intermediate_timestep_count) 1019 ENDDO 1037 1038 sums_us2_ws_l(nzb,tn) = sums_us2_ws_l(nzb+1,tn) 1039 1020 1040 1021 1041 1022 1042 END SUBROUTINE advec_u_ws_ij 1023 1024 1043 1025 1044 … … 1039 1058 IMPLICIT NONE 1040 1059 1041 INTEGER :: i, i_omp, j, k, tn 1042 LOGICAL :: degraded_l, degraded_s 1043 REAL :: gu, gv, flux_d, diss_d, u_comp, v_comp_l, w_comp 1060 INTEGER :: i, i_omp, j, k, tn, k_ppp, k_pp, k_mm 1061 REAL :: gu, gv, flux_d, diss_d, u_comp, v_comp_l, w_comp, div 1044 1062 REAL, DIMENSION(nzb:nzt+1) :: flux_t, diss_t, flux_n, & 1045 1063 diss_n, flux_r, diss_r, v_comp 1046 1047 degraded_l = .FALSE. 1048 degraded_s = .FALSE. 1049 1064 1050 1065 gu = 2.0 * u_gtrans 1051 1066 gv = 2.0 * v_gtrans 1052 1053 IF ( boundary_flags(j,i) /= 0 ) THEN 1067 1054 1068 ! 1055 !-- Degrade the order for Dirichlet bc. at the outflow boundary 1056 SELECT CASE ( boundary_flags(j,i) ) 1057 1058 CASE ( 1 ) 1059 DO k = nzb_v_inner(j,i)+1, nzt 1060 u_comp = u(k,j-1,i+1) + u(k,j,i+1) - gu 1061 flux_r(k) = u_comp * ( & 1062 7.0 * (v(k,j,i+1) + v(k,j,i) ) & 1063 - ( v(k,j,i+2) + v(k,j,i-1) ) ) * adv_mom_3 1064 diss_r(k) = - ABS( u_comp ) * ( & 1065 3.0 * ( v(k,j,i+1) - v(k,j,i) ) & 1066 - ( v(k,j,i+2) - v(k,j,i-1) ) ) * adv_mom_3 1067 ENDDO 1068 1069 CASE ( 2 ) 1070 DO k = nzb_v_inner(j,i)+1, nzt 1071 u_comp = u(k,j-1,i+1) + u(k,j,i+1) - gu 1072 flux_r(k) = u_comp * ( v(k,j,i+1) + v(k,j,i) ) * 0.25 1073 diss_r(k) = diss_2nd( v(k,j,i+1), v(k,j,i+1), v(k,j,i), & 1074 v(k,j,i-1), v(k,j,i-2), u_comp, & 1075 0.25, ddx ) 1076 ENDDO 1077 1078 CASE ( 3 ) 1079 DO k = nzb_v_inner(j,i)+1, nzt 1080 v_comp(k) = v(k,j+1,i) + v(k,j,i) 1081 flux_n(k) = ( v_comp(k)- gv ) * ( & 1082 7.0 * ( v(k,j+1,i) + v(k,j,i) ) & 1083 - ( v(k,j+2,i) + v(k,j-1,i) ) ) * adv_mom_3 1084 diss_n(k) = - ABS( v_comp(k) - gv ) * ( & 1085 3.0 * ( v(k,j+1,i) - v(k,j,i) ) & 1086 - ( v(k,j+2,i) - v(k,j-1,i) ) ) * adv_mom_3 1087 ENDDO 1088 1089 CASE ( 4 ) 1090 DO k = nzb_v_inner(j,i)+1, nzt 1091 v_comp(k) = v(k,j+1,i) + v(k,j,i) 1092 flux_n(k) = ( v_comp(k) - gv ) * & 1093 ( v(k,j+1,i) + v(k,j,i) ) * 0.25 1094 diss_n(k) = diss_2nd( v(k,j+1,i), v(k,j+1,i), v(k,j,i), & 1095 v(k,j-1,i), v(k,j-2,i), v_comp(k), & 1096 0.25, ddy ) 1097 ENDDO 1098 1099 CASE ( 5 ) 1100 DO k = nzb_w_inner(j,i)+1, nzt 1101 u_comp = u(k,j-1,i) + u(k,j,i) - gu 1102 flux_r(k) = u_comp * ( & 1103 7.0 * ( v(k,j,i+1) + v(k,j,i) ) & 1104 - ( v(k,j,i+2) + v(k,j,i-1) ) ) * adv_mom_3 1105 diss_r(k) = - ABS( u_comp ) * ( & 1106 3.0 * ( w(k,j,i+1) - w(k,j,i) ) & 1107 - ( v(k,j,i+2) - v(k,j,i-1) ) ) * adv_mom_3 1108 ENDDO 1109 1110 CASE ( 6 ) 1111 DO k = nzb_v_inner(j,i)+1, nzt 1112 u_comp = u(k,j-1,i) + u(k,j,i) - gu 1113 flux_l_v(k,j,tn) = u_comp * ( v(k,j,i) + v(k,j,i-1) ) * 0.25 1114 diss_l_v(k,j,tn) = diss_2nd( v(k,j,i+2), v(k,j,i+1), v(k,j,i),& 1115 v(k,j,i-1), v(k,j,i-1), u_comp, & 1116 0.25, ddx ) 1117 1118 u_comp = u(k,j-1,i+1) + u(k,j,i+1) - gu 1119 flux_r(k) = u_comp * ( & 1120 7.0 * ( v(k,j,i+1) + v(k,j,i) ) & 1121 - ( v(k,j,i+2) + v(k,j,i-1) ) ) * adv_mom_3 1122 diss_r(k) = - ABS( u_comp ) * ( & 1123 3.0 * ( v(k,j,i+1) - v(k,j,i) ) & 1124 - ( v(k,j,i+2) - v(k,j,i-1) ) ) * adv_mom_3 1125 ENDDO 1126 degraded_l = .TRUE. 1127 1128 CASE ( 7 ) 1129 DO k = nzb_v_inner(j,i)+1, nzt 1130 v_comp(k) = v(k,j,i) + v(k,j-1,i) - gv 1131 flux_s_v(k,tn) = v_comp(k) * ( v(k,j,i) + v(k,j-1,i) ) * 0.25 1132 diss_s_v(k,tn) = diss_2nd( v(k,j+2,i), v(k,j+1,i), v(k,j,i), & 1133 v(k,j-1,i), v(k,j-1,i), v_comp(k), & 1134 0.25, ddy ) 1135 1136 v_comp(k) = v(k,j+1,i) + v(k,j,i) 1137 flux_n(k) = ( v_comp(k) - gv ) * ( & 1138 7.0 * ( v(k,j+1,i) + v(k,j,i) ) & 1139 - ( v(k,j+2,i) + v(k,j-1,i) ) ) * adv_mom_3 1140 diss_n(k) = - ABS( v_comp(k) - gv ) * ( & 1141 3.0 * ( v(k,j+1,i) - v(k,j,i) ) & 1142 - ( v(k,j+2,i) - v(k,j-1,i) ) ) * adv_mom_3 1143 ENDDO 1144 degraded_s = .TRUE. 1145 1146 CASE DEFAULT 1147 1148 END SELECT 1149 ! 1150 !-- Compute the crosswise 5th order fluxes at the outflow 1151 IF ( boundary_flags(j,i) == 1 .OR. boundary_flags(j,i) == 2 .OR. & 1152 boundary_flags(j,i) == 5 .OR. boundary_flags(j,i) == 6 ) THEN 1153 1154 DO k = nzb_v_inner(j,i)+1, nzt 1155 v_comp(k) = v(k,j+1,i) + v(k,j,i) 1156 flux_n(k) = ( v_comp(k) - gv ) * ( & 1157 37.0 * ( v(k,j+1,i) + v(k,j,i) ) & 1158 - 8.0 * ( v(k,j+2,i) + v(k,j-1,i) ) & 1159 + ( v(k,j+3,i) + v(k,j-2,i) ) ) * adv_mom_5 1160 diss_n(k) = - ABS( v_comp(k) - gv ) * ( & 1161 10.0 * ( v(k,j+1,i) - v(k,j,i) ) & 1162 - 5.0 * ( v(k,j+2,i) - v(k,j-1,i) ) & 1163 + ( v(k,j+3,i) - v(k,j-2,i) ) ) * adv_mom_5 1164 ENDDO 1165 1166 ELSE 1167 1168 DO k = nzb_v_inner(j,i)+1, nzt 1169 u_comp = u(k,j-1,i+1) + u(k,j,i+1) - gu 1170 flux_r(k) = u_comp * ( & 1171 37.0 * ( v(k,j,i+1) + v(k,j,i) ) & 1172 - 8.0 * ( v(k,j,i+2) + v(k,j,i-1) ) & 1173 + ( v(k,j,i+3) + v(k,j,i-2) ) ) * adv_mom_5 1174 diss_r(k) = - ABS( u_comp ) * ( & 1175 10.0 * ( v(k,j,i+1) - v(k,j,i) ) & 1176 - 5.0 * ( v(k,j,i+2) - v(k,j,i-1) ) & 1177 + ( v(k,j,i+3) - v(k,j,i-2) ) ) * adv_mom_5 1178 ENDDO 1179 1180 ENDIF 1181 1182 ELSE 1183 ! 1184 !-- Compute the fifth order fluxes for the interior of PE domain. 1185 DO k = nzb_v_inner(j,i)+1, nzt 1186 u_comp = u(k,j-1,i+1) + u(k,j,i+1) - gu 1187 flux_r(k) = u_comp * ( & 1188 37.0 * ( v(k,j,i+1) + v(k,j,i) ) & 1189 - 8.0 * ( v(k,j,i+2) + v(k,j,i-1) ) & 1190 + ( v(k,j,i+3) + v(k,j,i-2) ) ) * adv_mom_5 1191 diss_r(k) = - ABS( u_comp ) * ( & 1192 10.0 * ( v(k,j,i+1) - v(k,j,i) ) & 1193 - 5.0 * ( v(k,j,i+2) - v(k,j,i-1) ) & 1194 + ( v(k,j,i+3) - v(k,j,i-2) ) ) * adv_mom_5 1195 1196 v_comp(k) = v(k,j+1,i) + v(k,j,i) 1197 flux_n(k) = ( v_comp(k) - gv ) * ( & 1198 37.0 * ( v(k,j+1,i) + v(k,j,i) ) & 1199 - 8.0 * ( v(k,j+2,i) + v(k,j-1,i) ) & 1200 + ( v(k,j+3,i) + v(k,j-2,i) ) ) * adv_mom_5 1201 diss_n(k) = - ABS( v_comp(k) - gv ) * ( & 1202 10.0 * ( v(k,j+1,i) - v(k,j,i) ) & 1203 - 5.0 * ( v(k,j+2,i) - v(k,j-1,i) ) & 1204 + ( v(k,j+3,i) - v(k,j-2,i) ) ) * adv_mom_5 1205 ENDDO 1206 1207 ENDIF 1208 ! 1209 !-- Compute left- and southside fluxes for the respective boundary 1210 IF ( i == i_omp .AND. .NOT. degraded_l ) THEN 1211 1212 DO k = nzb_v_inner(j,i)+1, nzt 1213 u_comp = u(k,j-1,i) + u(k,j,i) - gu 1214 flux_l_v(k,j,tn) = u_comp * ( & 1069 !-- Compute leftside fluxes for the respective boundary. 1070 IF ( i == i_omp ) THEN 1071 1072 DO k = nzb+1, nzb_max 1073 1074 u_comp = u(k,j-1,i) + u(k,j,i) - gu 1075 flux_l_v(k,j,tn) = u_comp * ( & 1076 ( 37.0 * IBITS(wall_flags_0(k,j,i),20,1) * adv_mom_5 & 1077 + 7.0 * IBITS(wall_flags_0(k,j,i),19,1) * adv_mom_3 & 1078 + IBITS(wall_flags_0(k,j,i),18,1) * adv_mom_1 & 1079 ) * & 1080 ( v(k,j,i) + v(k,j,i-1) ) & 1081 - ( 8.0 * IBITS(wall_flags_0(k,j,i),20,1) * adv_mom_5 & 1082 + IBITS(wall_flags_0(k,j,i),19,1) * adv_mom_3 & 1083 ) * & 1084 ( v(k,j,i+1) + v(k,j,i-2) ) & 1085 + ( IBITS(wall_flags_0(k,j,i),20,1) * adv_mom_5 & 1086 ) * & 1087 ( v(k,j,i+2) + v(k,j,i-3) ) & 1088 ) 1089 1090 diss_l_v(k,j,tn) = - ABS( u_comp ) * ( & 1091 ( 10.0 * IBITS(wall_flags_0(k,j,i),20,1) * adv_mom_5 & 1092 + 3.0 * IBITS(wall_flags_0(k,j,i),19,1) * adv_mom_3 & 1093 + IBITS(wall_flags_0(k,j,i),18,1) * adv_mom_1 & 1094 ) * & 1095 ( v(k,j,i) - v(k,j,i-1) ) & 1096 - ( 5.0 * IBITS(wall_flags_0(k,j,i),20,1) * adv_mom_5 & 1097 + IBITS(wall_flags_0(k,j,i),19,1) * adv_mom_3 & 1098 ) * & 1099 ( v(k,j,i+1) - v(k,j,i-2) ) & 1100 + ( IBITS(wall_flags_0(k,j,i),20,1) * adv_mom_5 & 1101 ) * & 1102 ( v(k,j,i+2) - v(k,j,i-3) ) & 1103 ) 1104 1105 ENDDO 1106 1107 DO k = nzb_max+1, nzt 1108 1109 u_comp = u(k,j-1,i) + u(k,j,i) - gu 1110 flux_l_v(k,j,tn) = u_comp * ( & 1215 1111 37.0 * ( v(k,j,i) + v(k,j,i-1) ) & 1216 1112 - 8.0 * ( v(k,j,i+1) + v(k,j,i-2) ) & 1217 1113 + ( v(k,j,i+2) + v(k,j,i-3) ) ) * adv_mom_5 1218 diss_l_v(k,j,tn) = - ABS( u_comp ) * ( 1114 diss_l_v(k,j,tn) = - ABS( u_comp ) * ( & 1219 1115 10.0 * ( v(k,j,i) - v(k,j,i-1) ) & 1220 1116 - 5.0 * ( v(k,j,i+1) - v(k,j,i-2) ) & 1221 1117 + ( v(k,j,i+2) - v(k,j,i-3) ) ) * adv_mom_5 1118 1222 1119 ENDDO 1223 1120 1224 1121 ENDIF 1122 ! 1123 !-- Compute southside fluxes for the respective boundary. 1124 IF ( j == nysv ) THEN 1225 1125 1226 IF ( j == nysv .AND. .NOT. degraded_s ) THEN 1227 1228 DO k = nzb_v_inner(j,i)+1, nzt 1229 v_comp_l = v(k,j,i) + v(k,j-1,i) - gv 1230 flux_s_v(k,tn) = v_comp_l * ( & 1126 DO k = nzb+1, nzb_max 1127 1128 v_comp_l = v(k,j,i) + v(k,j-1,i) - gv 1129 flux_s_v(k,tn) = v_comp_l * ( & 1130 ( 37.0 * IBITS(wall_flags_0(k,j,i),23,1) * adv_mom_5 & 1131 + 7.0 * IBITS(wall_flags_0(k,j,i),22,1) * adv_mom_3 & 1132 + IBITS(wall_flags_0(k,j,i),21,1) * adv_mom_1 & 1133 ) * & 1134 ( v(k,j,i) + v(k,j-1,i) ) & 1135 - ( 8.0 * IBITS(wall_flags_0(k,j,i),23,1) * adv_mom_5 & 1136 + IBITS(wall_flags_0(k,j,i),22,1) * adv_mom_3 & 1137 ) * & 1138 ( v(k,j+1,i) + v(k,j-2,i) ) & 1139 + ( IBITS(wall_flags_0(k,j,i),23,1) * adv_mom_5 & 1140 ) * & 1141 ( v(k,j+2,i) + v(k,j-3,i) ) & 1142 ) 1143 1144 diss_s_v(k,tn) = - ABS( v_comp_l ) * ( & 1145 ( 10.0 * IBITS(wall_flags_0(k,j,i),23,1) * adv_mom_5 & 1146 + 3.0 * IBITS(wall_flags_0(k,j,i),22,1) * adv_mom_3 & 1147 + IBITS(wall_flags_0(k,j,i),21,1) * adv_mom_1 & 1148 ) * & 1149 ( v(k,j,i) - v(k,j-1,i) ) & 1150 - ( 5.0 * IBITS(wall_flags_0(k,j,i),23,1) * adv_mom_5 & 1151 + IBITS(wall_flags_0(k,j,i),22,1) * adv_mom_3 & 1152 ) * & 1153 ( v(k,j+1,i) - v(k,j-2,i) ) & 1154 + ( IBITS(wall_flags_0(k,j,i),23,1) * adv_mom_5 & 1155 ) * & 1156 ( v(k,j+2,i) - v(k,j-3,i) ) & 1157 ) 1158 1159 ENDDO 1160 1161 DO k = nzb_max+1, nzt 1162 1163 v_comp_l = v(k,j,i) + v(k,j-1,i) - gv 1164 flux_s_v(k,tn) = v_comp_l * ( & 1231 1165 37.0 * ( v(k,j,i) + v(k,j-1,i) ) & 1232 1166 - 8.0 * ( v(k,j+1,i) + v(k,j-2,i) ) & 1233 1167 + ( v(k,j+2,i) + v(k,j-3,i) ) ) * adv_mom_5 1234 diss_s_v(k,tn) = - ABS( v_comp_l ) * ( 1168 diss_s_v(k,tn) = - ABS( v_comp_l ) * ( & 1235 1169 10.0 * ( v(k,j,i) - v(k,j-1,i) ) & 1236 1170 - 5.0 * ( v(k,j+1,i) - v(k,j-2,i) ) & 1237 1171 + ( v(k,j+2,i) - v(k,j-3,i) ) ) * adv_mom_5 1172 1238 1173 ENDDO 1239 1174 1240 1175 ENDIF 1241 ! 1242 !-- Now compute the tendency terms for the horizontal parts. 1243 DO k = nzb_v_inner(j,i)+1, nzt 1176 1177 flux_t(0) = 0.0 1178 diss_t(0) = 0.0 1179 flux_d = 0.0 1180 diss_d = 0.0 1181 ! 1182 !-- Now compute the fluxes and tendency terms for the horizontal and 1183 !-- verical parts. 1184 DO k = nzb+1, nzb_max 1185 1186 u_comp = u(k,j-1,i+1) + u(k,j,i+1) - gu 1187 flux_r(k) = u_comp * ( & 1188 ( 37.0 * IBITS(wall_flags_0(k,j,i),20,1) * adv_mom_5 & 1189 + 7.0 * IBITS(wall_flags_0(k,j,i),19,1) * adv_mom_3 & 1190 + IBITS(wall_flags_0(k,j,i),18,1) * adv_mom_1 & 1191 ) * & 1192 ( v(k,j,i+1) + v(k,j,i) ) & 1193 - ( 8.0 * IBITS(wall_flags_0(k,j,i),20,1) * adv_mom_5 & 1194 + IBITS(wall_flags_0(k,j,i),19,1) * adv_mom_3 & 1195 ) * & 1196 ( v(k,j,i+2) + v(k,j,i-1) ) & 1197 + ( IBITS(wall_flags_0(k,j,i),20,1) * adv_mom_5 & 1198 ) * & 1199 ( v(k,j,i+3) + v(k,j,i-2) ) & 1200 ) 1201 1202 diss_r(k) = - ABS( u_comp ) * ( & 1203 ( 10.0 * IBITS(wall_flags_0(k,j,i),20,1) * adv_mom_5 & 1204 + 3.0 * IBITS(wall_flags_0(k,j,i),19,1) * adv_mom_3 & 1205 + IBITS(wall_flags_0(k,j,i),18,1) * adv_mom_1 & 1206 ) * & 1207 ( v(k,j,i+1) - v(k,j,i) ) & 1208 - ( 5.0 * IBITS(wall_flags_0(k,j,i),20,1) * adv_mom_5 & 1209 + IBITS(wall_flags_0(k,j,i),19,1) * adv_mom_3 & 1210 ) * & 1211 ( v(k,j,i+2) - v(k,j,i-1) ) & 1212 + ( IBITS(wall_flags_0(k,j,i),20,1) * adv_mom_5 & 1213 ) * & 1214 ( v(k,j,i+3) - v(k,j,i-2) ) & 1215 ) 1216 1217 v_comp(k) = v(k,j+1,i) + v(k,j,i) 1218 flux_n(k) = ( v_comp(k) - gv ) * ( & 1219 ( 37.0 * IBITS(wall_flags_0(k,j,i),23,1) * adv_mom_5 & 1220 + 7.0 * IBITS(wall_flags_0(k,j,i),22,1) * adv_mom_3 & 1221 + IBITS(wall_flags_0(k,j,i),21,1) * adv_mom_1 & 1222 ) * & 1223 ( v(k,j+1,i) + v(k,j,i) ) & 1224 - ( 8.0 * IBITS(wall_flags_0(k,j,i),23,1) * adv_mom_5 & 1225 + IBITS(wall_flags_0(k,j,i),22,1) * adv_mom_3 & 1226 ) * & 1227 ( v(k,j+2,i) + v(k,j-1,i) ) & 1228 + ( IBITS(wall_flags_0(k,j,i),23,1) * adv_mom_5 & 1229 ) * & 1230 ( v(k,j+3,i) + v(k,j-2,i) ) & 1231 ) 1232 1233 diss_n(k) = - ABS( v_comp(k) - gv ) * ( & 1234 ( 10.0 * IBITS(wall_flags_0(k,j,i),23,1) * adv_mom_5 & 1235 + 3.0 * IBITS(wall_flags_0(k,j,i),22,1) * adv_mom_3 & 1236 + IBITS(wall_flags_0(k,j,i),21,1) * adv_mom_1 & 1237 ) * & 1238 ( v(k,j+1,i) - v(k,j,i) ) & 1239 - ( 5.0 * IBITS(wall_flags_0(k,j,i),23,1) * adv_mom_5 & 1240 + IBITS(wall_flags_0(k,j,i),22,1) * adv_mom_3 & 1241 ) * & 1242 ( v(k,j+2,i) - v(k,j-1,i) ) & 1243 + ( IBITS(wall_flags_0(k,j,i),23,1) * adv_mom_5 & 1244 ) * & 1245 ( v(k,j+3,i) - v(k,j-2,i) ) & 1246 ) 1247 ! 1248 !-- k index has to be modified near bottom and top, else array 1249 !-- subscripts will be exceeded. 1250 k_ppp = k + 3 * IBITS(wall_flags_0(k,j,i),26,1) 1251 k_pp = k + 2 * ( 1 - IBITS(wall_flags_0(k,j,i),24,1) ) 1252 k_mm = k - 2 * IBITS(wall_flags_0(k,j,i),26,1) 1253 1254 w_comp = w(k,j-1,i) + w(k,j,i) 1255 flux_t(k) = w_comp * ( & 1256 ( 37.0 * IBITS(wall_flags_0(k,j,i),26,1) * adv_mom_5 & 1257 + 7.0 * IBITS(wall_flags_0(k,j,i),25,1) * adv_mom_3 & 1258 + IBITS(wall_flags_0(k,j,i),24,1) * adv_mom_1 & 1259 ) * & 1260 ( v(k+1,j,i) + v(k,j,i) ) & 1261 - ( 8.0 * IBITS(wall_flags_0(k,j,i),26,1) * adv_mom_5 & 1262 + IBITS(wall_flags_0(k,j,i),25,1) * adv_mom_3 & 1263 ) * & 1264 ( v(k_pp,j,i) + v(k-1,j,i) ) & 1265 + ( IBITS(wall_flags_0(k,j,i),26,1) * adv_mom_5 & 1266 ) * & 1267 ( v(k_ppp,j,i) + v(k_mm,j,i) ) & 1268 ) 1269 1270 diss_t(k) = - ABS( w_comp ) * ( & 1271 ( 10.0 * IBITS(wall_flags_0(k,j,i),26,1) * adv_mom_5 & 1272 + 3.0 * IBITS(wall_flags_0(k,j,i),25,1) * adv_mom_3 & 1273 + IBITS(wall_flags_0(k,j,i),24,1) * adv_mom_1 & 1274 ) * & 1275 ( v(k+1,j,i) - v(k,j,i) ) & 1276 - ( 5.0 * IBITS(wall_flags_0(k,j,i),26,1) * adv_mom_5 & 1277 + IBITS(wall_flags_0(k,j,i),25,1) * adv_mom_3 & 1278 ) * & 1279 ( v(k_pp,j,i) - v(k-1,j,i) ) & 1280 + ( IBITS(wall_flags_0(k,j,i),26,1) * adv_mom_5 & 1281 ) * & 1282 ( v(k_ppp,j,i) - v(k_mm,j,i) ) & 1283 ) 1284 ! 1285 !-- Calculate the divergence of the velocity field. A respective 1286 !-- correction is needed to overcome numerical instabilities introduced 1287 !-- by a not sufficient reduction of divergences near topography. 1288 div = ( ( u_comp + gu - ( u(k,j-1,i) + u(k,j,i) ) ) * ddx & 1289 + ( v_comp(k) - ( v(k,j,i) + v(k,j-1,i) ) ) * ddy & 1290 + ( w_comp - ( w(k-1,j-1,i) + w(k-1,j,i) ) ) * ddzw(k) & 1291 ) * 0.5 1292 1244 1293 tend(k,j,i) = tend(k,j,i) - ( & 1245 1294 ( flux_r(k) + diss_r(k) & 1246 - flux_l_v(k,j,tn) - diss_l_v(k,j,tn) ) * ddx 1295 - flux_l_v(k,j,tn) - diss_l_v(k,j,tn) ) * ddx & 1247 1296 + ( flux_n(k) + diss_n(k) & 1248 - flux_s_v(k,tn) - diss_s_v(k,tn) ) * ddy ) 1249 1297 - flux_s_v(k,tn) - diss_s_v(k,tn) ) * ddy & 1298 + ( flux_t(k) + diss_t(k) & 1299 - flux_d - diss_d ) * ddzw(k) & 1300 ) + v(k,j,i) * div 1301 1250 1302 flux_l_v(k,j,tn) = flux_r(k) 1251 1303 diss_l_v(k,j,tn) = diss_r(k) 1252 1304 flux_s_v(k,tn) = flux_n(k) 1253 1305 diss_s_v(k,tn) = diss_n(k) 1254 1255 ! 1256 !-- Statistical Evaluation of v'v'. The factor has to be applied for 1306 flux_d = flux_t(k) 1307 diss_d = diss_t(k) 1308 1309 ! 1310 !-- Statistical Evaluation of v'v'. The factor has to be applied for 1257 1311 !-- right evaluation when gallilei_trans = .T. . 1258 1259 sums_vs2_ws_l(k,tn) = sums_vs2_ws_l(k,tn) & 1312 sums_vs2_ws_l(k,tn) = sums_vs2_ws_l(k,tn) & 1260 1313 + ( flux_n(k) & 1261 1314 * ( v_comp(k) - 2.0 * hom(k,1,2,0) ) & … … 1265 1318 / ( ABS( v_comp(k) - gv ) +1.0E-20 ) ) & 1266 1319 * weight_substep(intermediate_timestep_count) 1320 ! 1321 !-- Statistical Evaluation of w'v'. 1322 sums_wsvs_ws_l(k,tn) = sums_wsvs_ws_l(k,tn) & 1323 + ( flux_t(k) + diss_t(k) ) & 1324 * weight_substep(intermediate_timestep_count) 1267 1325 1268 1326 ENDDO 1269 sums_vs2_ws_l(nzb_v_inner(j,i),tn) = sums_vs2_ws_l(nzb_v_inner(j,i)+1,tn) 1270 1271 ! 1272 !-- Vertical advection, degradation of order near surface and top. 1273 !-- The fluxes flux_d and diss_d at the surface are 0. Due to reasons of 1274 !-- statistical evaluation the top flux at the surface should be 0 1275 flux_t(nzb_v_inner(j,i)) = 0.0 !statistical reasons 1276 diss_t(nzb_v_inner(j,i)) = 0.0 1277 ! 1278 !-- 2nd order scheme (bottom) 1279 k = nzb_v_inner(j,i)+1 1280 flux_d = flux_t(k-1) 1281 diss_d = diss_t(k-1) 1282 w_comp = w(k,j-1,i) + w(k,j,i) 1283 flux_t(k) = w_comp * ( v(k+1,j,i) + v(k,j,i) ) * 0.25 1284 diss_t(k) = diss_2nd( v(k+2,j,i), v(k+1,j,i), v(k,j,i), 0.0, 0.0, & 1285 w_comp, 0.25, ddzw(k) ) 1286 1287 tend(k,j,i) = tend(k,j,i) - ( flux_t(k) + diss_t(k) & 1288 - flux_d - diss_d ) * ddzw(k) 1289 1290 ! 1291 !-- WS3 as an intermediate step (bottom) 1292 k = nzb_v_inner(j,i)+2 1293 flux_d = flux_t(k-1) 1294 diss_d = diss_t(k-1) 1295 w_comp = w(k,j-1,i) + w(k,j,i) 1296 flux_t(k) = w_comp * ( & 1297 7.0 * ( v(k+1,j,i) + v(k,j,i) ) & 1298 - ( v(k+2,j,i) + v(k-1,j,i) ) ) * adv_mom_3 1299 diss_t(k) = - ABS( w_comp ) * ( & 1300 3.0 * ( v(k+1,j,i) - v(k,j,i) ) & 1301 - ( v(k+2,j,i) - v(k-1,j,i) ) ) * adv_mom_3 1302 1303 tend(k,j,i) = tend(k,j,i) - ( flux_t(k) + diss_t(k) & 1304 - flux_d - diss_d ) * ddzw(k) 1305 ! 1306 !-- WS5 1307 DO k = nzb_v_inner(j,i)+3, nzt-2 1308 flux_d = flux_t(k-1) 1309 diss_d = diss_t(k-1) 1327 1328 DO k = nzb_max+1, nzt 1329 1330 u_comp = u(k,j-1,i+1) + u(k,j,i+1) - gu 1331 flux_r(k) = u_comp * ( & 1332 37.0 * ( v(k,j,i+1) + v(k,j,i) ) & 1333 - 8.0 * ( v(k,j,i+2) + v(k,j,i-1) ) & 1334 + ( v(k,j,i+3) + v(k,j,i-2) ) ) * adv_mom_5 1335 1336 diss_r(k) = - ABS( u_comp ) * ( & 1337 10.0 * ( v(k,j,i+1) - v(k,j,i) ) & 1338 - 5.0 * ( v(k,j,i+2) - v(k,j,i-1) ) & 1339 + ( v(k,j,i+3) - v(k,j,i-2) ) ) * adv_mom_5 1340 1341 1342 v_comp(k) = v(k,j+1,i) + v(k,j,i) 1343 flux_n(k) = ( v_comp(k) - gv ) * ( & 1344 37.0 * ( v(k,j+1,i) + v(k,j,i) ) & 1345 - 8.0 * ( v(k,j+2,i) + v(k,j-1,i) ) & 1346 + ( v(k,j+3,i) + v(k,j-2,i) ) ) * adv_mom_5 1347 1348 diss_n(k) = - ABS( v_comp(k) - gv ) * ( & 1349 10.0 * ( v(k,j+1,i) - v(k,j,i) ) & 1350 - 5.0 * ( v(k,j+2,i) - v(k,j-1,i) ) & 1351 + ( v(k,j+3,i) - v(k,j-2,i) ) ) * adv_mom_5 1352 ! 1353 !-- k index has to be modified near bottom and top, else array 1354 !-- subscripts will be exceeded. 1355 k_ppp = k + 3 * IBITS(wall_flags_0(k,j,i),26,1) 1356 k_pp = k + 2 * ( 1 - IBITS(wall_flags_0(k,j,i),24,1) ) 1357 k_mm = k - 2 * IBITS(wall_flags_0(k,j,i),26,1) 1358 1310 1359 w_comp = w(k,j-1,i) + w(k,j,i) 1311 flux_t(k) = w_comp * ( & 1312 37.0 * ( v(k+1,j,i) + v(k,j,i) ) & 1313 - 8.0 * ( v(k+2,j,i) + v(k-1,j,i) ) & 1314 + ( v(k+3,j,i) + v(k-2,j,i) ) ) * adv_mom_5 1315 diss_t(k) = - ABS( w_comp ) * ( & 1316 10.0 * ( v(k+1,j,i) - v(k,j,i) ) & 1317 - 5.0 * ( v(k+2,j,i) - v(k-1,j,i) ) & 1318 + ( v(k+3,j,i) - v(k-2,j,i) ) ) * adv_mom_5 1319 1320 tend(k,j,i) = tend(k,j,i) - ( flux_t(k) + diss_t(k) & 1321 - flux_d - diss_d ) * ddzw(k) 1360 flux_t(k) = w_comp * ( & 1361 ( 37.0 * IBITS(wall_flags_0(k,j,i),26,1) * adv_mom_5 & 1362 + 7.0 * IBITS(wall_flags_0(k,j,i),25,1) * adv_mom_3 & 1363 + IBITS(wall_flags_0(k,j,i),24,1) * adv_mom_1 & 1364 ) * & 1365 ( v(k+1,j,i) + v(k,j,i) ) & 1366 - ( 8.0 * IBITS(wall_flags_0(k,j,i),26,1) * adv_mom_5 & 1367 + IBITS(wall_flags_0(k,j,i),25,1) * adv_mom_3 & 1368 ) * & 1369 ( v(k_pp,j,i) + v(k-1,j,i) ) & 1370 + ( IBITS(wall_flags_0(k,j,i),26,1) * adv_mom_5 & 1371 ) * & 1372 ( v(k_ppp,j,i) + v(k_mm,j,i) ) & 1373 ) 1374 1375 diss_t(k) = - ABS( w_comp ) * ( & 1376 ( 10.0 * IBITS(wall_flags_0(k,j,i),26,1) * adv_mom_5 & 1377 + 3.0 * IBITS(wall_flags_0(k,j,i),25,1) * adv_mom_3 & 1378 + IBITS(wall_flags_0(k,j,i),24,1) * adv_mom_1 & 1379 ) * & 1380 ( v(k+1,j,i) - v(k,j,i) ) & 1381 - ( 5.0 * IBITS(wall_flags_0(k,j,i),26,1) * adv_mom_5 & 1382 + IBITS(wall_flags_0(k,j,i),25,1) * adv_mom_3 & 1383 ) * & 1384 ( v(k_pp,j,i) - v(k-1,j,i) ) & 1385 + ( IBITS(wall_flags_0(k,j,i),26,1) * adv_mom_5 & 1386 ) * & 1387 ( v(k_ppp,j,i) - v(k_mm,j,i) ) & 1388 ) 1389 ! 1390 !-- Calculate the divergence of the velocity field. A respective 1391 !-- correction is needed to overcome numerical instabilities introduced 1392 !-- by a not sufficient reduction of divergences near topography. 1393 div = ( ( u_comp + gu - ( u(k,j-1,i) + u(k,j,i) ) ) * ddx & 1394 + ( v_comp(k) - ( v(k,j,i) + v(k,j-1,i) ) ) * ddy & 1395 + ( w_comp - ( w(k-1,j-1,i) + w(k-1,j,i) ) ) * ddzw(k) & 1396 ) * 0.5 1397 1398 tend(k,j,i) = tend(k,j,i) - ( & 1399 ( flux_r(k) + diss_r(k) & 1400 - flux_l_v(k,j,tn) - diss_l_v(k,j,tn) ) * ddx & 1401 + ( flux_n(k) + diss_n(k) & 1402 - flux_s_v(k,tn) - diss_s_v(k,tn) ) * ddy & 1403 + ( flux_t(k) + diss_t(k) & 1404 - flux_d - diss_d ) * ddzw(k) & 1405 ) + v(k,j,i) * div 1406 1407 flux_l_v(k,j,tn) = flux_r(k) 1408 diss_l_v(k,j,tn) = diss_r(k) 1409 flux_s_v(k,tn) = flux_n(k) 1410 diss_s_v(k,tn) = diss_n(k) 1411 flux_d = flux_t(k) 1412 diss_d = diss_t(k) 1413 1414 ! 1415 !-- Statistical Evaluation of v'v'. The factor has to be applied for 1416 !-- right evaluation when gallilei_trans = .T. . 1417 sums_vs2_ws_l(k,tn) = sums_vs2_ws_l(k,tn) & 1418 + ( flux_n(k) & 1419 * ( v_comp(k) - 2.0 * hom(k,1,2,0) ) & 1420 / ( v_comp(k) - gv + 1.0E-20 ) & 1421 + diss_n(k) & 1422 * ABS( v_comp(k) - 2.0 * hom(k,1,2,0) ) & 1423 / ( ABS( v_comp(k) - gv ) +1.0E-20 ) ) & 1424 * weight_substep(intermediate_timestep_count) 1425 ! 1426 !-- Statistical Evaluation of w'v'. 1427 sums_wsvs_ws_l(k,tn) = sums_wsvs_ws_l(k,tn) & 1428 + ( flux_t(k) + diss_t(k) ) & 1429 * weight_substep(intermediate_timestep_count) 1430 1322 1431 ENDDO 1323 ! 1324 !-- WS3 as an intermediate step (top) 1325 k = nzt - 1 1326 flux_d = flux_t(k-1) 1327 diss_d = diss_t(k-1) 1328 w_comp = w(k,j-1,i) + w(k,j,i) 1329 flux_t(k) = w_comp * ( & 1330 7.0 * ( v(k+1,j,i) + v(k,j,i) ) & 1331 - ( v(k+2,j,i) + v(k-1,j,i) ) ) * adv_mom_3 1332 diss_t(k) = - ABS( w_comp ) * ( & 1333 3.0 * ( v(k+1,j,i) - v(k,j,i) ) & 1334 - ( v(k+2,j,i) - v(k-1,j,i) ) ) * adv_mom_3 1335 tend(k,j,i) = tend(k,j,i) - ( flux_t(k) + diss_t(k) & 1336 - flux_d - diss_d ) * ddzw(k) 1337 ! 1338 !-- 2nd order scheme (top) 1339 k = nzt 1340 flux_d = flux_t(k-1) 1341 diss_d = diss_t(k-1) 1342 w_comp = w(k,j-1,i)+w(k,j,i) 1343 flux_t(k) = w_comp * ( v(k+1,j,i) + v(k,j,i) ) * 0.25 1344 diss_t(k) = diss_2nd( v(k+1,j,i), v(k+1,j,i), v(k,j,i), v(k-1,j,i), & 1345 v(k-2,j,i), w_comp, 0.25, ddzw(k) ) 1346 1347 tend(k,j,i) = tend(k,j,i) - ( flux_t(k) + diss_t(k) & 1348 - flux_d - diss_d ) * ddzw(k) 1349 1350 DO k = nzb_v_inner(j,i), nzt 1351 sums_wsvs_ws_l(k,tn) = sums_wsvs_ws_l(k,tn) & 1352 + ( flux_t(k) + diss_t(k) ) & 1353 * weight_substep(intermediate_timestep_count) 1354 ENDDO 1432 sums_vs2_ws_l(nzb,tn) = sums_vs2_ws_l(nzb+1,tn) 1433 1355 1434 1356 1435 END SUBROUTINE advec_v_ws_ij … … 1372 1451 IMPLICIT NONE 1373 1452 1374 INTEGER :: i, i_omp, j, k, tn 1375 LOGICAL :: degraded_l, degraded_s 1376 REAL :: gu, gv, flux_d, diss_d, u_comp, v_comp, w_comp 1453 INTEGER :: i, i_omp, j, k, tn, k_ppp, k_pp, k_mm 1454 REAL :: gu, gv, flux_d, diss_d, u_comp, v_comp, w_comp, div 1377 1455 REAL, DIMENSION(nzb:nzt+1) :: flux_t, diss_t, flux_r, diss_r, flux_n, & 1378 1456 diss_n 1379 1380 degraded_l = .FALSE.1381 degraded_s = .FALSE.1382 1457 1383 1458 gu = 2.0 * u_gtrans 1384 1459 gv = 2.0 * v_gtrans 1385 1460 1386 1387 IF ( boundary_flags(j,i) /= 0 ) THEN 1388 ! 1389 !-- Degrade the order for Dirichlet bc. at the outflow boundary 1390 SELECT CASE ( boundary_flags(j,i) ) 1391 1392 CASE ( 1 ) 1393 DO k = nzb_w_inner(j,i)+1, nzt 1394 u_comp = u(k+1,j,i+1) + u(k,j,i+1) - gu 1395 flux_r(k) = u_comp * ( & 1396 7.0 * ( w(k,j,i+1) + w(k,j,i) ) & 1397 - ( w(k,j,i+2) + w(k,j,i-1) ) ) * adv_mom_3 1398 diss_r(k) = -ABS( u_comp ) * ( & 1399 3.0 * ( w(k,j,i+1) - w(k,j,i) ) & 1400 - ( w(k,j,i+2) - w(k,j,i-1) ) ) * adv_mom_3 1401 ENDDO 1402 1403 CASE ( 2 ) 1404 DO k = nzb_w_inner(j,i)+1, nzt 1405 u_comp = u(k+1,j,i+1) + u(k,j,i+1) - gu 1406 flux_r(k) = u_comp * ( w(k,j,i+1) + w(k,j,i) ) * 0.25 1407 diss_r(k) = diss_2nd( w(k,j,i+1), w(k,j,i+1), w(k,j,i), & 1408 w(k,j,i-1), w(k,j,i-2), u_comp, & 1409 0.25, ddx ) 1410 ENDDO 1411 1412 CASE ( 3 ) 1413 DO k = nzb_w_inner(j,i)+1, nzt 1414 v_comp = v(k+1,j+1,i) + v(k,j+1,i) - gv 1415 flux_n(k) = v_comp * ( & 1416 7.0 * ( w(k,j+1,i) + w(k,j,i) ) & 1417 - ( w(k,j+2,i) + w(k,j-1,i) ) ) * adv_mom_3 1418 diss_n(k) = -ABS( v_comp ) * ( & 1419 3.0 * ( w(k,j+1,i) - w(k,j,i) ) & 1420 - ( w(k,j+2,i) - w(k,j-1,i) ) ) * adv_mom_3 1421 ENDDO 1422 1423 CASE ( 4 ) 1424 DO k = nzb_w_inner(j,i)+1, nzt 1425 v_comp = v(k+1,j+1,i) + v(k,j+1,i) - gv 1426 flux_n(k) = v_comp * ( w(k,j+1,i) + w(k,j,i) ) * 0.25 1427 diss_n(k) = diss_2nd( w(k,j+1,i), w(k,j+1,i), w(k,j,i), & 1428 w(k,j-1,i), w(k,j-2,i), v_comp, & 1429 0.25, ddy ) 1430 ENDDO 1431 1432 CASE ( 5 ) 1433 DO k = nzb_w_inner(j,i)+1, nzt 1434 u_comp = u(k+1,j,i+1) + u(k,j,i+1) - gu 1435 flux_r(k) = u_comp * ( & 1436 7.0 * ( w(k,j,i+1) + w(k,j,i) ) & 1437 - ( w(k,j,i+2) + w(k,j,i-1) ) ) * adv_mom_3 1438 diss_r(k) = - ABS( u_comp ) * ( & 1439 3.0 * ( w(k,j,i+1) - w(k,j,i) ) & 1440 - ( w(k,j,i+2) - w(k,j,i-1) ) ) * adv_mom_3 1441 ENDDO 1442 1443 CASE ( 6 ) 1444 DO k = nzb_w_inner(j,i)+1, nzt 1445 ! 1446 !-- Compute leftside fluxes for the left boundary of PE domain 1447 u_comp = u(k+1,j,i+1) + u(k,j,i+1) - gu 1448 flux_r(k) = u_comp *( & 1449 7.0 * ( w(k,j,i+1) + w(k,j,i) ) & 1450 - ( w(k,j,i+2) + w(k,j,i-1) ) ) * adv_mom_3 1451 diss_r(k) = - ABS( u_comp ) * ( & 1452 3.0 * ( w(k,j,i+1) - w(k,j,i) ) & 1453 - ( w(k,j,i+2) - w(k,j,i-1) ) ) * adv_mom_3 1454 1455 u_comp = u(k+1,j,i) + u(k,j,i) - gu 1456 flux_l_w(k,j,tn) = u_comp * ( w(k,j,i) + w(k,j,i-1) ) * 0.25 1457 diss_l_w(k,j,tn) = diss_2nd( w(k,j,i+2), w(k,j,i+1), w(k,j,i), & 1458 w(k,j,i-1), w(k,j,i-1), u_comp, & 1459 0.25, ddx ) 1460 ENDDO 1461 degraded_l = .TRUE. 1462 1463 CASE ( 7 ) 1464 DO k = nzb_w_inner(j,i)+1, nzt 1465 v_comp = v(k+1,j+1,i) + v(k,j+1,i) - gv 1466 flux_n(k) = v_comp *( & 1467 7.0 * ( w(k,j+1,i) + w(k,j,i) ) & 1468 - ( w(k,j+2,i) + w(k,j-1,i) ) ) * adv_mom_3 1469 diss_n(k) = - ABS( v_comp ) * ( & 1470 3.0 * ( w(k,j+1,i) - w(k,j,i) ) & 1471 - ( w(k,j+2,i) - w(k,j-1,i) ) ) * adv_mom_3 1472 ENDDO 1473 1474 CASE ( 8 ) 1475 DO k = nzb_w_inner(j,i)+1, nzt 1476 v_comp = v(k+1,j+1,i) + v(k,j+1,i) - gv 1477 flux_n(k) = v_comp * ( & 1478 7.0 * ( w(k,j+1,i) + w(k,j,i) ) & 1479 - ( w(k,j+2,i) + w(k,j-1,i) ) ) * adv_mom_3 1480 diss_n(k) = - ABS( v_comp ) * ( & 1481 3.0 * ( w(k,j+1,i) - w(k,j,i) ) & 1482 - ( w(k,j+2,i) - w(k,j-1,i) ) ) * adv_mom_3 1483 ! 1484 !-- Compute southside fluxes for the south boundary of PE domain 1485 v_comp = v(k+1,j,i) + v(k,j,i) - gv 1486 flux_s_w(k,tn) = v_comp * ( w(k,j,i) + w(k,j-1,i) ) * 0.25 1487 diss_s_w(k,tn) = diss_2nd( w(k,j+2,i), w(k,j+1,i), w(k,j,i), & 1488 w(k,j-1,i), w(k,j-1,i), v_comp, & 1489 0.25, ddy ) 1490 ENDDO 1491 degraded_s = .TRUE. 1492 1493 CASE DEFAULT 1494 1495 END SELECT 1496 ! 1497 !-- Compute the crosswise 5th order fluxes at the outflow 1498 IF ( boundary_flags(j,i) == 1 .OR. boundary_flags(j,i) == 2 .OR. & 1499 boundary_flags(j,i) == 5 .OR. boundary_flags(j,i) == 6 ) THEN 1500 1501 DO k = nzb_w_inner(j,i)+1, nzt 1502 v_comp = v(k+1,j+1,i) + v(k,j+1,i) - gv 1503 flux_n(k) = v_comp * ( & 1504 37.0 * ( w(k,j+1,i) + w(k,j,i) ) & 1505 - 8.0 * ( w(k,j+2,i) + w(k,j-1,i) ) & 1506 + ( w(k,j+3,i) + w(k,j-2,i) ) ) * adv_mom_5 1507 diss_n(k) = - ABS( v_comp ) * ( & 1508 10.0 * ( w(k,j+1,i) - w(k,j,i) ) & 1509 - 5.0 * ( w(k,j+2,i) - w(k,j-1,i) ) & 1510 + ( w(k,j+3,i) - w(k,j-2,i) ) ) * adv_mom_5 1511 ENDDO 1512 1513 ELSE 1514 1515 DO k = nzb_w_inner(j,i)+1, nzt 1516 u_comp = u(k+1,j,i+1) + u(k,j,i+1) - gu 1517 flux_r(k) = u_comp * ( & 1518 37.0 * ( w(k,j,i+1) + w(k,j,i) ) & 1519 - 8.0 * ( w(k,j,i+2) + w(k,j,i-1) ) & 1520 + ( w(k,j,i+3) + w(k,j,i-2) ) ) * adv_mom_5 1521 diss_r(k) = - ABS( u_comp ) * ( & 1522 10.0 * ( w(k,j,i+1) - w(k,j,i) ) & 1523 - 5.0 * ( w(k,j,i+2) - w(k,j,i-1) ) & 1524 + ( w(k,j,i+3) - w(k,j,i-2) ) ) * adv_mom_5 1525 ENDDO 1526 1527 ENDIF 1528 1529 ELSE 1530 ! 1531 !-- Compute the fifth order fluxes for the interior of PE domain. 1532 DO k = nzb_w_inner(j,i)+1, nzt 1533 u_comp = u(k+1,j,i+1) + u(k,j,i+1) - gu 1534 flux_r(k) = u_comp * ( & 1535 37.0 * ( w(k,j,i+1) + w(k,j,i) ) & 1536 - 8.0 * ( w(k,j,i+2) + w(k,j,i-1) ) & 1537 + ( w(k,j,i+3) + w(k,j,i-2) ) ) * adv_mom_5 1538 diss_r(k) = - ABS( u_comp ) * ( & 1539 10.0 * ( w(k,j,i+1) - w(k,j,i) ) & 1540 - 5.0 * ( w(k,j,i+2) - w(k,j,i-1) ) & 1541 + ( w(k,j,i+3) - w(k,j,i-2) ) ) * adv_mom_5 1542 1543 v_comp = v(k+1,j+1,i) + v(k,j+1,i) - gv 1544 flux_n(k) = v_comp * ( & 1545 37.0 * ( w(k,j+1,i) + w(k,j,i) ) & 1546 - 8.0 * ( w(k,j+2,i) + w(k,j-1,i) ) & 1547 + ( w(k,j+3,i) + w(k,j-2,i) ) ) * adv_mom_5 1548 diss_n(k) = - ABS( v_comp ) * ( & 1549 10.0 * ( w(k,j+1,i) - w(k,j,i) ) & 1550 - 5.0 * ( w(k,j+2,i) - w(k,j-1,i) ) & 1551 + ( w(k,j+3,i) - w(k,j-2,i) ) ) * adv_mom_5 1552 ENDDO 1553 1554 ENDIF 1555 ! 1556 !-- Compute left- and southside fluxes for the respective boundary 1557 IF ( j == nys .AND. .NOT. degraded_s ) THEN 1558 1559 DO k = nzb_w_inner(j,i)+1, nzt 1461 ! 1462 !-- Compute southside fluxes for the respective boundary. 1463 IF ( j == nys ) THEN 1464 1465 DO k = nzb+1, nzb_max 1466 1560 1467 v_comp = v(k+1,j,i) + v(k,j,i) - gv 1561 flux_s_w(k,tn) = v_comp * ( & 1468 flux_s_w(k,tn) = v_comp * ( & 1469 ( 37.0 * IBITS(wall_flags_0(k,j,i),32,1) * adv_mom_5 & 1470 + 7.0 * IBITS(wall_flags_0(k,j,i),31,1) * adv_mom_3 & 1471 + IBITS(wall_flags_0(k,j,i),30,1) * adv_mom_1 & 1472 ) * & 1473 ( w(k,j,i) + w(k,j-1,i) ) & 1474 - ( 8.0 * IBITS(wall_flags_0(k,j,i),32,1) * adv_mom_5 & 1475 + IBITS(wall_flags_0(k,j,i),31,1) * adv_mom_3 & 1476 ) * & 1477 ( w(k,j+1,i) + w(k,j-2,i) ) & 1478 + ( IBITS(wall_flags_0(k,j,i),32,1) * adv_mom_5 & 1479 ) * & 1480 ( w(k,j+2,i) + w(k,j-3,i) ) & 1481 ) 1482 1483 diss_s_w(k,tn) = - ABS( v_comp ) * ( & 1484 ( 10.0 * IBITS(wall_flags_0(k,j,i),32,1) * adv_mom_5 & 1485 + 3.0 * IBITS(wall_flags_0(k,j,i),31,1) * adv_mom_3 & 1486 + IBITS(wall_flags_0(k,j,i),30,1) * adv_mom_1 & 1487 ) * & 1488 ( w(k,j,i) - w(k,j-1,i) ) & 1489 - ( 5.0 * IBITS(wall_flags_0(k,j,i),32,1) * adv_mom_5 & 1490 + IBITS(wall_flags_0(k,j,i),31,1) * adv_mom_3 & 1491 ) * & 1492 ( w(k,j+1,i) - w(k,j-2,i) ) & 1493 + ( IBITS(wall_flags_0(k,j,i),32,1) * adv_mom_5 & 1494 ) * & 1495 ( w(k,j+2,i) - w(k,j-3,i) ) & 1496 ) 1497 1498 ENDDO 1499 1500 DO k = nzb_max+1, nzt 1501 1502 v_comp = v(k+1,j,i) + v(k,j,i) - gv 1503 flux_s_w(k,tn) = v_comp * ( & 1562 1504 37.0 * ( w(k,j,i) + w(k,j-1,i) ) & 1563 1505 - 8.0 * ( w(k,j+1,i) +w(k,j-2,i) ) & 1564 1506 + ( w(k,j+2,i) + w(k,j-3,i) ) ) * adv_mom_5 1565 diss_s_w(k,tn) = - ABS( v_comp ) * ( 1507 diss_s_w(k,tn) = - ABS( v_comp ) * ( & 1566 1508 10.0 * ( w(k,j,i) - w(k,j-1,i) ) & 1567 1509 - 5.0 * ( w(k,j+1,i) - w(k,j-2,i) ) & 1568 1510 + ( w(k,j+2,i) - w(k,j-3,i) ) ) * adv_mom_5 1569 ENDDO 1570 1511 1512 ENDDO 1513 1571 1514 ENDIF 1572 1573 IF ( i == i_omp .AND. .NOT. degraded_l ) THEN 1574 1575 DO k = nzb_w_inner(j,i)+1, nzt 1576 u_comp = u(k+1,j,i) + u(k,j,i) - gu 1577 flux_l_w(k,j,tn) = u_comp * ( & 1515 ! 1516 !-- Compute leftside fluxes for the respective boundary. 1517 IF ( i == i_omp ) THEN 1518 1519 DO k = nzb+1, nzb_max 1520 1521 u_comp = u(k+1,j,i) + u(k,j,i) - gu 1522 flux_l_w(k,j,tn) = u_comp * ( & 1523 ( 37.0 * IBITS(wall_flags_0(k,j,i),29,1) * adv_mom_5 & 1524 + 7.0 * IBITS(wall_flags_0(k,j,i),28,1) * adv_mom_3 & 1525 + IBITS(wall_flags_0(k,j,i),27,1) * adv_mom_1 & 1526 ) * & 1527 ( w(k,j,i) + w(k,j,i-1) ) & 1528 - ( 8.0 * IBITS(wall_flags_0(k,j,i),29,1) * adv_mom_5 & 1529 + IBITS(wall_flags_0(k,j,i),28,1) * adv_mom_3 & 1530 ) * & 1531 ( w(k,j,i+1) + w(k,j,i-2) ) & 1532 + ( IBITS(wall_flags_0(k,j,i),29,1) * adv_mom_5 & 1533 ) * & 1534 ( w(k,j,i+2) + w(k,j,i-3) ) & 1535 ) 1536 1537 diss_l_w(k,j,tn) = - ABS( u_comp ) * ( & 1538 ( 10.0 * IBITS(wall_flags_0(k,j,i),29,1) * adv_mom_5 & 1539 + 3.0 * IBITS(wall_flags_0(k,j,i),28,1) * adv_mom_3 & 1540 + IBITS(wall_flags_0(k,j,i),27,1) * adv_mom_1 & 1541 ) * & 1542 ( w(k,j,i) - w(k,j,i-1) ) & 1543 - ( 5.0 * IBITS(wall_flags_0(k,j,i),29,1) * adv_mom_5 & 1544 + IBITS(wall_flags_0(k,j,i),28,1) * adv_mom_3 & 1545 ) * & 1546 ( w(k,j,i+1) - w(k,j,i-2) ) & 1547 + ( IBITS(wall_flags_0(k,j,i),29,1) * adv_mom_5 & 1548 ) * & 1549 ( w(k,j,i+2) - w(k,j,i-3) ) & 1550 ) 1551 1552 ENDDO 1553 1554 DO k = nzb_max+1, nzt 1555 1556 u_comp = u(k+1,j,i) + u(k,j,i) - gu 1557 flux_l_w(k,j,tn) = u_comp * ( & 1578 1558 37.0 * ( w(k,j,i) + w(k,j,i-1) ) & 1579 1559 - 8.0 * ( w(k,j,i+1) + w(k,j,i-2) ) & 1580 1560 + ( w(k,j,i+2) + w(k,j,i-3) ) ) * adv_mom_5 1581 diss_l_w(k,j,tn) = - ABS( u_comp ) * (&1561 diss_l_w(k,j,tn) = - ABS( u_comp ) * ( & 1582 1562 10.0 * ( w(k,j,i) - w(k,j,i-1) ) & 1583 1563 - 5.0 * ( w(k,j,i+1) - w(k,j,i-2) ) & 1584 1564 + ( w(k,j,i+2) - w(k,j,i-3) ) ) * adv_mom_5 1585 ENDDO 1586 1565 1566 ENDDO 1567 1587 1568 ENDIF 1588 1569 1589 ! 1590 !-- Now compute the tendency terms for the horizontal parts. 1591 DO k = nzb_w_inner(j,i)+1, nzt 1570 flux_t(0) = 0.0 1571 diss_t(0) = 0.0 1572 flux_d = 0.0 1573 diss_d = 0.0 1574 ! 1575 !-- Now compute the fluxes and tendency terms for the horizontal 1576 !-- and vertical parts. 1577 DO k = nzb+1, nzb_max 1578 1579 u_comp = u(k+1,j,i+1) + u(k,j,i+1) - gu 1580 flux_r(k) = u_comp * ( & 1581 ( 37.0 * IBITS(wall_flags_0(k,j,i),29,1) * adv_mom_5 & 1582 + 7.0 * IBITS(wall_flags_0(k,j,i),28,1) * adv_mom_3 & 1583 + IBITS(wall_flags_0(k,j,i),27,1) * adv_mom_1 & 1584 ) * & 1585 ( w(k,j,i+1) + w(k,j,i) ) & 1586 - ( 8.0 * IBITS(wall_flags_0(k,j,i),29,1) * adv_mom_5 & 1587 + IBITS(wall_flags_0(k,j,i),28,1) * adv_mom_3 & 1588 ) * & 1589 ( w(k,j,i+2) + w(k,j,i-1) ) & 1590 + ( IBITS(wall_flags_0(k,j,i),29,1) * adv_mom_5 & 1591 ) * & 1592 ( w(k,j,i+3) + w(k,j,i-2) ) & 1593 ) 1594 1595 diss_r(k) = - ABS( u_comp ) * ( & 1596 ( 10.0 * IBITS(wall_flags_0(k,j,i),29,1) * adv_mom_5 & 1597 + 3.0 * IBITS(wall_flags_0(k,j,i),28,1) * adv_mom_3 & 1598 + IBITS(wall_flags_0(k,j,i),27,1) * adv_mom_1 & 1599 ) * & 1600 ( w(k,j,i+1) - w(k,j,i) ) & 1601 - ( 5.0 * IBITS(wall_flags_0(k,j,i),29,1) * adv_mom_5 & 1602 + IBITS(wall_flags_0(k,j,i),28,1) * adv_mom_3 & 1603 ) * & 1604 ( w(k,j,i+2) - w(k,j,i-1) ) & 1605 + ( IBITS(wall_flags_0(k,j,i),29,1) * adv_mom_5 & 1606 ) * & 1607 ( w(k,j,i+3) - w(k,j,i-2) ) & 1608 ) 1609 1610 v_comp = v(k+1,j+1,i) + v(k,j+1,i) - gv 1611 flux_n(k) = v_comp * ( & 1612 ( 37.0 * IBITS(wall_flags_0(k,j,i),32,1) * adv_mom_5 & 1613 + 7.0 * IBITS(wall_flags_0(k,j,i),31,1) * adv_mom_3 & 1614 + IBITS(wall_flags_0(k,j,i),30,1) * adv_mom_1 & 1615 ) * & 1616 ( w(k,j+1,i) + w(k,j,i) ) & 1617 - ( 8.0 * IBITS(wall_flags_0(k,j,i),32,1) * adv_mom_5 & 1618 + IBITS(wall_flags_0(k,j,i),31,1) * adv_mom_3 & 1619 ) * & 1620 ( w(k,j+2,i) + w(k,j-1,i) ) & 1621 + ( IBITS(wall_flags_0(k,j,i),32,1) * adv_mom_5 & 1622 ) * & 1623 ( w(k,j+3,i) + w(k,j-2,i) ) & 1624 ) 1625 1626 diss_n(k) = - ABS( v_comp ) * ( & 1627 ( 10.0 * IBITS(wall_flags_0(k,j,i),32,1) * adv_mom_5 & 1628 + 3.0 * IBITS(wall_flags_0(k,j,i),31,1) * adv_mom_3 & 1629 + IBITS(wall_flags_0(k,j,i),30,1) * adv_mom_1 & 1630 ) * & 1631 ( w(k,j+1,i) - w(k,j,i) ) & 1632 - ( 5.0 * IBITS(wall_flags_0(k,j,i),32,1) * adv_mom_5 & 1633 + IBITS(wall_flags_0(k,j,i),31,1) * adv_mom_3 & 1634 ) * & 1635 ( w(k,j+2,i) - w(k,j-1,i) ) & 1636 + ( IBITS(wall_flags_0(k,j,i),32,1) * adv_mom_5 & 1637 ) * & 1638 ( w(k,j+3,i) - w(k,j-2,i) ) & 1639 ) 1640 ! 1641 !-- k index has to be modified near bottom and top, else array 1642 !-- subscripts will be exceeded. 1643 k_ppp = k + 3 * IBITS(wall_flags_0(k,j,i),35,1) 1644 k_pp = k + 2 * ( 1 - IBITS(wall_flags_0(k,j,i),33,1) ) 1645 k_mm = k - 2 * IBITS(wall_flags_0(k,j,i),35,1) 1646 1647 w_comp = w(k+1,j,i) + w(k,j,i) 1648 flux_t(k) = w_comp * ( & 1649 ( 37.0 * IBITS(wall_flags_0(k,j,i),35,1) * adv_mom_5 & 1650 + 7.0 * IBITS(wall_flags_0(k,j,i),34,1) * adv_mom_3 & 1651 + IBITS(wall_flags_0(k,j,i),33,1) * adv_mom_1 & 1652 ) * & 1653 ( w(k+1,j,i) + w(k,j,i) ) & 1654 - ( 8.0 * IBITS(wall_flags_0(k,j,i),35,1) * adv_mom_5 & 1655 + IBITS(wall_flags_0(k,j,i),34,1) * adv_mom_3 & 1656 ) * & 1657 ( w(k_pp,j,i) + w(k-1,j,i) ) & 1658 + ( IBITS(wall_flags_0(k,j,i),35,1) * adv_mom_5 & 1659 ) * & 1660 ( w(k_ppp,j,i) + w(k_mm,j,i) ) & 1661 ) 1662 1663 diss_t(k) = - ABS( w_comp ) * ( & 1664 ( 10.0 * IBITS(wall_flags_0(k,j,i),35,1) * adv_mom_5 & 1665 + 3.0 * IBITS(wall_flags_0(k,j,i),34,1) * adv_mom_3 & 1666 + IBITS(wall_flags_0(k,j,i),33,1) * adv_mom_1 & 1667 ) * & 1668 ( w(k+1,j,i) - w(k,j,i) ) & 1669 - ( 5.0 * IBITS(wall_flags_0(k,j,i),35,1) * adv_mom_5 & 1670 + IBITS(wall_flags_0(k,j,i),34,1) * adv_mom_3 & 1671 ) * & 1672 ( w(k_pp,j,i) - w(k-1,j,i) ) & 1673 + ( IBITS(wall_flags_0(k,j,i),35,1) * adv_mom_5 & 1674 ) * & 1675 ( w(k_ppp,j,i) - w(k_mm,j,i) ) & 1676 ) 1677 ! 1678 !-- Calculate the divergence of the velocity field. A respective 1679 !-- correction is needed to overcome numerical instabilities introduced 1680 !-- by a not sufficient reduction of divergences near topography. 1681 div = ( ( u_comp + gu - ( u(k+1,j,i) + u(k,j,i) ) ) * ddx & 1682 + ( v_comp + gv - ( v(k+1,j,i) + v(k,j,i) ) ) * ddy & 1683 + ( w_comp - ( w(k,j,i) + w(k-1,j,i) ) ) * ddzu(k+1) & 1684 ) * 0.5 1685 1592 1686 tend(k,j,i) = tend(k,j,i) - ( & 1593 1687 ( flux_r(k) + diss_r(k) & 1594 - flux_l_w(k,j,tn) - diss_l_w(k,j,tn) ) * ddx 1688 - flux_l_w(k,j,tn) - diss_l_w(k,j,tn) ) * ddx & 1595 1689 + ( flux_n(k) + diss_n(k) & 1596 - flux_s_w(k,tn) - diss_s_w(k,tn) ) * ddy ) 1690 - flux_s_w(k,tn) - diss_s_w(k,tn) ) * ddy & 1691 + ( flux_t(k) + diss_t(k) & 1692 - flux_d - diss_d ) * ddzu(k+1) & 1693 ) + div * w(k,j,i) 1597 1694 1598 1695 flux_l_w(k,j,tn) = flux_r(k) 1599 1696 diss_l_w(k,j,tn) = diss_r(k) 1600 flux_s_w(k,tn) = flux_n(k) 1601 diss_s_w(k,tn) = diss_n(k) 1697 flux_s_w(k,tn) = flux_n(k) 1698 diss_s_w(k,tn) = diss_n(k) 1699 flux_d = flux_t(k) 1700 diss_d = diss_t(k) 1701 ! 1702 !-- Statistical Evaluation of w'w'. 1703 sums_ws2_ws_l(k,tn) = sums_ws2_ws_l(k,tn) & 1704 + ( flux_t(k) + diss_t(k) ) & 1705 * weight_substep(intermediate_timestep_count) 1706 1602 1707 ENDDO 1603 1708 1604 ! 1605 !-- Vertical advection, degradation of order near surface and top. 1606 !-- The fluxes flux_d and diss_d at the surface are 0. Due to reasons of 1607 !-- statistical evaluation the top flux at the surface should be 0 1608 flux_t(nzb_w_inner(j,i)) = 0.0 !statistical reasons 1609 diss_t(nzb_w_inner(j,i)) = 0.0 1610 ! 1611 !-- 2nd order scheme (bottom) 1612 k = nzb_w_inner(j,i)+1 1613 flux_d = flux_t(k-1) 1614 diss_d = diss_t(k-1) 1615 w_comp = w(k+1,j,i) + w(k,j,i) 1616 flux_t(k) = w_comp * ( w(k+1,j,i) + w(k,j,i) ) * 0.25 1617 diss_t(k) = diss_2nd( w(k+2,j,i), w(k+1,j,i), w(k,j,i), 0.0, 0.0, & 1618 w_comp, 0.25, ddzu(k+1) ) 1619 1620 tend(k,j,i) = tend(k,j,i) - ( flux_t(k) + diss_t(k) & 1621 - flux_d - diss_d ) * ddzu(k+1) 1622 ! 1623 !-- WS3 as an intermediate step (bottom) 1624 k = nzb_w_inner(j,i)+2 1625 flux_d = flux_t(k-1) 1626 diss_d = diss_t(k-1) 1627 w_comp = w(k+1,j,i) + w(k,j,i) 1628 flux_t(k) = w_comp * ( & 1629 7.0 * ( w(k+1,j,i) + w(k,j,i) ) & 1630 - ( w(k+2,j,i) + w(k-1,j,i) ) ) * adv_mom_3 1631 diss_t(k) = - ABS( w_comp ) * ( & 1632 3.0 * ( w(k+1,j,i) - w(k,j,i) ) & 1633 - ( w(k+2,j,i) - w(k-1,j,i) ) ) * adv_mom_3 1634 1635 tend(k,j,i) = tend(k,j,i) - ( flux_t(k) + diss_t(k) & 1636 - flux_d - diss_d ) * ddzu(k+1) 1637 ! 1638 !-- WS5 1639 DO k = nzb_w_inner(j,i)+3, nzt-2 1640 flux_d = flux_t(k-1) 1641 diss_d = diss_t(k-1) 1709 DO k = nzb_max+1, nzt 1710 1711 u_comp = u(k+1,j,i+1) + u(k,j,i+1) - gu 1712 flux_r(k) = u_comp * ( & 1713 37.0 * ( w(k,j,i+1) + w(k,j,i) ) & 1714 - 8.0 * ( w(k,j,i+2) + w(k,j,i-1) ) & 1715 + ( w(k,j,i+3) + w(k,j,i-2) ) ) * adv_mom_5 1716 1717 diss_r(k) = - ABS( u_comp ) * ( & 1718 10.0 * ( w(k,j,i+1) - w(k,j,i) ) & 1719 - 5.0 * ( w(k,j,i+2) - w(k,j,i-1) ) & 1720 + ( w(k,j,i+3) - w(k,j,i-2) ) ) * adv_mom_5 1721 1722 v_comp = v(k+1,j+1,i) + v(k,j+1,i) - gv 1723 flux_n(k) = v_comp * ( & 1724 37.0 * ( w(k,j+1,i) + w(k,j,i) ) & 1725 - 8.0 * ( w(k,j+2,i) + w(k,j-1,i) ) & 1726 + ( w(k,j+3,i) + w(k,j-2,i) ) ) * adv_mom_5 1727 1728 diss_n(k) = - ABS( v_comp ) * ( & 1729 10.0 * ( w(k,j+1,i) - w(k,j,i) ) & 1730 - 5.0 * ( w(k,j+2,i) - w(k,j-1,i) ) & 1731 + ( w(k,j+3,i) - w(k,j-2,i) ) ) * adv_mom_5 1732 ! 1733 !-- k index has to be modified near bottom and top, else array 1734 !-- subscripts will be exceeded. 1735 k_ppp = k + 3 * IBITS(wall_flags_0(k,j,i),35,1) 1736 k_pp = k + 2 * ( 1 - IBITS(wall_flags_0(k,j,i),33,1) ) 1737 k_mm = k - 2 * IBITS(wall_flags_0(k,j,i),35,1) 1738 1642 1739 w_comp = w(k+1,j,i) + w(k,j,i) 1643 flux_t(k) = w_comp * ( & 1644 37.0 * ( w(k+1,j,i) + w(k,j,i) ) & 1645 - 8.0 * ( w(k+2,j,i) + w(k-1,j,i) ) & 1646 + ( w(k+3,j,i) + w(k-2,j,i) ) ) * adv_mom_5 1647 diss_t(k) = - ABS( w_comp ) * ( & 1648 10.0 * ( w(k+1,j,i) - w(k,j,i) ) & 1649 - 5.0 * ( w(k+2,j,i) - w(k-1,j,i) ) & 1650 + ( w(k+3,j,i) - w(k-2,j,i) ) ) * adv_mom_5 1651 1652 tend(k,j,i) = tend(k,j,i) - ( flux_t(k) + diss_t(k) & 1653 - flux_d - diss_d ) * ddzu(k+1) 1740 flux_t(k) = w_comp * ( & 1741 ( 37.0 * IBITS(wall_flags_0(k,j,i),35,1) * adv_mom_5 & 1742 + 7.0 * IBITS(wall_flags_0(k,j,i),34,1) * adv_mom_3 & 1743 + IBITS(wall_flags_0(k,j,i),33,1) * adv_mom_1 & 1744 ) * & 1745 ( w(k+1,j,i) + w(k,j,i) ) & 1746 - ( 8.0 * IBITS(wall_flags_0(k,j,i),35,1) * adv_mom_5 & 1747 + IBITS(wall_flags_0(k,j,i),34,1) * adv_mom_3 & 1748 ) * & 1749 ( w(k_pp,j,i) + w(k-1,j,i) ) & 1750 + ( IBITS(wall_flags_0(k,j,i),35,1) * adv_mom_5 & 1751 ) * & 1752 ( w(k_ppp,j,i) + w(k_mm,j,i) ) & 1753 ) 1754 1755 diss_t(k) = - ABS( w_comp ) * ( & 1756 ( 10.0 * IBITS(wall_flags_0(k,j,i),35,1) * adv_mom_5 & 1757 + 3.0 * IBITS(wall_flags_0(k,j,i),34,1) * adv_mom_3 & 1758 + IBITS(wall_flags_0(k,j,i),33,1) * adv_mom_1 & 1759 ) * & 1760 ( w(k+1,j,i) - w(k,j,i) ) & 1761 - ( 5.0 * IBITS(wall_flags_0(k,j,i),35,1) * adv_mom_5 & 1762 + IBITS(wall_flags_0(k,j,i),34,1) * adv_mom_3 & 1763 ) * & 1764 ( w(k_pp,j,i) - w(k-1,j,i) ) & 1765 + ( IBITS(wall_flags_0(k,j,i),35,1) * adv_mom_5 & 1766 ) * & 1767 ( w(k_ppp,j,i) - w(k_mm,j,i) ) & 1768 ) 1769 ! 1770 !-- Calculate the divergence of the velocity field. A respective 1771 !-- correction is needed to overcome numerical instabilities introduced 1772 !-- by a not sufficient reduction of divergences near topography. 1773 div = ( ( u_comp + gu - ( u(k+1,j,i) + u(k,j,i) ) ) * ddx & 1774 + ( v_comp + gv - ( v(k+1,j,i) + v(k,j,i) ) ) * ddy & 1775 + ( w_comp - ( w(k,j,i) + w(k-1,j,i) ) ) * ddzu(k+1) & 1776 ) * 0.5 1777 1778 tend(k,j,i) = tend(k,j,i) - ( & 1779 ( flux_r(k) + diss_r(k) & 1780 - flux_l_w(k,j,tn) - diss_l_w(k,j,tn) ) * ddx & 1781 + ( flux_n(k) + diss_n(k) & 1782 - flux_s_w(k,tn) - diss_s_w(k,tn) ) * ddy & 1783 + ( flux_t(k) + diss_t(k) & 1784 - flux_d - diss_d ) * ddzu(k+1) & 1785 ) + div * w(k,j,i) 1786 1787 flux_l_w(k,j,tn) = flux_r(k) 1788 diss_l_w(k,j,tn) = diss_r(k) 1789 flux_s_w(k,tn) = flux_n(k) 1790 diss_s_w(k,tn) = diss_n(k) 1791 flux_d = flux_t(k) 1792 diss_d = diss_t(k) 1793 ! 1794 !-- Statistical Evaluation of w'w'. 1795 sums_ws2_ws_l(k,tn) = sums_ws2_ws_l(k,tn) & 1796 + ( flux_t(k) + diss_t(k) ) & 1797 * weight_substep(intermediate_timestep_count) 1798 1654 1799 ENDDO 1655 !-- WS3 as an intermediate step (top) 1656 k = nzt - 1 1657 flux_d = flux_t(k-1) 1658 diss_d = diss_t(k-1) 1659 w_comp = w(k+1,j,i) + w(k,j,i) 1660 flux_t(k) = w_comp * ( & 1661 7.0 * ( w(k+1,j,i) + w(k,j,i) ) & 1662 - ( w(k+2,j,i) + w(k-1,j,i) ) ) *adv_mom_3 1663 diss_t(k) = - ABS( w_comp ) * ( & 1664 3.0 * ( w(k+1,j,i) - w(k,j,i) ) & 1665 - ( w(k+2,j,i) - w(k-1,j,i) ) ) * adv_mom_3 1666 1667 tend(k,j,i) = tend(k,j,i) - ( flux_t(k) + diss_t(k) & 1668 - flux_d - diss_d ) * ddzu(k+1) 1669 ! 1670 !-- 2nd order scheme (top) 1671 k = nzt 1672 flux_d = flux_t(k-1) 1673 diss_d = diss_t(k-1) 1674 w_comp = w(k+1,j,i) + w(k,j,i) 1675 flux_t(k) = w_comp * ( w(k+1,j,i) + w(k,j,i) ) * 0.25 1676 diss_t(k) = diss_2nd( w(k+1,j,i), w(k+1,j,i), w(k,j,i), w(k-1,j,i), & 1677 w(k-2,j,i), w_comp, 0.25, ddzu(k+1) ) 1678 1679 tend(k,j,i) = tend(k,j,i) - ( flux_t(k) + diss_t(k) & 1680 - flux_d - diss_d ) * ddzu(k+1) 1681 1682 DO k = nzb_w_inner(j,i), nzt 1683 sums_ws2_ws_l(k,tn) = sums_ws2_ws_l(k,tn) & 1684 + ( flux_t(k) + diss_t(k) ) & 1685 * weight_substep(intermediate_timestep_count) 1686 ENDDO 1800 1687 1801 1688 1802 END SUBROUTINE advec_w_ws_ij … … 1703 1817 IMPLICIT NONE 1704 1818 1705 INTEGER :: i, j, k, tn = 0 1819 INTEGER :: i, j, k, tn = 0, k_ppp, k_pp, k_mm 1706 1820 REAL, DIMENSION(:,:,:), POINTER :: sk 1707 REAL :: flux_d, diss_d, u_comp, v_comp 1708 REAL, DIMENSION(nzb:nzt +1) :: flux_r, diss_r, flux_n, diss_n1709 REAL, DIMENSION(nzb+1:nzt) :: swap_flux_y_local, swap_diss_y_local, &1710 flux_t, diss_t1821 REAL :: flux_d, diss_d, u_comp, v_comp, div 1822 REAL, DIMENSION(nzb:nzt) :: flux_r, diss_r, flux_n, diss_n, flux_t, & 1823 diss_t 1824 REAL, DIMENSION(nzb+1:nzt) :: swap_flux_y_local, swap_diss_y_local 1711 1825 REAL, DIMENSION(nzb+1:nzt,nys:nyn) :: swap_flux_x_local, & 1712 1826 swap_diss_x_local … … 1717 1831 i = nxl 1718 1832 DO j = nys, nyn 1719 IF ( boundary_flags(j,i) == 6 ) THEN 1720 1721 DO k = nzb_s_inner(j,i)+1, nzt 1722 u_comp = u(k,j,i) - u_gtrans 1723 swap_flux_x_local(k,j) = u_comp * ( & 1724 sk(k,j,i) + sk(k,j,i-1)) * 0.5 1725 swap_diss_x_local(k,j) = diss_2nd( sk(k,j,i+2), sk(k,j,i+1), & 1726 sk(k,j,i), sk(k,j,i-1), & 1727 sk(k,j,i-1), u_comp, & 1728 0.5, ddx ) 1729 ENDDO 1730 1731 ELSE 1732 1733 DO k = nzb_s_inner(j,i)+1, nzt 1734 u_comp = u(k,j,i) - u_gtrans 1735 swap_flux_x_local(k,j) = u_comp*( & 1736 37.0 * ( sk(k,j,i)+sk(k,j,i-1) ) & 1737 - 8.0 * ( sk(k,j,i+1) + sk(k,j,i-2) ) & 1738 + ( sk(k,j,i+2) + sk(k,j,i-3) ) )& 1739 * adv_sca_5 1740 swap_diss_x_local(k,j) = - ABS( u_comp ) * ( & 1741 10.0 * (sk(k,j,i) - sk(k,j,i-1) ) & 1742 - 5.0 * ( sk(k,j,i+1) - sk(k,j,i-2) ) & 1743 + ( sk(k,j,i+2) - sk(k,j,i-3) ) )& 1744 * adv_sca_5 1745 ENDDO 1746 ENDIF 1833 1834 DO k = nzb+1, nzb_max 1835 1836 u_comp = u(k,j,i) - u_gtrans 1837 swap_flux_x_local(k,j) = u_comp * ( & 1838 ( 37.0 * IBITS(wall_flags_0(k,j,i),2,1) * adv_sca_5 & 1839 + 7.0 * IBITS(wall_flags_0(k,j,i),1,1) * adv_sca_3 & 1840 + IBITS(wall_flags_0(k,j,i),0,1) * adv_sca_1 & 1841 ) * & 1842 ( sk(k,j,i) + sk(k,j,i-1) ) & 1843 - ( 8.0 * IBITS(wall_flags_0(k,j,i),2,1) * adv_sca_5 & 1844 + IBITS(wall_flags_0(k,j,i),1,1) * adv_sca_3 & 1845 ) * & 1846 ( sk(k,j,i+1) + sk(k,j,i-2) ) & 1847 + ( IBITS(wall_flags_0(k,j,i),2,1) * adv_sca_5 & 1848 ) * ( sk(k,j,i+2) + sk(k,j,i-3) ) & 1849 ) 1850 1851 swap_diss_x_local(k,j) = -ABS( u_comp ) * ( & 1852 ( 10.0 * IBITS(wall_flags_0(k,j,i),2,1) * adv_sca_5 & 1853 + 3.0 * IBITS(wall_flags_0(k,j,i),1,1) * adv_sca_3 & 1854 + IBITS(wall_flags_0(k,j,i),0,1) * adv_sca_1 & 1855 ) * & 1856 ( sk(k,j,i) - sk(k,j,i-1) ) & 1857 - ( 5.0 * IBITS(wall_flags_0(k,j,i),2,1) * adv_sca_5 & 1858 + IBITS(wall_flags_0(k,j,i),1,1) * adv_sca_3 & 1859 ) * & 1860 ( sk(k,j,i+1) - sk(k,j,i-2) ) & 1861 + ( IBITS(wall_flags_0(k,j,i),2,1) * adv_sca_5 & 1862 ) * & 1863 ( sk(k,j,i+2) - sk(k,j,i-3) ) & 1864 ) 1865 1866 ENDDO 1867 1868 DO k = nzb_max+1, nzt 1869 1870 u_comp = u(k,j,i) - u_gtrans 1871 swap_flux_x_local(k,j) = u_comp * ( & 1872 37.0 * ( sk(k,j,i) + sk(k,j,i-1) ) & 1873 - 8.0 * ( sk(k,j,i+1) + sk(k,j,i-2) ) & 1874 + ( sk(k,j,i+2) + sk(k,j,i-3) ) & 1875 ) * adv_sca_5 1876 1877 swap_diss_x_local(k,j) = -ABS( u_comp ) * ( & 1878 10.0 * ( sk(k,j,i) - sk(k,j,i-1) ) & 1879 - 5.0 * ( sk(k,j,i+1) - sk(k,j,i-2) ) & 1880 + ( sk(k,j,i+2) - sk(k,j,i-3) ) & 1881 ) * adv_sca_5 1882 1883 ENDDO 1884 1747 1885 ENDDO 1748 ! 1749 !-- The following loop computes the horizontal fluxes for the interior of the 1750 !-- processor domain plus south boundary points. Furthermore tendency terms 1751 !-- are computed. 1886 1752 1887 DO i = nxl, nxr 1888 1753 1889 j = nys 1754 IF ( boundary_flags(j,i) == 8 ) THEN 1755 1756 DO k = nzb_s_inner(j,i)+1, nzt 1757 v_comp = v(k,j,i) - v_gtrans 1758 swap_flux_y_local(k) = v_comp * & 1759 ( sk(k,j,i) + sk(k,j-1,i) ) * 0.5 1760 swap_diss_y_local(k) = diss_2nd( sk(k,j+2,i), sk(k,j+1,i), & 1761 sk(k,j,i), sk(k,j-1,i), & 1762 sk(k,j-1,i), v_comp, 0.5, ddy ) 1763 ENDDO 1764 1765 ELSE 1766 1767 DO k = nzb_s_inner(j,i)+1, nzt 1768 v_comp = v(k,j,i) - v_gtrans 1769 swap_flux_y_local(k) = v_comp * ( & 1770 37.0 * ( sk(k,j,i) + sk(k,j-1,i) ) & 1771 - 8.0 * ( sk(k,j+1,i) + sk(k,j-2,i) ) & 1772 + ( sk(k,j+2,i) + sk(k,j-3,i) ) ) & 1773 * adv_sca_5 1774 swap_diss_y_local(k)= - ABS( v_comp ) * ( & 1775 10.0 * ( sk(k,j,i) - sk(k,j-1,i) ) & 1776 - 5.0 * ( sk(k,j+1,i) - sk(k,j-2,i) ) & 1777 + ( sk(k,j+2,i)-sk(k,j-3,i) ) ) & 1778 * adv_sca_5 1779 ENDDO 1780 1781 ENDIF 1890 DO k = nzb+1, nzb_max 1891 1892 v_comp = v(k,j,i) - v_gtrans 1893 swap_flux_y_local(k) = v_comp * ( & 1894 ( 37.0 * IBITS(wall_flags_0(k,j,i),5,1) * adv_sca_5 & 1895 + 7.0 * IBITS(wall_flags_0(k,j,i),4,1) * adv_sca_3 & 1896 + IBITS(wall_flags_0(k,j,i),3,1) * adv_sca_1 & 1897 ) * & 1898 ( sk(k,j,i) + sk(k,j-1,i) ) & 1899 - ( 8.0 * IBITS(wall_flags_0(k,j,i),5,1) * adv_sca_5 & 1900 + IBITS(wall_flags_0(k,j,i),4,1) * adv_sca_3 & 1901 ) * & 1902 ( sk(k,j+1,i) + sk(k,j-2,i) ) & 1903 + ( IBITS(wall_flags_0(k,j,i),5,1) * adv_sca_5 & 1904 ) * & 1905 ( sk(k,j+2,i) + sk(k,j-3,i) ) & 1906 ) 1907 1908 swap_diss_y_local(k) = -ABS( v_comp ) * ( & 1909 ( 10.0 * IBITS(wall_flags_0(k,j,i),5,1) * adv_sca_5 & 1910 + 3.0 * IBITS(wall_flags_0(k,j,i),4,1) * adv_sca_3 & 1911 + IBITS(wall_flags_0(k,j,i),3,1) * adv_sca_1 & 1912 ) * & 1913 ( sk(k,j,i) - sk(k,j-1,i) ) & 1914 - ( 5.0 * IBITS(wall_flags_0(k,j,i),5,1) * adv_sca_5 & 1915 + IBITS(wall_flags_0(k,j,i),4,1) * adv_sca_3 & 1916 ) * & 1917 ( sk(k,j+1,i) - sk(k,j-2,i) ) & 1918 + ( IBITS(wall_flags_0(k,j,i),5,1) * adv_sca_5 & 1919 ) * & 1920 ( sk(k,j+2,i) - sk(k,j-3,i) ) & 1921 ) 1922 1923 ENDDO 1924 ! 1925 !-- Above to the top of the highest topography. No degradation necessary. 1926 DO k = nzb_max+1, nzt 1927 1928 v_comp = v(k,j,i) - v_gtrans 1929 swap_flux_y_local(k) = v_comp * ( & 1930 37.0 * ( sk(k,j,i) + sk(k,j-1,i) ) & 1931 - 8.0 * ( sk(k,j+1,i) + sk(k,j-2,i) ) & 1932 + ( sk(k,j+2,i) + sk(k,j-3,i) ) & 1933 ) * adv_sca_5 1934 swap_diss_y_local(k) = -ABS( v_comp ) * ( & 1935 10.0 * ( sk(k,j,i) - sk(k,j-1,i) ) & 1936 - 5.0 * ( sk(k,j+1,i) - sk(k,j-2,i) ) & 1937 + sk(k,j+2,i) - sk(k,j-3,i) & 1938 ) * adv_sca_5 1939 1940 ENDDO 1782 1941 1783 1942 DO j = nys, nyn 1784 IF ( boundary_flags(j,i) /= 0 ) THEN 1785 ! 1786 !-- Degrade the order for Dirichlet bc. at the outflow boundary 1787 SELECT CASE ( boundary_flags(j,i) ) 1788 1789 CASE ( 1 ) 1790 DO k = nzb_s_inner(j,i)+1, nzt 1791 u_comp = u(k,j,i+1) - u_gtrans 1792 flux_r(k) = u_comp * ( & 1793 7.0 * ( sk(k,j,i+1) + sk(k,j,i) ) & 1794 - ( sk(k,j,i+2) + sk(k,j,i-1) ) ) & 1795 * adv_sca_3 1796 diss_r(k) = - ABS( u_comp ) * ( & 1797 3.0 * ( sk(k,j,i+1) - sk(k,j,i) ) & 1798 - ( sk(k,j,i+2) - sk(k,j,i-1) ) ) & 1799 * adv_sca_3 1800 ENDDO 1801 1802 CASE ( 2 ) 1803 DO k = nzb_s_inner(j,i)+1, nzt 1804 u_comp = u(k,j,i+1) - u_gtrans 1805 flux_r(k) = u_comp * ( sk(k,j,i+1) + sk(k,j,i) ) * 0.5 1806 diss_r(k) = diss_2nd( sk(k,j,i+1), sk(k,j,i+1), & 1807 sk(k,j,i), sk(k,j,i-1), & 1808 sk(k,j,i-2), u_comp, 0.5, ddx ) 1809 ENDDO 1810 1811 CASE ( 3 ) 1812 DO k = nzb_s_inner(j,i)+1, nzt 1813 v_comp = v(k,j+1,i) - v_gtrans 1814 flux_n(k) = v_comp * ( & 1815 7.0 * ( sk(k,j+1,i) + sk(k,j,i) ) & 1816 - ( sk(k,j+2,i) + sk(k,j-1,i) ) ) & 1817 * adv_sca_3 1818 diss_n(k) = - ABS( v_comp ) * ( & 1819 3.0 * ( sk(k,j+1,i) - sk(k,j,i) ) & 1820 - ( sk(k,j+2,i) - sk(k,j-1,i) ) ) & 1821 * adv_sca_3 1822 ENDDO 1823 1824 CASE ( 4 ) 1825 DO k = nzb_s_inner(j,i)+1, nzt 1826 v_comp = v(k,j+1,i) - v_gtrans 1827 flux_n(k) = v_comp * ( sk(k,j+1,i) + sk(k,j,i) ) * 0.5 1828 diss_n(k) = diss_2nd( sk(k,j+1,i), sk(k,j+1,i), & 1829 sk(k,j,i), sk(k,j-1,i), & 1830 sk(k,j-2,i), v_comp, 0.5, ddy ) 1831 ENDDO 1832 1833 CASE ( 5 ) 1834 DO k = nzb_w_inner(j,i)+1, nzt 1835 u_comp = u(k,j,i+1) - u_gtrans 1836 flux_r(k) = u_comp * ( & 1837 7.0 * ( sk(k,j,i+1) + sk(k,j,i) ) & 1838 - ( sk(k,j,i+2) + sk(k,j,i-1) ) ) & 1839 * adv_sca_3 1840 diss_r(k) = - ABS( u_comp ) * ( & 1841 3.0 * ( sk(k,j,i+1) - sk(k,j,i) ) & 1842 - ( sk(k,j,i+2) - sk(k,j,i-1) ) ) & 1843 * adv_sca_3 1844 ENDDO 1845 1846 CASE ( 6 ) 1847 DO k = nzb_s_inner(j,i)+1, nzt 1848 u_comp = u(k,j,i+1) - u_gtrans 1849 flux_r(k) = u_comp * ( & 1850 7.0 * ( sk(k,j,i+1) + sk(k,j,i) ) & 1851 - ( sk(k,j,i+2) + sk(k,j,i-1) ) ) & 1852 * adv_sca_3 1853 diss_r(k) = - ABS( u_comp ) * ( & 1854 3.0 * ( sk(k,j,i+1) - sk(k,j,i) ) & 1855 - ( sk(k,j,i+2) - sk(k,j,i-1) ) ) & 1856 * adv_sca_3 1857 ENDDO 1858 1859 CASE ( 7 ) 1860 DO k = nzb_s_inner(j,i)+1, nzt 1861 v_comp = v(k,j+1,i) - v_gtrans 1862 flux_n(k) = v_comp * ( & 1863 7.0 * ( sk(k,j+1,i) + sk(k,j,i) ) & 1864 - ( sk(k,j+2,i) + sk(k,j-1,i) ) ) & 1865 * adv_sca_3 1866 diss_n(k) = - ABS( v_comp ) * ( & 1867 3.0 * ( sk(k,j+1,i) - sk(k,j,i) ) & 1868 - ( sk(k,j+2,i) - sk(k,j-1,i) ) ) & 1869 * adv_sca_3 1870 ENDDO 1871 1872 CASE ( 8 ) 1873 DO k = nzb_s_inner(j,i)+1, nzt 1874 v_comp = v(k,j+1,i) - v_gtrans 1875 flux_n(k) = v_comp * ( & 1876 7.0 * ( sk(k,j+1,i) + sk(k,j,i) ) & 1877 - ( sk(k,j+2,i) + sk(k,j-1,i) ) ) & 1878 * adv_sca_3 1879 diss_n(k) = - ABS( v_comp ) * ( & 1880 3.0 * ( sk(k,j+1,i) - sk(k,j,i) ) & 1881 - ( sk(k,j+2,i) - sk(k,j-1,i) ) ) & 1882 * adv_sca_3 1883 ENDDO 1884 1885 CASE DEFAULT 1886 1887 END SELECT 1888 1889 IF ( boundary_flags(j,i) == 1 .OR. boundary_flags(j,i) == 2 .OR.& 1890 boundary_flags(j,i) == 5 .OR. boundary_flags(j,i) == 6 ) & 1891 THEN 1892 1893 DO k = nzb_s_inner(j,i)+1, nzt 1894 v_comp = v(k,j+1,i) - v_gtrans 1895 flux_n(k) = v_comp * ( & 1896 37.0 * ( sk(k,j+1,i) + sk(k,j,i) ) & 1897 - 8.0 * ( sk(k,j+2,i) + sk(k,j-1,i) ) & 1898 + ( sk(k,j+3,i) + sk(k,j-2,i) ) ) & 1899 * adv_sca_5 1900 diss_n(k) = - ABS( v_comp ) * ( & 1901 10.0 * ( sk(k,j+1,i) - sk(k,j,i) ) & 1902 - 5.0 * ( sk(k,j+2,i) - sk(k,j-1,i) ) & 1903 + ( sk(k,j+3,i) - sk(k,j-2,i) ) ) & 1904 * adv_sca_5 1905 ENDDO 1906 1907 ELSE 1908 1909 DO k = nzb_s_inner(j,i)+1, nzt 1910 u_comp = u(k,j,i+1) - u_gtrans 1911 flux_r(k) = u_comp * ( & 1912 37.0 * ( sk(k,j,i+1) + sk(k,j,i) ) & 1913 - 8.0 * ( sk(k,j,i+2) + sk(k,j,i-1) ) & 1914 + ( sk(k,j,i+3) + sk(k,j,i-2) ) ) & 1915 * adv_sca_5 1916 diss_r(k) = - ABS( u_comp ) * ( & 1917 10.0 * ( sk(k,j,i+1) - sk(k,j,i) ) & 1918 - 5.0 * ( sk(k,j,i+2) - sk(k,j,i-1) ) & 1919 + ( sk(k,j,i+3) - sk(k,j,i-2) ) ) & 1920 * adv_sca_5 1921 ENDDO 1922 1923 ENDIF 1924 1925 ELSE 1926 1927 DO k = nzb_s_inner(j,i)+1, nzt 1928 u_comp = u(k,j,i+1) - u_gtrans 1929 flux_r(k) = u_comp * ( & 1930 37.0 * ( sk(k,j,i+1) + sk(k,j,i) ) & 1931 - 8.0 * ( sk(k,j,i+2) + sk(k,j,i-1) ) & 1932 + ( sk(k,j,i+3) + sk(k,j,i-2) ) ) & 1933 * adv_sca_5 1934 diss_r(k) = - ABS( u_comp ) * ( & 1935 10.0 * ( sk(k,j,i+1) - sk(k,j,i) ) & 1936 - 5.0 * ( sk(k,j,i+2) - sk(k,j,i-1) ) & 1937 + ( sk(k,j,i+3) - sk(k,j,i-2) ) ) & 1938 * adv_sca_5 1939 1940 v_comp = v(k,j+1,i) - v_gtrans 1941 flux_n(k) = v_comp * ( & 1942 37.0 * ( sk(k,j+1,i) + sk(k,j,i) ) & 1943 - 8.0 * ( sk(k,j+2,i) + sk(k,j-1,i) ) & 1944 + ( sk(k,j+3,i) + sk(k,j-2,i) ) ) & 1945 * adv_sca_5 1946 diss_n(k) = - ABS( v_comp ) * ( & 1947 10.0 * ( sk(k,j+1,i) - sk(k,j,i) ) & 1948 - 5.0 * ( sk(k,j+2,i) - sk(k,j-1,i) ) & 1949 + ( sk(k,j+3,i) - sk(k,j-2,i) ) ) & 1950 * adv_sca_5 1951 ENDDO 1952 1953 ENDIF 1954 1955 DO k = nzb_s_inner(j,i)+1, nzt 1956 tend(k,j,i) = tend(k,j,i) - ( & 1957 ( flux_r(k) + diss_r(k) & 1958 - swap_flux_x_local(k,j) - swap_diss_x_local(k,j) ) * ddx & 1959 + ( flux_n(k) + diss_n(k) & 1960 - swap_flux_y_local(k) - swap_diss_y_local(k) ) * ddy) 1961 1943 1944 flux_t(0) = 0.0 1945 diss_t(0) = 0.0 1946 flux_d = 0.0 1947 diss_d = 0.0 1948 1949 DO k = nzb+1, nzb_max 1950 1951 u_comp = u(k,j,i+1) - u_gtrans 1952 flux_r(k) = u_comp * ( & 1953 ( 37.0 * IBITS(wall_flags_0(k,j,i),2,1) * adv_sca_5 & 1954 + 7.0 * IBITS(wall_flags_0(k,j,i),1,1) * adv_sca_3 & 1955 + IBITS(wall_flags_0(k,j,i),0,1) * adv_sca_1 & 1956 ) * & 1957 ( sk(k,j,i+1) + sk(k,j,i) ) & 1958 - ( 8.0 * IBITS(wall_flags_0(k,j,i),2,1) * adv_sca_5 & 1959 + IBITS(wall_flags_0(k,j,i),1,1) * adv_sca_3 & 1960 ) * & 1961 ( sk(k,j,i+2) + sk(k,j,i-1) ) & 1962 + ( IBITS(wall_flags_0(k,j,i),2,1) * adv_sca_5 & 1963 ) * ( sk(k,j,i+3) + sk(k,j,i-2) ) & 1964 ) 1965 1966 diss_r(k) = -ABS( u_comp ) * ( & 1967 ( 10.0 * IBITS(wall_flags_0(k,j,i),2,1) * adv_sca_5 & 1968 + 3.0 * IBITS(wall_flags_0(k,j,i),1,1) * adv_sca_3 & 1969 + IBITS(wall_flags_0(k,j,i),0,1) * adv_sca_1 & 1970 ) * & 1971 ( sk(k,j,i+1) - sk(k,j,i) ) & 1972 - ( 5.0 * IBITS(wall_flags_0(k,j,i),2,1) * adv_sca_5 & 1973 + IBITS(wall_flags_0(k,j,i),1,1) * adv_sca_3 & 1974 ) * & 1975 ( sk(k,j,i+2) - sk(k,j,i-1) ) & 1976 + ( IBITS(wall_flags_0(k,j,i),2,1) * adv_sca_5 & 1977 ) * & 1978 ( sk(k,j,i+3) - sk(k,j,i-2) ) & 1979 ) 1980 1981 v_comp = v(k,j+1,i) - v_gtrans 1982 flux_n(k) = v_comp * ( & 1983 ( 37.0 * IBITS(wall_flags_0(k,j,i),5,1) * adv_sca_5 & 1984 + 7.0 * IBITS(wall_flags_0(k,j,i),4,1) * adv_sca_3 & 1985 + IBITS(wall_flags_0(k,j,i),3,1) * adv_sca_1 & 1986 ) * & 1987 ( sk(k,j+1,i) + sk(k,j,i) ) & 1988 - ( 8.0 * IBITS(wall_flags_0(k,j,i),5,1) * adv_sca_5 & 1989 + IBITS(wall_flags_0(k,j,i),4,1) * adv_sca_3 & 1990 ) * & 1991 ( sk(k,j+2,i) + sk(k,j-1,i) ) & 1992 + ( IBITS(wall_flags_0(k,j,i),5,1) * adv_sca_5 & 1993 ) * & 1994 ( sk(k,j+3,i) + sk(k,j-2,i) ) & 1995 ) 1996 1997 diss_n(k) = -ABS( v_comp ) * ( & 1998 ( 10.0 * IBITS(wall_flags_0(k,j,i),5,1) * adv_sca_5 & 1999 + 3.0 * IBITS(wall_flags_0(k,j,i),4,1) * adv_sca_3 & 2000 + IBITS(wall_flags_0(k,j,i),3,1) * adv_sca_1 & 2001 ) * & 2002 ( sk(k,j+1,i) - sk(k,j,i) ) & 2003 - ( 5.0 * IBITS(wall_flags_0(k,j,i),5,1) * adv_sca_5 & 2004 + IBITS(wall_flags_0(k,j,i),4,1) * adv_sca_3 & 2005 ) * & 2006 ( sk(k,j+2,i) - sk(k,j-1,i) ) & 2007 + ( IBITS(wall_flags_0(k,j,i),5,1) * adv_sca_5 & 2008 ) * & 2009 ( sk(k,j+3,i) - sk(k,j-2,i) ) & 2010 ) 2011 ! 2012 !-- k index has to be modified near bottom and top, else array 2013 !-- subscripts will be exceeded. 2014 k_ppp = k + 3 * IBITS(wall_flags_0(k,j,i),8,1) 2015 k_pp = k + 2 * ( 1 - IBITS(wall_flags_0(k,j,i),6,1) ) 2016 k_mm = k - 2 * IBITS(wall_flags_0(k,j,i),8,1) 2017 2018 2019 flux_t(k) = w(k,j,i) * ( & 2020 ( 37.0 * IBITS(wall_flags_0(k,j,i),8,1) * adv_sca_5 & 2021 + 7.0 * IBITS(wall_flags_0(k,j,i),7,1) * adv_sca_3 & 2022 + IBITS(wall_flags_0(k,j,i),6,1) * adv_sca_1 & 2023 ) * & 2024 ( sk(k+1,j,i) + sk(k,j,i) ) & 2025 - ( 8.0 * IBITS(wall_flags_0(k,j,i),8,1) * adv_sca_5 & 2026 + IBITS(wall_flags_0(k,j,i),7,1) * adv_sca_3 & 2027 ) * & 2028 ( sk(k_pp,j,i) + sk(k-1,j,i) ) & 2029 + ( IBITS(wall_flags_0(k,j,i),8,1) * adv_sca_5 & 2030 ) * ( sk(k_ppp,j,i)+ sk(k_mm,j,i) ) & 2031 ) 2032 2033 diss_t(k) = -ABS( w(k,j,i) ) * ( & 2034 ( 10.0 * IBITS(wall_flags_0(k,j,i),8,1) * adv_sca_5 & 2035 + 3.0 * IBITS(wall_flags_0(k,j,i),7,1) * adv_sca_3 & 2036 + IBITS(wall_flags_0(k,j,i),6,1) * adv_sca_1 & 2037 ) * & 2038 ( sk(k+1,j,i) - sk(k,j,i) ) & 2039 - ( 5.0 * IBITS(wall_flags_0(k,j,i),8,1) * adv_sca_5 & 2040 + IBITS(wall_flags_0(k,j,i),7,1) * adv_sca_3 & 2041 ) * & 2042 ( sk(k_pp,j,i) - sk(k-1,j,i) ) & 2043 + ( IBITS(wall_flags_0(k,j,i),8,1) * adv_sca_5 & 2044 ) * & 2045 ( sk(k_ppp,j,i) - sk(k_mm,j,i) ) & 2046 ) 2047 ! 2048 !-- Calculate the divergence of the velocity field. A respective 2049 !-- correction is needed to overcome numerical instabilities caused 2050 !-- by a not sufficient reduction of divergences near topography. 2051 div = ( u(k,j,i+1) - u(k,j,i) ) * ddx & 2052 + ( v(k,j+1,i) - v(k,j,i) ) * ddy & 2053 + ( w(k,j,i) - w(k-1,j,i) ) * ddzw(k) 2054 2055 tend(k,j,i) = tend(k,j,i) - ( & 2056 ( flux_r(k) + diss_r(k) - swap_flux_x_local(k,j) - & 2057 swap_diss_x_local(k,j) ) * ddx & 2058 + ( flux_n(k) + diss_n(k) - swap_flux_y_local(k) - & 2059 swap_diss_y_local(k) ) * ddy & 2060 + ( flux_t(k) + diss_t(k) - flux_d - diss_d & 2061 ) * ddzw(k) & 2062 ) + sk(k,j,i) * div 2063 2064 swap_flux_y_local(k) = flux_n(k) 2065 swap_diss_y_local(k) = diss_n(k) 1962 2066 swap_flux_x_local(k,j) = flux_r(k) 1963 2067 swap_diss_x_local(k,j) = diss_r(k) 2068 flux_d = flux_t(k) 2069 diss_d = diss_t(k) 2070 2071 ENDDO 2072 2073 DO k = nzb_max+1, nzt 2074 2075 u_comp = u(k,j,i+1) - u_gtrans 2076 flux_r(k) = u_comp * ( & 2077 37.0 * ( sk(k,j,i+1) + sk(k,j,i) ) & 2078 - 8.0 * ( sk(k,j,i+2) + sk(k,j,i-1) ) & 2079 + ( sk(k,j,i+3) + sk(k,j,i-2) ) ) * adv_sca_5 2080 diss_r(k) = -ABS( u_comp ) * ( & 2081 10.0 * ( sk(k,j,i+1) - sk(k,j,i) ) & 2082 - 5.0 * ( sk(k,j,i+2) - sk(k,j,i-1) ) & 2083 + ( sk(k,j,i+3) - sk(k,j,i-2) ) ) * adv_sca_5 2084 2085 v_comp = v(k,j+1,i) - v_gtrans 2086 flux_n(k) = v_comp * ( & 2087 37.0 * ( sk(k,j+1,i) + sk(k,j,i) ) & 2088 - 8.0 * ( sk(k,j+2,i) + sk(k,j-1,i) ) & 2089 + ( sk(k,j+3,i) + sk(k,j-2,i) ) ) * adv_sca_5 2090 diss_n(k) = -ABS( v_comp ) * ( & 2091 10.0 * ( sk(k,j+1,i) - sk(k,j,i) ) & 2092 - 5.0 * ( sk(k,j+2,i) - sk(k,j-1,i) ) & 2093 + ( sk(k,j+3,i) - sk(k,j-2,i) ) ) * adv_sca_5 2094 ! 2095 !-- k index has to be modified near bottom and top, else array 2096 !-- subscripts will be exceeded. 2097 k_ppp = k + 3 * IBITS(wall_flags_0(k,j,i),8,1) 2098 k_pp = k + 2 * ( 1 - IBITS(wall_flags_0(k,j,i),6,1) ) 2099 k_mm = k - 2 * IBITS(wall_flags_0(k,j,i),8,1) 2100 2101 flux_t(k) = w(k,j,i) * ( & 2102 ( 37.0 * IBITS(wall_flags_0(k,j,i),8,1) * adv_sca_5 & 2103 + 7.0 * IBITS(wall_flags_0(k,j,i),7,1) * adv_sca_3 & 2104 + IBITS(wall_flags_0(k,j,i),6,1) * adv_sca_1 & 2105 ) * & 2106 ( sk(k+1,j,i) + sk(k,j,i) ) & 2107 - ( 8.0 * IBITS(wall_flags_0(k,j,i),8,1) * adv_sca_5 & 2108 + IBITS(wall_flags_0(k,j,i),7,1) * adv_sca_3 & 2109 ) * & 2110 ( sk(k_pp,j,i) + sk(k-1,j,i) ) & 2111 + ( IBITS(wall_flags_0(k,j,i),8,1) * adv_sca_5 & 2112 ) * ( sk(k_ppp,j,i)+ sk(k_mm,j,i) ) & 2113 ) 2114 2115 diss_t(k) = -ABS( w(k,j,i) ) * ( & 2116 ( 10.0 * IBITS(wall_flags_0(k,j,i),8,1) * adv_sca_5 & 2117 + 3.0 * IBITS(wall_flags_0(k,j,i),7,1) * adv_sca_3 & 2118 + IBITS(wall_flags_0(k,j,i),6,1) * adv_sca_1 & 2119 ) * & 2120 ( sk(k+1,j,i) - sk(k,j,i) ) & 2121 - ( 5.0 * IBITS(wall_flags_0(k,j,i),8,1) * adv_sca_5 & 2122 + IBITS(wall_flags_0(k,j,i),7,1) * adv_sca_3 & 2123 ) * & 2124 ( sk(k_pp,j,i) - sk(k-1,j,i) ) & 2125 + ( IBITS(wall_flags_0(k,j,i),8,1) * adv_sca_5 & 2126 ) * & 2127 ( sk(k_ppp,j,i) - sk(k_mm,j,i) ) & 2128 ) 2129 ! 2130 !-- Calculate the divergence of the velocity field. A respective 2131 !-- correction is needed to overcome numerical instabilities introduced 2132 !-- by a not sufficient reduction of divergences near topography. 2133 div = ( u(k,j,i+1) - u(k,j,i) ) * ddx & 2134 + ( v(k,j+1,i) - v(k,j,i) ) * ddy & 2135 + ( w(k,j,i) - w(k-1,j,i) ) * ddzw(k) 2136 2137 tend(k,j,i) = tend(k,j,i) - ( & 2138 ( flux_r(k) + diss_r(k) - swap_flux_x_local(k,j) - & 2139 swap_diss_x_local(k,j) ) * ddx & 2140 + ( flux_n(k) + diss_n(k) - swap_flux_y_local(k) - & 2141 swap_diss_y_local(k) ) * ddy & 2142 + ( flux_t(k) + diss_t(k) - flux_d - diss_d & 2143 ) * ddzw(k) & 2144 ) + sk(k,j,i) * div 2145 1964 2146 swap_flux_y_local(k) = flux_n(k) 1965 2147 swap_diss_y_local(k) = diss_n(k) 1966 ENDDO 2148 swap_flux_x_local(k,j) = flux_r(k) 2149 swap_diss_x_local(k,j) = diss_r(k) 2150 flux_d = flux_t(k) 2151 diss_d = diss_t(k) 2152 2153 ENDDO 2154 ! 2155 !-- evaluation of statistics 2156 SELECT CASE ( sk_char ) 2157 2158 CASE ( 'pt' ) 2159 DO k = nzb, nzt 2160 sums_wspts_ws_l(k,tn) = sums_wspts_ws_l(k,tn) & 2161 + ( flux_t(k) + diss_t(k) ) & 2162 * weight_substep(intermediate_timestep_count) 2163 ENDDO 2164 CASE ( 'sa' ) 2165 DO k = nzb, nzt 2166 sums_wssas_ws_l(k,tn) = sums_wssas_ws_l(k,tn) & 2167 + ( flux_t(k) + diss_t(k) ) & 2168 * weight_substep(intermediate_timestep_count) 2169 ENDDO 2170 CASE ( 'q' ) 2171 DO k = nzb, nzt 2172 sums_wsqs_ws_l(k,tn) = sums_wsqs_ws_l(k,tn) & 2173 + ( flux_t(k) + diss_t(k) ) & 2174 * weight_substep(intermediate_timestep_count) 2175 ENDDO 2176 2177 END SELECT 2178 1967 2179 ENDDO 1968 2180 ENDDO 1969 1970 !1971 !-- Vertical advection, degradation of order near surface and top.1972 !-- The fluxes flux_d and diss_d at the surface are 0. Due to reasons of1973 !-- statistical evaluation the top flux at the surface should be 01974 DO i = nxl, nxr1975 DO j = nys, nyn1976 !1977 !-- 2nd order scheme (bottom)1978 k=nzb_s_inner(j,i)+11979 !1980 !-- The fluxes flux_d and diss_d at the surface are 0. Due to static1981 !-- reasons the top flux at the surface should be 0.1982 flux_t(nzb_s_inner(j,i)) = 0.01983 diss_t(nzb_s_inner(j,i)) = 0.01984 flux_d = flux_t(k-1)1985 diss_d = diss_t(k-1)1986 flux_t(k) = w(k,j,i) * ( sk(k+1,j,i) + sk(k,j,i) ) * 0.51987 diss_t(k) = diss_2nd( sk(k+2,j,i), sk(k+1,j,i), sk(k,j,i), &1988 sk(k,j,i), sk(k,j,i), w(k,j,i), &1989 0.5, ddzw(k) )1990 tend(k,j,i) = tend(k,j,i) - ( flux_t(k) + diss_t(k) &1991 - flux_d - diss_d ) * ddzw(k)1992 !1993 !-- WS3 as an intermediate step (bottom)1994 k = nzb_s_inner(j,i)+21995 flux_d = flux_t(k-1)1996 diss_d = diss_t(k-1)1997 flux_t(k) = w(k,j,i) * ( &1998 7.0 * ( sk(k+1,j,i) + sk(k,j,i) ) &1999 - ( sk(k+2,j,i) + sk(k-1,j,i) ) ) * adv_sca_32000 diss_t(k) = - ABS( w(k,j,i) ) * ( &2001 3.0 * ( sk(k+1,j,i) - sk(k,j,i) ) &2002 - ( sk(k+2,j,i) - sk(k-1,j,i) ) ) * adv_sca_32003 tend(k,j,i) = tend(k,j,i) - ( flux_t(k) + diss_t(k) &2004 - flux_d - diss_d ) * ddzw(k)2005 !2006 !-- WS52007 DO k = nzb_s_inner(j,i)+3, nzt-22008 flux_d = flux_t(k-1)2009 diss_d = diss_t(k-1)2010 flux_t(k) = w(k,j,i) * ( &2011 37.0 * ( sk(k+1,j,i) + sk(k,j,i) ) &2012 - 8.0 * ( sk(k+2,j,i) + sk(k-1,j,i) ) &2013 + ( sk(k+3,j,i) + sk(k-2,j,i) ) ) * adv_sca_52014 diss_t(k) = - ABS(w(k,j,i)) * ( &2015 10.0 * ( sk(k+1,j,i) -sk(k,j,i) ) &2016 - 5.0 * ( sk(k+2,j,i) - sk(k-1,j,i) ) &2017 + ( sk(k+3,j,i) - sk(k-2,j,i) ) ) * adv_sca_52018 2019 tend(k,j,i) = tend(k,j,i) - ( flux_t(k) + diss_t(k) &2020 - flux_d - diss_d ) * ddzw(k)2021 ENDDO2022 !2023 !-- WS3 as an intermediate step (top)2024 k = nzt - 12025 flux_d = flux_t(k-1)2026 diss_d = diss_t(k-1)2027 flux_t(k) = w(k,j,i) * ( &2028 7.0 * ( sk(k+1,j,i) + sk(k,j,i) ) &2029 - ( sk(k+2,j,i) + sk(k-1,j,i) ) ) * adv_sca_32030 diss_t(k) = - ABS(w(k,j,i)) * ( &2031 3.0 * ( sk(k+1,j,i) - sk(k,j,i) ) &2032 - ( sk(k+2,j,i) - sk(k-1,j,i) ) ) * adv_sca_32033 2034 tend(k,j,i) = tend(k,j,i) - ( flux_t(k) + diss_t(k) &2035 - flux_d - diss_d ) * ddzw(k)2036 !2037 !-- 2nd order scheme (top)2038 k = nzt2039 flux_d = flux_t(k-1)2040 diss_d = diss_t(k-1)2041 flux_t(k) = w(k,j,i) * ( sk(k+1,j,i) + sk(k,j,i) ) * 0.52042 diss_t(k) = diss_2nd( sk(k+1,j,i), sk(k+1,j,i), sk(k,j,i), &2043 sk(k-1,j,i), sk(k-2,j,i), w(k,j,i), &2044 0.5, ddzw(k) )2045 2046 tend(k,j,i) = tend(k,j,i) - ( flux_t(k) + diss_t(k) &2047 - flux_d - diss_d ) * ddzw(k)2048 !2049 !-- evaluation of statistics2050 SELECT CASE ( sk_char )2051 2052 CASE ( 'pt' )2053 DO k = nzb_s_inner(j,i), nzt2054 sums_wspts_ws_l(k,tn) = sums_wspts_ws_l(k,tn) &2055 + ( flux_t(k) + diss_t(k) ) &2056 * weight_substep(intermediate_timestep_count)2057 ENDDO2058 CASE ( 'sa' )2059 DO k = nzb_s_inner(j,i), nzt2060 sums_wssas_ws_l(k,tn) = sums_wssas_ws_l(k,tn) &2061 + ( flux_t(k) + diss_t(k) ) &2062 * weight_substep(intermediate_timestep_count)2063 ENDDO2064 CASE ( 'q' )2065 DO k = nzb_s_inner(j,i), nzt2066 sums_wsqs_ws_l(k,tn) = sums_wsqs_ws_l(k,tn) &2067 + ( flux_t(k) + diss_t(k) ) &2068 * weight_substep(intermediate_timestep_count)2069 ENDDO2070 2071 END SELECT2072 ENDDO2073 ENDDO2074 2075 2181 2076 2182 END SUBROUTINE advec_s_ws … … 2091 2197 IMPLICIT NONE 2092 2198 2093 INTEGER :: i, j, k, tn = 0 2094 REAL :: gu, gv, flux_d, diss_d, v_comp, w_comp 2199 INTEGER :: i, j, k, tn = 0, k_ppp, k_pp, k_mm 2200 REAL :: gu, gv, flux_d, diss_d, v_comp, w_comp, div 2095 2201 REAL, DIMENSION(nzb+1:nzt) :: swap_flux_y_local_u, swap_diss_y_local_u 2096 REAL, DIMENSION(nzb+1:nzt,nys:nyn) :: swap_flux_x_local_u, 2202 REAL, DIMENSION(nzb+1:nzt,nys:nyn) :: swap_flux_x_local_u, & 2097 2203 swap_diss_x_local_u 2098 REAL, DIMENSION(nzb:nzt +1) :: flux_t, diss_t, flux_r, diss_r, flux_n, &2204 REAL, DIMENSION(nzb:nzt) :: flux_t, diss_t, flux_r, diss_r, flux_n, & 2099 2205 diss_n, u_comp 2100 2206 … … 2106 2212 i = nxlu 2107 2213 DO j = nys, nyn 2108 IF( boundary_flags(j,i) == 5 ) THEN 2109 2110 DO k = nzb_u_inner(j,i)+1, nzt 2111 u_comp(k) = u(k,j,i) + u(k,j,i-1) - gu 2112 swap_flux_x_local_u(k,j) = u_comp(k) * & 2113 ( u(k,j,i) + u(k,j,i-1) ) * 0.25 2114 swap_diss_x_local_u(k,j) = diss_2nd( u(k,j,i+2), u(k,j,i+1), & 2115 u(k,j,i), u(k,j,i-1), & 2116 u(k,j,i-1), u_comp(k), & 2117 0.25, ddx ) 2118 ENDDO 2119 2120 ELSE 2121 2122 DO k = nzb_u_inner(j,i)+1, nzt 2123 u_comp(k) = u(k,j,i) + u(k,j,i-1) - gu 2124 swap_flux_x_local_u(k,j) = u_comp(k) * ( & 2125 37.0 * ( u(k,j,i) + u(k,j,i-1) ) & 2126 - 8.0 * ( u(k,j,i+1) + u(k,j,i-2) ) & 2127 + (u(k,j,i+2)+u(k,j,i-3) ) ) & 2128 * adv_mom_5 2129 swap_diss_x_local_u(k,j) = - ABS(u_comp(k)) * ( & 2130 10.0 * ( u(k,j,i) - u(k,j,i-1) ) & 2131 - 5.0 * ( u(k,j,i+1) - u(k,j,i-2) ) & 2132 + ( u(k,j,i+2) - u(k,j,i-3) ) )& 2133 * adv_mom_5 2134 ENDDO 2135 2136 ENDIF 2137 2214 DO k = nzb+1, nzb_max 2215 2216 u_comp(k) = u(k,j,i) + u(k,j,i-1) - gu 2217 swap_flux_x_local_u(k,j) = u_comp(k) * ( & 2218 ( 37.0 * IBITS(wall_flags_0(k,j,i),11,1) * adv_mom_5 & 2219 + 7.0 * IBITS(wall_flags_0(k,j,i),10,1) * adv_mom_3 & 2220 + IBITS(wall_flags_0(k,j,i),9,1) * adv_mom_1 & 2221 ) * & 2222 ( u(k,j,i) + u(k,j,i-1) ) & 2223 - ( 8.0 * IBITS(wall_flags_0(k,j,i),11,1) * adv_mom_5 & 2224 + IBITS(wall_flags_0(k,j,i),10,1) * adv_mom_3 & 2225 ) * & 2226 ( u(k,j,i+1) + u(k,j,i-2) ) & 2227 + ( IBITS(wall_flags_0(k,j,i),11,1) * adv_mom_5 & 2228 ) * & 2229 ( u(k,j,i+2) + u(k,j,i-3) ) & 2230 ) 2231 2232 swap_diss_x_local_u(k,j) = - ABS( u_comp(k) ) * ( & 2233 ( 10.0 * IBITS(wall_flags_0(k,j,i),11,1) * adv_mom_5 & 2234 + 3.0 * IBITS(wall_flags_0(k,j,i),10,1) * adv_mom_3 & 2235 + IBITS(wall_flags_0(k,j,i),9,1) * adv_mom_1 & 2236 ) * & 2237 ( u(k,j,i) - u(k,j,i-1) ) & 2238 - ( 5.0 * IBITS(wall_flags_0(k,j,i),11,1) * adv_mom_5 & 2239 + IBITS(wall_flags_0(k,j,i),10,1) * adv_mom_3 & 2240 ) * & 2241 ( u(k,j,i+1) - u(k,j,i-2) ) & 2242 + ( IBITS(wall_flags_0(k,j,i),11,1) * adv_mom_5 & 2243 ) * & 2244 ( u(k,j,i+2) - u(k,j,i-3) ) & 2245 ) 2246 2247 ENDDO 2248 2249 DO k = nzb_max+1, nzt 2250 2251 u_comp(k) = u(k,j,i) + u(k,j,i-1) - gu 2252 swap_flux_x_local_u(k,j) = u_comp(k) * ( & 2253 37.0 * ( u(k,j,i) + u(k,j,i-1) ) & 2254 - 8.0 * ( u(k,j,i+1) + u(k,j,i-2) ) & 2255 + ( u(k,j,i+2) + u(k,j,i-3) ) ) * adv_mom_5 2256 swap_diss_x_local_u(k,j) = - ABS(u_comp(k)) * ( & 2257 10.0 * ( u(k,j,i) - u(k,j,i-1) ) & 2258 - 5.0 * ( u(k,j,i+1) - u(k,j,i-2) ) & 2259 + ( u(k,j,i+2) - u(k,j,i-3) ) ) * adv_mom_5 2260 2261 ENDDO 2138 2262 ENDDO 2139 2263 2140 2264 DO i = nxlu, nxr 2141 2265 ! 2142 !-- The following loop computes the fluxes for the south boundary points 2143 j = nys 2144 IF ( boundary_flags(j,i) == 8 ) THEN 2145 ! 2146 !-- Compute southside fluxes for the south boundary of PE domain 2147 DO k = nzb_u_inner(j,i)+1, nzt 2148 v_comp = v(k,j,i) + v(k,j,i-1) - gv 2149 swap_flux_y_local_u(k) = v_comp * & 2150 ( u(k,j,i) + u(k,j-1,i) ) * 0.25 2151 swap_diss_y_local_u(k) = diss_2nd( u(k,j+2,i), u(k,j+1,i), & 2152 u(k,j,i), u(k,j-1,i), & 2153 u(k,j-1,i), v_comp, & 2154 0.25, ddy ) 2155 ENDDO 2156 2157 ELSE 2158 2159 DO k = nzb_u_inner(j,i)+1, nzt 2160 v_comp = v(k,j,i) + v(k,j,i-1) - gv 2161 swap_flux_y_local_u(k) = v_comp * ( & 2162 37.0 * ( u(k,j,i) + u(k,j-1,i) ) & 2163 - 8.0 * ( u(k,j+1,i) + u(k,j-2,i) ) & 2164 + ( u(k,j+2,i) + u(k,j-3,i) ) ) & 2165 * adv_mom_5 2166 swap_diss_y_local_u(k) = - ABS( v_comp ) * ( & 2167 10.0 * ( u(k,j,i) - u(k,j-1,i) ) & 2168 - 5.0 * ( u(k,j+1,i) - u(k,j-2,i) ) & 2169 + ( u(k,j+2,i) - u(k,j-3,i) ) ) & 2170 * adv_mom_5 2171 ENDDO 2172 2173 ENDIF 2174 ! 2175 !-- Computation of interior fluxes and tendency terms 2176 DO j = nys, nyn 2177 IF ( boundary_flags(j,i) /= 0 ) THEN 2178 ! 2179 !-- Degrade the order for Dirichlet bc. at the outflow boundary 2180 SELECT CASE ( boundary_flags(j,i) ) 2181 2182 CASE ( 1 ) 2183 DO k = nzb_u_inner(j,i)+1, nzt 2184 u_comp(k) = u(k,j,i+1) + u(k,j,i) 2185 flux_r(k) = ( u_comp(k) - gu ) * ( & 2186 7.0 * ( u(k,j,i+1) + u(k,j,i) ) & 2187 - ( u(k,j,i+2) + u(k,j,i-1) ) ) & 2188 * adv_mom_3 2189 diss_r(k) = - ABS( u_comp(k) - gu ) * ( & 2190 3.0 * ( u(k,j,i+1) - u(k,j,i) ) & 2191 - ( u(k,j,i+2) - u(k,j,i-1) ) ) & 2192 * adv_mom_3 2193 ENDDO 2194 2195 CASE ( 2 ) 2196 DO k = nzb_u_inner(j,i)+1, nzt 2197 u_comp(k) = u(k,j,i+1) + u(k,j,i) 2198 flux_r(k) = ( u_comp(k) - gu ) * & 2199 ( u(k,j,i+1) + u(k,j,i) ) * 0.25 2200 diss_r(k) = diss_2nd( u(k,j,i+1), u(k,j,i+1), & 2201 u(k,j,i), u(k,j,i-1), & 2202 u(k,j,i-2), u_comp(k) ,0.25 ,ddx) 2203 ENDDO 2204 2205 CASE ( 3 ) 2206 DO k = nzb_u_inner(j,i)+1, nzt 2207 v_comp = v(k,j+1,i) + v(k,j+1,i-1) - gv 2208 flux_n(k) = v_comp * ( & 2209 7.0 * ( u(k,j+1,i) + u(k,j,i) ) & 2210 - ( u(k,j+2,i) + u(k,j-1,i) ) ) & 2211 * adv_mom_3 2212 diss_n(k) = - ABS( v_comp ) * ( & 2213 3.0 * ( u(k,j+1,i) - u(k,j,i) ) & 2214 - ( u(k,j+2,i) - u(k,j-1,i) ) ) & 2215 * adv_mom_3 2216 ENDDO 2217 2218 CASE ( 4 ) 2219 DO k = nzb_u_inner(j,i)+1, nzt 2220 v_comp = v(k,j+1,i) + v(k,j+1,i-1) - gv 2221 flux_n(k) = v_comp * ( u(k,j+1,i) + u(k,j,i) ) * 0.25 2222 diss_n(k) = diss_2nd( u(k,j+1,i), u(k,j+1,i), & 2223 u(k,j,i), u(k,j-1,i), & 2224 u(k,j-2,i), v_comp, 0.25, ddy ) 2225 ENDDO 2226 2227 CASE ( 5 ) 2228 DO k = nzb_u_inner(j,i)+1, nzt 2229 u_comp(k) = u(k,j,i+1) + u(k,j,i) 2230 flux_r(k) = ( u_comp(k) - gu ) * ( & 2231 7.0 * ( u(k,j,i+1) + u(k,j,i) ) & 2232 - ( u(k,j,i+2) + u(k,j,i-1) ) ) & 2233 * adv_mom_3 2234 diss_r(k) = - ABS( u_comp(k) - gu ) * ( & 2235 3.0 * ( u(k,j,i+1) - u(k,j,i) ) & 2236 - ( u(k,j,i+2) - u(k,j,i-1) ) ) & 2237 * adv_mom_3 2238 ENDDO 2239 2240 CASE ( 7 ) 2241 DO k = nzb_u_inner(j,i)+1, nzt 2242 v_comp = v(k,j+1,i) + v(k,j+1,i-1) - gv 2243 flux_n(k) = v_comp * ( & 2244 7.0 * ( u(k,j+1,i) + u(k,j,i) ) & 2245 - ( u(k,j+2,i) + u(k,j-1,i) ) ) & 2246 * adv_mom_3 2247 diss_n(k) = - ABS( v_comp ) * ( & 2248 3.0 * ( u(k,j+1,i) - u(k,j,i) ) & 2249 - ( u(k,j+2,i) - u(k,j-1,i) ) ) & 2250 * adv_mom_3 2251 ENDDO 2252 2253 CASE ( 8 ) 2254 DO k = nzb_u_inner(j,i)+1, nzt 2255 v_comp = v(k,j+1,i) + v(k,j+1,i-1) - gv 2256 flux_n(k) = v_comp * ( & 2257 7.0 * ( u(k,j+1,i) + u(k,j,i) ) & 2258 - ( u(k,j+2,i) + u(k,j-1,i) ) ) & 2259 * adv_mom_3 2260 diss_n(k) = - ABS( v_comp ) * ( & 2261 3.0 * ( u(k,j+1,i) - u(k,j,i) ) & 2262 - ( u(k,j+2,i) - u(k,j-1,i) ) ) & 2263 * adv_mom_3 2264 ENDDO 2265 2266 CASE DEFAULT 2267 2268 END SELECT 2269 ! 2270 !-- Compute the crosswise 5th order fluxes at the outflow 2271 IF ( boundary_flags(j,i) == 1 .OR. boundary_flags(j,i) == 2 .OR.& 2272 boundary_flags(j,i) == 5 ) THEN 2273 2274 DO k = nzb_u_inner(j,i)+1, nzt 2275 v_comp = v(k,j+1,i) + v(k,j+1,i-1) - gv 2276 flux_n(k) = v_comp * ( & 2277 37.0 * ( u(k,j+1,i) + u(k,j,i) ) & 2278 - 8.0 * ( u(k,j+2,i) +u(k,j-1,i) ) & 2279 + ( u(k,j+3,i) + u(k,j-2,i) ) ) & 2280 * adv_mom_5 2281 diss_n(k) = - ABS( v_comp ) * ( & 2282 10.0 * ( u(k,j+1,i) - u(k,j,i) ) & 2283 - 5.0 * ( u(k,j+2,i) - u(k,j-1,i) ) & 2284 + ( u(k,j+3,i) - u(k,j-2,i) ) ) & 2285 * adv_mom_5 2286 ENDDO 2287 2288 ELSE 2289 2290 DO k = nzb_u_inner(j,i)+1, nzt 2291 u_comp(k) = u(k,j,i+1) + u(k,j,i) 2292 flux_r(k) = ( u_comp(k) - gu ) * ( & 2293 37.0 * ( u(k,j,i+1) + u(k,j,i) ) & 2294 - 8.0 * ( u(k,j,i+2) + u(k,j,i-1) ) & 2295 + ( u(k,j,i+3) + u(k,j,i-2) ) ) & 2296 * adv_mom_5 2297 diss_r(k) = - ABS( u_comp(k) - gu ) * ( & 2298 10.0 * ( u(k,j,i+1) - u(k,j,i) ) & 2299 - 5.0 * ( u(k,j,i+2) - u(k,j,i-1) ) & 2300 + ( u(k,j,i+3) - u(k,j,i-2) ) ) & 2301 * adv_mom_5 2302 ENDDO 2303 2304 ENDIF 2305 2306 ELSE 2307 2308 DO k = nzb_u_inner(j,i)+1, nzt 2309 u_comp(k) = u(k,j,i+1) + u(k,j,i) 2310 flux_r(k) = ( u_comp(k) - gu ) * ( & 2311 37.0 * ( u(k,j,i+1) + u(k,j,i) ) & 2312 - 8.0 * ( u(k,j,i+2) + u(k,j,i-1) ) & 2313 + ( u(k,j,i+3) + u(k,j,i-2) ) ) & 2314 * adv_mom_5 2315 diss_r(k) = - ABS( u_comp(k) - gu ) * ( & 2316 10.0 * ( u(k,j,i+1) - u(k,j,i) ) & 2317 - 5.0 * ( u(k,j,i+2) - u(k,j,i-1) ) & 2318 + ( u(k,j,i+3) - u(k,j,i-2) ) ) * adv_mom_5 2319 2320 v_comp = v(k,j+1,i) + v(k,j+1,i-1) - gv 2321 flux_n(k) = v_comp * ( & 2322 37.0 * ( u(k,j+1,i) + u(k,j,i) ) & 2323 - 8.0 * ( u(k,j+2,i) + u(k,j-1,i) ) & 2324 + ( u(k,j+3,i) + u(k,j-2,i) ) ) * adv_mom_5 2325 diss_n(k) = - ABS( v_comp ) * ( & 2326 10.0 * ( u(k,j+1,i) - u(k,j,i) ) & 2327 - 5.0 * ( u(k,j+2,i) - u(k,j-1,i) ) & 2328 + ( u(k,j+3,i) - u(k,j-2,i) ) ) * adv_mom_5 2329 2330 ENDDO 2331 2332 ENDIF 2333 2334 DO k = nzb_u_inner(j,i)+1, nzt 2335 2336 tend(k,j,i) = tend(k,j,i) - ( & 2337 ( flux_r(k) + diss_r(k) & 2338 - swap_flux_x_local_u(k,j) - swap_diss_x_local_u(k,j) ) * ddx & 2339 + ( flux_n(k) + diss_n(k) & 2340 - swap_flux_y_local_u(k) - swap_diss_y_local_u(k) ) * ddy ) 2341 2342 swap_flux_x_local_u(k,j) = flux_r(k) 2343 swap_diss_x_local_u(k,j) = diss_r(k) 2344 swap_flux_y_local_u(k) = flux_n(k) 2345 swap_diss_y_local_u(k) = diss_n(k) 2346 2347 sums_us2_ws_l(k,tn) = sums_us2_ws_l(k,tn) & 2348 + ( flux_r(k) & 2349 * ( u_comp(k) - 2.0 * hom(k,1,1,0) ) & 2350 / ( u_comp(k) - gu + 1.0E-20 ) & 2351 + diss_r(k) & 2352 * ABS( u_comp(k) - 2.0 * hom(k,1,1,0) ) & 2353 / ( ABS( u_comp(k) - gu) + 1.0E-20) ) & 2354 * weight_substep(intermediate_timestep_count) 2355 ENDDO 2356 sums_us2_ws_l(nzb_u_inner(j,i),tn) = sums_us2_ws_l(nzb_u_inner(j,i)+1,tn) 2357 ENDDO 2266 !-- The following loop computes the fluxes for the south boundary points 2267 j = nys 2268 DO k = nzb+1, nzb_max 2269 2270 v_comp = v(k,j,i) + v(k,j,i-1) - gv 2271 swap_flux_y_local_u(k) = v_comp * ( & 2272 ( 37.0 * IBITS(wall_flags_0(k,j,i),14,1) * adv_mom_5 & 2273 + 7.0 * IBITS(wall_flags_0(k,j,i),13,1) * adv_mom_3 & 2274 + IBITS(wall_flags_0(k,j,i),12,1) * adv_mom_1 & 2275 ) * & 2276 ( u(k,j,i) + u(k,j-1,i) ) & 2277 - ( 8.0 * IBITS(wall_flags_0(k,j,i),14,1) * adv_mom_5 & 2278 + IBITS(wall_flags_0(k,j,i),13,1) * adv_mom_3 & 2279 ) * & 2280 ( u(k,j+1,i) + u(k,j-2,i) ) & 2281 + ( IBITS(wall_flags_0(k,j,i),14,1) * adv_mom_5 & 2282 ) * & 2283 ( u(k,j+2,i) + u(k,j-3,i) ) & 2284 ) 2285 2286 swap_diss_y_local_u(k) = - ABS ( v_comp ) * ( & 2287 ( 10.0 * IBITS(wall_flags_0(k,j,i),14,1) * adv_mom_5 & 2288 + 3.0 * IBITS(wall_flags_0(k,j,i),13,1) * adv_mom_3 & 2289 + IBITS(wall_flags_0(k,j,i),12,1) * adv_mom_1 & 2290 ) * & 2291 ( u(k,j,i) - u(k,j-1,i) ) & 2292 - ( 5.0 * IBITS(wall_flags_0(k,j,i),14,1) * adv_mom_5 & 2293 + IBITS(wall_flags_0(k,j,i),13,1) * adv_mom_3 & 2294 ) * & 2295 ( u(k,j+1,i) - u(k,j-2,i) ) & 2296 + ( IBITS(wall_flags_0(k,j,i),14,1) * adv_mom_5 & 2297 ) * & 2298 ( u(k,j+2,i) - u(k,j-3,i) ) & 2299 ) 2300 2301 ENDDO 2302 2303 DO k = nzb_max+1, nzt 2304 2305 v_comp = v(k,j,i) + v(k,j,i-1) - gv 2306 swap_flux_y_local_u(k) = v_comp * ( & 2307 37.0 * ( u(k,j,i) + u(k,j-1,i) ) & 2308 - 8.0 * ( u(k,j+1,i) + u(k,j-2,i) ) & 2309 + ( u(k,j+2,i) + u(k,j-3,i) ) ) * adv_mom_5 2310 swap_diss_y_local_u(k) = - ABS(v_comp) * ( & 2311 10.0 * ( u(k,j,i) - u(k,j-1,i) ) & 2312 - 5.0 * ( u(k,j+1,i) - u(k,j-2,i) ) & 2313 + ( u(k,j+2,i) - u(k,j-3,i) ) ) * adv_mom_5 2314 2315 ENDDO 2316 ! 2317 !-- Computation of interior fluxes and tendency terms 2318 DO j = nys, nyn 2319 2320 flux_t(0) = 0.0 2321 diss_t(0) = 0.0 2322 flux_d = 0.0 2323 diss_d = 0.0 2324 2325 DO k = nzb+1, nzb_max 2326 2327 u_comp(k) = u(k,j,i+1) + u(k,j,i) 2328 flux_r(k) = ( u_comp(k) - gu ) * ( & 2329 ( 37.0 * IBITS(wall_flags_0(k,j,i),11,1) * adv_mom_5 & 2330 + 7.0 * IBITS(wall_flags_0(k,j,i),10,1) * adv_mom_3 & 2331 + IBITS(wall_flags_0(k,j,i),9,1) * adv_mom_1 & 2332 ) * & 2333 ( u(k,j,i+1) + u(k,j,i) ) & 2334 - ( 8.0 * IBITS(wall_flags_0(k,j,i),11,1) * adv_mom_5 & 2335 + IBITS(wall_flags_0(k,j,i),10,1) * adv_mom_3 & 2336 ) * & 2337 ( u(k,j,i+2) + u(k,j,i-1) ) & 2338 + ( IBITS(wall_flags_0(k,j,i),11,1) * adv_mom_5 & 2339 ) * & 2340 ( u(k,j,i+3) + u(k,j,i-2) ) & 2341 ) 2342 2343 diss_r(k) = - ABS( u_comp(k) - gu ) * ( & 2344 ( 10.0 * IBITS(wall_flags_0(k,j,i),11,1) * adv_mom_5 & 2345 + 3.0 * IBITS(wall_flags_0(k,j,i),10,1) * adv_mom_3 & 2346 + IBITS(wall_flags_0(k,j,i),9,1) * adv_mom_1 & 2347 ) * & 2348 ( u(k,j,i+1) - u(k,j,i) ) & 2349 - ( 5.0 * IBITS(wall_flags_0(k,j,i),11,1) * adv_mom_5 & 2350 + IBITS(wall_flags_0(k,j,i),10,1) * adv_mom_3 & 2351 ) * & 2352 ( u(k,j,i+2) - u(k,j,i-1) ) & 2353 + ( IBITS(wall_flags_0(k,j,i),11,1) * adv_mom_5 & 2354 ) * & 2355 ( u(k,j,i+3) - u(k,j,i-2) ) & 2356 ) 2357 2358 v_comp = v(k,j+1,i) + v(k,j+1,i-1) - gv 2359 flux_n(k) = v_comp * ( & 2360 ( 37.0 * IBITS(wall_flags_0(k,j,i),14,1) * adv_mom_5 & 2361 + 7.0 * IBITS(wall_flags_0(k,j,i),13,1) * adv_mom_3 & 2362 + IBITS(wall_flags_0(k,j,i),12,1) * adv_mom_1 & 2363 ) * & 2364 ( u(k,j+1,i) + u(k,j,i) ) & 2365 - ( 8.0 * IBITS(wall_flags_0(k,j,i),14,1) * adv_mom_5 & 2366 + IBITS(wall_flags_0(k,j,i),13,1) * adv_mom_3 & 2367 ) * & 2368 ( u(k,j+2,i) + u(k,j-1,i) ) & 2369 + ( IBITS(wall_flags_0(k,j,i),14,1) * adv_mom_5 & 2370 ) * & 2371 ( u(k,j+3,i) + u(k,j-2,i) ) & 2372 ) 2373 2374 diss_n(k) = - ABS ( v_comp ) * ( & 2375 ( 10.0 * IBITS(wall_flags_0(k,j,i),14,1) * adv_mom_5 & 2376 + 3.0 * IBITS(wall_flags_0(k,j,i),13,1) * adv_mom_3 & 2377 + IBITS(wall_flags_0(k,j,i),12,1) * adv_mom_1 & 2378 ) * & 2379 ( u(k,j+1,i) - u(k,j,i) ) & 2380 - ( 5.0 * IBITS(wall_flags_0(k,j,i),14,1) * adv_mom_5 & 2381 + IBITS(wall_flags_0(k,j,i),13,1) * adv_mom_3 & 2382 ) * & 2383 ( u(k,j+2,i) - u(k,j-1,i) ) & 2384 + ( IBITS(wall_flags_0(k,j,i),14,1) * adv_mom_5 & 2385 ) * & 2386 ( u(k,j+3,i) - u(k,j-2,i) ) & 2387 ) 2388 ! 2389 !-- k index has to be modified near bottom and top, else array 2390 !-- subscripts will be exceeded. 2391 k_ppp = k + 3 * IBITS(wall_flags_0(k,j,i),17,1) 2392 k_pp = k + 2 * ( 1 - IBITS(wall_flags_0(k,j,i),15,1) ) 2393 k_mm = k - 2 * IBITS(wall_flags_0(k,j,i),17,1) 2394 2395 w_comp = w(k,j,i) + w(k,j,i-1) 2396 flux_t(k) = w_comp * ( & 2397 ( 37.0 * IBITS(wall_flags_0(k,j,i),17,1) * adv_mom_5 & 2398 + 7.0 * IBITS(wall_flags_0(k,j,i),16,1) * adv_mom_3 & 2399 + IBITS(wall_flags_0(k,j,i),15,1) * adv_mom_1 & 2400 ) * & 2401 ( u(k+1,j,i) + u(k,j,i) ) & 2402 - ( 8.0 * IBITS(wall_flags_0(k,j,i),17,1) * adv_mom_5 & 2403 + IBITS(wall_flags_0(k,j,i),16,1) * adv_mom_3 & 2404 ) * & 2405 ( u(k_pp,j,i) + u(k-1,j,i) ) & 2406 + ( IBITS(wall_flags_0(k,j,i),17,1) * adv_mom_5 & 2407 ) * & 2408 ( u(k_ppp,j,i) + u(k_mm,j,i) ) & 2409 ) 2410 2411 diss_t(k) = - ABS( w_comp ) * ( & 2412 ( 10.0 * IBITS(wall_flags_0(k,j,i),17,1) * adv_mom_5 & 2413 + 3.0 * IBITS(wall_flags_0(k,j,i),16,1) * adv_mom_3 & 2414 + IBITS(wall_flags_0(k,j,i),15,1) * adv_mom_1 & 2415 ) * & 2416 ( u(k+1,j,i) - u(k,j,i) ) & 2417 - ( 5.0 * IBITS(wall_flags_0(k,j,i),17,1) * adv_mom_5 & 2418 + IBITS(wall_flags_0(k,j,i),16,1) * adv_mom_3 & 2419 ) * & 2420 ( u(k_pp,j,i) - u(k-1,j,i) ) & 2421 + ( IBITS(wall_flags_0(k,j,i),17,1) * adv_mom_5 & 2422 ) * & 2423 ( u(k_ppp,j,i) - u(k_mm,j,i) ) & 2424 ) 2425 ! 2426 !-- Calculate the divergence of the velocity field. A respective 2427 !-- correction is needed to overcome numerical instabilities caused 2428 !-- by a not sufficient reduction of divergences near topography. 2429 div = ( ( u_comp(k) - ( u(k,j,i) + u(k,j,i-1) ) ) * ddx & 2430 + ( v_comp + gv - ( v(k,j,i) + v(k,j,i-1 ) ) ) * ddy & 2431 + ( w_comp - ( w(k-1,j,i) + w(k-1,j,i-1) ) ) & 2432 * ddzw(k) & 2433 ) * 0.5 2434 2435 tend(k,j,i) = tend(k,j,i) - ( & 2436 ( flux_r(k) + diss_r(k) & 2437 - swap_flux_x_local_u(k,j) - swap_diss_x_local_u(k,j) ) * ddx & 2438 + ( flux_n(k) + diss_n(k) & 2439 - swap_flux_y_local_u(k) - swap_diss_y_local_u(k) ) * ddy & 2440 + ( flux_t(k) + diss_t(k) & 2441 - flux_d - diss_d & 2442 ) * ddzw(k) & 2443 ) + div * u(k,j,i) 2444 2445 swap_flux_x_local_u(k,j) = flux_r(k) 2446 swap_diss_x_local_u(k,j) = diss_r(k) 2447 swap_flux_y_local_u(k) = flux_n(k) 2448 swap_diss_y_local_u(k) = diss_n(k) 2449 flux_d = flux_t(k) 2450 diss_d = diss_t(k) 2451 ! 2452 !-- Statistical Evaluation of u'u'. The factor has to be applied 2453 !-- for right evaluation when gallilei_trans = .T. . 2454 sums_us2_ws_l(k,tn) = sums_us2_ws_l(k,tn) & 2455 + ( flux_r(k) * & 2456 ( u_comp(k) - 2.0 * hom(k,1,1,0) ) & 2457 / ( u_comp(k) - gu + 1.0E-20 ) & 2458 + diss_r(k) * & 2459 ABS( u_comp(k) - 2.0 * hom(k,1,1,0) ) & 2460 / ( ABS( u_comp(k) - gu ) + 1.0E-20 ) ) & 2461 * weight_substep(intermediate_timestep_count) 2462 ! 2463 !-- Statistical Evaluation of w'u'. 2464 sums_wsus_ws_l(k,tn) = sums_wsus_ws_l(k,tn) & 2465 + ( flux_t(k) + diss_t(k) ) & 2466 * weight_substep(intermediate_timestep_count) 2467 ENDDO 2468 2469 DO k = nzb_max+1, nzt 2470 2471 u_comp(k) = u(k,j,i+1) + u(k,j,i) 2472 flux_r(k) = ( u_comp(k) - gu ) * ( & 2473 37.0 * ( u(k,j,i+1) + u(k,j,i) ) & 2474 - 8.0 * ( u(k,j,i+2) + u(k,j,i-1) ) & 2475 + ( u(k,j,i+3) + u(k,j,i-2) ) ) * adv_mom_5 2476 diss_r(k) = - ABS( u_comp(k) - gu ) * ( & 2477 10.0 * ( u(k,j,i+1) - u(k,j,i) ) & 2478 - 5.0 * ( u(k,j,i+2) - u(k,j,i-1) ) & 2479 + ( u(k,j,i+3) - u(k,j,i-2) ) ) * adv_mom_5 2480 2481 v_comp = v(k,j+1,i) + v(k,j+1,i-1) - gv 2482 flux_n(k) = v_comp * ( & 2483 37.0 * ( u(k,j+1,i) + u(k,j,i) ) & 2484 - 8.0 * ( u(k,j+2,i) + u(k,j-1,i) ) & 2485 + ( u(k,j+3,i) + u(k,j-2,i) ) ) * adv_mom_5 2486 diss_n(k) = - ABS( v_comp ) * ( & 2487 10.0 * ( u(k,j+1,i) - u(k,j,i) ) & 2488 - 5.0 * ( u(k,j+2,i) - u(k,j-1,i) ) & 2489 + ( u(k,j+3,i) - u(k,j-2,i) ) ) * adv_mom_5 2490 ! 2491 !-- k index has to be modified near bottom and top, else array 2492 !-- subscripts will be exceeded. 2493 k_ppp = k + 3 * IBITS(wall_flags_0(k,j,i),17,1) 2494 k_pp = k + 2 * ( 1 - IBITS(wall_flags_0(k,j,i),15,1) ) 2495 k_mm = k - 2 * IBITS(wall_flags_0(k,j,i),17,1) 2496 2497 w_comp = w(k,j,i) + w(k,j,i-1) 2498 flux_t(k) = w_comp * ( & 2499 ( 37.0 * IBITS(wall_flags_0(k,j,i),17,1) * adv_mom_5 & 2500 + 7.0 * IBITS(wall_flags_0(k,j,i),16,1) * adv_mom_3 & 2501 + IBITS(wall_flags_0(k,j,i),15,1) * adv_mom_1 & 2502 ) * & 2503 ( u(k+1,j,i) + u(k,j,i) ) & 2504 - ( 8.0 * IBITS(wall_flags_0(k,j,i),17,1) * adv_mom_5 & 2505 + IBITS(wall_flags_0(k,j,i),16,1) * adv_mom_3 & 2506 ) * & 2507 ( u(k_pp,j,i) + u(k-1,j,i) ) & 2508 + ( IBITS(wall_flags_0(k,j,i),17,1) * adv_mom_5 & 2509 ) * & 2510 ( u(k_ppp,j,i) + u(k_mm,j,i) ) & 2511 ) 2512 2513 diss_t(k) = - ABS( w_comp ) * ( & 2514 ( 10.0 * IBITS(wall_flags_0(k,j,i),17,1) * adv_mom_5 & 2515 + 3.0 * IBITS(wall_flags_0(k,j,i),16,1) * adv_mom_3 & 2516 + IBITS(wall_flags_0(k,j,i),15,1) * adv_mom_1 & 2517 ) * & 2518 ( u(k+1,j,i) - u(k,j,i) ) & 2519 - ( 5.0 * IBITS(wall_flags_0(k,j,i),17,1) * adv_mom_5 & 2520 + IBITS(wall_flags_0(k,j,i),16,1) * adv_mom_3 & 2521 ) * & 2522 ( u(k_pp,j,i) - u(k-1,j,i) ) & 2523 + ( IBITS(wall_flags_0(k,j,i),17,1) * adv_mom_5 & 2524 ) * & 2525 ( u(k_ppp,j,i) - u(k_mm,j,i) ) & 2526 ) 2527 ! 2528 !-- Calculate the divergence of the velocity field. A respective 2529 !-- correction is needed to overcome numerical instabilities caused 2530 !-- by a not sufficient reduction of divergences near topography. 2531 div = ( ( u_comp(k) - ( u(k,j,i) + u(k,j,i-1) ) ) * ddx & 2532 + ( v_comp + gv - ( v(k,j,i) + v(k,j,i-1 ) ) ) * ddy & 2533 + ( w_comp - ( w(k-1,j,i) + w(k-1,j,i-1) ) ) & 2534 * ddzw(k) & 2535 ) * 0.5 2536 2537 tend(k,j,i) = tend(k,j,i) - ( & 2538 ( flux_r(k) + diss_r(k) & 2539 - swap_flux_x_local_u(k,j) - swap_diss_x_local_u(k,j) ) * ddx & 2540 + ( flux_n(k) + diss_n(k) & 2541 - swap_flux_y_local_u(k) - swap_diss_y_local_u(k) ) * ddy & 2542 + ( flux_t(k) + diss_t(k) & 2543 - flux_d - diss_d & 2544 ) * ddzw(k) & 2545 ) + div * u(k,j,i) 2546 2547 swap_flux_x_local_u(k,j) = flux_r(k) 2548 swap_diss_x_local_u(k,j) = diss_r(k) 2549 swap_flux_y_local_u(k) = flux_n(k) 2550 swap_diss_y_local_u(k) = diss_n(k) 2551 flux_d = flux_t(k) 2552 diss_d = diss_t(k) 2553 ! 2554 !-- Statistical Evaluation of u'u'. The factor has to be applied 2555 !-- for right evaluation when gallilei_trans = .T. . 2556 sums_us2_ws_l(k,tn) = sums_us2_ws_l(k,tn) & 2557 + ( flux_r(k) * & 2558 ( u_comp(k) - 2.0 * hom(k,1,1,0) ) & 2559 / ( u_comp(k) - gu + 1.0E-20 ) & 2560 + diss_r(k) * & 2561 ABS( u_comp(k) - 2.0 * hom(k,1,1,0) ) & 2562 / ( ABS( u_comp(k) - gu ) + 1.0E-20 ) ) & 2563 * weight_substep(intermediate_timestep_count) 2564 ! 2565 !-- Statistical Evaluation of w'u'. 2566 sums_wsus_ws_l(k,tn) = sums_wsus_ws_l(k,tn) & 2567 + ( flux_t(k) + diss_t(k) ) & 2568 * weight_substep(intermediate_timestep_count) 2358 2569 ENDDO 2359 2360 !2361 !-- Vertical advection, degradation of order near surface and top.2362 !-- The fluxes flux_d and diss_d at the surface are 0. Due to reasons of2363 !-- statistical evaluation the top flux at the surface should be 02364 DO i = nxlu, nxr2365 DO j = nys, nyn2366 k = nzb_u_inner(j,i)+12367 !2368 !-- The fluxes flux_d and diss_d at the surface are 0. Due to static2369 !-- reasons the top flux at the surface should be 0.2370 flux_t(nzb_u_inner(j,i)) = 0.02371 diss_t(nzb_u_inner(j,i)) = 0.02372 flux_d = flux_t(k-1)2373 diss_d = diss_t(k-1)2374 !2375 !-- 2nd order scheme (bottom)2376 w_comp = w(k,j,i) + w(k,j,i-1)2377 flux_t(k) = w_comp * ( u(k+1,j,i) + u(k,j,i) ) * 0.252378 diss_t(k) = diss_2nd( u(k+2,j,i), u(k+1,j,i), u(k,j,i), &2379 0.0, 0.0, w_comp, 0.25, ddzw(k) )2380 2381 tend(k,j,i) = tend(k,j,i) - ( flux_t(k) + diss_t(k) &2382 - flux_d - diss_d ) * ddzw(k)2383 !2384 !-- WS3 as an intermediate step (bottom)2385 k = nzb_u_inner(j,i)+22386 flux_d = flux_t(k-1)2387 diss_d = diss_t(k-1)2388 w_comp = w(k,j,i) + w(k,j,i-1)2389 flux_t(k) = w_comp * ( &2390 7.0 * ( u(k+1,j,i) + u(k,j,i) ) &2391 - ( u(k+2,j,i) + u(k-1,j,i) ) ) * adv_mom_32392 diss_t(k) = - ABS( w_comp ) * ( &2393 3.0 * ( u(k+1,j,i) - u(k,j,i) ) &2394 - ( u(k+2,j,i) - u(k-1,j,i) ) ) * adv_mom_32395 2396 tend(k,j,i) = tend(k,j,i) - ( flux_t(k) + diss_t(k) &2397 - flux_d - diss_d ) * ddzw(k)2398 !2399 !WS52400 DO k = nzb_u_inner(j,i)+3, nzt-22401 2402 flux_d = flux_t(k-1)2403 diss_d = diss_t(k-1)2404 w_comp = w(k,j,i) + w(k,j,i-1)2405 flux_t(k) = w_comp * ( &2406 37.0 * ( u(k+1,j,i) + u(k,j,i) ) &2407 - 8.0 * ( u(k+2,j,i) + u(k-1,j,i) ) &2408 + ( u(k+3,j,i) + u(k-2,j,i) ) ) * adv_mom_52409 diss_t(k) = - ABS( w_comp ) * ( &2410 10.0 * ( u(k+1,j,i) - u(k,j,i) ) &2411 - 5.0 * ( u(k+2,j,i) - u(k-1,j,i) ) &2412 + ( u(k+3,j,i) - u(k-2,j,i) ) ) * adv_mom_52413 2414 tend(k,j,i) = tend(k,j,i) - ( flux_t(k) + diss_t(k) &2415 - flux_d - diss_d ) * ddzw(k)2416 2417 ENDDO2418 !2419 !-- WS3 as an intermediate step (top)2420 k = nzt-12421 flux_d = flux_t(k-1)2422 diss_d = diss_t(k-1)2423 w_comp = w(k,j,i) + w(k,j,i-1)2424 flux_t(k) = w_comp * ( &2425 7.0 * ( u(k+1,j,i) + u(k,j,i) ) &2426 - ( u(k+2,j,i) + u(k-1,j,i) ) ) * adv_mom_32427 diss_t(k) = - ABS( w_comp ) * ( &2428 3.0 * ( u(k+1,j,i) - u(k,j,i) ) &2429 - ( u(k+2,j,i) - u(k-1,j,i) ) ) * adv_mom_32430 2431 tend(k,j,i) = tend(k,j,i) - ( flux_t(k) + diss_t(k) &2432 - flux_d - diss_d ) * ddzw(k)2433 !2434 !-- 2nd order scheme (top)2435 k = nzt2436 flux_d = flux_t(k-1)2437 diss_d = diss_t(k-1)2438 w_comp = w(k,j,i) + w(k,j,i-1)2439 flux_t(k) = w_comp * ( u(k+1,j,i) + u(k,j,i) ) * 0.252440 diss_t(k) = diss_2nd( u(nzt+1,j,i), u(nzt+1,j,i), u(k,j,i), &2441 u(k-1,j,i), u(k-2,j,i), w_comp, &2442 0.25, ddzw(k))2443 2444 tend(k,j,i) = tend(k,j,i) - ( flux_t(k) + diss_t(k) &2445 - flux_d - diss_d ) * ddzw(k)2446 !2447 !-- at last vertical momentum flux is accumulated2448 DO k = nzb_u_inner(j,i), nzt2449 sums_wsus_ws_l(k,tn) = sums_wsus_ws_l(k,tn) &2450 + ( flux_t(k) + diss_t(k) ) &2451 * weight_substep(intermediate_timestep_count)2452 ENDDO2453 2570 ENDDO 2454 2571 ENDDO 2572 sums_us2_ws_l(nzb,tn) = sums_us2_ws_l(nzb+1,tn) 2455 2573 2456 2574 … … 2473 2591 2474 2592 2475 INTEGER :: i, j, k, tn = 0 2476 REAL :: gu, gv, flux_l, flux_s, flux_d, diss_l, diss_s, diss_d, & 2477 u_comp, w_comp 2593 INTEGER :: i, j, k, tn = 0, k_ppp, k_pp, k_mm 2594 REAL :: gu, gv, flux_d, diss_d, u_comp, w_comp, div 2478 2595 REAL, DIMENSION(nzb+1:nzt) :: swap_flux_y_local_v, swap_diss_y_local_v 2479 2596 REAL, DIMENSION(nzb+1:nzt,nys:nyn) :: swap_flux_x_local_v, & 2480 2597 swap_diss_x_local_v 2481 REAL, DIMENSION(nzb:nzt +1) :: flux_t, diss_t, flux_n, diss_n, flux_r,&2482 2598 REAL, DIMENSION(nzb:nzt) :: flux_t, diss_t, flux_n, diss_n, flux_r, & 2599 diss_r, v_comp 2483 2600 2484 2601 gu = 2.0 * u_gtrans 2485 2602 gv = 2.0 * v_gtrans 2486 2603 ! 2487 !-- First compute the whole left boundary of the processor domain2604 !-- First compute the whole left boundary of the processor domain 2488 2605 i = nxl 2489 2606 DO j = nysv, nyn 2490 2491 IF ( boundary_flags(j,i) == 6 ) THEN 2492 DO k = nzb_v_inner(j,i)+1, nzt 2493 u_comp = u(k,j-1,i) + u(k,j,i) - gu 2494 swap_flux_x_local_v(k,j) = u_comp * & 2495 ( v(k,j,i) + v(k,j,i-1)) * 0.25 2496 swap_diss_x_local_v(k,j) = diss_2nd( v(k,j,i+2), v(k,j,i+1), & 2497 v(k,j,i), v(k,j,i-1), & 2498 v(k,j,i-1), u_comp, & 2499 0.25, ddx ) 2607 DO k = nzb+1, nzb_max 2608 2609 u_comp = u(k,j-1,i) + u(k,j,i) - gu 2610 swap_flux_x_local_v(k,j) = u_comp * ( & 2611 ( 37.0 * IBITS(wall_flags_0(k,j,i),20,1) * adv_mom_5 & 2612 + 7.0 * IBITS(wall_flags_0(k,j,i),19,1) * adv_mom_3 & 2613 + IBITS(wall_flags_0(k,j,i),18,1) * adv_mom_1 & 2614 ) * & 2615 ( v(k,j,i) + v(k,j,i-1) ) & 2616 - ( 8.0 * IBITS(wall_flags_0(k,j,i),20,1) * adv_mom_5 & 2617 + IBITS(wall_flags_0(k,j,i),19,1) * adv_mom_3 & 2618 ) * & 2619 ( v(k,j,i+1) + v(k,j,i-2) ) & 2620 + ( IBITS(wall_flags_0(k,j,i),20,1) * adv_mom_5 & 2621 ) * & 2622 ( v(k,j,i+2) + v(k,j,i-3) ) & 2623 ) 2624 2625 swap_diss_x_local_v(k,j) = - ABS( u_comp ) * ( & 2626 ( 10.0 * IBITS(wall_flags_0(k,j,i),20,1) * adv_mom_5 & 2627 + 3.0 * IBITS(wall_flags_0(k,j,i),19,1) * adv_mom_3 & 2628 + IBITS(wall_flags_0(k,j,i),18,1) * adv_mom_1 & 2629 ) * & 2630 ( v(k,j,i) - v(k,j,i-1) ) & 2631 - ( 5.0 * IBITS(wall_flags_0(k,j,i),20,1) * adv_mom_5 & 2632 + IBITS(wall_flags_0(k,j,i),19,1) * adv_mom_3 & 2633 ) * & 2634 ( v(k,j,i+1) - v(k,j,i-2) ) & 2635 + ( IBITS(wall_flags_0(k,j,i),20,1) * adv_mom_5 & 2636 ) * & 2637 ( v(k,j,i+2) - v(k,j,i-3) ) & 2638 ) 2639 2640 ENDDO 2641 2642 DO k = nzb_max+1, nzt 2643 2644 u_comp = u(k,j-1,i) + u(k,j,i) - gu 2645 swap_flux_x_local_v(k,j) = u_comp * ( & 2646 37.0 * ( v(k,j,i) + v(k,j,i-1) ) & 2647 - 8.0 * ( v(k,j,i+1) + v(k,j,i-2) ) & 2648 + ( v(k,j,i+2) + v(k,j,i-3) ) ) * adv_mom_5 2649 swap_diss_x_local_v(k,j) = - ABS( u_comp ) * ( & 2650 10.0 * ( v(k,j,i) - v(k,j,i-1) ) & 2651 - 5.0 * ( v(k,j,i+1) - v(k,j,i-2) ) & 2652 + ( v(k,j,i+2) - v(k,j,i-3) ) ) * adv_mom_5 2653 2654 ENDDO 2655 2656 ENDDO 2657 2658 DO i = nxl, nxr 2659 2660 j = nysv 2661 DO k = nzb+1, nzb_max 2662 2663 v_comp(k) = v(k,j,i) + v(k,j-1,i) - gv 2664 swap_flux_y_local_v(k) = v_comp(k) * ( & 2665 ( 37.0 * IBITS(wall_flags_0(k,j,i),23,1) * adv_mom_5 & 2666 + 7.0 * IBITS(wall_flags_0(k,j,i),22,1) * adv_mom_3 & 2667 + IBITS(wall_flags_0(k,j,i),21,1) * adv_mom_1 & 2668 ) * & 2669 ( v(k,j,i) + v(k,j-1,i) ) & 2670 - ( 8.0 * IBITS(wall_flags_0(k,j,i),23,1) * adv_mom_5 & 2671 + IBITS(wall_flags_0(k,j,i),22,1) * adv_mom_3 & 2672 ) * & 2673 ( v(k,j+1,i) + v(k,j-2,i) ) & 2674 + ( IBITS(wall_flags_0(k,j,i),23,1) * adv_mom_5 & 2675 ) * & 2676 ( v(k,j+2,i) + v(k,j-3,i) ) & 2677 ) 2678 2679 swap_diss_y_local_v(k) = - ABS( v_comp(k) ) * ( & 2680 ( 10.0 * IBITS(wall_flags_0(k,j,i),23,1) * adv_mom_5 & 2681 + 3.0 * IBITS(wall_flags_0(k,j,i),22,1) * adv_mom_3 & 2682 + IBITS(wall_flags_0(k,j,i),21,1) * adv_mom_1 & 2683 ) * & 2684 ( v(k,j,i) - v(k,j-1,i) ) & 2685 - ( 5.0 * IBITS(wall_flags_0(k,j,i),23,1) * adv_mom_5 & 2686 + IBITS(wall_flags_0(k,j,i),22,1) * adv_mom_3 & 2687 ) * & 2688 ( v(k,j+1,i) - v(k,j-2,i) ) & 2689 + ( IBITS(wall_flags_0(k,j,i),23,1) * adv_mom_5 & 2690 ) * & 2691 ( v(k,j+2,i) - v(k,j-3,i) ) & 2692 ) 2693 2694 ENDDO 2695 2696 DO k = nzb_max+1, nzt 2697 2698 v_comp(k) = v(k,j,i) + v(k,j-1,i) - gv 2699 swap_flux_y_local_v(k) = v_comp(k) * ( & 2700 37.0 * ( v(k,j,i) + v(k,j-1,i) ) & 2701 - 8.0 * ( v(k,j+1,i) + v(k,j-2,i) ) & 2702 + ( v(k,j+2,i) + v(k,j-3,i) ) ) * adv_mom_5 2703 swap_diss_y_local_v(k) = - ABS( v_comp(k) ) * ( & 2704 10.0 * ( v(k,j,i) - v(k,j-1,i) ) & 2705 - 5.0 * ( v(k,j+1,i) - v(k,j-2,i) ) & 2706 + ( v(k,j+2,i) - v(k,j-3,i) ) ) * adv_mom_5 2707 2708 ENDDO 2709 2710 DO j = nysv, nyn 2711 2712 flux_t(0) = 0.0 2713 diss_t(0) = 0.0 2714 flux_d = 0.0 2715 diss_d = 0.0 2716 2717 DO k = nzb+1, nzb_max 2718 2719 u_comp = u(k,j-1,i+1) + u(k,j,i+1) - gu 2720 flux_r(k) = u_comp * ( & 2721 ( 37.0 * IBITS(wall_flags_0(k,j,i),20,1) * adv_mom_5 & 2722 + 7.0 * IBITS(wall_flags_0(k,j,i),19,1) * adv_mom_3 & 2723 + IBITS(wall_flags_0(k,j,i),18,1) * adv_mom_1 & 2724 ) * & 2725 ( v(k,j,i+1) + v(k,j,i) ) & 2726 - ( 8.0 * IBITS(wall_flags_0(k,j,i),20,1) * adv_mom_5 & 2727 + IBITS(wall_flags_0(k,j,i),19,1) * adv_mom_3 & 2728 ) * & 2729 ( v(k,j,i+2) + v(k,j,i-1) ) & 2730 + ( IBITS(wall_flags_0(k,j,i),20,1) * adv_mom_5 & 2731 ) * & 2732 ( v(k,j,i+3) + v(k,j,i-2) ) & 2733 ) 2734 2735 diss_r(k) = - ABS( u_comp ) * ( & 2736 ( 10.0 * IBITS(wall_flags_0(k,j,i),20,1) * adv_mom_5 & 2737 + 3.0 * IBITS(wall_flags_0(k,j,i),19,1) * adv_mom_3 & 2738 + IBITS(wall_flags_0(k,j,i),18,1) * adv_mom_1 & 2739 ) * & 2740 ( v(k,j,i+1) - v(k,j,i) ) & 2741 - ( 5.0 * IBITS(wall_flags_0(k,j,i),20,1) * adv_mom_5 & 2742 + IBITS(wall_flags_0(k,j,i),19,1) * adv_mom_3 & 2743 ) * & 2744 ( v(k,j,i+2) - v(k,j,i-1) ) & 2745 + ( IBITS(wall_flags_0(k,j,i),20,1) * adv_mom_5 & 2746 ) * & 2747 ( v(k,j,i+3) - v(k,j,i-2) ) & 2748 ) 2749 2750 v_comp(k) = v(k,j+1,i) + v(k,j,i) 2751 flux_n(k) = ( v_comp(k) - gv ) * ( & 2752 ( 37.0 * IBITS(wall_flags_0(k,j,i),23,1) * adv_mom_5 & 2753 + 7.0 * IBITS(wall_flags_0(k,j,i),22,1) * adv_mom_3 & 2754 + IBITS(wall_flags_0(k,j,i),21,1) * adv_mom_1 & 2755 ) * & 2756 ( v(k,j+1,i) + v(k,j,i) ) & 2757 - ( 8.0 * IBITS(wall_flags_0(k,j,i),23,1) * adv_mom_5 & 2758 + IBITS(wall_flags_0(k,j,i),22,1) * adv_mom_3 & 2759 ) * & 2760 ( v(k,j+2,i) + v(k,j-1,i) ) & 2761 + ( IBITS(wall_flags_0(k,j,i),23,1) * adv_mom_5 & 2762 ) * & 2763 ( v(k,j+3,i) + v(k,j-2,i) ) & 2764 ) 2765 2766 diss_n(k) = - ABS( v_comp(k) - gv ) * ( & 2767 ( 10.0 * IBITS(wall_flags_0(k,j,i),23,1) * adv_mom_5 & 2768 + 3.0 * IBITS(wall_flags_0(k,j,i),22,1) * adv_mom_3 & 2769 + IBITS(wall_flags_0(k,j,i),21,1) * adv_mom_1 & 2770 ) * & 2771 ( v(k,j+1,i) - v(k,j,i) ) & 2772 - ( 5.0 * IBITS(wall_flags_0(k,j,i),23,1) * adv_mom_5 & 2773 + IBITS(wall_flags_0(k,j,i),22,1) * adv_mom_3 & 2774 ) * & 2775 ( v(k,j+2,i) - v(k,j-1,i) ) & 2776 + ( IBITS(wall_flags_0(k,j,i),23,1) * adv_mom_5 & 2777 ) * & 2778 ( v(k,j+3,i) - v(k,j-2,i) ) & 2779 ) 2780 ! 2781 !-- k index has to be modified near bottom and top, else array 2782 !-- subscripts will be exceeded. 2783 k_ppp = k + 3 * IBITS(wall_flags_0(k,j,i),26,1) 2784 k_pp = k + 2 * ( 1 - IBITS(wall_flags_0(k,j,i),24,1) ) 2785 k_mm = k - 2 * IBITS(wall_flags_0(k,j,i),26,1) 2786 2787 w_comp = w(k,j-1,i) + w(k,j,i) 2788 flux_t(k) = w_comp * ( & 2789 ( 37.0 * IBITS(wall_flags_0(k,j,i),26,1) * adv_mom_5 & 2790 + 7.0 * IBITS(wall_flags_0(k,j,i),25,1) * adv_mom_3 & 2791 + IBITS(wall_flags_0(k,j,i),24,1) * adv_mom_1 & 2792 ) * & 2793 ( v(k+1,j,i) + v(k,j,i) ) & 2794 - ( 8.0 * IBITS(wall_flags_0(k,j,i),26,1) * adv_mom_5 & 2795 + IBITS(wall_flags_0(k,j,i),25,1) * adv_mom_3 & 2796 ) * & 2797 ( v(k_pp,j,i) + v(k-1,j,i) ) & 2798 + ( IBITS(wall_flags_0(k,j,i),26,1) * adv_mom_5 & 2799 ) * & 2800 ( v(k_ppp,j,i) + v(k_mm,j,i) ) & 2801 ) 2802 2803 diss_t(k) = - ABS( w_comp ) * ( & 2804 ( 10.0 * IBITS(wall_flags_0(k,j,i),26,1) * adv_mom_5 & 2805 + 3.0 * IBITS(wall_flags_0(k,j,i),25,1) * adv_mom_3 & 2806 + IBITS(wall_flags_0(k,j,i),24,1) * adv_mom_1 & 2807 ) * & 2808 ( v(k+1,j,i) - v(k,j,i) ) & 2809 - ( 5.0 * IBITS(wall_flags_0(k,j,i),26,1) * adv_mom_5 & 2810 + IBITS(wall_flags_0(k,j,i),25,1) * adv_mom_3 & 2811 ) * & 2812 ( v(k_pp,j,i) - v(k-1,j,i) ) & 2813 + ( IBITS(wall_flags_0(k,j,i),26,1) * adv_mom_5 & 2814 ) * & 2815 ( v(k_ppp,j,i) - v(k_mm,j,i) ) & 2816 ) 2817 ! 2818 !-- Calculate the divergence of the velocity field. A respective 2819 !-- correction is needed to overcome numerical instabilities caused 2820 !-- by a not sufficient reduction of divergences near topography. 2821 div = ( ( u_comp + gu - ( u(k,j-1,i) + u(k,j,i) ) ) * ddx & 2822 + ( v_comp(k) - ( v(k,j,i) + v(k,j-1,i) ) ) * ddy & 2823 + ( w_comp - ( w(k-1,j-1,i) + w(k-1,j,i) ) & 2824 ) * ddzw(k) & 2825 ) * 0.5 2826 2827 tend(k,j,i) = tend(k,j,i) - ( & 2828 ( flux_r(k) + diss_r(k) & 2829 - swap_flux_x_local_v(k,j) - swap_diss_x_local_v(k,j) & 2830 ) * ddx & 2831 + ( flux_n(k) + diss_n(k) & 2832 - swap_flux_y_local_v(k) - swap_diss_y_local_v(k) & 2833 ) * ddy & 2834 + ( flux_t(k) + diss_t(k) & 2835 - flux_d - diss_d & 2836 ) * ddzw(k) & 2837 ) + v(k,j,i) * div 2838 2839 swap_flux_x_local_v(k,j) = flux_r(k) 2840 swap_diss_x_local_v(k,j) = diss_r(k) 2841 swap_flux_y_local_v(k) = flux_n(k) 2842 swap_diss_y_local_v(k) = diss_n(k) 2843 flux_d = flux_t(k) 2844 diss_d = diss_t(k) 2845 2846 ! 2847 !-- Statistical Evaluation of v'v'. The factor has to be applied 2848 !-- for right evaluation when gallilei_trans = .T. . 2849 sums_vs2_ws_l(k,tn) = sums_vs2_ws_l(k,tn) & 2850 + ( flux_n(k) & 2851 * ( v_comp(k) - 2.0 * hom(k,1,2,0) ) & 2852 / ( v_comp(k) - gv + 1.0E-20 ) & 2853 + diss_n(k) & 2854 * ABS( v_comp(k) - 2.0 * hom(k,1,2,0) ) & 2855 / ( ABS( v_comp(k) - gv ) +1.0E-20 ) ) & 2856 * weight_substep(intermediate_timestep_count) 2857 ! 2858 !-- Statistical Evaluation of w'v'. 2859 sums_wsvs_ws_l(k,tn) = sums_wsvs_ws_l(k,tn) & 2860 + ( flux_t(k) + diss_t(k) ) & 2861 * weight_substep(intermediate_timestep_count) 2862 2500 2863 ENDDO 2501 2502 ELSE 2503 2504 DO k = nzb_v_inner(j,i)+1, nzt 2505 u_comp = u(k,j-1,i) + u(k,j,i) - gu 2506 swap_flux_x_local_v(k,j) = u_comp * ( & 2507 37.0 * ( v(k,j,i) + v(k,j,i-1) ) & 2508 - 8.0 * ( v(k,j,i+1) + v(k,j,i-2) ) & 2509 + ( v(k,j,i+2) + v(k,j,i-3) ) )& 2510 * adv_mom_5 2511 swap_diss_x_local_v(k,j) = - ABS( u_comp ) * ( & 2512 10.0 * ( v(k,j,i) - v(k,j,i-1) ) & 2513 - 5.0 * ( v(k,j,i+1) - v(k,j,i-2) ) & 2514 + ( v(k,j,i+2) - v(k,j,i-3) ) )& 2515 * adv_mom_5 2864 2865 DO k = nzb_max+1, nzt 2866 2867 u_comp = u(k,j-1,i+1) + u(k,j,i+1) - gu 2868 flux_r(k) = u_comp * ( & 2869 37.0 * ( v(k,j,i+1) + v(k,j,i) ) & 2870 - 8.0 * ( v(k,j,i+2) + v(k,j,i-1) ) & 2871 + ( v(k,j,i+3) + v(k,j,i-2) ) ) * adv_mom_5 2872 2873 diss_r(k) = - ABS( u_comp ) * ( & 2874 10.0 * ( v(k,j,i+1) - v(k,j,i) ) & 2875 - 5.0 * ( v(k,j,i+2) - v(k,j,i-1) ) & 2876 + ( v(k,j,i+3) - v(k,j,i-2) ) ) * adv_mom_5 2877 2878 2879 v_comp(k) = v(k,j+1,i) + v(k,j,i) 2880 flux_n(k) = ( v_comp(k) - gv ) * ( & 2881 37.0 * ( v(k,j+1,i) + v(k,j,i) ) & 2882 - 8.0 * ( v(k,j+2,i) + v(k,j-1,i) ) & 2883 + ( v(k,j+3,i) + v(k,j-2,i) ) ) * adv_mom_5 2884 2885 diss_n(k) = - ABS( v_comp(k) - gv ) * ( & 2886 10.0 * ( v(k,j+1,i) - v(k,j,i) ) & 2887 - 5.0 * ( v(k,j+2,i) - v(k,j-1,i) ) & 2888 + ( v(k,j+3,i) - v(k,j-2,i) ) ) * adv_mom_5 2889 ! 2890 !-- k index has to be modified near bottom and top, else array 2891 !-- subscripts will be exceeded. 2892 k_ppp = k + 3 * IBITS(wall_flags_0(k,j,i),26,1) 2893 k_pp = k + 2 * ( 1 - IBITS(wall_flags_0(k,j,i),24,1) ) 2894 k_mm = k - 2 * IBITS(wall_flags_0(k,j,i),26,1) 2895 2896 w_comp = w(k,j-1,i) + w(k,j,i) 2897 flux_t(k) = w_comp * ( & 2898 ( 37.0 * IBITS(wall_flags_0(k,j,i),26,1) * adv_mom_5 & 2899 + 7.0 * IBITS(wall_flags_0(k,j,i),25,1) * adv_mom_3 & 2900 + IBITS(wall_flags_0(k,j,i),24,1) * adv_mom_1 & 2901 ) * & 2902 ( v(k+1,j,i) + v(k,j,i) ) & 2903 - ( 8.0 * IBITS(wall_flags_0(k,j,i),26,1) * adv_mom_5 & 2904 + IBITS(wall_flags_0(k,j,i),25,1) * adv_mom_3 & 2905 ) * & 2906 ( v(k_pp,j,i) + v(k-1,j,i) ) & 2907 + ( IBITS(wall_flags_0(k,j,i),26,1) * adv_mom_5 & 2908 ) * & 2909 ( v(k_ppp,j,i) + v(k_mm,j,i) ) & 2910 ) 2911 2912 diss_t(k) = - ABS( w_comp ) * ( & 2913 ( 10.0 * IBITS(wall_flags_0(k,j,i),26,1) * adv_mom_5 & 2914 + 3.0 * IBITS(wall_flags_0(k,j,i),25,1) * adv_mom_3 & 2915 + IBITS(wall_flags_0(k,j,i),24,1) * adv_mom_1 & 2916 ) * & 2917 ( v(k+1,j,i) - v(k,j,i) ) & 2918 - ( 5.0 * IBITS(wall_flags_0(k,j,i),26,1) * adv_mom_5 & 2919 + IBITS(wall_flags_0(k,j,i),25,1) * adv_mom_3 & 2920 ) * & 2921 ( v(k_pp,j,i) - v(k-1,j,i) ) & 2922 + ( IBITS(wall_flags_0(k,j,i),26,1) * adv_mom_5 & 2923 ) * & 2924 ( v(k_ppp,j,i) - v(k_mm,j,i) ) & 2925 ) 2926 ! 2927 !-- Calculate the divergence of the velocity field. A respective 2928 !-- correction is needed to overcome numerical instabilities caused 2929 !-- by a not sufficient reduction of divergences near topography. 2930 div = ( ( u_comp + gu - ( u(k,j-1,i) + u(k,j,i) ) ) * ddx & 2931 + ( v_comp(k) - ( v(k,j,i) + v(k,j-1,i) ) ) * ddy & 2932 + ( w_comp - ( w(k-1,j-1,i) + w(k-1,j,i) ) ) & 2933 * ddzw(k) & 2934 ) * 0.5 2935 2936 tend(k,j,i) = tend(k,j,i) - ( & 2937 ( flux_r(k) + diss_r(k) & 2938 - swap_flux_x_local_v(k,j) - swap_diss_x_local_v(k,j) & 2939 ) * ddx & 2940 + ( flux_n(k) + diss_n(k) & 2941 - swap_flux_y_local_v(k) - swap_diss_y_local_v(k) & 2942 ) * ddy & 2943 + ( flux_t(k) + diss_t(k) & 2944 - flux_d - diss_d & 2945 ) * ddzw(k) & 2946 ) + v(k,j,i) * div 2947 2948 swap_flux_x_local_v(k,j) = flux_r(k) 2949 swap_diss_x_local_v(k,j) = diss_r(k) 2950 swap_flux_y_local_v(k) = flux_n(k) 2951 swap_diss_y_local_v(k) = diss_n(k) 2952 flux_d = flux_t(k) 2953 diss_d = diss_t(k) 2954 2955 ! 2956 !-- Statistical Evaluation of v'v'. The factor has to be applied 2957 !-- for right evaluation when gallilei_trans = .T. . 2958 sums_vs2_ws_l(k,tn) = sums_vs2_ws_l(k,tn) & 2959 + ( flux_n(k) & 2960 * ( v_comp(k) - 2.0 * hom(k,1,2,0) ) & 2961 / ( v_comp(k) - gv + 1.0E-20 ) & 2962 + diss_n(k) & 2963 * ABS( v_comp(k) - 2.0 * hom(k,1,2,0) ) & 2964 / ( ABS( v_comp(k) - gv ) +1.0E-20 ) ) & 2965 * weight_substep(intermediate_timestep_count) 2966 ! 2967 !-- Statistical Evaluation of w'v'. 2968 sums_wsvs_ws_l(k,tn) = sums_wsvs_ws_l(k,tn) & 2969 + ( flux_t(k) + diss_t(k) ) & 2970 * weight_substep(intermediate_timestep_count) 2971 2516 2972 ENDDO 2517 2518 ENDIF 2519 2973 ENDDO 2520 2974 ENDDO 2521 2522 DO i = nxl, nxr 2523 j = nysv 2524 IF ( boundary_flags(j,i) == 7 ) THEN 2525 2526 DO k = nzb_v_inner(j,i)+1, nzt 2527 v_comp(k) = v(k,j,i) + v(k,j-1,i) - gv 2528 swap_flux_y_local_v(k) = v_comp(k) * & 2529 ( v(k,j,i) + v(k,j-1,i) ) * 0.25 2530 swap_diss_y_local_v(k) = diss_2nd( v(k,j+2,i), v(k,j+1,i), & 2531 v(k,j,i), v(k,j-1,i), & 2532 v(k,j-1,i), v_comp(k), & 2533 0.25, ddy ) 2534 ENDDO 2535 2536 ELSE 2537 2538 DO k = nzb_v_inner(j,i)+1, nzt 2539 v_comp(k) = v(k,j,i) + v(k,j-1,i) - gv 2540 swap_flux_y_local_v(k) = v_comp(k) * ( & 2541 37.0 * ( v(k,j,i) + v(k,j-1,i) ) & 2542 - 8.0 * ( v(k,j+1,i) + v(k,j-2,i) ) & 2543 + ( v(k,j+2,i) + v(k,j-3,i) ) ) & 2544 * adv_mom_5 2545 swap_diss_y_local_v(k) = - ABS( v_comp(k) ) * ( & 2546 10.0 * ( v(k,j,i) - v(k,j-1,i) ) & 2547 - 5.0 * ( v(k,j+1,i) - v(k,j-2,i) ) & 2548 + ( v(k,j+2,i) - v(k,j-3,i) ) ) & 2549 * adv_mom_5 2550 ENDDO 2551 2552 ENDIF 2553 2554 DO j = nysv, nyn 2555 IF ( boundary_flags(j,i) /= 0 ) THEN 2556 ! 2557 !-- Degrade the order for Dirichlet bc. at the outflow boundary 2558 SELECT CASE ( boundary_flags(j,i) ) 2559 2560 CASE ( 1 ) 2561 DO k = nzb_v_inner(j,i)+1, nzt 2562 u_comp = u(k,j-1,i+1) + u(k,j,i+1) - gu 2563 flux_r(k) = u_comp * ( & 2564 7.0 * (v(k,j,i+1) + v(k,j,i) ) & 2565 - ( v(k,j,i+2) + v(k,j,i-1) ) ) & 2566 * adv_mom_3 2567 diss_r(k) = - ABS( u_comp ) * ( & 2568 3.0 * ( v(k,j,i+1) - v(k,j,i) ) & 2569 - ( v(k,j,i+2) - v(k,j,i-1) ) ) & 2570 * adv_mom_3 2571 ENDDO 2572 2573 CASE ( 2 ) 2574 DO k = nzb_v_inner(j,i)+1, nzt 2575 u_comp = u(k,j-1,i+1) + u(k,j,i+1) - gu 2576 flux_r(k) = u_comp * ( v(k,j,i+1) + v(k,j,i) ) * 0.25 2577 diss_r(k) = diss_2nd( v(k,j,i+1), v(k,j,i+1), & 2578 v(k,j,i), v(k,j,i-1), & 2579 v(k,j,i-2), u_comp, 0.25, ddx ) 2580 ENDDO 2581 2582 CASE ( 3 ) 2583 DO k = nzb_v_inner(j,i)+1, nzt 2584 v_comp(k) = v(k,j+1,i) + v(k,j,i) 2585 flux_n(k) = ( v_comp(k)- gv ) * ( & 2586 7.0 * ( v(k,j+1,i) + v(k,j,i) ) & 2587 - ( v(k,j+2,i) + v(k,j-1,i) ) ) & 2588 * adv_mom_3 2589 diss_n(k) = - ABS(v_comp(k) - gv) * ( & 2590 3.0 * ( v(k,j+1,i) - v(k,j,i) ) & 2591 - ( v(k,j+2,i) - v(k,j-1,i) ) ) & 2592 * adv_mom_3 2593 ENDDO 2594 2595 CASE ( 4 ) 2596 DO k = nzb_v_inner(j,i)+1, nzt 2597 v_comp(k) = v(k,j+1,i) + v(k,j,i) 2598 flux_n(k) = ( v_comp(k) - gv ) * & 2599 ( v(k,j+1,i) + v(k,j,i) ) * 0.25 2600 diss_n(k) = diss_2nd( v(k,j+1,i), v(k,j+1,i), & 2601 v(k,j,i), v(k,j-1,i), & 2602 v(k,j-2,i), v_comp(k), 0.25, ddy) 2603 ENDDO 2604 2605 CASE ( 5 ) 2606 DO k = nzb_w_inner(j,i)+1, nzt 2607 u_comp = u(k,j-1,i) + u(k,j,i) - gu 2608 flux_r(k) = u_comp * ( & 2609 7.0 * ( v(k,j,i+1) + v(k,j,i) ) & 2610 - ( v(k,j,i+2) + v(k,j,i-1) ) ) & 2611 * adv_mom_3 2612 diss_r(k) = - ABS (u_comp ) * ( & 2613 3.0 * ( w(k,j,i+1) - w(k,j,i) ) & 2614 - ( v(k,j,i+2) - v(k,j,i-1) ) ) & 2615 * adv_mom_3 2616 ENDDO 2617 2618 CASE ( 6 ) 2619 DO k = nzb_v_inner(j,i)+1, nzt 2620 2621 u_comp = u(k,j-1,i+1) + u(k,j,i+1) - gu 2622 flux_r(k) = u_comp * ( & 2623 7.0 * ( v(k,j,i+1) + v(k,j,i) ) & 2624 - ( v(k,j,i+2) + v(k,j,i-1) ) ) & 2625 * adv_mom_3 2626 diss_r(k) = - ABS( u_comp ) * ( & 2627 3.0 * ( v(k,j,i+1) - v(k,j,i) ) & 2628 - ( v(k,j,i+2) - v(k,j,i-1) ) ) & 2629 * adv_mom_3 2630 ENDDO 2631 2632 CASE ( 7 ) 2633 DO k = nzb_v_inner(j,i)+1, nzt 2634 v_comp(k) = v(k,j+1,i) + v(k,j,i) 2635 flux_n(k) = ( v_comp(k) - gv ) * ( & 2636 7.0 * ( v(k,j+1,i) + v(k,j,i) ) & 2637 - ( v(k,j+2,i) + v(k,j-1,i) ) ) & 2638 * adv_mom_3 2639 diss_n(k) = - ABS( v_comp(k) - gv ) * ( & 2640 3.0 * ( v(k,j+1,i) - v(k,j,i) ) & 2641 - ( v(k,j+2,i) - v(k,j-1,i) ) ) & 2642 * adv_mom_3 2643 ENDDO 2644 2645 CASE DEFAULT 2646 2647 END SELECT 2648 ! 2649 !-- Compute the crosswise 5th order fluxes at the outflow 2650 IF ( boundary_flags(j,i) == 1 .OR. boundary_flags(j,i) == 2 .OR.& 2651 boundary_flags(j,i) == 5 .OR. boundary_flags(j,i) == 6 ) & 2652 THEN 2653 2654 DO k = nzb_v_inner(j,i)+1, nzt 2655 v_comp(k) = v(k,j+1,i) + v(k,j,i) 2656 flux_n(k) = ( v_comp(k) - gv ) * ( & 2657 37.0 * ( v(k,j+1,i) + v(k,j,i) ) & 2658 - 8.0 * ( v(k,j+2,i) + v(k,j-1,i) ) & 2659 + ( v(k,j+3,i) + v(k,j-2,i) ) ) & 2660 * adv_mom_5 2661 diss_n(k) = - ABS( v_comp(k) - gv ) * ( & 2662 10.0 * ( v(k,j+1,i) - v(k,j,i) ) & 2663 - 5.0 * ( v(k,j+2,i) - v(k,j-1,i) ) & 2664 + ( v(k,j+3,i) - v(k,j-2,i) ) ) & 2665 * adv_mom_5 2666 ENDDO 2667 2668 ELSE 2669 2670 DO k = nzb_v_inner(j,i)+1, nzt 2671 u_comp = u(k,j-1,i+1) + u(k,j,i+1) - gu 2672 flux_r(k) = u_comp * ( & 2673 37.0 * ( v(k,j,i+1) + v(k,j,i) ) & 2674 - 8.0 * ( v(k,j,i+2) + v(k,j,i-1) ) & 2675 + ( v(k,j,i+3) + v(k,j,i-2) ) ) & 2676 * adv_mom_5 2677 diss_r(k) = - ABS( u_comp ) * ( & 2678 10.0 * ( v(k,j,i+1) - v(k,j,i) ) & 2679 - 5.0 * ( v(k,j,i+2) - v(k,j,i-1) ) & 2680 + ( v(k,j,i+3) - v(k,j,i-2) ) ) & 2681 * adv_mom_5 2682 ENDDO 2683 2684 ENDIF 2685 2686 2687 ELSE 2688 2689 DO k = nzb_v_inner(j,i)+1, nzt 2690 u_comp = u(k,j-1,i+1) + u(k,j,i+1) - gu 2691 flux_r(k) = u_comp * ( & 2692 37.0 * ( v(k,j,i+1) + v(k,j,i) ) & 2693 - 8.0 * ( v(k,j,i+2) + v(k,j,i-1) ) & 2694 + ( v(k,j,i+3) + v(k,j,i-2) ) ) & 2695 * adv_mom_5 2696 diss_r(k) = - ABS ( u_comp ) * ( & 2697 10.0 * ( v(k,j,i+1) - v(k,j,i) ) & 2698 - 5.0 * ( v(k,j,i+2) - v(k,j,i-1) ) & 2699 + ( v(k,j,i+3) - v(k,j,i-2) ) ) * adv_mom_5 2700 2701 v_comp(k) = v(k,j+1,i) + v(k,j,i) 2702 flux_n(k) = ( v_comp(k) - gv ) * ( & 2703 37.0 * ( v(k,j+1,i) + v(k,j,i) ) & 2704 - 8.0 * ( v(k,j+2,i) + v(k,j-1,i) ) & 2705 + ( v(k,j+3,i) + v(k,j-2,i) ) ) * adv_mom_5 2706 diss_n(k) = - ABS( v_comp(k) - gv ) * ( & 2707 10.0 * ( v(k,j+1,i) - v(k,j,i) ) & 2708 - 5.0 * ( v(k,j+2,i) - v(k,j-1,i) ) & 2709 + ( v(k,j+3,i) - v(k,j-2,i) ) ) *adv_mom_5 2710 2711 ENDDO 2712 ENDIF 2713 2714 DO k = nzb_v_inner(j,i)+1, nzt 2715 tend(k,j,i) = tend(k,j,i) - ( & 2716 ( flux_r(k) + diss_r(k) & 2717 - swap_flux_x_local_v(k,j) - swap_diss_x_local_v(k,j) ) * ddx & 2718 + ( flux_n(k) + diss_n(k) & 2719 - swap_flux_y_local_v(k) - swap_diss_y_local_v(k) ) * ddy ) 2720 2721 swap_flux_x_local_v(k,j) = flux_r(k) 2722 swap_diss_x_local_v(k,j) = diss_r(k) 2723 swap_flux_y_local_v(k) = flux_n(k) 2724 swap_diss_y_local_v(k) = diss_n(k) 2725 2726 sums_vs2_ws_l(k,tn) = sums_vs2_ws_l(k,tn) & 2727 + ( flux_n(k) * ( v_comp(k) - 2.0 * hom(k,1,2,0) ) & 2728 / ( v_comp(k) - gv + 1.0E-20 ) & 2729 + diss_n(k) * ABS( v_comp(k) - 2.0 * hom(k,1,2,0) ) & 2730 / ( ABS( v_comp(k) - gv ) + 1.0E-20 ) ) & 2731 * weight_substep(intermediate_timestep_count) 2732 ENDDO 2733 sums_vs2_ws_l(nzb_v_inner(j,i),tn) = sums_vs2_ws_l(nzb_v_inner(j,i)+1,tn) 2734 ENDDO 2735 ENDDO 2736 ! 2737 !-- Vertical advection, degradation of order near surface and top. 2738 !-- The fluxes flux_d and diss_d at the surface are 0. Due to reasons of 2739 !-- statistical evaluation the top flux at the surface should be 0 2740 DO i = nxl, nxr 2741 DO j = nysv, nyn 2742 ! 2743 !-- The fluxes flux_d and diss_d at the surface are 0. Due to static 2744 !-- reasons the top flux at the surface should be 0. 2745 flux_t(nzb_v_inner(j,i)) = 0.0 2746 diss_t(nzb_v_inner(j,i)) = 0.0 2747 k = nzb_v_inner(j,i)+1 2748 flux_d = flux_t(k-1) 2749 diss_d = diss_t(k-1) 2750 ! 2751 !-- 2nd order scheme (bottom) 2752 w_comp = w(k,j-1,i) + w(k,j,i) 2753 flux_t(k) = w_comp * ( v(k+1,j,i) + v(k,j,i) ) * 0.25 2754 diss_t(k) = diss_2nd( v(k+2,j,i), v(k+1,j,i), v(k,j,i), & 2755 0.0, 0.0, w_comp, 0.25, ddzw(k) ) 2756 2757 tend(k,j,i) = tend(k,j,i) - ( flux_t(k) + diss_t(k) & 2758 - flux_d - diss_d ) * ddzw(k) 2759 ! 2760 !-- WS3 as an intermediate step (bottom) 2761 k = nzb_v_inner(j,i) + 2 2762 flux_d = flux_t(k-1) 2763 diss_d = diss_t(k-1) 2764 w_comp = w(k,j-1,i) + w(k,j,i) 2765 flux_t(k) = w_comp * ( & 2766 7.0 * ( v(k+1,j,i) + v(k,j,i) ) & 2767 - ( v(k+2,j,i) + v(k-1,j,i) ) ) * adv_mom_3 2768 diss_t(k) = - ABS( w_comp ) * ( & 2769 3.0 * ( v(k+1,j,i) - v(k,j,i) ) & 2770 - ( v(k+2,j,i) - v(k-1,j,i) ) ) * adv_mom_3 2771 2772 tend(k,j,i) = tend(k,j,i) - ( flux_t(k) + diss_t(k) & 2773 - flux_d - diss_d ) * ddzw(k) 2774 2775 ! 2776 !-- WS5 2777 DO k = nzb_v_inner(j,i)+3, nzt-2 2778 flux_d = flux_t(k-1) 2779 diss_d = diss_t(k-1) 2780 w_comp = w(k,j-1,i) + w(k,j,i) 2781 flux_t(k) = w_comp * ( & 2782 37.0 * ( v(k+1,j,i) + v(k,j,i) ) & 2783 - 8.0 * ( v(k+2,j,i) + v(k-1,j,i) ) & 2784 + ( v(k+3,j,i) + v(k-2,j,i) ) ) * adv_mom_5 2785 diss_t(k) = - ABS( w_comp ) * ( & 2786 10.0 * ( v(k+1,j,i) - v(k,j,i) ) & 2787 - 5.0 * ( v(k+2,j,i) - v(k-1,j,i) ) & 2788 + ( v(k+3,j,i) - v(k-2,j,i) ) ) * adv_mom_5 2789 2790 tend(k,j,i) = tend(k,j,i) - ( flux_t(k) + diss_t(k) & 2791 - flux_d - diss_d ) * ddzw(k) 2792 ENDDO 2793 ! 2794 !-- WS3 as an intermediate step (top) 2795 k = nzt-1 2796 flux_d = flux_t(k-1) 2797 diss_d = diss_t(k-1) 2798 w_comp = w(k,j-1,i) + w(k,j,i) 2799 flux_t(k) = w_comp * ( & 2800 7.0 * ( v(k+1,j,i) + v(k,j,i) ) & 2801 - ( v(k+2,j,i) + v(k-1,j,i) ) ) * adv_mom_3 2802 diss_t(k) = - ABS( w_comp ) * ( & 2803 3.0 * ( v(k+1,j,i) - v(k,j,i) ) & 2804 - ( v(k+2,j,i) - v(k-1,j,i) ) ) * adv_mom_3 2805 2806 tend(k,j,i) = tend(k,j,i) - ( flux_t(k) + diss_t(k) & 2807 - flux_d - diss_d ) * ddzw(k) 2808 ! 2809 !-- 2nd order scheme (top) 2810 k = nzt 2811 flux_d = flux_t(k-1) 2812 diss_d = diss_t(k-1) 2813 w_comp = w(k,j-1,i) + w(k,j,i) 2814 flux_t(k) = w_comp * ( v(k+1,j,i) + v(k,j,i) ) * 0.25 2815 diss_t(k) = diss_2nd( v(nzt+1,j,i), v(nzt+1,j,i), v(k,j,i), & 2816 v(k-1,j,i), v(k-2,j,i), w_comp, 0.25, ddzw(k)) 2817 2818 tend(k,j,i) = tend(k,j,i) - ( flux_t(k) + diss_t(k) & 2819 - flux_d - diss_d ) * ddzw(k) 2820 ! 2821 !- At last vertical momentum flux is accumulated. 2822 DO k = nzb_v_inner(j,i), nzt 2823 sums_wsvs_ws_l(k,tn) = sums_wsvs_ws_l(k,tn) & 2824 + ( flux_t(k) + diss_t(k) ) & 2825 * weight_substep(intermediate_timestep_count) 2826 ENDDO 2827 sums_vs2_ws_l(nzb_v_inner(j,i),tn) = sums_vs2_ws_l(nzb_v_inner(j,i)+1,tn) 2828 ENDDO 2829 ENDDO 2975 sums_vs2_ws_l(nzb,tn) = sums_vs2_ws_l(nzb+1,tn) 2976 2830 2977 2831 2978 END SUBROUTINE advec_v_ws … … 2846 2993 IMPLICIT NONE 2847 2994 2848 INTEGER :: i, j, k, tn = 0 2849 REAL :: gu, gv, flux_d, diss_d, u_comp, v_comp, w_comp 2850 REAL :: flux_t(nzb:nzt+1), diss_t(nzb:nzt+1) 2851 REAL, DIMENSION(nzb:nzt+1) :: flux_r, diss_r, flux_n, diss_n 2852 REAL, DIMENSION(nzb+1:nzt) :: swap_flux_y_local_w, swap_diss_y_local_w 2995 INTEGER :: i, j, k, tn = 0, k_ppp, k_pp, k_mm 2996 REAL :: gu, gv, flux_d, diss_d, u_comp, v_comp, w_comp, div 2997 REAL, DIMENSION(nzb:nzt) :: flux_t, diss_t 2998 REAL, DIMENSION(nzb+1:nzt) :: flux_r, diss_r, flux_n, diss_n, & 2999 swap_flux_y_local_w, & 3000 swap_diss_y_local_w 2853 3001 REAL, DIMENSION(nzb+1:nzt,nys:nyn) :: swap_flux_x_local_w, & 2854 3002 swap_diss_x_local_w … … 2860 3008 i = nxl 2861 3009 DO j = nys, nyn 2862 2863 IF ( boundary_flags(j,i) == 6 ) THEN 2864 2865 DO k = nzb_v_inner(j,i)+1, nzt 2866 u_comp = u(k+1,j,i) + u(k,j,i) - gu 2867 swap_flux_x_local_w(k,j) = u_comp * & 2868 (w(k,j,i)+w(k,j,i-1)) * 0.25 2869 swap_flux_x_local_w(k,j) = diss_2nd( w(k,j,i+2), w(k,j,i+1), & 2870 w(k,j,i), w(k,j,i-1), & 2871 w(k,j,i-1), u_comp, & 2872 0.25, ddx ) 3010 DO k = nzb+1, nzb_max 3011 3012 u_comp = u(k+1,j,i) + u(k,j,i) - gu 3013 swap_flux_x_local_w(k,j) = u_comp * ( & 3014 ( 37.0 * IBITS(wall_flags_0(k,j,i),29,1) * adv_mom_5 & 3015 + 7.0 * IBITS(wall_flags_0(k,j,i),28,1) * adv_mom_3 & 3016 + IBITS(wall_flags_0(k,j,i),27,1) * adv_mom_1 & 3017 ) * & 3018 ( w(k,j,i) + w(k,j,i-1) ) & 3019 - ( 8.0 * IBITS(wall_flags_0(k,j,i),29,1) * adv_mom_5 & 3020 + IBITS(wall_flags_0(k,j,i),28,1) * adv_mom_3 & 3021 ) * & 3022 ( w(k,j,i+1) + w(k,j,i-2) ) & 3023 + ( IBITS(wall_flags_0(k,j,i),29,1) * adv_mom_5 & 3024 ) * & 3025 ( w(k,j,i+2) + w(k,j,i-3) ) & 3026 ) 3027 3028 swap_diss_x_local_w(k,j) = - ABS( u_comp ) * ( & 3029 ( 10.0 * IBITS(wall_flags_0(k,j,i),29,1) * adv_mom_5 & 3030 + 3.0 * IBITS(wall_flags_0(k,j,i),28,1) * adv_mom_3 & 3031 + IBITS(wall_flags_0(k,j,i),27,1) * adv_mom_1 & 3032 ) * & 3033 ( w(k,j,i) - w(k,j,i-1) ) & 3034 - ( 5.0 * IBITS(wall_flags_0(k,j,i),29,1) * adv_mom_5 & 3035 + IBITS(wall_flags_0(k,j,i),28,1) * adv_mom_3 & 3036 ) * & 3037 ( w(k,j,i+1) - w(k,j,i-2) ) & 3038 + ( IBITS(wall_flags_0(k,j,i),29,1) * adv_mom_5 & 3039 ) * & 3040 ( w(k,j,i+2) - w(k,j,i-3) ) & 3041 ) 3042 3043 ENDDO 3044 3045 DO k = nzb_max+1, nzt 3046 3047 u_comp = u(k+1,j,i) + u(k,j,i) - gu 3048 swap_flux_x_local_w(k,j) = u_comp * ( & 3049 37.0 * ( w(k,j,i) + w(k,j,i-1) ) & 3050 - 8.0 * ( w(k,j,i+1) + w(k,j,i-2) ) & 3051 + ( w(k,j,i+2) + w(k,j,i-3) ) ) * adv_mom_5 3052 swap_diss_x_local_w(k,j) = - ABS( u_comp ) * ( & 3053 10.0 * ( w(k,j,i) - w(k,j,i-1) ) & 3054 - 5.0 * ( w(k,j,i+1) - w(k,j,i-2) ) & 3055 + ( w(k,j,i+2) - w(k,j,i-3) ) ) * adv_mom_5 3056 3057 ENDDO 3058 3059 ENDDO 3060 3061 DO i = nxl, nxr 3062 3063 j = nys 3064 DO k = nzb+1, nzb_max 3065 3066 v_comp = v(k+1,j,i) + v(k,j,i) - gv 3067 swap_flux_y_local_w(k) = v_comp * ( & 3068 ( 37.0 * IBITS(wall_flags_0(k,j,i),32,1) * adv_mom_5 & 3069 + 7.0 * IBITS(wall_flags_0(k,j,i),31,1) * adv_mom_3 & 3070 + IBITS(wall_flags_0(k,j,i),30,1) * adv_mom_1 & 3071 ) * & 3072 ( w(k,j,i) + w(k,j-1,i) ) & 3073 - ( 8.0 * IBITS(wall_flags_0(k,j,i),32,1) * adv_mom_5 & 3074 + IBITS(wall_flags_0(k,j,i),31,1) * adv_mom_3 & 3075 ) * & 3076 ( w(k,j+1,i) + w(k,j-2,i) ) & 3077 + ( IBITS(wall_flags_0(k,j,i),32,1) * adv_mom_5 & 3078 ) * & 3079 ( w(k,j+2,i) + w(k,j-3,i) ) & 3080 ) 3081 3082 swap_diss_y_local_w(k) = - ABS( v_comp ) * ( & 3083 ( 10.0 * IBITS(wall_flags_0(k,j,i),32,1) * adv_mom_5 & 3084 + 3.0 * IBITS(wall_flags_0(k,j,i),31,1) * adv_mom_3 & 3085 + IBITS(wall_flags_0(k,j,i),30,1) * adv_mom_1 & 3086 ) * & 3087 ( w(k,j,i) - w(k,j-1,i) ) & 3088 - ( 5.0 * IBITS(wall_flags_0(k,j,i),32,1) * adv_mom_5 & 3089 + IBITS(wall_flags_0(k,j,i),31,1) * adv_mom_3 & 3090 ) * & 3091 ( w(k,j+1,i) - w(k,j-2,i) ) & 3092 + ( IBITS(wall_flags_0(k,j,i),32,1) * adv_mom_5 & 3093 ) * & 3094 ( w(k,j+2,i) - w(k,j-3,i) ) & 3095 ) 3096 3097 ENDDO 3098 3099 DO k = nzb_max+1, nzt 3100 3101 v_comp = v(k+1,j,i) + v(k,j,i) - gv 3102 swap_flux_y_local_w(k) = v_comp * ( & 3103 37.0 * ( w(k,j,i) + w(k,j-1,i) ) & 3104 - 8.0 * ( w(k,j+1,i) +w(k,j-2,i) ) & 3105 + ( w(k,j+2,i) + w(k,j-3,i) ) ) * adv_mom_5 3106 swap_diss_y_local_w(k) = - ABS( v_comp ) * ( & 3107 10.0 * ( w(k,j,i) - w(k,j-1,i) ) & 3108 - 5.0 * ( w(k,j+1,i) - w(k,j-2,i) ) & 3109 + ( w(k,j+2,i) - w(k,j-3,i) ) ) * adv_mom_5 3110 3111 ENDDO 3112 3113 DO j = nys, nyn 3114 3115 flux_t(0) = 0.0 3116 diss_t(0) = 0.0 3117 flux_d = 0.0 3118 diss_d = 0.0 3119 3120 DO k = nzb+1, nzb_max 3121 3122 u_comp = u(k+1,j,i+1) + u(k,j,i+1) - gu 3123 flux_r(k) = u_comp * ( & 3124 ( 37.0 * IBITS(wall_flags_0(k,j,i),29,1) * adv_mom_5 & 3125 + 7.0 * IBITS(wall_flags_0(k,j,i),28,1) * adv_mom_3 & 3126 + IBITS(wall_flags_0(k,j,i),27,1) * adv_mom_1 & 3127 ) * & 3128 ( w(k,j,i+1) + w(k,j,i) ) & 3129 - ( 8.0 * IBITS(wall_flags_0(k,j,i),29,1) * adv_mom_5 & 3130 + IBITS(wall_flags_0(k,j,i),28,1) * adv_mom_3 & 3131 ) * & 3132 ( w(k,j,i+2) + w(k,j,i-1) ) & 3133 + ( IBITS(wall_flags_0(k,j,i),29,1) * adv_mom_5 & 3134 ) * & 3135 ( w(k,j,i+3) + w(k,j,i-2) ) & 3136 ) 3137 3138 diss_r(k) = - ABS( u_comp ) * ( & 3139 ( 10.0 * IBITS(wall_flags_0(k,j,i),29,1) * adv_mom_5 & 3140 + 3.0 * IBITS(wall_flags_0(k,j,i),28,1) * adv_mom_3 & 3141 + IBITS(wall_flags_0(k,j,i),27,1) * adv_mom_1 & 3142 ) * & 3143 ( w(k,j,i+1) - w(k,j,i) ) & 3144 - ( 5.0 * IBITS(wall_flags_0(k,j,i),29,1) * adv_mom_5 & 3145 + IBITS(wall_flags_0(k,j,i),28,1) * adv_mom_3 & 3146 ) * & 3147 ( w(k,j,i+2) - w(k,j,i-1) ) & 3148 + ( IBITS(wall_flags_0(k,j,i),29,1) * adv_mom_5 & 3149 ) * & 3150 ( w(k,j,i+3) - w(k,j,i-2) ) & 3151 ) 3152 3153 v_comp = v(k+1,j+1,i) + v(k,j+1,i) - gv 3154 flux_n(k) = v_comp * ( & 3155 ( 37.0 * IBITS(wall_flags_0(k,j,i),32,1) * adv_mom_5 & 3156 + 7.0 * IBITS(wall_flags_0(k,j,i),31,1) * adv_mom_3 & 3157 + IBITS(wall_flags_0(k,j,i),30,1) * adv_mom_1 & 3158 ) * & 3159 ( w(k,j+1,i) + w(k,j,i) ) & 3160 - ( 8.0 * IBITS(wall_flags_0(k,j,i),32,1) * adv_mom_5 & 3161 + IBITS(wall_flags_0(k,j,i),31,1) * adv_mom_3 & 3162 ) * & 3163 ( w(k,j+2,i) + w(k,j-1,i) ) & 3164 + ( IBITS(wall_flags_0(k,j,i),32,1) * adv_mom_5 & 3165 ) * & 3166 ( w(k,j+3,i) + w(k,j-2,i) ) & 3167 ) 3168 3169 diss_n(k) = - ABS( v_comp ) * ( & 3170 ( 10.0 * IBITS(wall_flags_0(k,j,i),32,1) * adv_mom_5 & 3171 + 3.0 * IBITS(wall_flags_0(k,j,i),31,1) * adv_mom_3 & 3172 + IBITS(wall_flags_0(k,j,i),30,1) * adv_mom_1 & 3173 ) * & 3174 ( w(k,j+1,i) - w(k,j,i) ) & 3175 - ( 5.0 * IBITS(wall_flags_0(k,j,i),32,1) * adv_mom_5 & 3176 + IBITS(wall_flags_0(k,j,i),31,1) * adv_mom_3 & 3177 ) * & 3178 ( w(k,j+2,i) - w(k,j-1,i) ) & 3179 + ( IBITS(wall_flags_0(k,j,i),32,1) * adv_mom_5 & 3180 ) * & 3181 ( w(k,j+3,i) - w(k,j-2,i) ) & 3182 ) 3183 ! 3184 !-- k index has to be modified near bottom and top, else array 3185 !-- subscripts will be exceeded. 3186 k_ppp = k + 3 * IBITS(wall_flags_0(k,j,i),35,1) 3187 k_pp = k + 2 * ( 1 - IBITS(wall_flags_0(k,j,i),33,1) ) 3188 k_mm = k - 2 * IBITS(wall_flags_0(k,j,i),35,1) 3189 3190 w_comp = w(k+1,j,i) + w(k,j,i) 3191 flux_t(k) = w_comp * ( & 3192 ( 37.0 * IBITS(wall_flags_0(k,j,i),35,1) * adv_mom_5 & 3193 + 7.0 * IBITS(wall_flags_0(k,j,i),34,1) * adv_mom_3 & 3194 + IBITS(wall_flags_0(k,j,i),33,1) * adv_mom_1 & 3195 ) * & 3196 ( w(k+1,j,i) + w(k,j,i) ) & 3197 - ( 8.0 * IBITS(wall_flags_0(k,j,i),35,1) * adv_mom_5 & 3198 + IBITS(wall_flags_0(k,j,i),34,1) * adv_mom_3 & 3199 ) * & 3200 ( w(k_pp,j,i) + w(k-1,j,i) ) & 3201 + ( IBITS(wall_flags_0(k,j,i),35,1) * adv_mom_5 & 3202 ) * & 3203 ( w(k_ppp,j,i) + w(k_mm,j,i) ) & 3204 ) 3205 3206 diss_t(k) = - ABS( w_comp ) * ( & 3207 ( 10.0 * IBITS(wall_flags_0(k,j,i),35,1) * adv_mom_5 & 3208 + 3.0 * IBITS(wall_flags_0(k,j,i),34,1) * adv_mom_3 & 3209 + IBITS(wall_flags_0(k,j,i),33,1) * adv_mom_1 & 3210 ) * & 3211 ( w(k+1,j,i) - w(k,j,i) ) & 3212 - ( 5.0 * IBITS(wall_flags_0(k,j,i),35,1) * adv_mom_5 & 3213 + IBITS(wall_flags_0(k,j,i),34,1) * adv_mom_3 & 3214 ) * & 3215 ( w(k_pp,j,i) - w(k-1,j,i) ) & 3216 + ( IBITS(wall_flags_0(k,j,i),35,1) * adv_mom_5 & 3217 ) * & 3218 ( w(k_ppp,j,i) - w(k_mm,j,i) ) & 3219 ) 3220 ! 3221 !-- Calculate the divergence of the velocity field. A respective 3222 !-- correction is needed to overcome numerical instabilities caused 3223 !-- by a not sufficient reduction of divergences near topography. 3224 div = ( ( u_comp + gu - ( u(k+1,j,i) + u(k,j,i) ) ) * ddx & 3225 + ( v_comp + gv - ( v(k+1,j,i) + v(k,j,i) ) ) * ddy & 3226 + ( w_comp - ( w(k,j,i) + w(k-1,j,i) ) ) & 3227 * ddzu(k+1) & 3228 ) * 0.5 3229 3230 tend(k,j,i) = tend(k,j,i) - ( & 3231 ( flux_r(k) + diss_r(k) & 3232 - swap_flux_x_local_w(k,j) - swap_diss_x_local_w(k,j) & 3233 ) * ddx & 3234 + ( flux_n(k) + diss_n(k) & 3235 - swap_flux_y_local_w(k) - swap_diss_y_local_w(k) & 3236 ) * ddy & 3237 + ( flux_t(k) + diss_t(k) & 3238 - flux_d - diss_d & 3239 ) * ddzu(k+1) & 3240 ) + div * w(k,j,i) 3241 3242 swap_flux_x_local_w(k,j) = flux_r(k) 3243 swap_diss_x_local_w(k,j) = diss_r(k) 3244 swap_flux_y_local_w(k) = flux_n(k) 3245 swap_diss_y_local_w(k) = diss_n(k) 3246 flux_d = flux_t(k) 3247 diss_d = diss_t(k) 3248 3249 sums_ws2_ws_l(k,tn) = sums_ws2_ws_l(k,tn) & 3250 + ( flux_t(k) + diss_t(k) ) & 3251 * weight_substep(intermediate_timestep_count) 3252 2873 3253 ENDDO 2874 2875 ELSE 2876 2877 DO k = nzb_v_inner(j,i)+1, nzt 2878 u_comp = u(k+1,j,i) + u(k,j,i) - gu 2879 swap_flux_x_local_w(k,j) = u_comp * ( & 2880 37.0 * ( w(k,j,i) + w(k,j,i-1) ) & 2881 - 8.0 * ( w(k,j,i+1) + w(k,j,i-2) ) & 2882 + ( w(k,j,i+2) + w(k,j,i-3) ) )& 2883 * adv_mom_5 2884 swap_diss_x_local_w(k,j) = - ABS( u_comp ) * ( & 2885 10.0 * ( w(k,j,i) - w(k,j,i-1) ) & 2886 - 5.0 * ( w(k,j,i+1) - w(k,j,i-2) ) & 2887 + ( w(k,j,i+2) - w(k,j,i-3) ) )& 2888 * adv_mom_5 3254 3255 DO k = nzb_max+1, nzt 3256 3257 u_comp = u(k+1,j,i+1) + u(k,j,i+1) - gu 3258 flux_r(k) = u_comp * ( & 3259 37.0 * ( w(k,j,i+1) + w(k,j,i) ) & 3260 - 8.0 * ( w(k,j,i+2) + w(k,j,i-1) ) & 3261 + ( w(k,j,i+3) + w(k,j,i-2) ) ) * adv_mom_5 3262 3263 diss_r(k) = - ABS( u_comp ) * ( & 3264 10.0 * ( w(k,j,i+1) - w(k,j,i) ) & 3265 - 5.0 * ( w(k,j,i+2) - w(k,j,i-1) ) & 3266 + ( w(k,j,i+3) - w(k,j,i-2) ) ) * adv_mom_5 3267 3268 v_comp = v(k+1,j+1,i) + v(k,j+1,i) - gv 3269 flux_n(k) = v_comp * ( & 3270 37.0 * ( w(k,j+1,i) + w(k,j,i) ) & 3271 - 8.0 * ( w(k,j+2,i) + w(k,j-1,i) ) & 3272 + ( w(k,j+3,i) + w(k,j-2,i) ) ) * adv_mom_5 3273 3274 diss_n(k) = - ABS( v_comp ) * ( & 3275 10.0 * ( w(k,j+1,i) - w(k,j,i) ) & 3276 - 5.0 * ( w(k,j+2,i) - w(k,j-1,i) ) & 3277 + ( w(k,j+3,i) - w(k,j-2,i) ) ) * adv_mom_5 3278 ! 3279 !-- k index has to be modified near bottom and top, else array 3280 !-- subscripts will be exceeded. 3281 k_ppp = k + 3 * IBITS(wall_flags_0(k,j,i),35,1) 3282 k_pp = k + 2 * ( 1 - IBITS(wall_flags_0(k,j,i),33,1) ) 3283 k_mm = k - 2 * IBITS(wall_flags_0(k,j,i),35,1) 3284 3285 w_comp = w(k+1,j,i) + w(k,j,i) 3286 flux_t(k) = w_comp * ( & 3287 ( 37.0 * IBITS(wall_flags_0(k,j,i),35,1) * adv_mom_5 & 3288 + 7.0 * IBITS(wall_flags_0(k,j,i),34,1) * adv_mom_3 & 3289 + IBITS(wall_flags_0(k,j,i),33,1) * adv_mom_1 & 3290 ) * & 3291 ( w(k+1,j,i) + w(k,j,i) ) & 3292 - ( 8.0 * IBITS(wall_flags_0(k,j,i),35,1) * adv_mom_5 & 3293 + IBITS(wall_flags_0(k,j,i),34,1) * adv_mom_3 & 3294 ) * & 3295 ( w(k_pp,j,i) + w(k-1,j,i) ) & 3296 + ( IBITS(wall_flags_0(k,j,i),35,1) * adv_mom_5 & 3297 ) * & 3298 ( w(k_ppp,j,i) + w(k_mm,j,i) ) & 3299 ) 3300 3301 diss_t(k) = - ABS( w_comp ) * ( & 3302 ( 10.0 * IBITS(wall_flags_0(k,j,i),35,1) * adv_mom_5 & 3303 + 3.0 * IBITS(wall_flags_0(k,j,i),34,1) * adv_mom_3 & 3304 + IBITS(wall_flags_0(k,j,i),33,1) * adv_mom_1 & 3305 ) * & 3306 ( w(k+1,j,i) - w(k,j,i) ) & 3307 - ( 5.0 * IBITS(wall_flags_0(k,j,i),35,1) * adv_mom_5 & 3308 + IBITS(wall_flags_0(k,j,i),34,1) * adv_mom_3 & 3309 ) * & 3310 ( w(k_pp,j,i) - w(k-1,j,i) ) & 3311 + ( IBITS(wall_flags_0(k,j,i),35,1) * adv_mom_5 & 3312 ) * & 3313 ( w(k_ppp,j,i) - w(k_mm,j,i) ) & 3314 ) 3315 ! 3316 !-- Calculate the divergence of the velocity field. A respective 3317 !-- correction is needed to overcome numerical instabilities caused 3318 !-- by a not sufficient reduction of divergences near topography. 3319 div = ( ( u_comp + gu - ( u(k+1,j,i) + u(k,j,i) ) ) * ddx & 3320 + ( v_comp + gv - ( v(k+1,j,i) + v(k,j,i) ) ) * ddy & 3321 + ( w_comp - ( w(k,j,i) + w(k-1,j,i) ) ) & 3322 * ddzu(k+1) & 3323 ) * 0.5 3324 3325 tend(k,j,i) = tend(k,j,i) - ( & 3326 ( flux_r(k) + diss_r(k) & 3327 - swap_flux_x_local_w(k,j) - swap_diss_x_local_w(k,j) & 3328 ) * ddx & 3329 + ( flux_n(k) + diss_n(k) & 3330 - swap_flux_y_local_w(k) - swap_diss_y_local_w(k) & 3331 ) * ddy & 3332 + ( flux_t(k) + diss_t(k) & 3333 - flux_d - diss_d & 3334 ) * ddzu(k+1) & 3335 ) + div * w(k,j,i) 3336 3337 swap_flux_x_local_w(k,j) = flux_r(k) 3338 swap_diss_x_local_w(k,j) = diss_r(k) 3339 swap_flux_y_local_w(k) = flux_n(k) 3340 swap_diss_y_local_w(k) = diss_n(k) 3341 flux_d = flux_t(k) 3342 diss_d = diss_t(k) 3343 3344 sums_ws2_ws_l(k,tn) = sums_ws2_ws_l(k,tn) & 3345 + ( flux_t(k) + diss_t(k) ) & 3346 * weight_substep(intermediate_timestep_count) 3347 2889 3348 ENDDO 2890 2891 ENDIF 2892 3349 ENDDO 2893 3350 ENDDO 2894 3351 2895 DO i = nxl, nxr2896 j = nys2897 IF ( boundary_flags(j,i) == 8 ) THEN2898 2899 DO k = nzb_v_inner(j,i)+1, nzt2900 v_comp = v(k+1,j,i) + v(k,j,i) - gv2901 swap_flux_y_local_w(k) = v_comp * &2902 ( w(k,j,i) + w(k,j-1,i) ) * 0.252903 swap_diss_y_local_w(k) = diss_2nd( w(k,j+2,i), w(k,j+1,i), &2904 w(k,j,i), w(k,j-1,i), &2905 w(k,j-1,i), v_comp, 0.25, ddy)2906 ENDDO2907 2908 ELSE2909 2910 DO k = nzb_v_inner(j,i)+1, nzt2911 v_comp = v(k+1,j,i) + v(k,j,i) - gv2912 swap_flux_y_local_w(k) = v_comp * ( &2913 37.0 * ( w(k,j,i) + w(k,j-1,i) ) &2914 - 8.0 * ( w(k,j+1,i) +w(k,j-2,i) ) &2915 + ( w(k,j+2,i) +w(k,j-3,i) ) ) &2916 * adv_mom_52917 swap_diss_y_local_w(k) = - ABS( v_comp ) * ( &2918 10.0 * ( w(k,j,i) - w(k,j-1,i) ) &2919 - 5.0 * ( w(k,j+1,i) - w(k,j-2,i) ) &2920 + ( w(k,j+2,i) - w(k,j-3,i) ) ) &2921 * adv_mom_52922 ENDDO2923 2924 ENDIF2925 2926 DO j = nys, nyn2927 2928 IF ( boundary_flags(j,i) /= 0 ) THEN2929 !2930 !-- Degrade the order for Dirichlet bc. at the outflow boundary2931 SELECT CASE ( boundary_flags(j,i) )2932 2933 CASE ( 1 )2934 DO k = nzb_w_inner(j,i)+1, nzt2935 u_comp = u(k+1,j,i+1) + u(k,j,i+1) - gu2936 flux_r(k) = u_comp * ( &2937 7.0 * ( w(k,j,i+1) + w(k,j,i) ) &2938 - ( w(k,j,i+2) + w(k,j,i-1) ) ) &2939 * adv_mom_32940 diss_r(k) = -ABS( u_comp ) * ( &2941 3.0 * ( w(k,j,i+1) - w(k,j,i) ) &2942 - ( w(k,j,i+2) - w(k,j,i-1) ) ) &2943 * adv_mom_32944 ENDDO2945 2946 CASE ( 2 )2947 DO k = nzb_w_inner(j,i)+1, nzt2948 u_comp = u(k+1,j,i+1) + u(k,j,i+1) - gu2949 flux_r(k) = u_comp * ( w(k,j,i+1) + w(k,j,i) ) * 0.252950 diss_r(k) = diss_2nd( w(k,j,i+1), w(k,j,i+1), &2951 w(k,j,i), w(k,j,i-1), &2952 w(k,j,i-2), u_comp, 0.25, ddx )2953 ENDDO2954 2955 CASE ( 3 )2956 DO k = nzb_w_inner(j,i)+1, nzt2957 v_comp = v(k+1,j+1,i) + v(k,j+1,i) - gv2958 flux_n(k) = v_comp * ( &2959 7.0 * ( w(k,j+1,i) + w(k,j,i) ) &2960 - ( w(k,j+2,i) + w(k,j-1,i) ) ) &2961 * adv_mom_32962 diss_n(k) = -ABS( v_comp ) * ( &2963 3.0 * ( w(k,j+1,i) - w(k,j,i) ) &2964 - ( w(k,j+2,i) - w(k,j-1,i) ) ) &2965 * adv_mom_32966 ENDDO2967 2968 CASE ( 4 )2969 DO k = nzb_w_inner(j,i)+1, nzt2970 v_comp = v(k+1,j+1,i) + v(k,j+1,i) - gv2971 flux_n(k) = v_comp * ( w(k,j+1,i) + w(k,j,i) ) * 0.252972 diss_n(k) = diss_2nd( w(k,j+1,i), w(k,j+1,i), &2973 w(k,j,i), w(k,j-1,i), &2974 w(k,j-2,i), v_comp, 0.25, ddy )2975 ENDDO2976 2977 CASE ( 5 )2978 DO k = nzb_w_inner(j,i)+1, nzt2979 u_comp = u(k+1,j,i+1) + u(k,j,i+1) - gu2980 flux_r(k) = u_comp * ( &2981 7.0 * ( w(k,j,i+1) + w(k,j,i) ) &2982 - ( w(k,j,i+2) + w(k,j,i-1) ) ) &2983 * adv_mom_32984 diss_r(k) = - ABS( u_comp ) * ( &2985 3.0 * ( w(k,j,i+1) - w(k,j,i) ) &2986 - ( w(k,j,i+2) - w(k,j,i-1) ) ) &2987 * adv_mom_32988 ENDDO2989 2990 CASE ( 6 )2991 DO k = nzb_w_inner(j,i)+1, nzt2992 u_comp = u(k+1,j,i+1) + u(k,j,i+1) - gu2993 flux_r(k) = u_comp *( &2994 7.0 * ( w(k,j,i+1) + w(k,j,i) ) &2995 - ( w(k,j,i+2) + w(k,j,i-1) ) ) &2996 * adv_mom_32997 diss_r(k) = - ABS( u_comp ) * ( &2998 3.0 * ( w(k,j,i+1) - w(k,j,i) ) &2999 - ( w(k,j,i+2) - w(k,j,i-1) ) ) &3000 * adv_mom_33001 ENDDO3002 3003 CASE ( 7 )3004 DO k = nzb_w_inner(j,i)+1, nzt3005 v_comp = v(k+1,j+1,i) + v(k,j+1,i) - gv3006 flux_n(k) = v_comp *( &3007 7.0 * ( w(k,j+1,i) + w(k,j,i) ) &3008 - ( w(k,j+2,i) + w(k,j-1,i) ) ) &3009 * adv_mom_33010 diss_n(k) = - ABS( v_comp ) * ( &3011 3.0 * ( w(k,j+1,i) - w(k,j,i) ) &3012 - ( w(k,j+2,i) - w(k,j-1,i) ) ) &3013 * adv_mom_33014 ENDDO3015 3016 CASE ( 8 )3017 DO k = nzb_w_inner(j,i)+1, nzt3018 v_comp = v(k+1,j+1,i) + v(k,j+1,i) - gv3019 flux_n(k) = v_comp * ( &3020 7.0 * ( w(k,j+1,i) + w(k,j,i) ) &3021 - ( w(k,j+2,i) + w(k,j-1,i) ) ) &3022 * adv_mom_33023 diss_n(k) = - ABS( v_comp ) * ( &3024 3.0 * ( w(k,j+1,i) - w(k,j,i) ) &3025 - ( w(k,j+2,i) - w(k,j-1,i) ) ) &3026 * adv_mom_33027 3028 ENDDO3029 3030 CASE DEFAULT3031 3032 END SELECT3033 !3034 !-- Compute the crosswise 5th order fluxes at the outflow3035 IF ( boundary_flags(j,i) == 1 .OR. boundary_flags(j,i) == 2 .OR.&3036 boundary_flags(j,i) == 5 .OR. boundary_flags(j,i) == 6 ) &3037 THEN3038 3039 DO k = nzb_w_inner(j,i)+1, nzt3040 v_comp = v(k+1,j+1,i) + v(k,j+1,i) - gv3041 flux_n(k) = v_comp * ( &3042 37.0 * ( w(k,j+1,i) + w(k,j,i) ) &3043 - 8.0 * ( w(k,j+2,i) + w(k,j-1,i) ) &3044 + ( w(k,j+3,i) + w(k,j-2,i) ) ) &3045 * adv_mom_53046 diss_n(k) = - ABS( v_comp ) * ( &3047 10.0 * ( w(k,j+1,i) - w(k,j,i) ) &3048 - 5.0 * ( w(k,j+2,i) - w(k,j-1,i) ) &3049 + ( w(k,j+3,i) - w(k,j-2,i) ) ) &3050 * adv_mom_53051 ENDDO3052 3053 ELSE3054 3055 DO k = nzb_w_inner(j,i)+1, nzt3056 u_comp = u(k+1,j,i+1) + u(k,j,i+1) - gu3057 flux_r(k) = u_comp * ( &3058 37.0 * ( w(k,j,i+1) + w(k,j,i) ) &3059 - 8.0 * ( w(k,j,i+2) + w(k,j,i-1) ) &3060 + ( w(k,j,i+3) + w(k,j,i-2) ) ) &3061 * adv_mom_53062 diss_r(k) = - ABS( u_comp ) * ( &3063 10.0 * ( w(k,j,i+1) - w(k,j,i) ) &3064 - 5.0 * ( w(k,j,i+2) - w(k,j,i-1) ) &3065 + ( w(k,j,i+3) - w(k,j,i-2) ) ) &3066 * adv_mom_53067 ENDDO3068 3069 ENDIF3070 3071 ELSE3072 !3073 !-- Compute the fifth order fluxes for the interior of PE domain.3074 DO k = nzb_w_inner(j,i)+1, nzt3075 u_comp = u(k+1,j,i+1) + u(k,j,i+1) - gu3076 flux_r(k) = u_comp * ( &3077 37.0 * ( w(k,j,i+1) + w(k,j,i) ) &3078 - 8.0 * ( w(k,j,i+2) + w(k,j,i-1) ) &3079 + ( w(k,j,i+3) + w(k,j,i-2) ) ) &3080 * adv_mom_53081 diss_r(k) = - ABS( u_comp ) * ( &3082 10.0 * ( w(k,j,i+1) - w(k,j,i) ) &3083 - 5.0 * ( w(k,j,i+2) - w(k,j,i-1) ) &3084 + ( w(k,j,i+3) - w(k,j,i-2) ) ) * adv_mom_53085 3086 v_comp = v(k+1,j+1,i) + v(k,j+1,i) - gv3087 flux_n(k) = v_comp * ( &3088 37.0 * ( w(k,j+1,i) + w(k,j,i) ) &3089 - 8.0 * ( w(k,j+2,i) + w(k,j-1,i) ) &3090 + ( w(k,j+3,i) + w(k,j-2,i) ) ) * adv_mom_53091 diss_n(k) = - ABS( v_comp ) * ( &3092 10.0 * ( w(k,j+1,i) - w(k,j,i) ) &3093 - 5.0 * ( w(k,j+2,i) - w(k,j-1,i) ) &3094 + ( w(k,j+3,i) - w(k,j-2,i) ) ) * adv_mom_53095 ENDDO3096 3097 ENDIF3098 3099 DO k = nzb_v_inner(j,i)+1, nzt3100 tend(k,j,i) = tend(k,j,i) - ( &3101 ( flux_r(k) + diss_r(k) &3102 - swap_flux_x_local_w(k,j) - swap_diss_x_local_w(k,j) ) * ddx &3103 + ( flux_n(k) + diss_n(k) &3104 - swap_flux_y_local_w(k) - swap_diss_y_local_w(k) ) * ddy )3105 3106 swap_flux_x_local_w(k,j) = flux_r(k)3107 swap_diss_x_local_w(k,j) = diss_r(k)3108 swap_flux_y_local_w(k) = flux_n(k)3109 swap_diss_y_local_w(k) = diss_n(k)3110 ENDDO3111 ENDDO3112 ENDDO3113 3114 !3115 !-- Vertical advection, degradation of order near surface and top.3116 !-- The fluxes flux_d and diss_d at the surface are 0. Due to reasons of3117 !-- statistical evaluation the top flux at the surface should be 03118 DO i = nxl, nxr3119 DO j = nys, nyn3120 k = nzb_w_inner(j,i)+13121 flux_d = w(k-1,j,i) * ( w(k,j,i) + w(k-1,j,i))3122 flux_t(k-1) = flux_d3123 diss_d = 0.03124 diss_t(k-1) = diss_d3125 !3126 !-- 2nd order scheme (bottom)3127 w_comp = w(k+1,j,i) + w(k,j,i)3128 flux_t(k) = w_comp * ( w(k+1,j,i) + w(k,j,i) ) * 0.253129 diss_t(k) = diss_2nd( w(k+2,j,i), w(k+1,j,i), w(k,j,i), 0.0, 0.0, &3130 w_comp, 0.25, ddzu(k+1) )3131 3132 tend(k,j,i) = tend(k,j,i) - ( flux_t(k) + diss_t(k) &3133 - flux_d - diss_d ) * ddzu(k+1)3134 !3135 !-- WS3 as an intermediate step (bottom)3136 k = nzb_w_inner(j,i) + 23137 flux_d = flux_t(k-1)3138 diss_d = diss_t(k-1)3139 w_comp = w(k+1,j,i) + w(k,j,i)3140 flux_t(k) = w_comp * ( &3141 7.0 * ( w(k+1,j,i) + w(k,j,i) ) &3142 - ( w(k+2,j,i) + w(k-1,j,i) ) ) * adv_mom_33143 diss_t(k) = - ABS( w_comp ) * ( &3144 3.0 * ( w(k+1,j,i) - w(k,j,i) ) &3145 - ( w(k+2,j,i) - w(k-1,j,i) ) ) * adv_mom_33146 3147 tend(k,j,i) = tend(k,j,i) - ( flux_t(k) + diss_t(k) &3148 - flux_d - diss_d ) * ddzu(k+1)3149 !3150 !-- WS53151 DO k = nzb_v_inner(j,i)+3, nzt-23152 flux_d = flux_t(k-1)3153 diss_d = diss_t(k-1)3154 3155 w_comp = w(k+1,j,i) + w(k,j,i)3156 flux_t(k) = w_comp * ( &3157 37.0 * ( w(k+1,j,i) + w(k,j,i) ) &3158 - 8.0 * ( w(k+2,j,i) + w(k-1,j,i) ) &3159 + ( w(k+3,j,i) + w(k-2,j,i) ) ) * adv_mom_53160 diss_t(k) = - ABS( w_comp ) * ( &3161 10.0 * ( w(k+1,j,i) - w(k,j,i) ) &3162 - 5.0 * ( w(k+2,j,i) - w(k-1,j,i) ) &3163 + ( w(k+3,j,i) - w(k-2,j,i) ) ) * adv_mom_53164 3165 tend(k,j,i) = tend(k,j,i) - ( flux_t(k) + diss_t(k) &3166 - flux_d - diss_d ) * ddzu(k+1)3167 ENDDO3168 !3169 !-- WS3 as an intermediate step (top)3170 k = nzt-13171 flux_d = flux_t(k-1)3172 diss_d = diss_t(k-1)3173 w_comp = w(k+1,j,i)+w(k,j,i)3174 flux_t(k) = w_comp * ( &3175 7.0 * ( w(k+1,j,i) + w(k,j,i) ) &3176 - ( w(k+2,j,i) + w(k-1,j,i) ) ) * adv_mom_33177 diss_t(k) = - ABS( w_comp ) * ( &3178 3.0 * ( w(k+1,j,i) - w(k,j,i) ) &3179 - ( w(k+2,j,i) - w(k-1,j,i) ) ) * adv_mom_33180 3181 tend(k,j,i) = tend(k,j,i) - ( flux_t(k) + diss_t(k) &3182 - flux_d - diss_d ) * ddzu(k+1)3183 !3184 !-- 2nd order scheme (top)3185 k = nzt3186 flux_d = flux_t(k-1)3187 diss_d = diss_t(k-1)3188 w_comp = w(k+1,j,i) + w(k,j,i)3189 flux_t(k) = w_comp * ( w(k+1,j,i) + w(k,j,i) ) * 0.253190 diss_t(k) = diss_2nd( w(nzt+1,j,i), w(nzt+1,j,i), w(k,j,i), &3191 w(k-1,j,i), w(k-2,j,i), w_comp, &3192 0.25, ddzu(k+1) )3193 3194 tend(k,j,i) = tend(k,j,i) - ( flux_t(k) + diss_t(k) &3195 - flux_d - diss_d ) * ddzu(k+1)3196 !3197 !-- at last vertical momentum flux is accumulated3198 DO k = nzb_w_inner(j,i), nzt3199 sums_ws2_ws_l(k,tn) = sums_ws2_ws_l(k,tn) &3200 + ( flux_t(k) + diss_t(k) ) &3201 * weight_substep(intermediate_timestep_count)3202 ENDDO3203 3204 ENDDO3205 ENDDO3206 3207 3352 END SUBROUTINE advec_w_ws 3208 3209 3210 3211 SUBROUTINE local_diss_ij( i, j, ar, var_char )3212 3213 END SUBROUTINE local_diss_ij3214 3215 SUBROUTINE local_diss( ar )3216 3217 3218 END SUBROUTINE local_diss3219 3220 !3221 !-- Computation of 2nd order dissipation. This numerical dissipation is3222 !-- necessary to keep a stable numerical solution in regions where the3223 !-- order of the schemes is degraded.3224 3225 REAL FUNCTION diss_2nd( v2, v1, v0, vm1, vm2, vel_comp, factor, grid ) &3226 RESULT( dissip )3227 3228 IMPLICIT NONE3229 3230 REAL, INTENT(IN) :: v2, v1, v0, vm1, vm2, vel_comp, factor, &3231 grid3232 3233 dissip = 0.03234 3235 END FUNCTION diss_2nd3236 3353 3237 3354 END MODULE advec_ws -
palm/trunk/SOURCE/check_parameters.f90
r846 r861 4 4 ! Current revisions: 5 5 ! ----------------- 6 ! 6 ! Check for topography and ws-scheme removed. 7 ! Check for loop_optimization = 'vector' and ws-scheme removed. 7 8 ! 8 9 ! Former revisions: … … 456 457 IF ( topography /= 'flat' ) THEN 457 458 action = ' ' 458 IF ( scalar_advec /= 'pw-scheme' ) THEN459 IF ( scalar_advec /= 'pw-scheme' .AND. scalar_advec /= 'ws-scheme') THEN 459 460 WRITE( action, '(A,A)' ) 'scalar_advec = ', scalar_advec 460 461 ENDIF 461 IF ( momentum_advec /= 'pw-scheme' ) THEN 462 IF ( momentum_advec /= 'pw-scheme' .AND. momentum_advec /= 'ws-scheme' ) & 463 THEN 462 464 WRITE( action, '(A,A)' ) 'momentum_advec = ', momentum_advec 463 465 ENDIF … … 488 490 CALL message( 'check_parameters', 'PA0014', 1, 2, 0, 6, 0 ) 489 491 ENDIF 490 IF ( momentum_advec == 'ws-scheme' .OR. scalar_advec == 'ws-scheme' ) &491 THEN492 message_string = 'topography is still not allowed with ' // &493 'momentum_advec = "' // TRIM( momentum_advec ) // &494 '"or scalar_advec = "' // TRIM( scalar_advec ) //'"'495 ! message number still needs modification496 CALL message( 'check_parameters', 'PA0341', 1, 2, 0, 6, 0 )497 END IF498 499 492 ! 500 493 !-- In case of non-flat topography, check whether the convention how to … … 739 732 IF ( collision_kernel(6:9) == 'fast' ) use_kernel_tables = .TRUE. 740 733 741 742 734 IF ( TRIM( initializing_actions ) /= 'read_restart_data' .AND. & 743 735 TRIM( initializing_actions ) /= 'cyclic_fill' ) THEN … … 1406 1398 CALL message( 'check_parameters', 'PA0053', 1, 2, 0, 6, 0 ) 1407 1399 ENDIF 1408 IF ( (scalar_advec == 'ws-scheme' .OR. momentum_advec == 'ws-scheme' ) &1409 .AND. loop_optimization == 'vector' ) THEN1410 message_string = 'non-cyclic lateral boundaries do not allow ' // &1411 'loop_optimization = vector and ' // &1412 'scalar_advec = "' // TRIM( scalar_advec ) // '"'1413 ! The error message number still needs modification.1414 CALL message( 'check_parameters', 'PA0342', 1, 2, 0, 6, 0 )1415 END IF1416 1400 IF ( galilei_transformation ) THEN 1417 1401 message_string = 'non-cyclic lateral boundaries do not allow ' // & -
palm/trunk/SOURCE/init_grid.f90
r844 r861 4 4 ! Current revisions: 5 5 ! ----------------- 6 ! Set wall_flags_0. The array is needed for degradation in ws-scheme near walls, 7 ! inflow and outflow boundaries as well as near the bottom and the top of the 8 ! model domain. 9 ! 10 ! Initialization of nzb_s_inner and nzb_w_inner. 11 ! gls has to be at least nbgp to do not exceed the array bounds of nzb_local 12 ! while setting wall_flags_0 6 13 ! 7 14 ! Former revisions: … … 104 111 corner_sr, wall_l, wall_n, wall_r,& 105 112 wall_s, nzb_local, nzb_tmp 113 114 LOGICAL :: flag_set = .FALSE. 106 115 107 116 REAL :: dx_l, dy_l, dz_stretched … … 311 320 !-- the flag arrays needed for the multigrid method 312 321 gls = 2**( maximum_grid_level ) 322 IF ( gls < nbgp ) gls = nbgp 313 323 314 324 ALLOCATE( corner_nl(nys:nyn,nxl:nxr), corner_nr(nys:nyn,nxl:nxr), & … … 589 599 590 600 END SELECT 591 601 ! 602 !-- Determine the maximum level of topography. Furthermore it is used for 603 !-- steering the degradation of order of the applied advection scheme. 604 nzb_max = MAXVAL( nzb_local ) 592 605 ! 593 606 !-- Consistency checks and index array initialization are only required for … … 653 666 ! 654 667 !-- Initialize index arrays nzb_s_inner and nzb_w_inner 655 nzb_s_inner = nzb_local(nys -1:nyn+1,nxl-1:nxr+1)656 nzb_w_inner = nzb_local(nys -1:nyn+1,nxl-1:nxr+1)668 nzb_s_inner = nzb_local(nysg:nyng,nxlg:nxrg) 669 nzb_w_inner = nzb_local(nysg:nyng,nxlg:nxrg) 657 670 658 671 ! … … 1018 1031 ENDDO 1019 1032 ENDDO 1020 ENDDO 1033 ENDDO 1021 1034 1022 1035 ! … … 1036 1049 1037 1050 ENDIF 1051 ! 1052 !-- Allocate flags needed for masking walls. 1053 ALLOCATE( wall_flags_0(nzb:nzt,nys:nyn,nxl:nxr) ) 1054 wall_flags_0 = 0 1055 1056 IF ( scalar_advec == 'ws-scheme' ) THEN 1057 ! 1058 !-- Set flags to steer the degradation of the advection scheme in advec_ws 1059 !-- near topography, inflow- and outflow boundaries as well as bottom and 1060 !-- top of model domain. wall_flags_0 remains zero for all non-prognostic 1061 !-- grid points. 1062 DO i = nxl, nxr 1063 DO j = nys, nyn 1064 DO k = nzb_s_inner(j,i)+1, nzt 1065 ! 1066 !-- scalar - x-direction 1067 !-- WS1 (0), WS3 (1), WS5 (2) 1068 IF ( k <= nzb_s_inner(j,i+1) .OR. ( outflow_l .AND. i == nxl ) & 1069 .OR. ( outflow_r .AND. i == nxr ) ) THEN 1070 wall_flags_0(k,j,i) = IBSET( wall_flags_0(k,j,i), 0 ) 1071 ELSEIF ( k <= nzb_s_inner(j,i+2) .OR. k <= nzb_s_inner(j,i-1) & 1072 .OR. ( outflow_r .AND. i == nxr-1 ) & 1073 .OR. ( outflow_l .AND. i == nxlu ) ) THEN 1074 wall_flags_0(k,j,i) = IBSET( wall_flags_0(k,j,i), 1 ) 1075 ELSE 1076 wall_flags_0(k,j,i) = IBSET( wall_flags_0(k,j,i), 2 ) 1077 ENDIF 1078 ! 1079 !-- scalar - y-direction 1080 !-- WS1 (3), WS3 (4), WS5 (5) 1081 IF ( k <= nzb_s_inner(j+1,i) .OR. ( outflow_s .AND. j == nys ) & 1082 .OR. ( outflow_n .AND. j == nyn ) ) THEN 1083 wall_flags_0(k,j,i) = IBSET( wall_flags_0(k,j,i), 3 ) 1084 !-- WS3 1085 ELSEIF ( k <= nzb_s_inner(j+2,i) .OR. k <= nzb_s_inner(j-1,i) & 1086 .OR. ( outflow_s .AND. j == nysv ) & 1087 .OR. ( outflow_n .AND. j == nyn-1 ) ) THEN 1088 wall_flags_0(k,j,i) = IBSET( wall_flags_0(k,j,i), 4 ) 1089 !-- WS5 1090 ELSE 1091 wall_flags_0(k,j,i) = IBSET( wall_flags_0(k,j,i), 5 ) 1092 ENDIF 1093 ! 1094 !-- scalar - z-direction 1095 !-- WS1 (6), WS3 (7), WS5 (8) 1096 flag_set = .FALSE. 1097 IF ( k == nzb_s_inner(j,i) + 1 .OR. k == nzt ) THEN 1098 wall_flags_0(k,j,i) = IBSET( wall_flags_0(k,j,i), 6 ) 1099 flag_set = .TRUE. 1100 ELSEIF ( k == nzb_s_inner(j,i) + 2 .OR. k == nzt - 1 ) THEN 1101 wall_flags_0(k,j,i) = IBSET( wall_flags_0(k,j,i), 7 ) 1102 flag_set = .TRUE. 1103 ELSEIF ( k > nzb_s_inner(j,i) .AND. .NOT. flag_set ) THEN 1104 wall_flags_0(k,j,i) = IBSET( wall_flags_0(k,j,i), 8 ) 1105 ENDIF 1106 ENDDO 1107 ENDDO 1108 ENDDO 1109 ENDIF 1110 1111 IF ( momentum_advec == 'ws-scheme' ) THEN 1112 ! 1113 !-- Set wall_flags_0 to steer the degradation of the advection scheme in advec_ws 1114 !-- near topography, inflow- and outflow boundaries as well as bottom and 1115 !-- top of model domain. wall_flags_0 remains zero for all non-prognostic 1116 !-- grid points. 1117 DO i = nxl, nxr 1118 DO j = nys, nyn 1119 DO k = nzb_u_inner(j,i)+1, nzt 1120 ! 1121 !-- u component - x-direction 1122 !-- WS1 (9), WS3 (10), WS5 (11) 1123 IF ( k <= nzb_u_inner(j,i+1) & 1124 .OR. ( outflow_r .AND. i == nxr ) ) THEN 1125 wall_flags_0(k,j,i) = IBSET( wall_flags_0(k,j,i), 9 ) 1126 ELSEIF ( k <= nzb_u_inner(j,i+2) .OR. k <= nzb_u_inner(j,i-1) & 1127 .OR. ( outflow_r .AND. i == nxr-1 ) & 1128 .OR. ( outflow_l .AND. i == nxlu ) ) THEN 1129 wall_flags_0(k,j,i) = IBSET( wall_flags_0(k,j,i), 10 ) 1130 ELSE 1131 wall_flags_0(k,j,i) = IBSET( wall_flags_0(k,j,i), 11 ) 1132 ENDIF 1133 ! 1134 !-- u component - y-direction 1135 !-- WS1 (12), WS3 (13), WS5 (14) 1136 IF ( k <= nzb_u_inner(j+1,i) .OR. ( outflow_s .AND. j == nys ) & 1137 .OR. ( outflow_n .AND. j == nyn ) ) THEN 1138 wall_flags_0(k,j,i) = IBSET( wall_flags_0(k,j,i), 12 ) 1139 ELSEIF ( k <= nzb_u_inner(j+2,i) .OR. k <= nzb_u_inner(j-1,i) & 1140 .OR. ( outflow_s .AND. j == nysv ) & 1141 .OR. ( outflow_n .AND. j == nyn-1 ) ) THEN 1142 wall_flags_0(k,j,i) = IBSET( wall_flags_0(k,j,i), 13 ) 1143 ELSE 1144 wall_flags_0(k,j,i) = IBSET( wall_flags_0(k,j,i), 14 ) 1145 ENDIF 1146 ! 1147 !-- u component - z-direction 1148 !-- WS1 (15), WS3 (16), WS5 (17) 1149 flag_set = .FALSE. 1150 IF ( k == nzb_u_inner(j,i) + 1 .OR. k == nzt ) THEN 1151 wall_flags_0(k,j,i) = IBSET( wall_flags_0(k,j,i), 15 ) 1152 flag_set = .TRUE. 1153 ELSEIF ( k == nzb_u_inner(j,i) + 2 .OR. k == nzt - 1 ) THEN 1154 wall_flags_0(k,j,i) = IBSET( wall_flags_0(k,j,i), 16 ) 1155 flag_set = .TRUE. 1156 ELSEIF ( k > nzb_u_inner(j,i) .AND. .NOT. flag_set ) THEN 1157 wall_flags_0(k,j,i) = IBSET( wall_flags_0(k,j,i), 17 ) 1158 ENDIF 1159 1160 ENDDO 1161 ENDDO 1162 ENDDO 1163 1164 DO i = nxl, nxr 1165 DO j = nys, nyn 1166 DO k = nzb_v_inner(j,i)+1, nzt 1167 ! 1168 !-- v component - x-direction 1169 !-- WS1 (18), WS3 (19), WS5 (20) 1170 IF ( k <= nzb_v_inner(j,i+1) .OR. ( outflow_l .AND. i == nxl ) & 1171 .OR. ( outflow_r .AND. i == nxr ) ) THEN 1172 wall_flags_0(k,j,i) = IBSET( wall_flags_0(k,j,i), 18 ) 1173 !-- WS3 1174 ELSEIF ( k <= nzb_v_inner(j,i+2) .OR. k <= nzb_v_inner(j,i-1) & 1175 .OR. ( outflow_r .AND. i == nxr-1 ) & 1176 .OR. ( outflow_l .AND. i == nxlu ) ) THEN 1177 wall_flags_0(k,j,i) = IBSET( wall_flags_0(k,j,i), 19 ) 1178 ELSE 1179 wall_flags_0(k,j,i) = IBSET( wall_flags_0(k,j,i), 20 ) 1180 ENDIF 1181 ! 1182 !-- v component - y-direction 1183 !-- WS1 (21), WS3 (22), WS5 (23) 1184 IF ( k <= nzb_v_inner(j+1,i) & 1185 .OR. ( outflow_n .AND. j == nyn ) ) THEN 1186 wall_flags_0(k,j,i) = IBSET( wall_flags_0(k,j,i), 21 ) 1187 ELSEIF ( k <= nzb_v_inner(j+2,i) .OR. k <= nzb_v_inner(j-1,i) & 1188 .OR. ( outflow_s .AND. j == nysv ) & 1189 .OR. ( outflow_n .AND. j == nyn-1 ) ) THEN 1190 wall_flags_0(k,j,i) = IBSET( wall_flags_0(k,j,i), 22 ) 1191 ELSE 1192 wall_flags_0(k,j,i) = IBSET( wall_flags_0(k,j,i), 23 ) 1193 ENDIF 1194 ! 1195 !-- v component - z-direction 1196 !-- WS1 (24), WS3 (25), WS5 (26) 1197 flag_set = .FALSE. 1198 IF ( k == nzb_v_inner(j,i) + 1 .OR. k == nzt ) THEN 1199 wall_flags_0(k,j,i) = IBSET( wall_flags_0(k,j,i), 24 ) 1200 flag_set = .TRUE. 1201 ELSEIF ( k == nzb_v_inner(j,i) + 2 .OR. k == nzt - 1 ) THEN 1202 wall_flags_0(k,j,i) = IBSET( wall_flags_0(k,j,i), 25 ) 1203 flag_set = .TRUE. 1204 ELSEIF ( k > nzb_v_inner(j,i) .AND. .NOT. flag_set ) THEN 1205 wall_flags_0(k,j,i) = IBSET( wall_flags_0(k,j,i), 26 ) 1206 ENDIF 1207 1208 ENDDO 1209 ENDDO 1210 ENDDO 1211 DO i = nxl, nxr 1212 DO j = nys, nyn 1213 DO k = nzb_w_inner(j,i)+1, nzt 1214 ! 1215 !-- w component - x-direction 1216 !-- WS1 (27), WS3 (28), WS5 (29) 1217 IF ( k <= nzb_w_inner(j,i+1) .OR. ( outflow_l .AND. i == nxl ) & 1218 .OR. ( outflow_r .AND. i == nxr ) ) THEN 1219 wall_flags_0(k,j,i) = IBSET( wall_flags_0(k,j,i), 27 ) 1220 ELSEIF ( k <= nzb_w_inner(j,i+2) .OR. k <= nzb_w_inner(j,i-1) & 1221 .OR. ( outflow_r .AND. i == nxr-1 ) & 1222 .OR. ( outflow_l .AND. i == nxlu ) ) THEN 1223 wall_flags_0(k,j,i) = IBSET( wall_flags_0(k,j,i), 28 ) 1224 ELSE 1225 wall_flags_0(k,j,i) = IBSET( wall_flags_0(k,j,i),29 ) 1226 ENDIF 1227 ! 1228 !-- w component - y-direction 1229 !-- WS1 (30), WS3 (31), WS5 (32) 1230 IF ( k <= nzb_w_inner(j+1,i) .OR. ( outflow_s .AND. j == nys ) & 1231 .OR. ( outflow_n .AND. j == nyn ) ) THEN 1232 wall_flags_0(k,j,i) = IBSET( wall_flags_0(k,j,i), 30 ) 1233 ELSEIF ( k <= nzb_w_inner(j+2,i) .OR. k <= nzb_w_inner(j-1,i) & 1234 .OR. ( outflow_s .AND. j == nysv ) & 1235 .OR. ( outflow_n .AND. j == nyn-1 ) ) THEN 1236 wall_flags_0(k,j,i) = IBSET( wall_flags_0(k,j,i), 31 ) 1237 ELSE 1238 wall_flags_0(k,j,i) = IBSET( wall_flags_0(k,j,i), 32 ) 1239 ENDIF 1240 ! 1241 !-- w component - z-direction 1242 !-- WS1 (33), WS3 (34), WS5 (35) 1243 flag_set = .FALSE. 1244 IF ( k == nzb_w_inner(j,i) .OR. k == nzb_w_inner(j,i) + 1 & 1245 .OR. k == nzt ) THEN 1246 ! 1247 !-- Please note, at k == nzb_w_inner(j,i) a flag is explictely 1248 !-- set, although this is not a prognostic level. However, 1249 !-- contrary to the advection of u,v and s this is necessary 1250 !-- because flux_t(nzb_w_inner(j,i)) is used for the tendency 1251 !-- at k == nzb_w_inner(j,i)+1. 1252 wall_flags_0(k,j,i) = IBSET( wall_flags_0(k,j,i), 33 ) 1253 flag_set = .TRUE. 1254 ELSEIF ( k == nzb_w_inner(j,i) + 2 .OR. k == nzt - 1 ) THEN 1255 wall_flags_0(k,j,i) = IBSET( wall_flags_0(k,j,i), 34 ) 1256 flag_set = .TRUE. 1257 ELSEIF ( k > nzb_w_inner(j,i) .AND. .NOT. flag_set ) THEN 1258 wall_flags_0(k,j,i) = IBSET( wall_flags_0(k,j,i), 35 ) 1259 ENDIF 1260 1261 ENDDO 1262 ENDDO 1263 ENDDO 1264 1265 ENDIF 1038 1266 1039 1267 ! -
palm/trunk/SOURCE/init_pt_anomaly.f90
r668 r861 4 4 ! Current revisions: 5 5 ! ----------------- 6 ! 7 ! Modification of the amplitude to obtain a visible temperature perturbation. 6 8 ! 7 9 ! Former revisions: … … 62 64 radius = SQRT( x**2 + y**2 + z**2 ) 63 65 IF ( radius <= rc ) THEN 64 betrag = 5.0 * EXP( -( radius / 2.0 )**2 )66 betrag = 5.0 * EXP( -( radius * 0.001 / 2.0 )**2 ) 65 67 ELSE 66 68 betrag = 0.0 -
palm/trunk/SOURCE/modules.f90
r850 r861 4 4 ! Current revisions: 5 5 ! ----------------- 6 ! 6 ! +wall_flags_0 7 ! -boundary_flags 8 ! +nzb_max 9 ! +adv_sca_1, +adv_mom_1 7 10 ! 8 11 ! Former revisions: … … 422 425 423 426 REAL :: pi = 3.141592654 424 REAL :: adv_ sca_5, adv_sca_3, adv_mom_5, adv_mom_3427 REAL :: adv_mom_1, adv_mom_3, adv_mom_5, adv_sca_1, adv_sca_3, adv_sca_5 425 428 426 429 … … 913 916 nxlu, nxr, nxra, nxrg, nx_on_file, nny, ny = 0, ny_a, ny_o, & 914 917 nya, nyn, nyna, nyng, nys, nysg, nysv, ny_on_file, nnz, nz = 0,& 915 nza, nzb, nzb_diff, nz t, nzta, nzt_diff918 nza, nzb, nzb_diff, nzb_max, nzt, nzta, nzt_diff 916 919 917 920 … … 923 926 924 927 925 INTEGER, DIMENSION(:,:), ALLOCATABLE :: boundary_flags,&926 ngp_2dh_outer, ngp_2dh_s_inner, mg_loc_ind, nzb_diff_s_inner,&927 nzb_diff_ s_outer, nzb_diff_u, nzb_diff_v, nzb_inner, nzb_outer,&928 nzb_ s_inner, nzb_s_outer, nzb_u_inner, nzb_u_outer, &929 nzb_ v_inner, nzb_v_outer, nzb_w_inner, nzb_w_outer, nzb_2d928 INTEGER, DIMENSION(:,:), ALLOCATABLE :: ngp_2dh_outer, ngp_2dh_s_inner, & 929 mg_loc_ind, nzb_diff_s_inner, nzb_diff_s_outer, nzb_diff_u, & 930 nzb_diff_v, nzb_inner, nzb_outer, nzb_s_inner, nzb_s_outer, & 931 nzb_u_inner, nzb_u_outer, nzb_v_inner, nzb_v_outer, & 932 nzb_w_inner, nzb_w_outer, nzb_2d 930 933 931 934 INTEGER, DIMENSION(:,:,:), POINTER :: flags 932 935 933 INTEGER, DIMENSION(:,:,:), ALLOCATABLE, TARGET :: wall_flags_1, & 934 wall_flags_2, wall_flags_3, wall_flags_4, wall_flags_5, & 935 wall_flags_6, wall_flags_7, wall_flags_8, wall_flags_9, & 936 wall_flags_10 936 INTEGER( KIND = SELECTED_INT_KIND(11) ), DIMENSION(:,:,:), ALLOCATABLE :: & 937 wall_flags_0 ! need to have 34 Bit 938 939 INTEGER, DIMENSION(:,:,:), ALLOCATABLE, TARGET :: & 940 wall_flags_1, wall_flags_2, wall_flags_3, wall_flags_4, & 941 wall_flags_5, wall_flags_6, wall_flags_7, wall_flags_8, & 942 wall_flags_9, wall_flags_10 943 937 944 938 945 SAVE -
palm/trunk/SOURCE/palm.f90
r850 r861 83 83 INTEGER :: i, run_description_header_i(80) 84 84 85 version = 'PALM 3.8 '85 version = 'PALM 3.8a' 86 86 87 87 #if defined( __parallel )
Note: See TracChangeset
for help on using the changeset viewer.
