- Timestamp:
- Mar 14, 2019 4:50:07 PM (6 years ago)
- Location:
- palm/trunk
- Files:
-
- 2 edited
-
SCRIPTS/inifor_script (modified) (1 diff)
-
SOURCE/pmc_interface_mod.f90 (modified) (93 diffs)
Legend:
- Unmodified
- Added
- Removed
-
palm/trunk/SCRIPTS/inifor_script
r3791 r3792 22 22 # Current revisions: 23 23 # ------------------ 24 # initial revision24 # 25 25 # 26 26 # Former revisions: 27 27 # ----------------- 28 28 # $Id$ 29 # initial revision 30 # 31 # 29 32 # 30 33 #--------------------------------------------------------------------------------# -
palm/trunk/SOURCE/pmc_interface_mod.f90
r3741 r3792 25 25 ! ----------------- 26 26 ! $Id$ 27 ! Interpolations improved. Large number of obsolete subroutines removed. 28 ! All unused variables removed. 29 ! 30 ! 3741 2019-02-13 16:24:49Z hellstea 27 31 ! Interpolations and child initialization adjusted to handle set ups with child 28 32 ! pe-subdomain dimension not integer divisible by the grid-spacing ratio in the … … 448 452 INTEGER(iwp), PARAMETER :: child_to_parent = 2 !< 449 453 INTEGER(iwp), PARAMETER :: parent_to_child = 1 !< 454 INTEGER(iwp), PARAMETER :: interpolation_scheme_lrsn = 2 !< Interpolation scheme to be used on lateral boundaries (to be made user parameter) 455 INTEGER(iwp), PARAMETER :: interpolation_scheme_t = 3 !< Interpolation scheme to be used on top boundary (to be made user parameter) 450 456 ! 451 457 !-- Coupler setup … … 457 463 ! 458 464 !-- Control parameters 459 CHARACTER(LEN=7), SAVE :: nesting_datatransfer_mode = 'mixed' !< steering 460 !< parameter for data- 461 !< transfer mode 462 CHARACTER(LEN=8), SAVE :: nesting_mode = 'two-way' !< steering parameter 463 !< for 1- or 2-way nesting 465 CHARACTER(LEN=7), SAVE :: nesting_datatransfer_mode = 'mixed' !< steering parameter for data-transfer mode 466 CHARACTER(LEN=8), SAVE :: nesting_mode = 'two-way' !< steering parameter for 1- or 2-way nesting 464 467 465 468 LOGICAL, SAVE :: nested_run = .FALSE. !< general switch 466 469 LOGICAL :: rans_mode_parent = .FALSE. !< mode of parent model (.F. - LES mode, .T. - RANS mode) 467 468 REAL(wp), SAVE :: anterp_relax_length_l = -1.0_wp !<469 REAL(wp), SAVE :: anterp_relax_length_r = -1.0_wp !<470 REAL(wp), SAVE :: anterp_relax_length_s = -1.0_wp !<471 REAL(wp), SAVE :: anterp_relax_length_n = -1.0_wp !<472 REAL(wp), SAVE :: anterp_relax_length_t = -1.0_wp !<473 470 ! 474 471 !-- Geometry … … 477 474 REAL(wp), SAVE, PUBLIC :: lower_left_coord_x !< 478 475 REAL(wp), SAVE, PUBLIC :: lower_left_coord_y !< 479 480 476 ! 481 477 !-- Children's parent-grid arrays … … 484 480 INTEGER(iwp), SAVE, DIMENSION(4), PUBLIC :: coarse_bound_w !< subdomain index bounds for children's parent-grid work arrays 485 481 486 REAL(wp), SAVE, DIMENSION(:,:,:), ALLOCATABLE, TARGET :: dissc !< coarsegrid array on child domain - dissipation rate487 REAL(wp), SAVE, DIMENSION(:,:,:), ALLOCATABLE, TARGET :: ec !<488 REAL(wp), SAVE, DIMENSION(:,:,:), ALLOCATABLE, TARGET :: ptc !<489 REAL(wp), SAVE, DIMENSION(:,:,:), ALLOCATABLE, TARGET :: uc !<490 REAL(wp), SAVE, DIMENSION(:,:,:), ALLOCATABLE, TARGET :: vc !<491 REAL(wp), SAVE, DIMENSION(:,:,:), ALLOCATABLE, TARGET :: wc !<492 REAL(wp), SAVE, DIMENSION(:,:,:), ALLOCATABLE, TARGET :: q_c !<493 REAL(wp), SAVE, DIMENSION(:,:,:), ALLOCATABLE, TARGET :: qcc !<494 REAL(wp), SAVE, DIMENSION(:,:,:), ALLOCATABLE, TARGET :: qrc !<495 REAL(wp), SAVE, DIMENSION(:,:,:), ALLOCATABLE, TARGET :: nrc !<496 REAL(wp), SAVE, DIMENSION(:,:,:), ALLOCATABLE, TARGET :: ncc !<497 REAL(wp), SAVE, DIMENSION(:,:,:), ALLOCATABLE, TARGET :: sc !<482 REAL(wp), SAVE, DIMENSION(:,:,:), ALLOCATABLE, TARGET :: dissc !< Parent-grid array on child domain - dissipation rate 483 REAL(wp), SAVE, DIMENSION(:,:,:), ALLOCATABLE, TARGET :: ec !< Parent-grid array on child domain - SGS TKE 484 REAL(wp), SAVE, DIMENSION(:,:,:), ALLOCATABLE, TARGET :: ptc !< Parent-grid array on child domain - potential temperature 485 REAL(wp), SAVE, DIMENSION(:,:,:), ALLOCATABLE, TARGET :: uc !< Parent-grid array on child domain - velocity component u 486 REAL(wp), SAVE, DIMENSION(:,:,:), ALLOCATABLE, TARGET :: vc !< Parent-grid array on child domain - velocity component v 487 REAL(wp), SAVE, DIMENSION(:,:,:), ALLOCATABLE, TARGET :: wc !< Parent-grid array on child domain - velocity component w 488 REAL(wp), SAVE, DIMENSION(:,:,:), ALLOCATABLE, TARGET :: q_c !< Parent-grid array on child domain - 489 REAL(wp), SAVE, DIMENSION(:,:,:), ALLOCATABLE, TARGET :: qcc !< Parent-grid array on child domain - 490 REAL(wp), SAVE, DIMENSION(:,:,:), ALLOCATABLE, TARGET :: qrc !< Parent-grid array on child domain - 491 REAL(wp), SAVE, DIMENSION(:,:,:), ALLOCATABLE, TARGET :: nrc !< Parent-grid array on child domain - 492 REAL(wp), SAVE, DIMENSION(:,:,:), ALLOCATABLE, TARGET :: ncc !< Parent-grid array on child domain - 493 REAL(wp), SAVE, DIMENSION(:,:,:), ALLOCATABLE, TARGET :: sc !< Parent-grid array on child domain - 498 494 INTEGER(idp), SAVE, DIMENSION(:,:), ALLOCATABLE, TARGET, PUBLIC :: nr_partc !< 499 495 INTEGER(idp), SAVE, DIMENSION(:,:), ALLOCATABLE, TARGET, PUBLIC :: part_adrc !< 500 496 501 REAL(wp), SAVE, DIMENSION(:,:,:,:), ALLOCATABLE, TARGET :: chem_spec_c !< coarse grid array on child domain - chemical species 502 503 ! 504 !-- Child interpolation coefficients and child-array indices to be 505 !-- precomputed and stored. 506 INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:) :: ico !< 507 INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:) :: icu !< 508 INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:) :: jco !< 509 INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:) :: jcv !< 510 INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:) :: kco !< 511 INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:) :: kcw !< 512 REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:) :: celltmpd !< 513 REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:) :: r1xo !< 514 REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:) :: r2xo !< 515 REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:) :: r1xu !< 516 REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:) :: r2xu !< 517 REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:) :: r1yo !< 518 REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:) :: r2yo !< 519 REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:) :: r1yv !< 520 REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:) :: r2yv !< 521 REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:) :: r1zo !< 522 REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:) :: r2zo !< 523 REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:) :: r1zw !< 524 REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:) :: r2zw !< 525 526 ! 527 !-- Child index arrays and log-ratio arrays for the log-law near-wall 528 !-- corrections. These are not truly 3-D arrays but multiple 2-D arrays. 529 INTEGER(iwp), SAVE :: ncorr !< 4th dimension of the log_ratio-arrays 530 INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:,:,:) :: logc_u_l !< 531 INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:,:,:) :: logc_u_n !< 532 INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:,:,:) :: logc_u_r !< 533 INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:,:,:) :: logc_u_s !< 534 INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:,:,:) :: logc_v_l !< 535 INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:,:,:) :: logc_v_n !< 536 INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:,:,:) :: logc_v_r !< 537 INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:,:,:) :: logc_v_s !< 538 INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:,:,:) :: logc_w_l !< 539 INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:,:,:) :: logc_w_n !< 540 INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:,:,:) :: logc_w_r !< 541 INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:,:,:) :: logc_w_s !< 542 INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:,:) :: logc_kbounds_u_l !< 543 INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:,:) :: logc_kbounds_u_n !< 544 INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:,:) :: logc_kbounds_u_r !< 545 INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:,:) :: logc_kbounds_u_s !< 546 INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:,:) :: logc_kbounds_v_l !< 547 INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:,:) :: logc_kbounds_v_n !< 548 INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:,:) :: logc_kbounds_v_r !< 549 INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:,:) :: logc_kbounds_v_s !< 550 INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:,:) :: logc_kbounds_w_l !< 551 INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:,:) :: logc_kbounds_w_n !< 552 INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:,:) :: logc_kbounds_w_r !< 553 INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:,:) :: logc_kbounds_w_s !< 554 REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:,:,:) :: logc_ratio_u_l !< 555 REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:,:,:) :: logc_ratio_u_n !< 556 REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:,:,:) :: logc_ratio_u_r !< 557 REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:,:,:) :: logc_ratio_u_s !< 558 REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:,:,:) :: logc_ratio_v_l !< 559 REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:,:,:) :: logc_ratio_v_n !< 560 REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:,:,:) :: logc_ratio_v_r !< 561 REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:,:,:) :: logc_ratio_v_s !< 562 REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:,:,:) :: logc_ratio_w_l !< 563 REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:,:,:) :: logc_ratio_w_n !< 564 REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:,:,:) :: logc_ratio_w_r !< 565 REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:,:,:) :: logc_ratio_w_s !< 566 ! 497 REAL(wp), SAVE, DIMENSION(:,:,:,:), ALLOCATABLE, TARGET :: chem_spec_c !< Parent-grid array on child domain - chemical species 498 ! 499 !-- Grid-spacing ratios. 567 500 INTEGER(iwp), SAVE :: igsr !< Integer grid-spacing ratio in i-direction 568 501 INTEGER(iwp), SAVE :: jgsr !< Integer grid-spacing ratio in j-direction 569 502 INTEGER(iwp), SAVE :: kgsr !< Integer grid-spacing ratio in k-direction 503 ! 504 !-- Highest prognostic parent-grid k-indices. 570 505 INTEGER(iwp), SAVE :: kcto !< Upper bound for k in anterpolation of variables other than w. 571 506 INTEGER(iwp), SAVE :: kctw !< Upper bound for k in anterpolation of w. 572 INTEGER(iwp), SAVE :: nxlfc !< Lower index limit in x-direction for fine-to-coarse index mapping and interpolaton coefficient arrays573 INTEGER(iwp), SAVE :: nxrfc !< Upper index limit in x-direction for fine-to-coarse index mapping and interpolaton coefficient arrays574 INTEGER(iwp), SAVE :: nynfc !< Upper index limit in y-direction for fine-to-coarse index mapping and interpolaton coefficient arrays575 INTEGER(iwp), SAVE :: nysfc !< Lower index limit in y-direction for fine-to-coarse index mapping and interpolaton coefficient arrays576 !577 !-- Upper bound for k in log-law correction in interpolation.578 INTEGER(iwp), SAVE :: nzt_topo_nestbc_l !<579 INTEGER(iwp), SAVE :: nzt_topo_nestbc_n !<580 INTEGER(iwp), SAVE :: nzt_topo_nestbc_r !<581 INTEGER(iwp), SAVE :: nzt_topo_nestbc_s !<582 !583 !-- Spatial under-relaxation coefficients for anterpolation.584 REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:) :: frax !<585 REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:) :: fray !<586 REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:) :: fraz !<587 507 ! 588 508 !-- Child-array indices to be precomputed and stored for anterpolation. … … 606 526 INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:,:,:) :: ijkfc_w !< number of child grid boxes contribution to a parent grid box, w-grid 607 527 INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:,:,:) :: ijkfc_s !< number of child grid boxes contribution to a parent grid box, scalar-grid 608 528 ! 529 !-- Work arrays for interpolation and user-defined type definitions for horizontal work-array exchange 530 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: workarrc_lr 531 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: workarrc_sn 532 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: workarrc_t 533 INTEGER(iwp) :: workarrc_lr_exchange_type 534 INTEGER(iwp) :: workarrc_sn_exchange_type 535 INTEGER(iwp) :: workarrc_t_exchange_type_x 536 INTEGER(iwp) :: workarrc_t_exchange_type_y 537 609 538 INTEGER(iwp), DIMENSION(3) :: parent_grid_info_int !< 610 539 REAL(wp), DIMENSION(7) :: parent_grid_info_real !< … … 652 581 INTEGER(idp),ALLOCATABLE,DIMENSION(:,:),PUBLIC,TARGET :: part_adr !< 653 582 654 !AH 655 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: workarr_lr 656 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: workarr_sn 657 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: workarr_t 658 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: workarrc_lr 659 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: workarrc_sn 660 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: workarrc_t 661 INTEGER(iwp) :: workarrc_lr_exchange_type 662 INTEGER(iwp) :: workarrc_sn_exchange_type 663 INTEGER(iwp) :: workarrc_t_exchange_type_x 664 INTEGER(iwp) :: workarrc_t_exchange_type_y 665 !AH 666 583 667 584 INTERFACE pmci_boundary_conds 668 585 MODULE PROCEDURE pmci_boundary_conds … … 713 630 END INTERFACE get_child_gridspacing 714 631 715 716 632 INTERFACE pmci_set_swaplevel 717 633 MODULE PROCEDURE pmci_set_swaplevel 718 634 END INTERFACE pmci_set_swaplevel 719 635 720 PUBLIC anterp_relax_length_l, anterp_relax_length_r, & 721 anterp_relax_length_s, anterp_relax_length_n, & 722 anterp_relax_length_t, child_to_parent, comm_world_nesting, & 723 cpl_id, nested_run, nesting_datatransfer_mode, nesting_mode, & 724 parent_to_child, rans_mode_parent 636 PUBLIC child_to_parent, comm_world_nesting, cpl_id, nested_run, & 637 nesting_datatransfer_mode, nesting_mode, parent_to_child, rans_mode_parent 725 638 726 639 PUBLIC pmci_boundary_conds … … 733 646 PUBLIC pmci_set_swaplevel 734 647 PUBLIC get_number_of_childs, get_childid, get_child_edges, get_child_gridspacing 735 736 648 737 649 … … 903 815 REAL(wp) :: xez !< 904 816 REAL(wp) :: yez !< 905 906 REAL(wp), DIMENSION(5) :: fval !< 907 817 REAL(wp), DIMENSION(5) :: fval !< 908 818 REAL(wp), DIMENSION(:), ALLOCATABLE :: cl_coord_x !< 909 819 REAL(wp), DIMENSION(:), ALLOCATABLE :: cl_coord_y !< … … 912 822 ! Initialize the pmc parent 913 823 CALL pmc_parentinit 914 915 824 ! 916 825 !-- Corners of all children of the present parent … … 924 833 ALLOCATE( childgrid(1:SIZE( pmc_parent_for_child ) - 1) ) 925 834 ENDIF 926 927 835 ! 928 836 !-- Get coordinates from all children … … 948 856 !-- transfer 949 857 DO k = 1, nz 950 IF ( zw(k) > fval(1) ) THEN 858 !AH Let's try to make the parent-grid arrays higher by one parent dz 859 !AH IF ( zw(k) > fval(1) ) THEN 860 IF ( zw(k) > fval(1)+dz(1) ) THEN 951 861 nz_cl = k 952 862 EXIT … … 954 864 ENDDO 955 865 956 zmax_coarse = fval(1:2) 957 cl_height = fval(1) 866 !AH Let's make the parent-grid arrays higher by one parent dz 867 !AH zmax_coarse = fval(1:2) 868 !AH cl_height = fval(1) 869 zmax_coarse(1) = fval(1) + dz(1) 870 zmax_coarse(2) = fval(2) + dz(1) 871 cl_height = fval(1) + dz(1) 872 !AH 958 873 959 874 ! … … 1008 923 !-- that the top ghost layer of the child grid does not exceed 1009 924 !-- the parent domain top boundary. 1010 1011 925 IF ( cl_height > zw(nz) ) THEN 1012 926 nomatch = 1 … … 1092 1006 !-- for coupling are stored once into the pmc context. While data transfer, the array do not 1093 1007 !-- have to be specified again 1094 1095 1008 CALL pmc_s_clear_next_array_list 1096 1009 DO WHILE ( pmc_s_getnextarray( child_id, myname ) ) … … 1118 1031 1119 1032 1120 SUBROUTINE pmci_create_index_list1033 SUBROUTINE pmci_create_index_list 1121 1034 1122 1035 IMPLICIT NONE … … 1220 1133 END SUBROUTINE pmci_create_index_list 1221 1134 1135 1136 1222 1137 SUBROUTINE set_child_edge_coords 1223 1138 IMPLICIT NONE … … 1254 1169 SUBROUTINE pmci_setup_child 1255 1170 1256 1257 1171 #if defined( __parallel ) 1258 1172 IMPLICIT NONE 1259 1173 1260 CHARACTER(LEN=da_namelen) :: myname !< 1261 1262 INTEGER(iwp) :: i !< 1263 INTEGER(iwp) :: ierr !< 1174 CHARACTER(LEN=da_namelen) :: myname !< 1175 INTEGER(iwp) :: ierr !< MPI error code 1264 1176 INTEGER(iwp) :: icl !< Left index limit for children's parent-grid arrays 1265 1177 INTEGER(iwp) :: icla !< Left index limit for allocation of index-mapping and other auxiliary arrays … … 1268 1180 INTEGER(iwp) :: icra !< Right index limit for allocation of index-mapping and other auxiliary arrays 1269 1181 INTEGER(iwp) :: icrw !< Right index limit for children's parent-grid work arrays 1270 INTEGER(iwp) :: j !<1271 1182 INTEGER(iwp) :: jcn !< North index limit for children's parent-grid arrays 1272 1183 INTEGER(iwp) :: jcna !< North index limit for allocation of index-mapping and other auxiliary arrays … … 1276 1187 INTEGER(iwp) :: jcsw !< South index limit for children's parent-grid work arrays 1277 1188 INTEGER(iwp) :: n !< Running index for number of chemical species 1278 1279 1189 INTEGER(iwp), DIMENSION(5) :: val !< 1280 1281 1190 REAL(wp) :: xcs !< 1282 1191 REAL(wp) :: xce !< … … 1289 1198 !-- Child setup 1290 1199 !-- Root model does not have a parent and is not a child, therefore no child setup on root model 1291 1292 1200 IF ( .NOT. pmc_is_rootmodel() ) THEN 1293 1201 1294 1202 CALL pmc_childinit 1295 1203 ! 1296 !-- Here AND ONLY HERE the arrays are defined, which actualy will be1297 !-- exchanged between child and parent.1204 !-- The arrays, which actually will be exchanged between child and parent 1205 !-- are defined Here AND ONLY HERE. 1298 1206 !-- If a variable is removed, it only has to be removed from here. 1299 1207 !-- Please check, if the arrays are in the list of POSSIBLE exchange arrays … … 1382 1290 CALL pmc_recv_from_parent( rans_mode_parent, 1, 0, 19, ierr ) 1383 1291 ! 1384 !1385 1292 !-- Receive Coarse grid information. 1386 1293 CALL pmc_recv_from_parent( parent_grid_info_real, & 1387 1294 SIZE(parent_grid_info_real), 0, 21, ierr ) 1388 1295 CALL pmc_recv_from_parent( parent_grid_info_int, 3, 0, 22, ierr ) 1389 ! 1390 !-- Debug-printouts - keep them 1391 ! WRITE(0,*) 'Coarse grid from parent ' 1392 ! WRITE(0,*) 'startx_tot = ',parent_grid_info_real(1) 1393 ! WRITE(0,*) 'starty_tot = ',parent_grid_info_real(2) 1394 ! WRITE(0,*) 'endx_tot = ',parent_grid_info_real(5) 1395 ! WRITE(0,*) 'endy_tot = ',parent_grid_info_real(6) 1396 ! WRITE(0,*) 'dx = ',parent_grid_info_real(3) 1397 ! WRITE(0,*) 'dy = ',parent_grid_info_real(4) 1398 ! WRITE(0,*) 'dz = ',parent_grid_info_real(7) 1399 ! WRITE(0,*) 'nx_coarse = ',parent_grid_info_int(1) 1400 ! WRITE(0,*) 'ny_coarse = ',parent_grid_info_int(2) 1401 ! WRITE(0,*) 'nz_coarse = ',parent_grid_info_int(3) 1296 1402 1297 ENDIF 1403 1298 … … 1416 1311 ALLOCATE( cg%coord_x(-nbgp:cg%nx+nbgp) ) 1417 1312 ALLOCATE( cg%coord_y(-nbgp:cg%ny+nbgp) ) 1418 1419 1313 ALLOCATE( cg%dzu(1:cg%nz+1) ) 1420 1314 ALLOCATE( cg%dzw(1:cg%nz+1) ) … … 1469 1363 CALL pmc_c_setind_and_allocmem 1470 1364 ! 1471 !-- Precompute interpolation coefficients and child-array indices 1472 CALL pmci_init_interp_tril 1473 ! 1474 !-- Precompute the log-law correction index- and ratio-arrays 1475 IF ( constant_flux_layer ) THEN 1476 CALL pmci_init_loglaw_correction 1477 ENDIF 1478 ! 1479 !-- Two-way coupling for general and vertical nesting. 1480 !-- Precompute the index arrays and relaxation functions for the 1481 !-- anterpolation 1482 ! 1483 !-- Note that the anterpolation index bounds are needed also in case 1484 !-- of one-way coupling because of the reversibility correction 1485 !-- included in the interpolation algorithms. 1486 CALL pmci_init_anterp_tophat 1487 ! 1488 !-- Check that the child and parent grid lines match 1365 !-- Precompute the index-mapping arrays 1366 CALL pmci_define_index_mapping 1367 ! 1368 !-- Check that the child and parent grid lines do match 1489 1369 CALL pmci_check_grid_matching 1490 1370 … … 1502 1382 INTEGER(iwp), DIMENSION(5,numprocs) :: coarse_bound_all !< 1503 1383 INTEGER(iwp), DIMENSION(2) :: size_of_array !< 1504 1505 1384 INTEGER(iwp) :: i !< 1506 1385 INTEGER(iwp) :: iauxl !< … … 1515 1394 REAL(wp) :: yexn !< Parent-grid array exceedance behind the north edge of the child PE subdomain 1516 1395 1517 !AH!1518 !AH!-- If the fine- and coarse grid nodes do not match:1519 !AH loffset = MOD( coord_x(nxl), cg%dx )1520 !AH xexl = cg%dx + loffset1521 !AH xcs = coord_x(nxl) - xexl1522 !AH DO i = 0, cg%nx1523 !AH IF ( cg%coord_x(i) > xcs ) THEN1524 !AH icl = MAX( -1, i-1 )1525 !AH EXIT1526 !AH ENDIF1527 !AH ENDDO1528 !AH!1529 !AH!-- If the fine- and coarse grid nodes do not match1530 !AH roffset = MOD( coord_x(nxr+1), cg%dx )1531 !AH xexr = cg%dx + roffset1532 !AH xce = coord_x(nxr+1)1533 !AH IF ( nxr == nx ) THEN1534 !AH xce = xce + xexr1535 !AH ENDIF1536 !AH DO i = cg%nx, 0 , -11537 !AH IF ( cg%coord_x(i) < xce ) THEN1538 !AH icr = MIN( cg%nx+1, i+1 )1539 !AH EXIT1540 !AH ENDIF1541 !AH ENDDO1542 !AH!1543 !AH!-- If the fine- and coarse grid nodes do not match1544 !AH soffset = MOD( coord_y(nys), cg%dy )1545 !AH yexs = cg%dy + soffset1546 !AH ycs = coord_y(nys) - yexs1547 !AH DO j = 0, cg%ny1548 !AH IF ( cg%coord_y(j) > ycs ) THEN1549 !AH jcs = MAX( -nbgp, j-1 )1550 !AH EXIT1551 !AH ENDIF1552 !AH ENDDO1553 !AH!1554 !AH!-- If the fine- and coarse grid nodes do not match1555 !AH noffset = MOD( coord_y(nyn+1), cg%dy )1556 !AH yexn = cg%dy + noffset1557 !AH yce = coord_y(nyn+1)1558 !AH IF ( nyn == ny ) THEN1559 !AH yce = yce + yexn1560 !AH ENDIF1561 !AH DO j = cg%ny, 0, -11562 !AH IF ( cg%coord_y(j) < yce ) THEN1563 !AH jcn = MIN( cg%ny + nbgp, j+1 )1564 !AH EXIT1565 !AH ENDIF1566 !AH ENDDO1567 !AH1568 !AH coarse_bound(1) = icl1569 !AH coarse_bound(2) = icr1570 !AH coarse_bound(3) = jcs1571 !AH coarse_bound(4) = jcn1572 !AH coarse_bound(5) = myid1573 1396 ! 1574 1397 !-- Determine the anterpolation index limits. If at least half of the … … 1578 1401 !-- anterpolation domain, or not included at all if we are at the outer 1579 1402 !-- edge of the child domain. 1580 1581 1403 ! 1582 1404 !-- Left … … 1698 1520 END SUBROUTINE pmci_map_fine_to_coarse_grid 1699 1521 1700 1701 1702 SUBROUTINE pmci_init_interp_tril 1703 ! 1704 !-- Precomputation of the interpolation coefficients and child-array indices 1705 !-- to be used by the interpolation routines interp_tril_lr, interp_tril_ns 1706 !-- and interp_tril_t. 1522 1523 1524 SUBROUTINE pmci_define_index_mapping 1525 ! 1526 !-- Precomputation of the mapping of the child- and parent-grid indices. 1707 1527 1708 1528 IMPLICIT NONE 1709 1529 1710 INTEGER(iwp) :: acsize !< Maximum dimension of anterpolation cell. 1711 INTEGER(iwp) :: i !< Child-grid i-index 1712 INTEGER(iwp) :: ierr !< MPI error code 1713 INTEGER(iwp) :: j !< Child-grid j-index 1714 INTEGER(iwp) :: k !< Child-grid k-index 1715 INTEGER(iwp) :: kc !< 1716 INTEGER(iwp) :: kdzo !< 1717 INTEGER(iwp) :: kdzw !< 1718 INTEGER(iwp) :: moff !< Parent-grid bound offset in j-direction 1719 INTEGER(iwp) :: loff !< Parent-grid bound offset in i-direction 1720 1721 REAL(wp) :: dzmin !< 1722 REAL(wp) :: parentdzmax !< 1723 REAL(wp) :: xb !< 1724 REAL(wp) :: xcsu !< 1725 REAL(wp) :: xfso !< 1726 REAL(wp) :: xcso !< 1727 REAL(wp) :: xfsu !< 1728 REAL(wp) :: yb !< 1729 REAL(wp) :: ycso !< 1730 REAL(wp) :: ycsv !< 1731 REAL(wp) :: yfso !< 1732 REAL(wp) :: yfsv !< 1733 REAL(wp) :: zcso !< 1734 REAL(wp) :: zcsw !< 1735 REAL(wp) :: zfso !< 1736 REAL(wp) :: zfsw !< 1737 1738 1739 !AH 1530 INTEGER(iwp) :: i !< Child-grid index 1531 INTEGER(iwp) :: ii !< Parent-grid index 1532 INTEGER(iwp) :: istart !< 1533 INTEGER(iwp) :: ir !< 1534 INTEGER(iwp) :: iw !< Child-grid index limited to -1 <= iw <= nx+1 1535 INTEGER(iwp) :: j !< Child-grid index 1536 INTEGER(iwp) :: jj !< Parent-grid index 1537 INTEGER(iwp) :: jstart !< 1538 INTEGER(iwp) :: jr !< 1539 INTEGER(iwp) :: jw !< Child-grid index limited to -1 <= jw <= ny+1 1540 INTEGER(iwp) :: k !< Child-grid index 1541 INTEGER(iwp) :: kk !< Parent-grid index 1542 INTEGER(iwp) :: kstart !< 1543 INTEGER(iwp) :: kw !< Child-grid index limited to kw <= nzt+1 1544 REAL(wp) :: tolerance !< 1545 1740 1546 ! 1741 1547 !-- Allocate child-grid work arrays for interpolation. 1742 CALL pmci_allocate_finegrid_workarrays 1548 igsr = NINT( cg%dx / dx, iwp ) 1549 jgsr = NINT( cg%dy / dy, iwp ) 1550 kgsr = NINT( cg%dzw(1) / dzw(1), iwp ) 1551 WRITE(9,"('igsr, jgsr, kgsr: ',3(i3,2x))") igsr, jgsr, kgsr 1552 FLUSH(9) 1743 1553 ! 1744 1554 !-- Determine index bounds for the parent-grid work arrays for 1745 1555 !-- interpolation and allocate them. 1746 CALL pmci_allocate_ coarsegrid_workarrays1556 CALL pmci_allocate_workarrays 1747 1557 ! 1748 1558 !-- Define the MPI-datatypes for parent-grid work array 1749 1559 !-- exchange between the PE-subdomains. 1750 CALL pmci_create_coarsegrid_workarray_exchange_datatypes 1751 ! 1752 !-- Determine index bounds for the fine-to-coarse grid index mapping arrays 1753 !-- and interpolation-coefficient arrays and allocate them. 1754 CALL pmci_allocate_fine_to_coarse_mapping_arrays 1755 !AH 1756 ! 1757 xb = nxl * dx 1758 IF ( bc_dirichlet_l ) THEN 1759 loff = 2 1760 ELSE 1761 loff = 0 1762 ENDIF 1763 !AH DO i = nxlg, nxrg 1764 DO i = nxl-1, nxr+1 1765 xfsu = coord_x(i) - ( lower_left_coord_x + xb ) 1766 xfso = coord_x(i) + 0.5_wp * dx - ( lower_left_coord_x + xb ) 1767 ! 1768 !-- icl points to 2 parent-grid cells left form the left nest boundary, 1769 !-- thence icl + loff points to the left nest boundary. 1770 icu(i) = icl + loff + FLOOR( xfsu / cg%dx ) 1771 ico(i) = icl + loff + FLOOR( ( xfso - 0.5_wp * cg%dx ) / cg%dx ) 1772 xcsu = ( icu(i) - ( icl + loff ) ) * cg%dx 1773 xcso = ( ico(i) - ( icl + loff ) + 0.5_wp ) * cg%dx 1774 r2xu(i) = ( xfsu - xcsu ) / cg%dx 1775 r2xo(i) = ( xfso - xcso ) / cg%dx 1776 r1xu(i) = 1.0_wp - r2xu(i) 1777 r1xo(i) = 1.0_wp - r2xo(i) 1778 ENDDO 1779 ! 1780 !-- Fill up the values behind nest boundaries by copying from inside 1781 !-- the domain. 1782 IF ( bc_dirichlet_l ) THEN 1783 icu(nxlfc:nxl-1) = icu(nxlfc+igsr:nxl-1+igsr) - 1 1784 r1xu(nxlfc:nxl-1) = r1xu(nxlfc+igsr:nxl-1+igsr) 1785 r2xu(nxlfc:nxl-1) = r2xu(nxlfc+igsr:nxl-1+igsr) 1786 ico(nxlfc:nxl-1) = ico(nxlfc+igsr:nxl-1+igsr) - 1 1787 r1xo(nxlfc:nxl-1) = r1xo(nxlfc+igsr:nxl-1+igsr) 1788 r2xo(nxlfc:nxl-1) = r2xo(nxlfc+igsr:nxl-1+igsr) 1789 ENDIF 1790 1791 IF ( bc_dirichlet_r ) THEN 1792 icu(nxr+1:nxrfc) = icu(nxr+1-igsr:nxrfc-igsr) + 1 1793 r1xu(nxr+1:nxrfc) = r1xu(nxr+1-igsr:nxrfc-igsr) 1794 r2xu(nxr+1:nxrfc) = r2xu(nxr+1-igsr:nxrfc-igsr) 1795 ico(nxr+1:nxrfc) = ico(nxr+1-igsr:nxrfc-igsr) + 1 1796 r1xo(nxr+1:nxrfc) = r1xo(nxr+1-igsr:nxrfc-igsr) 1797 r2xo(nxr+1:nxrfc) = r2xo(nxr+1-igsr:nxrfc-igsr) 1798 ENDIF 1799 ! 1800 !-- Print out the indices and coefficients for checking and debugging purposes 1801 DO i = nxlfc, nxrfc 1802 WRITE(9,"('pmci_init_interp_tril: i, icu, r1xu r2xu ', 2(i4,2x),2(e12.5,2x))") & 1803 i, icu(i), r1xu(i), r2xu(i) 1804 FLUSH(9) 1805 ENDDO 1806 WRITE(9,*) 1807 DO i = nxlfc, nxrfc 1808 WRITE(9,"('pmci_init_interp_tril: i, ico, r1xo r2xo ', 2(i4,2x),2(e12.5,2x))") & 1809 i, ico(i), r1xo(i), r2xo(i) 1810 FLUSH(9) 1811 ENDDO 1812 WRITE(9,*) 1813 1814 yb = nys * dy 1815 IF ( bc_dirichlet_s ) THEN 1816 moff = 2 1817 ELSE 1818 moff = 0 1819 ENDIF 1820 !AH DO j = nysg, nyng 1821 DO j = nys-1, nyn+1 1822 yfsv = coord_y(j) - ( lower_left_coord_y + yb ) 1823 yfso = coord_y(j) + 0.5_wp * dy - ( lower_left_coord_y + yb ) 1824 ! 1825 !-- jcs points to 2 parent-grid cells south form the south nest boundary, 1826 !-- thence jcs + moff points to the south nest boundary. 1827 jcv(j) = jcs + moff + FLOOR( yfsv / cg%dy ) 1828 jco(j) = jcs + moff + FLOOR( ( yfso - 0.5_wp * cg%dy ) / cg%dy ) 1829 ycsv = ( jcv(j) - ( jcs + moff ) ) * cg%dy 1830 ycso = ( jco(j) - ( jcs + moff ) + 0.5_wp ) * cg%dy 1831 r2yv(j) = ( yfsv - ycsv ) / cg%dy 1832 r2yo(j) = ( yfso - ycso ) / cg%dy 1833 r1yv(j) = 1.0_wp - r2yv(j) 1834 r1yo(j) = 1.0_wp - r2yo(j) 1835 ENDDO 1836 ! 1837 !-- Fill up the values behind nest boundaries by copying from inside 1838 !-- the domain. 1839 IF ( bc_dirichlet_s ) THEN 1840 jcv(nysfc:nys-1) = jcv(nysfc+jgsr:nys-1+jgsr) - 1 1841 r1yv(nysfc:nys-1) = r1yv(nysfc+jgsr:nys-1+jgsr) 1842 r2yv(nysfc:nys-1) = r2yv(nysfc+jgsr:nys-1+jgsr) 1843 jco(nysfc:nys-1) = jco(nysfc+jgsr:nys-1+jgsr) - 1 1844 r1yo(nysfc:nys-1) = r1yo(nysfc+jgsr:nys-1+jgsr) 1845 r2yo(nysfc:nys-1) = r2yo(nysfc+jgsr:nys-1+jgsr) 1846 ENDIF 1847 1848 IF ( bc_dirichlet_n ) THEN 1849 jcv(nyn+1:nynfc) = jcv(nyn+1-jgsr:nynfc-jgsr) + 1 1850 r1yv(nyn+1:nynfc) = r1yv(nyn+1-jgsr:nynfc-jgsr) 1851 r2yv(nyn+1:nynfc) = r2yv(nyn+1-jgsr:nynfc-jgsr) 1852 jco(nyn+1:nynfc) = jco(nyn+1-jgsr:nynfc-jgsr) + 1 1853 r1yo(nyn+1:nynfc) = r1yo(nyn+1-jgsr:nynfc-jgsr) 1854 r2yo(nyn+1:nynfc) = r2yo(nyn+1-jgsr:nynfc-jgsr) 1855 ENDIF 1856 ! 1857 !-- Print out the indices and coefficients for checking and debugging purposes 1858 DO j = nysfc, nynfc 1859 WRITE(9,"('pmci_init_interp_tril: j, jcv, r1yv r2yv ', 2(i4,2x),2(e12.5,2x))") & 1860 j, jcv(j), r1yv(j), r2yv(j) 1861 FLUSH(9) 1862 ENDDO 1863 WRITE(9,*) 1864 DO j = nysfc, nynfc 1865 WRITE(9,"('pmci_init_interp_tril: j, jco, r1yo r2yo ', 2(i4,2x),2(e12.5,2x))") & 1866 j, jco(j), r1yo(j), r2yo(j) 1867 FLUSH(9) 1868 ENDDO 1869 WRITE(9,*) 1870 1871 DO k = nzb, nzt + 1 1872 zfsw = zw(k) 1873 zfso = zu(k) 1874 1875 DO kc = 0, cg%nz+1 1876 IF ( cg%zw(kc) > zfsw ) EXIT 1877 ENDDO 1878 kcw(k) = kc - 1 1879 1880 DO kc = 0, cg%nz+1 1881 IF ( cg%zu(kc) > zfso ) EXIT 1882 ENDDO 1883 kco(k) = kc - 1 1884 1885 zcsw = cg%zw(kcw(k)) 1886 zcso = cg%zu(kco(k)) 1887 kdzw = MIN( kcw(k)+1, cg%nz+1 ) 1888 kdzo = MIN( kco(k)+1, cg%nz+1 ) 1889 r2zw(k) = ( zfsw - zcsw ) / cg%dzw(kdzw) 1890 r2zo(k) = ( zfso - zcso ) / cg%dzu(kdzo) 1891 r1zw(k) = 1.0_wp - r2zw(k) 1892 r1zo(k) = 1.0_wp - r2zo(k) 1893 ENDDO 1894 ! 1895 !-- Set the interpolation index- and coefficient-information to the 1896 !-- child-grid cells within the uppermost parent-grid cell. This 1897 !-- information is only needed for the reversibility correction. 1898 kco(nzt+2:nzt+kgsr) = kco(nzt+1) + 1 1899 r1zo(nzt+2:nzt+kgsr) = r1zo(nzt+2-kgsr:nzt) 1900 r2zo(nzt+2:nzt+kgsr) = r2zo(nzt+2-kgsr:nzt) 1901 ! 1902 !-- kcw, r1zw and r2zw are not needed when k > nzt+1 1903 kcw(nzt+2:nzt+kgsr) = 0 1904 r1zw(nzt+2:nzt+kgsr) = 0.0_wp 1905 r2zw(nzt+2:nzt+kgsr) = 0.0_wp 1906 ! 1907 !-- Print out the indices and coefficients for checking and debugging purposes 1908 DO k = nzb, nzt+1 1909 WRITE(9,"('pmci_init_interp_tril: k, kcw, r1zw r2zw ', 2(i4,2x),2(e12.5,2x))") & 1910 k, kcw(k), r1zw(k), r2zw(k) 1911 FLUSH(9) 1912 ENDDO 1913 WRITE(9,*) 1914 DO k = nzb, nzt + kgsr 1915 WRITE(9,"('pmci_init_interp_tril: k, kco, r1zo r2zo ', 2(i4,2x),2(e12.5,2x))") & 1916 k, kco(k), r1zo(k), r2zo(k) 1917 FLUSH(9) 1918 ENDDO 1919 WRITE(9,*) 1920 ! 1921 !-- Determine the maximum dimension of anterpolation cells and allocate the 1922 !-- work array celltmpd needed in the reversibility correction in the 1923 !-- interpolation 1924 dzmin = 999999.9_wp 1925 DO k = 1, nzt+1 1926 dzmin = MIN( dzmin, dzu(k), dzw(k) ) 1927 ENDDO 1928 parentdzmax = 0.0_wp 1929 DO k = 1, cg%nz+1 1930 parentdzmax = MAX(parentdzmax , cg%dzu(k), cg%dzw(k) ) 1931 ENDDO 1932 acsize = CEILING( cg%dx / dx ) * CEILING( cg%dy / dy ) * & 1933 CEILING( parentdzmax / dzmin ) 1934 ALLOCATE( celltmpd(1:acsize) ) 1935 1936 END SUBROUTINE pmci_init_interp_tril 1937 1938 1939 1940 SUBROUTINE pmci_allocate_finegrid_workarrays 1941 ! 1942 !-- Allocate child-grid work-arrays for interpolation 1943 IMPLICIT NONE 1944 1945 1946 igsr = NINT( cg%dx / dx, iwp ) 1947 jgsr = NINT( cg%dy / dy, iwp ) 1948 kgsr = NINT( cg%dzw(1) / dzw(1), iwp ) 1949 write(9,"('igsr, jgsr, kgsr: ',3(i3,2x))") igsr, jgsr, kgsr 1950 flush(9) 1951 ! 1952 !-- Note that i-indexing for workarr_lr runs from 0 to igsr-1. 1953 !-- For u, only 0-element is used and all elements 0:igsr-1 1954 !-- are used for all other variables. 1955 ALLOCATE( workarr_lr(nzb:nzt+1,nysg:nyng,0:igsr-1) ) 1956 ! 1957 !-- Note that j-indexing for workarr_sn runs from 0 to jgsr-1. 1958 !-- For v, only 0-element is used and all elements 0:jgsr-1 1959 !-- are used for all other variables. 1960 ALLOCATE( workarr_sn(nzb:nzt+1,0:jgsr-1,nxlg:nxrg) ) 1961 ! 1962 !-- Note that genuine k-indexing is used for workarr_t. 1963 !-- Only nzt-element is used for w and elements nzt+1:nzt+kgsr 1964 !-- are used for all other variables. 1965 ALLOCATE( workarr_t(nzt:nzt+kgsr,nysg:nyng,nxlg:nxrg) ) 1966 1967 END SUBROUTINE pmci_allocate_finegrid_workarrays 1968 1969 1970 1971 SUBROUTINE pmci_allocate_coarsegrid_workarrays 1972 ! 1973 !-- Allocate parent-grid work-arrays for interpolation 1974 IMPLICIT NONE 1975 1976 ! 1977 !-- Determine and store the PE-subdomain dependent index bounds 1978 IF ( bc_dirichlet_l ) THEN 1979 iclw = icl + 1 1980 ELSE 1981 iclw = icl - 1 1982 ENDIF 1983 1984 IF ( bc_dirichlet_r ) THEN 1985 icrw = icr - 1 1986 ELSE 1987 icrw = icr + 1 1988 ENDIF 1989 1990 IF ( bc_dirichlet_s ) THEN 1991 jcsw = jcs + 1 1992 ELSE 1993 jcsw = jcs - 1 1994 ENDIF 1995 1996 IF ( bc_dirichlet_n ) THEN 1997 jcnw = jcn - 1 1998 ELSE 1999 jcnw = jcn + 1 2000 ENDIF 2001 2002 coarse_bound_w(1) = iclw 2003 coarse_bound_w(2) = icrw 2004 coarse_bound_w(3) = jcsw 2005 coarse_bound_w(4) = jcnw 2006 ! 2007 !-- Left and right boundaries. 2008 ALLOCATE( workarrc_lr(0:cg%nz+1,jcsw:jcnw,0:2) ) 2009 ! 2010 !-- South and north boundaries. 2011 ALLOCATE( workarrc_sn(0:cg%nz+1,0:2,iclw:icrw) ) 2012 ! 2013 !-- Top boundary. 2014 ALLOCATE( workarrc_t(0:2,jcsw:jcnw,iclw:icrw) ) 2015 2016 END SUBROUTINE pmci_allocate_coarsegrid_workarrays 2017 2018 2019 2020 SUBROUTINE pmci_create_coarsegrid_workarray_exchange_datatypes 2021 ! 2022 !-- Define specific MPI types for workarrc-exhchange. 2023 IMPLICIT NONE 2024 2025 #if defined( __parallel ) 2026 ! 2027 !-- For the left and right boundaries 2028 CALL MPI_TYPE_VECTOR( 3, cg%nz+2, (jcnw-jcsw+1)*(cg%nz+2), MPI_REAL, & 2029 workarrc_lr_exchange_type, ierr ) 2030 CALL MPI_TYPE_COMMIT( workarrc_lr_exchange_type, ierr ) 2031 ! 2032 !-- For the south and north boundaries 2033 CALL MPI_TYPE_VECTOR( 1, 3*(cg%nz+2), 3*(cg%nz+2), MPI_REAL, & 2034 workarrc_sn_exchange_type, ierr ) 2035 CALL MPI_TYPE_COMMIT( workarrc_sn_exchange_type, ierr ) 2036 ! 2037 !-- For the top-boundary x-slices 2038 CALL MPI_TYPE_VECTOR( icrw-iclw+1, 3, 3*(jcnw-jcsw+1), MPI_REAL, & 2039 workarrc_t_exchange_type_x, ierr ) 2040 CALL MPI_TYPE_COMMIT( workarrc_t_exchange_type_x, ierr ) 2041 ! 2042 !-- For the top-boundary y-slices 2043 CALL MPI_TYPE_VECTOR( 1, 3*(jcnw-jcsw+1), 3*(jcnw-jcsw+1), MPI_REAL, & 2044 workarrc_t_exchange_type_y, ierr ) 2045 CALL MPI_TYPE_COMMIT( workarrc_t_exchange_type_y, ierr ) 2046 #endif 2047 2048 END SUBROUTINE pmci_create_coarsegrid_workarray_exchange_datatypes 2049 2050 2051 2052 SUBROUTINE pmci_allocate_fine_to_coarse_mapping_arrays 2053 ! 2054 !-- Define index limits and allocate the fine-to-coarse grid index mapping 2055 !-- arrays and interpolation coefficient arrays. 2056 IMPLICIT NONE 2057 2058 2059 IF ( bc_dirichlet_l ) THEN 2060 !AH nxlfc = MIN( nxl-igsr, nxlg ) 2061 nxlfc = nxl - igsr 2062 ELSE 2063 !AH nxlfc = nxlg 2064 nxlfc = nxl - 1 2065 ENDIF 2066 IF ( bc_dirichlet_r ) THEN 2067 !AH nxrfc = MAX( nxr+igsr, nxrg ) 2068 nxrfc = nxr + igsr 2069 ELSE 2070 !AH nxrfc = nxrg 2071 nxrfc = nxr + 1 2072 ENDIF 2073 2074 IF ( bc_dirichlet_s ) THEN 2075 !AH nysfc = MIN( nys-jgsr, nysg ) 2076 nysfc = nys - jgsr 2077 ELSE 2078 !AH nysfc = nysg 2079 nysfc = nys - 1 2080 ENDIF 2081 IF ( bc_dirichlet_n ) THEN 2082 !AH nynfc = MAX( nyn+jgsr, nyng ) 2083 nynfc = nyn + jgsr 2084 ELSE 2085 !AH nynfc = nyng 2086 nynfc = nyn + 1 2087 ENDIF 2088 2089 ALLOCATE( icu(nxlfc:nxrfc) ) 2090 ALLOCATE( ico(nxlfc:nxrfc) ) 2091 ALLOCATE( jcv(nysfc:nynfc) ) 2092 ALLOCATE( jco(nysfc:nynfc) ) 2093 ALLOCATE( kcw(nzb:nzt+kgsr) ) 2094 ALLOCATE( kco(nzb:nzt+kgsr) ) 2095 2096 ALLOCATE( r1xu(nxlfc:nxrfc) ) 2097 ALLOCATE( r2xu(nxlfc:nxrfc) ) 2098 ALLOCATE( r1xo(nxlfc:nxrfc) ) 2099 ALLOCATE( r2xo(nxlfc:nxrfc) ) 2100 ALLOCATE( r1yv(nysfc:nynfc) ) 2101 ALLOCATE( r2yv(nysfc:nynfc) ) 2102 ALLOCATE( r1yo(nysfc:nynfc) ) 2103 ALLOCATE( r2yo(nysfc:nynfc) ) 2104 ALLOCATE( r1zw(nzb:nzt+kgsr) ) 2105 ALLOCATE( r2zw(nzb:nzt+kgsr) ) 2106 ALLOCATE( r1zo(nzb:nzt+kgsr) ) 2107 ALLOCATE( r2zo(nzb:nzt+kgsr) ) 2108 2109 END SUBROUTINE pmci_allocate_fine_to_coarse_mapping_arrays 2110 2111 2112 2113 SUBROUTINE pmci_init_loglaw_correction 2114 ! 2115 !-- Precomputation of the index and log-ratio arrays for the log-law 2116 !-- corrections for near-wall nodes after the nest-BC interpolation. 2117 !-- These are used by the interpolation routines interp_tril_lr and 2118 !-- interp_tril_ns. 2119 2120 IMPLICIT NONE 2121 2122 INTEGER(iwp) :: direction !< Wall normal index: 1=k, 2=j, 3=i. 2123 INTEGER(iwp) :: dum !< dummy value for reduce operation 2124 INTEGER(iwp) :: i !< 2125 INTEGER(iwp) :: ierr !< MPI status 2126 INTEGER(iwp) :: inc !< Wall outward-normal index increment -1 2127 !< or 1, for direction=1, inc=1 always 2128 INTEGER(iwp) :: j !< 2129 INTEGER(iwp) :: k !< 2130 INTEGER(iwp) :: k_wall_u_ji !< topography top index on u-grid 2131 INTEGER(iwp) :: k_wall_u_ji_p !< topography top index on u-grid 2132 INTEGER(iwp) :: k_wall_u_ji_m !< topography top index on u-grid 2133 INTEGER(iwp) :: k_wall_v_ji !< topography top index on v-grid 2134 INTEGER(iwp) :: k_wall_v_ji_p !< topography top index on v-grid 2135 INTEGER(iwp) :: k_wall_v_ji_m !< topography top index on v-grid 2136 INTEGER(iwp) :: k_wall_w_ji !< topography top index on w-grid 2137 INTEGER(iwp) :: k_wall_w_ji_p !< topography top index on w-grid 2138 INTEGER(iwp) :: k_wall_w_ji_m !< topography top index on w-grid 2139 INTEGER(iwp) :: kb !< 2140 INTEGER(iwp) :: lc !< 2141 INTEGER(iwp) :: ni !< 2142 INTEGER(iwp) :: nj !< 2143 INTEGER(iwp) :: nk !< 2144 INTEGER(iwp) :: nzt_topo_max !< 2145 INTEGER(iwp) :: wall_index !< Index of the wall-node coordinate 2146 2147 REAL(wp) :: z0_topo !< roughness at vertical walls 2148 REAL(wp), ALLOCATABLE, DIMENSION(:) :: lcr !< 2149 2150 ! 2151 !-- First determine the maximum k-index needed for the near-wall corrections. 2152 !-- This maximum is individual for each boundary to minimize the storage 2153 !-- requirements and to minimize the corresponding loop k-range in the 2154 !-- interpolation routines. 2155 nzt_topo_nestbc_l = nzb 2156 IF ( bc_dirichlet_l ) THEN 2157 DO i = nxl-1, nxl 2158 DO j = nys, nyn 2159 ! 2160 !-- Concept need to be reconsidered for 3D-topography 2161 !-- Determine largest topography index on scalar grid 2162 nzt_topo_nestbc_l = MAX( nzt_topo_nestbc_l, & 2163 get_topography_top_index_ji( j, i, 's' ) ) 2164 ! 2165 !-- Determine largest topography index on u grid 2166 nzt_topo_nestbc_l = MAX( nzt_topo_nestbc_l, & 2167 get_topography_top_index_ji( j, i, 'u' ) ) 2168 ! 2169 !-- Determine largest topography index on v grid 2170 nzt_topo_nestbc_l = MAX( nzt_topo_nestbc_l, & 2171 get_topography_top_index_ji( j, i, 'v' ) ) 2172 ! 2173 !-- Determine largest topography index on w grid 2174 nzt_topo_nestbc_l = MAX( nzt_topo_nestbc_l, & 2175 get_topography_top_index_ji( j, i, 'w' ) ) 2176 ENDDO 2177 ENDDO 2178 nzt_topo_nestbc_l = nzt_topo_nestbc_l + 1 2179 ENDIF 2180 2181 nzt_topo_nestbc_r = nzb 2182 IF ( bc_dirichlet_r ) THEN 2183 i = nxr + 1 2184 DO j = nys, nyn 2185 ! 2186 !-- Concept need to be reconsidered for 3D-topography 2187 !-- Determine largest topography index on scalar grid 2188 nzt_topo_nestbc_r = MAX( nzt_topo_nestbc_r, & 2189 get_topography_top_index_ji( j, i, 's' ) ) 2190 ! 2191 !-- Determine largest topography index on u grid 2192 nzt_topo_nestbc_r = MAX( nzt_topo_nestbc_r, & 2193 get_topography_top_index_ji( j, i, 'u' ) ) 2194 ! 2195 !-- Determine largest topography index on v grid 2196 nzt_topo_nestbc_r = MAX( nzt_topo_nestbc_r, & 2197 get_topography_top_index_ji( j, i, 'v' ) ) 2198 ! 2199 !-- Determine largest topography index on w grid 2200 nzt_topo_nestbc_r = MAX( nzt_topo_nestbc_r, & 2201 get_topography_top_index_ji( j, i, 'w' ) ) 2202 ENDDO 2203 nzt_topo_nestbc_r = nzt_topo_nestbc_r + 1 2204 ENDIF 2205 2206 nzt_topo_nestbc_s = nzb 2207 IF ( bc_dirichlet_s ) THEN 2208 DO j = nys-1, nys 2209 DO i = nxl, nxr 2210 ! 2211 !-- Concept need to be reconsidered for 3D-topography 2212 !-- Determine largest topography index on scalar grid 2213 nzt_topo_nestbc_s = MAX( nzt_topo_nestbc_s, & 2214 get_topography_top_index_ji( j, i, 's' ) ) 2215 ! 2216 !-- Determine largest topography index on u grid 2217 nzt_topo_nestbc_s = MAX( nzt_topo_nestbc_s, & 2218 get_topography_top_index_ji( j, i, 'u' ) ) 2219 ! 2220 !-- Determine largest topography index on v grid 2221 nzt_topo_nestbc_s = MAX( nzt_topo_nestbc_s, & 2222 get_topography_top_index_ji( j, i, 'v' ) ) 2223 ! 2224 !-- Determine largest topography index on w grid 2225 nzt_topo_nestbc_s = MAX( nzt_topo_nestbc_s, & 2226 get_topography_top_index_ji( j, i, 'w' ) ) 2227 ENDDO 2228 ENDDO 2229 nzt_topo_nestbc_s = nzt_topo_nestbc_s + 1 2230 ENDIF 2231 2232 nzt_topo_nestbc_n = nzb 2233 IF ( bc_dirichlet_n ) THEN 2234 j = nyn + 1 2235 DO i = nxl, nxr 2236 ! 2237 !-- Concept need to be reconsidered for 3D-topography 2238 !-- Determine largest topography index on scalar grid 2239 nzt_topo_nestbc_n = MAX( nzt_topo_nestbc_n, & 2240 get_topography_top_index_ji( j, i, 's' ) ) 2241 ! 2242 !-- Determine largest topography index on u grid 2243 nzt_topo_nestbc_n = MAX( nzt_topo_nestbc_n, & 2244 get_topography_top_index_ji( j, i, 'u' ) ) 2245 ! 2246 !-- Determine largest topography index on v grid 2247 nzt_topo_nestbc_n = MAX( nzt_topo_nestbc_n, & 2248 get_topography_top_index_ji( j, i, 'v' ) ) 2249 ! 2250 !-- Determine largest topography index on w grid 2251 nzt_topo_nestbc_n = MAX( nzt_topo_nestbc_n, & 2252 get_topography_top_index_ji( j, i, 'w' ) ) 2253 ENDDO 2254 nzt_topo_nestbc_n = nzt_topo_nestbc_n + 1 2255 ENDIF 2256 2257 #if defined( __parallel ) 2258 ! 2259 !-- Determine global topography-top index along child boundary. 2260 dum = nzb 2261 CALL MPI_ALLREDUCE( nzt_topo_nestbc_l, dum, 1, MPI_INTEGER, & 2262 MPI_MAX, comm1dy, ierr ) 2263 nzt_topo_nestbc_l = dum 2264 2265 dum = nzb 2266 CALL MPI_ALLREDUCE( nzt_topo_nestbc_r, dum, 1, MPI_INTEGER, & 2267 MPI_MAX, comm1dy, ierr ) 2268 nzt_topo_nestbc_r = dum 2269 2270 dum = nzb 2271 CALL MPI_ALLREDUCE( nzt_topo_nestbc_n, dum, 1, MPI_INTEGER, & 2272 MPI_MAX, comm1dx, ierr ) 2273 nzt_topo_nestbc_n = dum 2274 2275 dum = nzb 2276 CALL MPI_ALLREDUCE( nzt_topo_nestbc_s, dum, 1, MPI_INTEGER, & 2277 MPI_MAX, comm1dx, ierr ) 2278 nzt_topo_nestbc_s = dum 2279 #endif 2280 ! 2281 !-- Then determine the maximum number of near-wall nodes per wall point based 2282 !-- on the grid-spacing ratios. 2283 nzt_topo_max = MAX( nzt_topo_nestbc_l, nzt_topo_nestbc_r, & 2284 nzt_topo_nestbc_s, nzt_topo_nestbc_n ) 2285 ! 2286 !-- Note that the outer division must be integer division. 2287 ni = CEILING( cg%dx / dx ) / 2 2288 nj = CEILING( cg%dy / dy ) / 2 2289 nk = 1 2290 DO k = 1, nzt_topo_max 2291 nk = MAX( nk, CEILING( cg%dzu(kco(k)+1) / dzu(k) ) ) 2292 ENDDO 2293 nk = nk / 2 ! Note that this must be integer division. 2294 ncorr = MAX( ni, nj, nk ) 2295 2296 ALLOCATE( lcr(0:ncorr-1) ) 2297 lcr = 1.0_wp 2298 2299 z0_topo = roughness_length 2300 ! 2301 !-- First horizontal walls. Note that also logc_w_? and logc_ratio_w_? and 2302 !-- logc_kbounds_* need to be allocated and initialized here. 2303 !-- Left boundary 2304 IF ( bc_dirichlet_l ) THEN 2305 2306 ALLOCATE( logc_u_l(1:2,nzb:nzt_topo_nestbc_l,nys:nyn) ) 2307 ALLOCATE( logc_v_l(1:2,nzb:nzt_topo_nestbc_l,nys:nyn) ) 2308 ALLOCATE( logc_w_l(1:2,nzb:nzt_topo_nestbc_l,nys:nyn) ) 2309 ALLOCATE( logc_kbounds_u_l(1:2,nys:nyn) ) 2310 ALLOCATE( logc_kbounds_v_l(1:2,nys:nyn) ) 2311 ALLOCATE( logc_kbounds_w_l(1:2,nys:nyn) ) 2312 ALLOCATE( logc_ratio_u_l(1:2,0:ncorr-1,nzb:nzt_topo_nestbc_l,nys:nyn) ) 2313 ALLOCATE( logc_ratio_v_l(1:2,0:ncorr-1,nzb:nzt_topo_nestbc_l,nys:nyn) ) 2314 ALLOCATE( logc_ratio_w_l(1:2,0:ncorr-1,nzb:nzt_topo_nestbc_l,nys:nyn) ) 2315 logc_u_l = 0 2316 logc_v_l = 0 2317 logc_w_l = 0 2318 logc_ratio_u_l = 1.0_wp 2319 logc_ratio_v_l = 1.0_wp 2320 logc_ratio_w_l = 1.0_wp 2321 direction = 1 2322 inc = 1 2323 2324 DO j = nys, nyn 2325 ! 2326 !-- Left boundary for u 2327 i = 0 2328 ! 2329 !-- For loglaw correction the roughness z0 is required. z0, however, 2330 !-- is part of the surfacetypes now. Set default roughness instead. 2331 !-- Determine topography top index on u-grid 2332 kb = get_topography_top_index_ji( j, i, 'u' ) 2333 k = kb + 1 2334 wall_index = kb 2335 2336 CALL pmci_define_loglaw_correction_parameters( lc, lcr, k, & 2337 j, inc, wall_index, z0_topo, & 2338 kb, direction, ncorr ) 2339 2340 logc_u_l(1,k,j) = lc 2341 logc_ratio_u_l(1,0:ncorr-1,k,j) = lcr(0:ncorr-1) 2342 lcr(0:ncorr-1) = 1.0_wp 2343 ! 2344 !-- Left boundary for v 2345 i = -1 2346 ! 2347 !-- Determine topography top index on v-grid 2348 kb = get_topography_top_index_ji( j, i, 'v' ) 2349 k = kb + 1 2350 wall_index = kb 2351 2352 CALL pmci_define_loglaw_correction_parameters( lc, lcr, k, & 2353 j, inc, wall_index, z0_topo, & 2354 kb, direction, ncorr ) 2355 2356 logc_v_l(1,k,j) = lc 2357 logc_ratio_v_l(1,0:ncorr-1,k,j) = lcr(0:ncorr-1) 2358 lcr(0:ncorr-1) = 1.0_wp 2359 2360 ENDDO 2361 2362 ENDIF 2363 ! 2364 !-- Right boundary 2365 IF ( bc_dirichlet_r ) THEN 2366 2367 ALLOCATE( logc_u_r(1:2,nzb:nzt_topo_nestbc_r,nys:nyn) ) 2368 ALLOCATE( logc_v_r(1:2,nzb:nzt_topo_nestbc_r,nys:nyn) ) 2369 ALLOCATE( logc_w_r(1:2,nzb:nzt_topo_nestbc_r,nys:nyn) ) 2370 ALLOCATE( logc_kbounds_u_r(1:2,nys:nyn) ) 2371 ALLOCATE( logc_kbounds_v_r(1:2,nys:nyn) ) 2372 ALLOCATE( logc_kbounds_w_r(1:2,nys:nyn) ) 2373 ALLOCATE( logc_ratio_u_r(1:2,0:ncorr-1,nzb:nzt_topo_nestbc_r,nys:nyn) ) 2374 ALLOCATE( logc_ratio_v_r(1:2,0:ncorr-1,nzb:nzt_topo_nestbc_r,nys:nyn) ) 2375 ALLOCATE( logc_ratio_w_r(1:2,0:ncorr-1,nzb:nzt_topo_nestbc_r,nys:nyn) ) 2376 logc_u_r = 0 2377 logc_v_r = 0 2378 logc_w_r = 0 2379 logc_ratio_u_r = 1.0_wp 2380 logc_ratio_v_r = 1.0_wp 2381 logc_ratio_w_r = 1.0_wp 2382 direction = 1 2383 inc = 1 2384 2385 DO j = nys, nyn 2386 ! 2387 !-- Right boundary for u 2388 i = nxr + 1 2389 ! 2390 !-- For loglaw correction the roughness z0 is required. z0, however, 2391 !-- is part of the surfacetypes now, so call subroutine according 2392 !-- to the present surface tpye. 2393 !-- Determine topography top index on u-grid 2394 kb = get_topography_top_index_ji( j, i, 'u' ) 2395 k = kb + 1 2396 wall_index = kb 2397 2398 CALL pmci_define_loglaw_correction_parameters( lc, lcr, k, & 2399 j, inc, wall_index, z0_topo, & 2400 kb, direction, ncorr ) 2401 2402 logc_u_r(1,k,j) = lc 2403 logc_ratio_u_r(1,0:ncorr-1,k,j) = lcr(0:ncorr-1) 2404 lcr(0:ncorr-1) = 1.0_wp 2405 ! 2406 !-- Right boundary for v 2407 i = nxr + 1 2408 ! 2409 !-- Determine topography top index on v-grid 2410 kb = get_topography_top_index_ji( j, i, 'v' ) 2411 k = kb + 1 2412 wall_index = kb 2413 2414 CALL pmci_define_loglaw_correction_parameters( lc, lcr, k, & 2415 j, inc, wall_index, z0_topo, & 2416 kb, direction, ncorr ) 2417 2418 logc_v_r(1,k,j) = lc 2419 logc_ratio_v_r(1,0:ncorr-1,k,j) = lcr(0:ncorr-1) 2420 lcr(0:ncorr-1) = 1.0_wp 2421 2422 ENDDO 2423 2424 ENDIF 2425 ! 2426 !-- South boundary 2427 IF ( bc_dirichlet_s ) THEN 2428 2429 ALLOCATE( logc_u_s(1:2,nzb:nzt_topo_nestbc_s,nxl:nxr) ) 2430 ALLOCATE( logc_v_s(1:2,nzb:nzt_topo_nestbc_s,nxl:nxr) ) 2431 ALLOCATE( logc_w_s(1:2,nzb:nzt_topo_nestbc_s,nxl:nxr) ) 2432 ALLOCATE( logc_kbounds_u_s(1:2,nxl:nxr) ) 2433 ALLOCATE( logc_kbounds_v_s(1:2,nxl:nxr) ) 2434 ALLOCATE( logc_kbounds_w_s(1:2,nxl:nxr) ) 2435 ALLOCATE( logc_ratio_u_s(1:2,0:ncorr-1,nzb:nzt_topo_nestbc_s,nxl:nxr) ) 2436 ALLOCATE( logc_ratio_v_s(1:2,0:ncorr-1,nzb:nzt_topo_nestbc_s,nxl:nxr) ) 2437 ALLOCATE( logc_ratio_w_s(1:2,0:ncorr-1,nzb:nzt_topo_nestbc_s,nxl:nxr) ) 2438 logc_u_s = 0 2439 logc_v_s = 0 2440 logc_w_s = 0 2441 logc_ratio_u_s = 1.0_wp 2442 logc_ratio_v_s = 1.0_wp 2443 logc_ratio_w_s = 1.0_wp 2444 direction = 1 2445 inc = 1 2446 2447 DO i = nxl, nxr 2448 ! 2449 !-- South boundary for u 2450 j = -1 2451 ! 2452 !-- Determine topography top index on u-grid 2453 kb = get_topography_top_index_ji( j, i, 'u' ) 2454 k = kb + 1 2455 wall_index = kb 2456 2457 CALL pmci_define_loglaw_correction_parameters( lc, lcr, k, & 2458 j, inc, wall_index, z0_topo, & 2459 kb, direction, ncorr ) 2460 2461 logc_u_s(1,k,i) = lc 2462 logc_ratio_u_s(1,0:ncorr-1,k,i) = lcr(0:ncorr-1) 2463 lcr(0:ncorr-1) = 1.0_wp 2464 ! 2465 !-- South boundary for v 2466 j = 0 2467 ! 2468 !-- Determine topography top index on v-grid 2469 kb = get_topography_top_index_ji( j, i, 'v' ) 2470 k = kb + 1 2471 wall_index = kb 2472 2473 CALL pmci_define_loglaw_correction_parameters( lc, lcr, k, & 2474 j, inc, wall_index, z0_topo, & 2475 kb, direction, ncorr ) 2476 2477 logc_v_s(1,k,i) = lc 2478 logc_ratio_v_s(1,0:ncorr-1,k,i) = lcr(0:ncorr-1) 2479 lcr(0:ncorr-1) = 1.0_wp 2480 2481 ENDDO 2482 2483 ENDIF 2484 ! 2485 !-- North boundary 2486 IF ( bc_dirichlet_n ) THEN 2487 2488 ALLOCATE( logc_u_n(1:2,nzb:nzt_topo_nestbc_n,nxl:nxr) ) 2489 ALLOCATE( logc_v_n(1:2,nzb:nzt_topo_nestbc_n,nxl:nxr) ) 2490 ALLOCATE( logc_w_n(1:2,nzb:nzt_topo_nestbc_n,nxl:nxr) ) 2491 ALLOCATE( logc_kbounds_u_n(1:2,nxl:nxr) ) 2492 ALLOCATE( logc_kbounds_v_n(1:2,nxl:nxr) ) 2493 ALLOCATE( logc_kbounds_w_n(1:2,nxl:nxr) ) 2494 ALLOCATE( logc_ratio_u_n(1:2,0:ncorr-1,nzb:nzt_topo_nestbc_n,nxl:nxr) ) 2495 ALLOCATE( logc_ratio_v_n(1:2,0:ncorr-1,nzb:nzt_topo_nestbc_n,nxl:nxr) ) 2496 ALLOCATE( logc_ratio_w_n(1:2,0:ncorr-1,nzb:nzt_topo_nestbc_n,nxl:nxr) ) 2497 logc_u_n = 0 2498 logc_v_n = 0 2499 logc_w_n = 0 2500 logc_ratio_u_n = 1.0_wp 2501 logc_ratio_v_n = 1.0_wp 2502 logc_ratio_w_n = 1.0_wp 2503 direction = 1 2504 inc = 1 2505 2506 DO i = nxl, nxr 2507 ! 2508 !-- North boundary for u 2509 j = nyn + 1 2510 ! 2511 !-- Determine topography top index on u-grid 2512 kb = get_topography_top_index_ji( j, i, 'u' ) 2513 k = kb + 1 2514 wall_index = kb 2515 2516 CALL pmci_define_loglaw_correction_parameters( lc, lcr, k, & 2517 j, inc, wall_index, z0_topo, & 2518 kb, direction, ncorr ) 2519 2520 logc_u_n(1,k,i) = lc 2521 logc_ratio_u_n(1,0:ncorr-1,k,i) = lcr(0:ncorr-1) 2522 lcr(0:ncorr-1) = 1.0_wp 2523 ! 2524 !-- North boundary for v 2525 j = nyn + 1 2526 ! 2527 !-- Determine topography top index on v-grid 2528 kb = get_topography_top_index_ji( j, i, 'v' ) 2529 k = kb + 1 2530 wall_index = kb 2531 2532 CALL pmci_define_loglaw_correction_parameters( lc, lcr, k, & 2533 j, inc, wall_index, z0_topo, & 2534 kb, direction, ncorr ) 2535 logc_v_n(1,k,i) = lc 2536 logc_ratio_v_n(1,0:ncorr-1,k,i) = lcr(0:ncorr-1) 2537 lcr(0:ncorr-1) = 1.0_wp 2538 2539 ENDDO 2540 2541 ENDIF 2542 ! 2543 !-- Then vertical walls and corners if necessary 2544 IF ( topography /= 'flat' ) THEN 2545 ! 2546 !-- Workaround, set z0 at vertical surfaces simply to the given roughness 2547 !-- lenth, which is required to determine the logarithmic correction 2548 !-- factors at the child boundaries, which are at the ghost-points. 2549 !-- The surface data type for vertical surfaces, however, is not defined 2550 !-- at ghost-points, so that no z0 can be retrieved at this point. 2551 !-- Maybe, revise this later and define vertical surface datattype also 2552 !-- at ghost-points. 2553 z0_topo = roughness_length 2554 2555 kb = 0 ! kb is not used when direction > 1 2556 ! 2557 !-- Left boundary 2558 IF ( bc_dirichlet_l ) THEN 2559 logc_kbounds_u_l(1:2,nys:nyn) = 0 2560 logc_kbounds_v_l(1:2,nys:nyn) = 0 2561 logc_kbounds_w_l(1:2,nys:nyn) = 0 2562 2563 direction = 2 2564 2565 DO j = nys, nyn 2566 ! 2567 !-- Determine the lowest k-indices for u at j,i, j+1,i and j-1,i. 2568 i = 0 2569 k_wall_u_ji = get_topography_top_index_ji( j, i, 'u' ) 2570 k_wall_u_ji_p = get_topography_top_index_ji( j+1, i, 'u' ) 2571 k_wall_u_ji_m = get_topography_top_index_ji( j-1, i, 'u' ) 2572 ! 2573 !-- Wall for u on the south side. 2574 IF ( ( k_wall_u_ji < k_wall_u_ji_m ) .AND. & 2575 ( k_wall_u_ji >= k_wall_u_ji_p ) ) THEN 2576 inc = 1 2577 wall_index = j 2578 ! 2579 !-- Store the kbounds for use in pmci_interp_tril_lr. 2580 logc_kbounds_u_l(1,j) = k_wall_u_ji + 1 2581 logc_kbounds_u_l(2,j) = k_wall_u_ji_m 2582 DO k = logc_kbounds_u_l(1,j), logc_kbounds_u_l(2,j) 2583 CALL pmci_define_loglaw_correction_parameters( lc, lcr, & 2584 k, j, inc, wall_index, z0_topo, kb, direction, & 2585 ncorr ) 2586 IF ( lc == -99 ) THEN 2587 ! 2588 !-- The pivot point is out of subdomain, skip the correction. 2589 logc_u_l(2,k,j) = 0 2590 logc_ratio_u_l(2,0:ncorr-1,k,j) = 1.0_wp 2591 ELSE 2592 ! 2593 !-- The direction of the wall-normal index is stored as the 2594 !-- sign of the logc-element. 2595 logc_u_l(2,k,j) = inc * lc 2596 logc_ratio_u_l(2,0:ncorr-1,k,j) = lcr(0:ncorr-1) 2597 ENDIF 2598 lcr(0:ncorr-1) = 1.0_wp 2599 ENDDO 2600 ENDIF 2601 ! 2602 !-- Wall for u on the north side. 2603 IF ( ( k_wall_u_ji < k_wall_u_ji_p ) .AND. & 2604 ( k_wall_u_ji >= k_wall_u_ji_m ) ) THEN 2605 inc = -1 2606 wall_index = j + 1 2607 ! 2608 !-- Store the kbounds for use in pmci_interp_tril_lr. 2609 logc_kbounds_u_l(1,j) = k_wall_u_ji + 1 2610 logc_kbounds_u_l(2,j) = k_wall_u_ji_p 2611 DO k = logc_kbounds_u_l(1,j), logc_kbounds_u_l(2,j) 2612 CALL pmci_define_loglaw_correction_parameters( lc, lcr, & 2613 k, j, inc, wall_index, z0_topo, kb, direction, & 2614 ncorr ) 2615 IF ( lc == -99 ) THEN 2616 ! 2617 !-- The pivot point is out of subdomain, skip the correction. 2618 logc_u_l(2,k,j) = 0 2619 logc_ratio_u_l(2,0:ncorr-1,k,j) = 1.0_wp 2620 ELSE 2621 ! 2622 !-- The direction of the wall-normal index is stored as the 2623 !-- sign of the logc-element. 2624 logc_u_l(2,k,j) = inc * lc 2625 logc_ratio_u_l(2,0:ncorr-1,k,j) = lcr(0:ncorr-1) 2626 ENDIF 2627 lcr(0:ncorr-1) = 1.0_wp 2628 ENDDO 2629 ENDIF 2630 ! 2631 !-- Determine the lowest k-indices for w at j,i, j+1,i and j-1,i. 2632 i = -1 2633 k_wall_w_ji = get_topography_top_index_ji( j, i, 'w' ) 2634 k_wall_w_ji_p = get_topography_top_index_ji( j+1, i, 'w' ) 2635 k_wall_w_ji_m = get_topography_top_index_ji( j-1, i, 'w' ) 2636 ! 2637 !-- Wall for w on the south side. 2638 IF ( ( k_wall_w_ji < k_wall_w_ji_m ) .AND. & 2639 ( k_wall_w_ji >= k_wall_w_ji_p ) ) THEN 2640 inc = 1 2641 wall_index = j 2642 ! 2643 !-- Store the kbounds for use in pmci_interp_tril_lr. 2644 logc_kbounds_w_l(1,j) = k_wall_w_ji + 1 2645 logc_kbounds_w_l(2,j) = k_wall_w_ji_m 2646 DO k = logc_kbounds_w_l(1,j), logc_kbounds_w_l(2,j) 2647 CALL pmci_define_loglaw_correction_parameters( lc, lcr, & 2648 k, j, inc, wall_index, z0_topo, kb, direction, & 2649 ncorr ) 2650 IF ( lc == -99 ) THEN 2651 ! 2652 !-- The pivot point is out of subdomain, skip the correction. 2653 logc_w_l(2,k,j) = 0 2654 logc_ratio_w_l(2,0:ncorr-1,k,j) = 1.0_wp 2655 ELSE 2656 ! 2657 !-- The direction of the wall-normal index is stored as the 2658 !-- sign of the logc-element. 2659 logc_w_l(2,k,j) = inc * lc 2660 logc_ratio_w_l(2,0:ncorr-1,k,j) = lcr(0:ncorr-1) 2661 ENDIF 2662 lcr(0:ncorr-1) = 1.0_wp 2663 ENDDO 2664 ENDIF 2665 ! 2666 !-- Wall for w on the north side. 2667 IF ( ( k_wall_w_ji < k_wall_w_ji_p ) .AND. & 2668 ( k_wall_w_ji >= k_wall_w_ji_m ) ) THEN 2669 inc = -1 2670 wall_index = j+1 2671 ! 2672 !-- Store the kbounds for use in pmci_interp_tril_lr. 2673 logc_kbounds_w_l(1,j) = k_wall_w_ji + 1 2674 logc_kbounds_w_l(2,j) = k_wall_w_ji_p 2675 DO k = logc_kbounds_w_l(1,j), logc_kbounds_w_l(2,j) 2676 CALL pmci_define_loglaw_correction_parameters( lc, lcr, & 2677 k, j, inc, wall_index, z0_topo, kb, direction, & 2678 ncorr ) 2679 IF ( lc == -99 ) THEN 2680 ! 2681 !-- The pivot point is out of subdomain, skip the correction. 2682 logc_w_l(2,k,j) = 0 2683 logc_ratio_w_l(2,0:ncorr-1,k,j) = 1.0_wp 2684 ELSE 2685 ! 2686 !-- The direction of the wall-normal index is stored as the 2687 !-- sign of the logc-element. 2688 logc_w_l(2,k,j) = inc * lc 2689 logc_ratio_w_l(2,0:ncorr-1,k,j) = lcr(0:ncorr-1) 2690 ENDIF 2691 lcr(0:ncorr-1) = 1.0_wp 2692 ENDDO 2693 ENDIF 2694 2695 ENDDO 2696 2697 ENDIF ! IF ( bc_dirichlet_l ) 2698 ! 2699 !-- Right boundary 2700 IF ( bc_dirichlet_r ) THEN 2701 logc_kbounds_u_r(1:2,nys:nyn) = 0 2702 logc_kbounds_v_r(1:2,nys:nyn) = 0 2703 logc_kbounds_w_r(1:2,nys:nyn) = 0 2704 2705 direction = 2 2706 i = nx + 1 2707 2708 DO j = nys, nyn 2709 ! 2710 !-- Determine the lowest k-indices for u at j,i, j+1,i and j-1,i. 2711 k_wall_u_ji = get_topography_top_index_ji( j, i, 'u' ) 2712 k_wall_u_ji_p = get_topography_top_index_ji( j+1, i, 'u' ) 2713 k_wall_u_ji_m = get_topography_top_index_ji( j-1, i, 'u' ) 2714 ! 2715 !-- Wall for u on the south side. 2716 IF ( ( k_wall_u_ji < k_wall_u_ji_m ) .AND. & 2717 ( k_wall_u_ji >= k_wall_u_ji_p ) ) THEN 2718 inc = 1 2719 wall_index = j 2720 ! 2721 !-- Store the kbounds for use in pmci_interp_tril_lr. 2722 logc_kbounds_u_r(1,j) = k_wall_u_ji + 1 2723 logc_kbounds_u_r(2,j) = k_wall_u_ji_m 2724 DO k = logc_kbounds_u_r(1,j), logc_kbounds_u_r(2,j) 2725 CALL pmci_define_loglaw_correction_parameters( lc, lcr, & 2726 k, j, inc, wall_index, z0_topo, kb, direction, ncorr ) 2727 IF ( lc == -99 ) THEN 2728 ! 2729 !-- The pivot point is out of subdomain, skip the correction. 2730 logc_u_r(2,k,j) = 0 2731 logc_ratio_u_r(2,0:ncorr-1,k,j) = 1.0_wp 2732 ELSE 2733 ! 2734 !-- The direction of the wall-normal index is stored as the 2735 !-- sign of the logc-element. 2736 logc_u_r(2,k,j) = inc * lc 2737 logc_ratio_u_r(2,0:ncorr-1,k,j) = lcr(0:ncorr-1) 2738 ENDIF 2739 lcr(0:ncorr-1) = 1.0_wp 2740 ENDDO 2741 ENDIF 2742 ! 2743 !-- Wall for u on the south side. 2744 IF ( ( k_wall_u_ji < k_wall_u_ji_p ) .AND. & 2745 ( k_wall_u_ji >= k_wall_u_ji_m ) ) THEN 2746 inc = -1 2747 wall_index = j + 1 2748 ! 2749 !-- Store the kbounds for use in pmci_interp_tril_lr. 2750 logc_kbounds_u_r(1,j) = k_wall_u_ji + 1 2751 logc_kbounds_u_r(2,j) = k_wall_u_ji_p 2752 DO k = logc_kbounds_u_r(1,j), logc_kbounds_u_r(2,j) 2753 CALL pmci_define_loglaw_correction_parameters( lc, lcr, & 2754 k, j, inc, wall_index, z0_topo, kb, direction, & 2755 ncorr ) 2756 IF ( lc == -99 ) THEN 2757 ! 2758 !-- The pivot point is out of subdomain, skip the correction. 2759 logc_u_r(2,k,j) = 0 2760 logc_ratio_u_r(2,0:ncorr-1,k,j) = 1.0_wp 2761 ELSE 2762 ! 2763 !-- The direction of the wall-normal index is stored as the 2764 !-- sign of the logc-element. 2765 logc_u_r(2,k,j) = inc * lc 2766 logc_ratio_u_r(2,0:ncorr-1,k,j) = lcr(0:ncorr-1) 2767 ENDIF 2768 lcr(0:ncorr-1) = 1.0_wp 2769 ENDDO 2770 ENDIF 2771 ! 2772 !-- Determine the lowest k-indices for w at j,i, j+1,i and j-1,i. 2773 k_wall_w_ji = get_topography_top_index_ji( j, i, 'w' ) 2774 k_wall_w_ji_p = get_topography_top_index_ji( j+1, i, 'w' ) 2775 k_wall_w_ji_m = get_topography_top_index_ji( j-1, i, 'w' ) 2776 ! 2777 !-- Wall for w on the south side. 2778 IF ( ( k_wall_w_ji < k_wall_w_ji_m ) .AND. & 2779 ( k_wall_w_ji >= k_wall_w_ji_p ) ) THEN 2780 inc = 1 2781 wall_index = j 2782 ! 2783 !-- Store the kbounds for use in pmci_interp_tril_lr. 2784 logc_kbounds_w_r(1,j) = k_wall_w_ji + 1 2785 logc_kbounds_w_r(2,j) = k_wall_w_ji_m 2786 DO k = logc_kbounds_w_r(1,j), logc_kbounds_w_r(2,j) 2787 CALL pmci_define_loglaw_correction_parameters( lc, lcr, & 2788 k, j, inc, wall_index, z0_topo, kb, direction, & 2789 ncorr ) 2790 IF ( lc == -99 ) THEN 2791 ! 2792 !-- The pivot point is out of subdomain, skip the correction. 2793 logc_w_r(2,k,j) = 0 2794 logc_ratio_w_r(2,0:ncorr-1,k,j) = 1.0_wp 2795 ELSE 2796 ! 2797 !-- The direction of the wall-normal index is stored as the 2798 !-- sign of the logc-element. 2799 logc_w_r(2,k,j) = inc * lc 2800 logc_ratio_w_r(2,0:ncorr-1,k,j) = lcr(0:ncorr-1) 2801 ENDIF 2802 lcr(0:ncorr-1) = 1.0_wp 2803 ENDDO 2804 ENDIF 2805 ! 2806 !-- Wall for w on the north side. 2807 IF ( ( k_wall_w_ji < k_wall_w_ji_p ) .AND. & 2808 ( k_wall_w_ji >= k_wall_w_ji_m ) ) THEN 2809 inc = -1 2810 wall_index = j+1 2811 ! 2812 !-- Store the kbounds for use in pmci_interp_tril_lr. 2813 logc_kbounds_w_r(1,j) = k_wall_w_ji + 1 2814 logc_kbounds_w_r(2,j) = k_wall_w_ji_p 2815 DO k = logc_kbounds_w_r(1,j), logc_kbounds_w_r(2,j) 2816 CALL pmci_define_loglaw_correction_parameters( lc, lcr, & 2817 k, j, inc, wall_index, z0_topo, kb, direction, & 2818 ncorr ) 2819 IF ( lc == -99 ) THEN 2820 ! 2821 !-- The pivot point is out of subdomain, skip the correction. 2822 logc_w_r(2,k,j) = 0 2823 logc_ratio_w_r(2,0:ncorr-1,k,j) = 1.0_wp 2824 ELSE 2825 ! 2826 !-- The direction of the wall-normal index is stored as the 2827 !-- sign of the logc-element. 2828 logc_w_r(2,k,j) = inc * lc 2829 logc_ratio_w_r(2,0:ncorr-1,k,j) = lcr(0:ncorr-1) 2830 ENDIF 2831 lcr(0:ncorr-1) = 1.0_wp 2832 ENDDO 2833 ENDIF 2834 2835 ENDDO 2836 2837 ENDIF ! IF ( bc_dirichlet_r ) 2838 ! 2839 !-- South boundary 2840 IF ( bc_dirichlet_s ) THEN 2841 logc_kbounds_u_s(1:2,nxl:nxr) = 0 2842 logc_kbounds_v_s(1:2,nxl:nxr) = 0 2843 logc_kbounds_w_s(1:2,nxl:nxr) = 0 2844 2845 direction = 3 2846 2847 DO i = nxl, nxr 2848 ! 2849 !-- Determine the lowest k-indices for v at j,i, j,i+1 and j,i-1. 2850 j = 0 2851 k_wall_v_ji = get_topography_top_index_ji( j, i, 'v' ) 2852 k_wall_v_ji_p = get_topography_top_index_ji( j, i+1, 'v' ) 2853 k_wall_v_ji_m = get_topography_top_index_ji( j, i-1, 'v' ) 2854 ! 2855 !-- Wall for v on the left side. 2856 IF ( ( k_wall_v_ji < k_wall_v_ji_m ) .AND. & 2857 ( k_wall_v_ji >= k_wall_v_ji_p ) ) THEN 2858 inc = 1 2859 wall_index = i 2860 ! 2861 !-- Store the kbounds for use in pmci_interp_tril_sn. 2862 logc_kbounds_v_s(1,i) = k_wall_v_ji + 1 2863 logc_kbounds_v_s(2,i) = k_wall_v_ji_m 2864 DO k = logc_kbounds_v_s(1,i), logc_kbounds_v_s(2,i) 2865 CALL pmci_define_loglaw_correction_parameters( lc, lcr, & 2866 k, i, inc, wall_index, z0_topo, kb, direction, & 2867 ncorr ) 2868 IF ( lc == -99 ) THEN 2869 ! 2870 !-- The pivot point is out of subdomain, skip the correction. 2871 logc_v_s(2,k,i) = 0 2872 logc_ratio_v_s(2,0:ncorr-1,k,i) = 1.0_wp 2873 ELSE 2874 ! 2875 !-- The direction of the wall-normal index is stored as the 2876 !-- sign of the logc-element. 2877 logc_v_s(2,k,i) = inc * lc 2878 logc_ratio_v_s(2,0:ncorr-1,k,i) = lcr(0:ncorr-1) 2879 ENDIF 2880 lcr(0:ncorr-1) = 1.0_wp 2881 ENDDO 2882 ENDIF 2883 ! 2884 !-- Wall for v on the right side. 2885 IF ( ( k_wall_v_ji < k_wall_v_ji_p ) .AND. & 2886 ( k_wall_v_ji >= k_wall_v_ji_m ) ) THEN 2887 inc = -1 2888 wall_index = i+1 2889 ! 2890 !-- Store the kbounds for use in pmci_interp_tril_sn. 2891 logc_kbounds_v_s(1,i) = k_wall_v_ji + 1 2892 logc_kbounds_v_s(2,i) = k_wall_v_ji_p 2893 DO k = logc_kbounds_v_s(1,i), logc_kbounds_v_s(2,i) 2894 CALL pmci_define_loglaw_correction_parameters( lc, lcr, & 2895 k, i, inc, wall_index, z0_topo, kb, direction, & 2896 ncorr ) 2897 IF ( lc == -99 ) THEN 2898 ! 2899 !-- The pivot point is out of subdomain, skip the correction. 2900 logc_v_s(2,k,i) = 0 2901 logc_ratio_v_s(2,0:ncorr-1,k,i) = 1.0_wp 2902 ELSE 2903 ! 2904 !-- The direction of the wall-normal index is stored as the 2905 !-- sign of the logc-element. 2906 logc_v_s(2,k,i) = inc * lc 2907 logc_ratio_v_s(2,0:ncorr-1,k,i) = lcr(0:ncorr-1) 2908 ENDIF 2909 lcr(0:ncorr-1) = 1.0_wp 2910 ENDDO 2911 ENDIF 2912 ! 2913 !-- Determine the lowest k-indices for w at j,i, j,i+1 and j,i-1. 2914 j = -1 2915 k_wall_w_ji = get_topography_top_index_ji( j, i, 'w' ) 2916 k_wall_w_ji_p = get_topography_top_index_ji( j, i+1, 'w' ) 2917 k_wall_w_ji_m = get_topography_top_index_ji( j, i-1, 'w' ) 2918 ! 2919 !-- Wall for w on the left side. 2920 IF ( ( k_wall_w_ji < k_wall_w_ji_m ) .AND. & 2921 ( k_wall_w_ji >= k_wall_w_ji_p ) ) THEN 2922 inc = 1 2923 wall_index = i 2924 ! 2925 !-- Store the kbounds for use in pmci_interp_tril_sn. 2926 logc_kbounds_w_s(1,i) = k_wall_w_ji + 1 2927 logc_kbounds_w_s(2,i) = k_wall_w_ji_m 2928 DO k = logc_kbounds_w_s(1,i), logc_kbounds_w_s(2,i) 2929 CALL pmci_define_loglaw_correction_parameters( lc, lcr, & 2930 k, i, inc, wall_index, z0_topo, kb, direction, & 2931 ncorr ) 2932 IF ( lc == -99 ) THEN 2933 ! 2934 !-- The pivot point is out of subdomain, skip the correction. 2935 logc_w_s(2,k,i) = 0 2936 logc_ratio_w_s(2,0:ncorr-1,k,i) = 1.0_wp 2937 ELSE 2938 ! 2939 !-- The direction of the wall-normal index is stored as the 2940 !-- sign of the logc-element. 2941 logc_w_s(2,k,i) = inc * lc 2942 logc_ratio_w_s(2,0:ncorr-1,k,i) = lcr(0:ncorr-1) 2943 ENDIF 2944 lcr(0:ncorr-1) = 1.0_wp 2945 ENDDO 2946 ENDIF 2947 ! 2948 !-- Wall for w on the right side. 2949 IF ( ( k_wall_w_ji < k_wall_w_ji_p ) .AND. & 2950 ( k_wall_w_ji >= k_wall_w_ji_m ) ) THEN 2951 inc = -1 2952 wall_index = i+1 2953 ! 2954 !-- Store the kbounds for use in pmci_interp_tril_sn. 2955 logc_kbounds_w_s(1,i) = k_wall_w_ji + 1 2956 logc_kbounds_w_s(2,i) = k_wall_w_ji_p 2957 DO k = logc_kbounds_w_s(1,i), logc_kbounds_w_s(2,i) 2958 CALL pmci_define_loglaw_correction_parameters( lc, lcr, & 2959 k, i, inc, wall_index, z0_topo, kb, direction, & 2960 ncorr ) 2961 IF ( lc == -99 ) THEN 2962 ! 2963 !-- The pivot point is out of subdomain, skip the correction. 2964 logc_w_s(2,k,i) = 0 2965 logc_ratio_w_s(2,0:ncorr-1,k,i) = 1.0_wp 2966 ELSE 2967 ! 2968 !-- The direction of the wall-normal index is stored as the 2969 !-- sign of the logc-element. 2970 logc_w_s(2,k,i) = inc * lc 2971 logc_ratio_w_s(2,0:ncorr-1,k,i) = lcr(0:ncorr-1) 2972 ENDIF 2973 lcr(0:ncorr-1) = 1.0_wp 2974 ENDDO 2975 ENDIF 2976 2977 ENDDO 2978 2979 ENDIF ! IF (bc_dirichlet_s ) 2980 ! 2981 !-- North boundary 2982 IF ( bc_dirichlet_n ) THEN 2983 logc_kbounds_u_n(1:2,nxl:nxr) = 0 2984 logc_kbounds_v_n(1:2,nxl:nxr) = 0 2985 logc_kbounds_w_n(1:2,nxl:nxr) = 0 2986 2987 direction = 3 2988 j = ny + 1 2989 2990 DO i = nxl, nxr 2991 ! 2992 !-- Determine the lowest k-indices for v at j,i, j,i+1 and j,i-1 2993 k_wall_v_ji = get_topography_top_index_ji( j, i, 'v' ) 2994 k_wall_v_ji_p = get_topography_top_index_ji( j, i+1, 'v' ) 2995 k_wall_v_ji_m = get_topography_top_index_ji( j, i-1, 'v' ) 2996 ! 2997 !-- Wall for v on the left side. 2998 IF ( ( k_wall_v_ji < k_wall_v_ji_m ) .AND. & 2999 ( k_wall_v_ji >= k_wall_v_ji_p ) ) THEN 3000 inc = 1 3001 wall_index = i 3002 ! 3003 !-- Store the kbounds for use in pmci_interp_tril_sn. 3004 logc_kbounds_v_n(1,i) = k_wall_v_ji + 1 3005 logc_kbounds_v_n(2,i) = k_wall_v_ji_m 3006 DO k = logc_kbounds_v_n(1,i), logc_kbounds_v_n(2,i) 3007 CALL pmci_define_loglaw_correction_parameters( lc, lcr, & 3008 k, i, inc, wall_index, z0_topo, kb, direction, & 3009 ncorr ) 3010 IF ( lc == -99 ) THEN 3011 ! 3012 !-- The pivot point is out of subdomain, skip the correction. 3013 logc_v_n(2,k,i) = 0 3014 logc_ratio_v_n(2,0:ncorr-1,k,i) = 1.0_wp 3015 ELSE 3016 ! 3017 !-- The direction of the wall-normal index is stored as the 3018 !-- sign of the logc-element. 3019 logc_v_n(2,k,i) = inc * lc 3020 logc_ratio_v_n(2,0:ncorr-1,k,i) = lcr(0:ncorr-1) 3021 ENDIF 3022 lcr(0:ncorr-1) = 1.0_wp 3023 ENDDO 3024 ENDIF 3025 ! 3026 !-- Wall for v on the right side. 3027 IF ( ( k_wall_v_ji < k_wall_v_ji_p ) .AND. & 3028 ( k_wall_v_ji >= k_wall_v_ji_m ) ) THEN 3029 inc = -1 3030 wall_index = i + 1 3031 ! 3032 !-- Store the kbounds for use in pmci_interp_tril_sn. 3033 logc_kbounds_v_n(1,i) = k_wall_v_ji + 1 3034 logc_kbounds_v_n(2,i) = k_wall_v_ji_p 3035 DO k = logc_kbounds_v_n(1,i), logc_kbounds_v_n(2,i) 3036 CALL pmci_define_loglaw_correction_parameters( lc, lcr, & 3037 k, i, inc, wall_index, z0_topo, kb, direction, & 3038 ncorr ) 3039 IF ( lc == -99 ) THEN 3040 ! 3041 !-- The pivot point is out of subdomain, skip the correction. 3042 logc_v_n(2,k,i) = 0 3043 logc_ratio_v_n(2,0:ncorr-1,k,i) = 1.0_wp 3044 ELSE 3045 ! 3046 !-- The direction of the wall-normal index is stored as the 3047 !-- sign of the logc-element. 3048 logc_v_n(2,k,i) = inc * lc 3049 logc_ratio_v_n(2,0:ncorr-1,k,i) = lcr(0:ncorr-1) 3050 ENDIF 3051 lcr(0:ncorr-1) = 1.0_wp 3052 ENDDO 3053 ENDIF 3054 ! 3055 !-- Determine the lowest k-indices for w at j,i, j,i+1 and j,i-1. 3056 k_wall_w_ji = get_topography_top_index_ji( j, i, 'w' ) 3057 k_wall_w_ji_p = get_topography_top_index_ji( j, i+1, 'w' ) 3058 k_wall_w_ji_m = get_topography_top_index_ji( j, i-1, 'w' ) 3059 ! 3060 !-- Wall for w on the left side. 3061 IF ( ( k_wall_w_ji < k_wall_w_ji_m ) .AND. & 3062 ( k_wall_w_ji >= k_wall_w_ji_p ) ) THEN 3063 inc = 1 3064 wall_index = i 3065 ! 3066 !-- Store the kbounds for use in pmci_interp_tril_sn. 3067 logc_kbounds_w_n(1,i) = k_wall_w_ji + 1 3068 logc_kbounds_w_n(2,i) = k_wall_w_ji_m 3069 DO k = logc_kbounds_w_n(1,i), logc_kbounds_w_n(2,i) 3070 CALL pmci_define_loglaw_correction_parameters( lc, lcr, & 3071 k, i, inc, wall_index, z0_topo, kb, direction, & 3072 ncorr ) 3073 IF ( lc == -99 ) THEN 3074 ! 3075 !-- The pivot point is out of subdomain, skip the correction. 3076 logc_w_n(2,k,i) = 0 3077 logc_ratio_w_n(2,0:ncorr-1,k,i) = 1.0_wp 3078 ELSE 3079 ! 3080 !-- The direction of the wall-normal index is stored as the 3081 !-- sign of the logc-element. 3082 logc_w_n(2,k,i) = inc * lc 3083 logc_ratio_w_n(2,0:ncorr-1,k,i) = lcr(0:ncorr-1) 3084 ENDIF 3085 lcr(0:ncorr-1) = 1.0_wp 3086 ENDDO 3087 ENDIF 3088 ! 3089 !-- Wall for w on the right side, but not on the left side 3090 IF ( ( k_wall_w_ji < k_wall_w_ji_p ) .AND. & 3091 ( k_wall_w_ji >= k_wall_w_ji_m ) ) THEN 3092 inc = -1 3093 wall_index = i+1 3094 ! 3095 !-- Store the kbounds for use in pmci_interp_tril_sn. 3096 logc_kbounds_w_n(1,i) = k_wall_w_ji + 1 3097 logc_kbounds_w_n(2,i) = k_wall_w_ji_p 3098 DO k = logc_kbounds_w_n(1,i), logc_kbounds_w_n(2,i) 3099 CALL pmci_define_loglaw_correction_parameters( lc, lcr, & 3100 k, i, inc, wall_index, z0_topo, kb, direction, & 3101 ncorr ) 3102 IF ( lc == -99 ) THEN 3103 ! 3104 !-- The pivot point is out of subdomain, skip the correction. 3105 logc_w_n(2,k,i) = 0 3106 logc_ratio_w_n(2,0:ncorr-1,k,i) = 1.0_wp 3107 ELSE 3108 ! 3109 !-- The direction of the wall-normal index is stored as the 3110 !-- sign of the logc-element. 3111 logc_w_n(2,k,i) = inc * lc 3112 logc_ratio_w_n(2,0:ncorr-1,k,i) = lcr(0:ncorr-1) 3113 ENDIF 3114 lcr(0:ncorr-1) = 1.0_wp 3115 ENDDO 3116 ENDIF 3117 3118 ENDDO 3119 3120 ENDIF ! IF ( bc_dirichlet_n ) 3121 3122 ENDIF ! IF ( topography /= 'flat' ) 3123 3124 END SUBROUTINE pmci_init_loglaw_correction 3125 3126 3127 3128 SUBROUTINE pmci_define_loglaw_correction_parameters( lc, lcr, k, ij, inc, & 3129 wall_index, z0_l, kb, direction, ncorr ) 3130 3131 IMPLICIT NONE 3132 3133 INTEGER(iwp), INTENT(IN) :: direction !< 3134 INTEGER(iwp), INTENT(IN) :: ij !< 3135 INTEGER(iwp), INTENT(IN) :: inc !< 3136 INTEGER(iwp), INTENT(IN) :: k !< 3137 INTEGER(iwp), INTENT(IN) :: kb !< 3138 INTEGER(iwp), INTENT(OUT) :: lc !< 3139 INTEGER(iwp), INTENT(IN) :: ncorr !< 3140 INTEGER(iwp), INTENT(IN) :: wall_index !< 3141 3142 INTEGER(iwp) :: alcorr !< 3143 INTEGER(iwp) :: corr_index !< 3144 INTEGER(iwp) :: lcorr !< 3145 3146 LOGICAL :: more !< 3147 3148 REAL(wp), DIMENSION(0:ncorr-1), INTENT(INOUT) :: lcr !< 3149 REAL(wp), INTENT(IN) :: z0_l !< 3150 3151 REAL(wp) :: logvelc1 !< 3152 3153 3154 SELECT CASE ( direction ) 3155 3156 CASE (1) ! k 3157 more = .TRUE. 3158 lcorr = 0 3159 DO WHILE ( more .AND. lcorr <= ncorr-1 ) 3160 corr_index = k + lcorr 3161 IF ( lcorr == 0 ) THEN 3162 CALL pmci_find_logc_pivot_k( lc, logvelc1, z0_l, kb ) 3163 ENDIF 3164 3165 IF ( corr_index < lc ) THEN 3166 lcr(lcorr) = LOG( ( zu(k) - zw(kb) ) / z0_l ) / logvelc1 3167 more = .TRUE. 3168 ELSE 3169 lcr(lcorr) = 1.0_wp 3170 more = .FALSE. 3171 ENDIF 3172 lcorr = lcorr + 1 3173 ENDDO 3174 3175 CASE (2) ! j 3176 more = .TRUE. 3177 lcorr = 0 3178 alcorr = 0 3179 DO WHILE ( more .AND. alcorr <= ncorr-1 ) 3180 corr_index = ij + lcorr ! In this case (direction = 2) ij is j 3181 IF ( lcorr == 0 ) THEN 3182 CALL pmci_find_logc_pivot_j( lc, logvelc1, ij, wall_index, & 3183 z0_l, inc ) 3184 ENDIF 3185 ! 3186 !-- The role of inc here is to make the comparison operation "<" 3187 !-- valid in both directions 3188 IF ( ( inc * corr_index < inc * lc ) .AND. ( lc /= -99 ) ) THEN 3189 lcr(alcorr) = LOG( ABS( coord_y(corr_index) + 0.5_wp * dy & 3190 - coord_y(wall_index) ) / z0_l ) & 3191 / logvelc1 3192 more = .TRUE. 3193 ELSE 3194 lcr(alcorr) = 1.0_wp 3195 more = .FALSE. 3196 ENDIF 3197 lcorr = lcorr + inc 3198 alcorr = ABS( lcorr ) 3199 ENDDO 3200 3201 CASE (3) ! i 3202 more = .TRUE. 3203 lcorr = 0 3204 alcorr = 0 3205 DO WHILE ( more .AND. alcorr <= ncorr-1 ) 3206 corr_index = ij + lcorr ! In this case (direction = 3) ij is i 3207 IF ( lcorr == 0 ) THEN 3208 CALL pmci_find_logc_pivot_i( lc, logvelc1, ij, wall_index, & 3209 z0_l, inc ) 3210 ENDIF 3211 ! 3212 !-- The role of inc here is to make the comparison operation "<" 3213 !-- valid in both directions 3214 IF ( ( inc * corr_index < inc * lc ) .AND. ( lc /= -99 ) ) THEN 3215 lcr(alcorr) = LOG( ABS( coord_x(corr_index) + 0.5_wp * dx & 3216 - coord_x(wall_index) ) / z0_l ) & 3217 / logvelc1 3218 more = .TRUE. 3219 ELSE 3220 lcr(alcorr) = 1.0_wp 3221 more = .FALSE. 3222 ENDIF 3223 lcorr = lcorr + inc 3224 alcorr = ABS( lcorr ) 3225 ENDDO 3226 3227 END SELECT 3228 3229 END SUBROUTINE pmci_define_loglaw_correction_parameters 3230 3231 3232 3233 SUBROUTINE pmci_find_logc_pivot_k( lc, logzc1, z0_l, kb ) 3234 ! 3235 !-- Finds the pivot node and the log-law factor for near-wall nodes for 3236 !-- which the wall-parallel velocity components will be log-law corrected 3237 !-- after interpolation. This subroutine is only for horizontal walls. 3238 3239 IMPLICIT NONE 3240 3241 INTEGER(iwp), INTENT(IN) :: kb !< 3242 INTEGER(iwp), INTENT(OUT) :: lc !< 3243 3244 INTEGER(iwp) :: kbc !< 3245 INTEGER(iwp) :: k1 !< 3246 3247 REAL(wp), INTENT(OUT) :: logzc1 !< 3248 REAL(wp), INTENT(IN) :: z0_l !< 3249 3250 REAL(wp) :: zuc1 !< 3251 3252 ! 3253 !-- kbc is the first coarse-grid point above the surface 3254 kbc = nzb + 1 3255 DO WHILE ( cg%zu(kbc) < zu(kb) ) 3256 kbc = kbc + 1 3257 ENDDO 3258 zuc1 = cg%zu(kbc) 3259 k1 = kb + 1 3260 DO WHILE ( zu(k1) < zuc1 ) ! Important: must be <, not <= 3261 k1 = k1 + 1 3262 ENDDO 3263 logzc1 = LOG( (zu(k1) - zw(kb) ) / z0_l ) 3264 lc = k1 3265 3266 END SUBROUTINE pmci_find_logc_pivot_k 3267 3268 3269 3270 SUBROUTINE pmci_find_logc_pivot_j( lc, logyc1, j, jw, z0_l, inc ) 3271 ! 3272 !-- Finds the pivot node and the log-law factor for near-wall nodes for 3273 !-- which the wall-parallel velocity components will be log-law corrected 3274 !-- after interpolation. This subroutine is only for vertical walls on 3275 !-- south/north sides of the node. If the pivot node is found to be outside 3276 !-- the subdomain, a marker value of -99 is set to lc and this tells 3277 !-- pmci_init_loglaw_correction to not do the correction in this case. 3278 3279 IMPLICIT NONE 3280 3281 INTEGER(iwp), INTENT(IN) :: inc !< increment must be 1 or -1. 3282 INTEGER(iwp), INTENT(IN) :: j !< 3283 INTEGER(iwp), INTENT(IN) :: jw !< 3284 INTEGER(iwp), INTENT(OUT) :: lc !< 3285 3286 INTEGER(iwp) :: jwc !< 3287 INTEGER(iwp) :: j1 !< 3288 3289 REAL(wp), INTENT(IN) :: z0_l !< 3290 REAL(wp), INTENT(OUT) :: logyc1 !< 3291 3292 REAL(wp) :: ycb !< 3293 REAL(wp) :: yc1 !< 3294 3295 ! 3296 !-- yc1 is the y-coordinate of the first coarse-grid u- and w-nodes out from 3297 !-- the wall. Here we assume that the wall index in the coarse grid is the 3298 !-- closest one if they don't match. 3299 jwc = pmci_find_nearest_coarse_grid_index_j( jw ) 3300 yc1 = cg%coord_y(jwc) - lower_left_coord_y + 0.5_wp * inc * cg%dy 3301 ! 3302 !-- Check if yc1 is out of the subdomain y-range. In such case set the marker 3303 !-- value -99 for lc in order to skip the loglaw-correction locally. 3304 IF ( yc1 < ( REAL( nysg, KIND=wp ) + 0.5_wp ) * dy ) THEN 3305 lc = -99 3306 logyc1 = 1.0_wp 3307 ELSE IF ( yc1 > ( REAL( nyng, KIND=wp ) + 0.5_wp ) * dy ) THEN 3308 lc = -99 3309 logyc1 = 1.0_wp 3310 ELSE 3311 ! 3312 !-- j1 is the first fine-grid index further away from the wall than yc1 3313 j1 = j 3314 ! 3315 !-- Important: the binary relation must be <, not <= 3316 ycb = 0.5_wp * dy - lower_left_coord_y 3317 DO WHILE ( inc * ( coord_y(j1) + ycb ) < inc * yc1 ) 3318 j1 = j1 + inc 3319 ENDDO 3320 3321 logyc1 = LOG( ABS( coord_y(j1) + 0.5_wp * dy - coord_y(jw) ) / z0_l ) 3322 lc = j1 3323 ENDIF 3324 3325 END SUBROUTINE pmci_find_logc_pivot_j 3326 3327 3328 3329 SUBROUTINE pmci_find_logc_pivot_i( lc, logxc1, i, iw, z0_l, inc ) 3330 ! 3331 !-- Finds the pivot node and the log-law factor for near-wall nodes for 3332 !-- which the wall-parallel velocity components will be log-law corrected 3333 !-- after interpolation. This subroutine is only for vertical walls on 3334 !-- left/right sides of the node. If the pivot node is found to be outside 3335 !-- the subdomain, a marker value of -99 is set to lc and this tells 3336 !-- pmci_init_loglaw_correction to not do the correction in this case. 3337 3338 IMPLICIT NONE 3339 3340 INTEGER(iwp), INTENT(IN) :: i !< 3341 INTEGER(iwp), INTENT(IN) :: inc !< increment must be 1 or -1. 3342 INTEGER(iwp), INTENT(IN) :: iw !< 3343 INTEGER(iwp), INTENT(OUT) :: lc !< 3344 3345 INTEGER(iwp) :: iwc !< 3346 INTEGER(iwp) :: i1 !< 3347 3348 REAL(wp), INTENT(IN) :: z0_l !< 3349 REAL(wp), INTENT(OUT) :: logxc1 !< 3350 3351 REAL(wp) :: xcb !< 3352 REAL(wp) :: xc1 !< 3353 3354 ! 3355 !-- xc1 is the x-coordinate of the first coarse-grid v- and w-nodes out from 3356 !-- the wall. Here we assume that the wall index in the coarse grid is the 3357 !-- closest one if they don't match. 3358 iwc = pmci_find_nearest_coarse_grid_index_i( iw ) 3359 xc1 = cg%coord_x(iwc) - lower_left_coord_x + 0.5_wp * inc * cg%dx 3360 ! 3361 !-- Check if xc1 is out of the subdomain x-range. In such case set the marker 3362 !-- value -99 for lc in order to skip the loglaw-correction locally. 3363 IF ( xc1 < ( REAL( nxlg, KIND=wp ) + 0.5_wp ) * dx ) THEN 3364 lc = -99 3365 logxc1 = 1.0_wp 3366 ELSE IF ( xc1 > ( REAL( nxrg, KIND=wp ) + 0.5_wp ) * dx ) THEN 3367 lc = -99 3368 logxc1 = 1.0_wp 3369 ELSE 3370 ! 3371 !-- i1 is the first fine-grid index futher away from the wall than xc1. 3372 i1 = i 3373 ! 3374 !-- Important: the binary relation must be <, not <= 3375 xcb = 0.5_wp * dx - lower_left_coord_x 3376 DO WHILE ( inc * ( coord_x(i1) + xcb ) < inc * xc1 ) 3377 i1 = i1 + inc 3378 ENDDO 3379 3380 logxc1 = LOG( ABS( coord_x(i1) + 0.5_wp*dx - coord_x(iw) ) / z0_l ) 3381 lc = i1 3382 ENDIF 3383 3384 END SUBROUTINE pmci_find_logc_pivot_i 3385 3386 3387 3388 FUNCTION pmci_find_nearest_coarse_grid_index_j( jw ) 3389 3390 IMPLICIT NONE 3391 INTEGER(iwp) :: jw !< Fine-grid wall index 3392 3393 INTEGER(iwp) :: jc 3394 INTEGER(iwp) :: pmci_find_nearest_coarse_grid_index_j 3395 REAL(wp) :: dist 3396 REAL(wp) :: newdist 3397 3398 3399 dist = coord_y(nyn) - coord_y(nys) 3400 DO jc = jcs, jcn 3401 newdist = ABS( cg%coord_y(jc) - coord_y(jw) ) 3402 IF ( newdist < dist ) THEN 3403 pmci_find_nearest_coarse_grid_index_j = jc 3404 dist = newdist 3405 ENDIF 3406 ENDDO 3407 3408 END FUNCTION pmci_find_nearest_coarse_grid_index_j 3409 3410 3411 3412 FUNCTION pmci_find_nearest_coarse_grid_index_i( iw ) 3413 3414 IMPLICIT NONE 3415 INTEGER(iwp) :: iw !< Fine-grid wall index 3416 3417 INTEGER(iwp) :: ic 3418 INTEGER(iwp) :: pmci_find_nearest_coarse_grid_index_i 3419 REAL(wp) :: dist 3420 REAL(wp) :: newdist 3421 3422 3423 dist = coord_x(nxr) - coord_x(nxl) 3424 DO ic = icl, icr 3425 newdist = ABS( cg%coord_x(ic) - coord_x(iw) ) 3426 IF ( newdist < dist ) THEN 3427 pmci_find_nearest_coarse_grid_index_i = ic 3428 dist = newdist 3429 ENDIF 3430 ENDDO 3431 3432 END FUNCTION pmci_find_nearest_coarse_grid_index_i 3433 3434 3435 3436 SUBROUTINE pmci_init_anterp_tophat 3437 ! 3438 !-- Precomputation of the child-array indices for 3439 !-- corresponding coarse-grid array index and the 3440 !-- Under-relaxation coefficients to be used by anterp_tophat. 3441 3442 IMPLICIT NONE 3443 3444 INTEGER(iwp) :: i !< Fine-grid index 3445 INTEGER(iwp) :: ii !< Coarse-grid index 3446 INTEGER(iwp) :: istart !< 3447 INTEGER(iwp) :: ir !< 3448 INTEGER(iwp) :: iw !< Fine-grid index limited to -1 <= iw <= nx+1 3449 INTEGER(iwp) :: j !< Fine-grid index 3450 INTEGER(iwp) :: jj !< Coarse-grid index 3451 INTEGER(iwp) :: jstart !< 3452 INTEGER(iwp) :: jr !< 3453 INTEGER(iwp) :: jw !< Fine-grid index limited to -1 <= jw <= ny+1 3454 INTEGER(iwp) :: k !< Fine-grid index 3455 INTEGER(iwp) :: kk !< Coarse-grid index 3456 INTEGER(iwp) :: kstart !< 3457 INTEGER(iwp) :: kw !< Fine-grid index limited to kw <= nzt+1 3458 REAL(wp) :: xi !< 3459 REAL(wp) :: eta !< 3460 REAL(wp) :: tolerance !< 3461 REAL(wp) :: zeta !< 3462 3463 ! 3464 !-- Default values for under-relaxation lengths: 3465 IF ( anterp_relax_length_l < 0.0_wp ) THEN 3466 anterp_relax_length_l = 0.1_wp * ( nx + 1 ) * dx 3467 ENDIF 3468 IF ( anterp_relax_length_r < 0.0_wp ) THEN 3469 anterp_relax_length_r = 0.1_wp * ( nx + 1 ) * dx 3470 ENDIF 3471 IF ( anterp_relax_length_s < 0.0_wp ) THEN 3472 anterp_relax_length_s = 0.1_wp * ( ny + 1 ) * dy 3473 ENDIF 3474 IF ( anterp_relax_length_n < 0.0_wp ) THEN 3475 anterp_relax_length_n = 0.1_wp * ( ny + 1 ) * dy 3476 ENDIF 3477 IF ( anterp_relax_length_t < 0.0_wp ) THEN 3478 anterp_relax_length_t = 0.1_wp * zu(nzt) 3479 ENDIF 1560 CALL pmci_create_workarray_exchange_datatypes 3480 1561 ! 3481 1562 !-- First determine kcto and kctw which refer to the uppermost … … 3492 1573 ENDDO 3493 1574 kctw = kk - 1 3494 !AH 3495 write(9,"('kcto, kctw = ', 2(i3,2x))") kcto, kctw 3496 3497 !AH 3498 ! ALLOCATE( iflu(icl:icr) ) 3499 ! ALLOCATE( iflo(icl:icr) ) 3500 ! ALLOCATE( ifuu(icl:icr) ) 3501 ! ALLOCATE( ifuo(icl:icr) ) 3502 ! ALLOCATE( jflv(jcs:jcn) ) 3503 ! ALLOCATE( jflo(jcs:jcn) ) 3504 ! ALLOCATE( jfuv(jcs:jcn) ) 3505 ! ALLOCATE( jfuo(jcs:jcn) ) 3506 ! 3507 ! ALLOCATE( iflu(icl-1:icr+1) ) 3508 ! ALLOCATE( iflo(icl-1:icr+1) ) 3509 ! ALLOCATE( ifuu(icl-1:icr+1) ) 3510 ! ALLOCATE( ifuo(icl-1:icr+1) ) 3511 ! ALLOCATE( jflv(jcs-1:jcn+1) ) 3512 ! ALLOCATE( jflo(jcs-1:jcn+1) ) 3513 ! ALLOCATE( jfuv(jcs-1:jcn+1) ) 3514 ! ALLOCATE( jfuo(jcs-1:jcn+1) ) 3515 ! 1575 1576 WRITE(9,"('kcto, kctw = ', 2(i3,2x))") kcto, kctw 1577 FLUSH(9) 1578 3516 1579 icla = coarse_bound_aux(1) 3517 1580 icra = coarse_bound_aux(2) … … 3526 1589 ALLOCATE( jfuv(jcsa:jcna) ) 3527 1590 ALLOCATE( jfuo(jcsa:jcna) ) 3528 !AH3529 1591 ALLOCATE( kflw(0:cg%nz+1) ) 3530 1592 ALLOCATE( kflo(0:cg%nz+1) ) 3531 1593 ALLOCATE( kfuw(0:cg%nz+1) ) 3532 1594 ALLOCATE( kfuo(0:cg%nz+1) ) 3533 !AH3534 ! ALLOCATE( ijkfc_u(0:cg%nz+1,jcs:jcn,icl:icr) )3535 ! ALLOCATE( ijkfc_v(0:cg%nz+1,jcs:jcn,icl:icr) )3536 ! ALLOCATE( ijkfc_w(0:cg%nz+1,jcs:jcn,icl:icr) )3537 ! ALLOCATE( ijkfc_s(0:cg%nz+1,jcs:jcn,icl:icr) )3538 !3539 ! ALLOCATE( ijkfc_u(0:cg%nz+1,jcs-1:jcn+1,icl-1:icr+1) )3540 ! ALLOCATE( ijkfc_v(0:cg%nz+1,jcs-1:jcn+1,icl-1:icr+1) )3541 ! ALLOCATE( ijkfc_w(0:cg%nz+1,jcs-1:jcn+1,icl-1:icr+1) )3542 ! ALLOCATE( ijkfc_s(0:cg%nz+1,jcs-1:jcn+1,icl-1:icr+1) )3543 !3544 1595 ALLOCATE( ijkfc_u(0:cg%nz+1,jcsa:jcna,icla:icra) ) 3545 1596 ALLOCATE( ijkfc_v(0:cg%nz+1,jcsa:jcna,icla:icra) ) 3546 1597 ALLOCATE( ijkfc_w(0:cg%nz+1,jcsa:jcna,icla:icra) ) 3547 1598 ALLOCATE( ijkfc_s(0:cg%nz+1,jcsa:jcna,icla:icra) ) 3548 !AH3549 1599 3550 1600 ijkfc_u = 0 … … 3568 1618 ! 3569 1619 !-- Print out the index bounds for checking and debugging purposes 3570 write(9,"('pmci_init_anterp_tophat, ii, iflu, ifuu: ', 3(i4,2x))") &1620 WRITE(9,"('pmci_init_anterp_tophat, ii, iflu, ifuu: ', 3(i4,2x))") & 3571 1621 ii, iflu(ii), ifuu(ii) 3572 flush(9) 3573 1622 FLUSH(9) 3574 1623 ENDDO 3575 write(9,*)1624 WRITE(9,*) 3576 1625 ! 3577 1626 !-- i-indices of others for each ii-index value … … 3594 1643 ! 3595 1644 !-- Print out the index bounds for checking and debugging purposes 3596 write(9,"('pmci_init_anterp_tophat, ii, iflo, ifuo: ', 3(i4,2x))") &1645 WRITE(9,"('pmci_init_anterp_tophat, ii, iflo, ifuo: ', 3(i4,2x))") & 3597 1646 ii, iflo(ii), ifuo(ii) 3598 flush(9)1647 FLUSH(9) 3599 1648 ENDDO 3600 write(9,*)1649 WRITE(9,*) 3601 1650 ! 3602 1651 !-- j-indices of v for each jj-index value … … 3615 1664 ! 3616 1665 !-- Print out the index bounds for checking and debugging purposes 3617 write(9,"('pmci_init_anterp_tophat, jj, jflv, jfuv: ', 3(i4,2x))") &1666 WRITE(9,"('pmci_init_anterp_tophat, jj, jflv, jfuv: ', 3(i4,2x))") & 3618 1667 jj, jflv(jj), jfuv(jj) 3619 flush(9)1668 FLUSH(9) 3620 1669 ENDDO 3621 write(9,*)1670 WRITE(9,*) 3622 1671 ! 3623 1672 !-- j-indices of others for each jj-index value … … 3640 1689 ! 3641 1690 !-- Print out the index bounds for checking and debugging purposes 3642 write(9,"('pmci_init_anterp_tophat, jj, jflo, jfuo: ', 3(i4,2x))") &1691 WRITE(9,"('pmci_init_anterp_tophat, jj, jflo, jfuo: ', 3(i4,2x))") & 3643 1692 jj, jflo(jj), jfuo(jj) 3644 flush(9)1693 FLUSH(9) 3645 1694 ENDDO 3646 write(9,*)1695 WRITE(9,*) 3647 1696 ! 3648 1697 !-- k-indices of w for each kk-index value … … 3665 1714 ! 3666 1715 !-- Print out the index bounds for checking and debugging purposes 3667 write(9,"('pmci_init_anterp_tophat, kk, kflw, kfuw: ', 4(i4,2x), 2(e12.5,2x))") &1716 WRITE(9,"('pmci_init_anterp_tophat, kk, kflw, kfuw: ', 4(i4,2x), 2(e12.5,2x))") & 3668 1717 kk, kflw(kk), kfuw(kk), nzt, cg%zu(kk), cg%zw(kk) 3669 flush(9)1718 FLUSH(9) 3670 1719 ENDDO 3671 write(9,*)1720 WRITE(9,*) 3672 1721 ! 3673 1722 !-- k-indices of others for each kk-index value … … 3692 1741 ENDDO 3693 1742 ! 3694 !-- Set the k-index bounds separately for the parent-grid cells cg%nz and cg%nz+1 .3695 !-- Index bounds for cg%nz are needed for the reversibility correction.3696 kflo(cg%nz) = nzt+1 ! Needed for the reversibility correction3697 kfuo(cg%nz) = nzt+kgsr ! Needed for the reversibility correction3698 kflo(cg%nz+1) = nzt+kgsr ! Obsolete3699 kfuo(cg%nz+1) = nzt+kgsr ! Obsolete3700 ! 3701 !-- 1743 !-- Set the k-index bounds separately for the parent-grid cells cg%nz and cg%nz+1 1744 !-- although they are not actually needed. 1745 kflo(cg%nz) = nzt+1 1746 kfuo(cg%nz) = nzt+kgsr 1747 kflo(cg%nz+1) = nzt+kgsr 1748 kfuo(cg%nz+1) = nzt+kgsr 1749 ! 1750 !-- Print out the index bounds for checking and debugging purposes 3702 1751 DO kk = 1, cg%nz+1 3703 write(9,"('pmci_init_anterp_tophat, kk, kflo, kfuo: ', 4(i4,2x), 2(e12.5,2x))") &1752 WRITE(9,"('pmci_init_anterp_tophat, kk, kflo, kfuo: ', 4(i4,2x), 2(e12.5,2x))") & 3704 1753 kk, kflo(kk), kfuo(kk), nzt, cg%zu(kk), cg%zw(kk) 3705 flush(9)1754 FLUSH(9) 3706 1755 ENDDO 3707 write(9,*)1756 WRITE(9,*) 3708 1757 ! 3709 1758 !-- Precomputation of number of fine-grid nodes inside parent-grid cells. 3710 1759 !-- Note that ii, jj, and kk are parent-grid indices. 3711 1760 !-- This information is needed in anterpolation and in reversibility 3712 !-- correction in interpolation. For the reversibility correction, ijkfc- 3713 !-- information is needed also beyond the indices for wall_flags_0-masking 3714 !-- must be modified here in the boundary-normal direction (iw, jw, kw). 3715 !AH DO ii = icl, icr 3716 !AH DO jj = jcs, jcn 3717 !AH DO ii = icl-1, icr+1 3718 !AH DO jj = jcs-1, jcn+1 1761 !-- correction in interpolation. 3719 1762 DO ii = icla, icra 3720 1763 DO jj = jcsa, jcna … … 3776 1819 ENDDO ! jj 3777 1820 ENDDO ! ii 3778 ! 3779 !-- Spatial under-relaxation coefficients 3780 ALLOCATE( frax(icl:icr) ) 3781 ALLOCATE( fray(jcs:jcn) ) 1821 1822 END SUBROUTINE pmci_define_index_mapping 1823 1824 1825 1826 SUBROUTINE pmci_allocate_workarrays 1827 ! 1828 !-- Allocate parent-grid work-arrays for interpolation 1829 IMPLICIT NONE 1830 1831 ! 1832 !-- Determine and store the PE-subdomain dependent index bounds 1833 IF ( bc_dirichlet_l ) THEN 1834 iclw = icl + 1 1835 ELSE 1836 iclw = icl - 1 1837 ENDIF 1838 1839 IF ( bc_dirichlet_r ) THEN 1840 icrw = icr - 1 1841 ELSE 1842 icrw = icr + 1 1843 ENDIF 1844 1845 IF ( bc_dirichlet_s ) THEN 1846 jcsw = jcs + 1 1847 ELSE 1848 jcsw = jcs - 1 1849 ENDIF 1850 1851 IF ( bc_dirichlet_n ) THEN 1852 jcnw = jcn - 1 1853 ELSE 1854 jcnw = jcn + 1 1855 ENDIF 1856 1857 coarse_bound_w(1) = iclw 1858 coarse_bound_w(2) = icrw 1859 coarse_bound_w(3) = jcsw 1860 coarse_bound_w(4) = jcnw 1861 ! 1862 !-- Left and right boundaries. 1863 ALLOCATE( workarrc_lr(0:cg%nz+1,jcsw:jcnw,0:2) ) 1864 ! 1865 !-- South and north boundaries. 1866 ALLOCATE( workarrc_sn(0:cg%nz+1,0:2,iclw:icrw) ) 1867 ! 1868 !-- Top boundary. 1869 !AH ALLOCATE( workarrc_t(0:2,jcsw:jcnw,iclw:icrw) ) 1870 ALLOCATE( workarrc_t(-2:3,jcsw:jcnw,iclw:icrw) ) 1871 1872 END SUBROUTINE pmci_allocate_workarrays 1873 1874 1875 1876 SUBROUTINE pmci_create_workarray_exchange_datatypes 1877 ! 1878 !-- Define specific MPI types for workarrc-exhchange. 1879 IMPLICIT NONE 1880 1881 #if defined( __parallel ) 1882 ! 1883 !-- For the left and right boundaries 1884 CALL MPI_TYPE_VECTOR( 3, cg%nz+2, (jcnw-jcsw+1)*(cg%nz+2), MPI_REAL, & 1885 workarrc_lr_exchange_type, ierr ) 1886 CALL MPI_TYPE_COMMIT( workarrc_lr_exchange_type, ierr ) 1887 ! 1888 !-- For the south and north boundaries 1889 CALL MPI_TYPE_VECTOR( 1, 3*(cg%nz+2), 3*(cg%nz+2), MPI_REAL, & 1890 workarrc_sn_exchange_type, ierr ) 1891 CALL MPI_TYPE_COMMIT( workarrc_sn_exchange_type, ierr ) 1892 ! 1893 !-- For the top-boundary x-slices 1894 !AH CALL MPI_TYPE_VECTOR( icrw-iclw+1, 3, 3*(jcnw-jcsw+1), MPI_REAL, & 1895 !AH workarrc_t_exchange_type_x, ierr ) 1896 CALL MPI_TYPE_VECTOR( icrw-iclw+1, 6, 6*(jcnw-jcsw+1), MPI_REAL, & 1897 workarrc_t_exchange_type_x, ierr ) 1898 CALL MPI_TYPE_COMMIT( workarrc_t_exchange_type_x, ierr ) 1899 ! 1900 !-- For the top-boundary y-slices 1901 !AH CALL MPI_TYPE_VECTOR( 1, 3*(jcnw-jcsw+1), 3*(jcnw-jcsw+1), MPI_REAL, & 1902 !AH workarrc_t_exchange_type_y, ierr ) 1903 CALL MPI_TYPE_VECTOR( 1, 6*(jcnw-jcsw+1), 6*(jcnw-jcsw+1), MPI_REAL, & 1904 workarrc_t_exchange_type_y, ierr ) 1905 CALL MPI_TYPE_COMMIT( workarrc_t_exchange_type_y, ierr ) 1906 #endif 3782 1907 3783 frax(icl:icr) = 1.0_wp 3784 fray(jcs:jcn) = 1.0_wp 3785 3786 !AH IF ( nesting_mode /= 'vertical' ) THEN 3787 !AH DO ii = icl, icr 3788 !AH IF ( ifuu(ii) < ( nx + 1 ) / 2 ) THEN 3789 !AH xi = ( MAX( 0.0_wp, ( cg%coord_x(ii) - & 3790 !AH lower_left_coord_x ) ) / anterp_relax_length_l )**4 3791 !AH frax(ii) = xi / ( 1.0_wp + xi ) 3792 !AH ELSE 3793 !AH xi = ( MAX( 0.0_wp, ( lower_left_coord_x + ( nx + 1 ) * dx - & 3794 !AH cg%coord_x(ii) ) ) / & 3795 !AH anterp_relax_length_r )**4 3796 !AH frax(ii) = xi / ( 1.0_wp + xi ) 3797 !AH ENDIF 3798 !AH ENDDO 3799 !AH 3800 !AH DO jj = jcs, jcn 3801 !AH IF ( jfuv(jj) < ( ny + 1 ) / 2 ) THEN 3802 !AH eta = ( MAX( 0.0_wp, ( cg%coord_y(jj) - & 3803 !AH lower_left_coord_y ) ) / anterp_relax_length_s )**4 3804 !AH fray(jj) = eta / ( 1.0_wp + eta ) 3805 !AH ELSE 3806 !AH eta = ( MAX( 0.0_wp, ( lower_left_coord_y + ( ny + 1 ) * dy - & 3807 !AH cg%coord_y(jj)) ) / & 3808 !AH anterp_relax_length_n )**4 3809 !AH fray(jj) = eta / ( 1.0_wp + eta ) 3810 !AH ENDIF 3811 !AH ENDDO 3812 !AH ENDIF 3813 3814 ALLOCATE( fraz(0:kcto) ) 3815 fraz(0:kcto) = 1.0_wp 3816 !AH DO kk = 0, kcto 3817 !AH zeta = ( ( zu(nzt) - cg%zu(kk) ) / anterp_relax_length_t )**4 3818 !AH fraz(kk) = zeta / ( 1.0_wp + zeta ) 3819 !AH ENDDO 3820 3821 END SUBROUTINE pmci_init_anterp_tophat 1908 END SUBROUTINE pmci_create_workarray_exchange_datatypes 3822 1909 3823 1910 … … 3921 2008 END SUBROUTINE pmci_check_grid_matching 3922 2009 3923 3924 2010 #endif 3925 2011 END SUBROUTINE pmci_setup_child … … 4000 2086 pmc_max_array = pmc_max_array + nspec 4001 2087 #endif 2088 4002 2089 END SUBROUTINE pmci_num_arrays 4003 2090 … … 4012 2099 INTEGER(iwp), INTENT(IN),OPTIONAL :: n !< index of chemical species 4013 2100 4014 CHARACTER(LEN=*), INTENT(IN) :: name !<2101 CHARACTER(LEN=*), INTENT(IN) :: name !< 4015 2102 4016 2103 #if defined( __parallel ) 4017 INTEGER(iwp) :: ierr !<2104 INTEGER(iwp) :: ierr !< MPI error code 4018 2105 4019 2106 REAL(wp), POINTER, DIMENSION(:,:) :: p_2d !< … … 4027 2114 NULLIFY( p_2d ) 4028 2115 NULLIFY( i_2d ) 4029 4030 2116 ! 4031 2117 !-- List of array names, which can be coupled. … … 4046 2132 IF ( TRIM(name) == "part_adr" ) i_2d => part_adr 4047 2133 IF ( INDEX( TRIM(name), "chem_" ) /= 0 ) p_3d => chem_species(n)%conc 4048 4049 2134 ! 4050 2135 !-- Next line is just an example for a 2D array (not active for coupling!) 4051 2136 !-- Please note, that z0 has to be declared as TARGET array in modules.f90 4052 2137 ! IF ( TRIM(name) == "z0" ) p_2d => z0 4053 4054 2138 IF ( TRIM(name) == "u" ) p_3d_sec => u_2 4055 2139 IF ( TRIM(name) == "v" ) p_3d_sec => v_2 … … 4094 2178 4095 2179 4096 INTEGER FUNCTION get_number_of_childs () 2180 INTEGER FUNCTION get_number_of_childs () ! Change the name to "get_number_of_children" 4097 2181 4098 2182 IMPLICIT NONE … … 4196 2280 NULLIFY( p_2d ) 4197 2281 NULLIFY( i_2d ) 4198 4199 2282 ! 4200 2283 !-- List of array names, which can be coupled … … 4286 2369 INTEGER(iwp) :: child_id !< 4287 2370 INTEGER(iwp) :: m !< 4288 4289 2371 REAL(wp) :: waittime !< 4290 2372 … … 4324 2406 INTEGER(iwp) :: k !< 4325 2407 INTEGER(iwp) :: n !< running index for chemical species 4326 4327 2408 REAL(wp) :: waittime !< 4328 2409 … … 4350 2431 ! 4351 2432 !-- The interpolation. 4352 CALL pmci_interp_1sto_all ( u, uc, icu, jco, kco, r1xu, r2xu, r1yo, & 4353 r2yo, r1zo, r2zo, kcto, iflu, ifuu, & 4354 jflo, jfuo, kflo, kfuo, ijkfc_u, 'u' ) 4355 CALL pmci_interp_1sto_all ( v, vc, ico, jcv, kco, r1xo, r2xo, r1yv, & 4356 r2yv, r1zo, r2zo, kcto, iflo, ifuo, & 4357 jflv, jfuv, kflo, kfuo, ijkfc_v, 'v' ) 4358 CALL pmci_interp_1sto_all ( w, wc, ico, jco, kcw, r1xo, r2xo, r1yo, & 4359 r2yo, r1zw, r2zw, kctw, iflo, ifuo, & 4360 jflo, jfuo, kflw, kfuw, ijkfc_w, 'w' ) 4361 4362 IF ( ( rans_mode_parent .AND. rans_mode ) .OR. & 4363 ( .NOT. rans_mode_parent .AND. .NOT. rans_mode .AND. & 2433 CALL pmci_interp_1sto_all ( u, uc, kcto, iflu, ifuu, jflo, jfuo, kflo, kfuo, 'u' ) 2434 CALL pmci_interp_1sto_all ( v, vc, kcto, iflo, ifuo, jflv, jfuv, kflo, kfuo, 'v' ) 2435 CALL pmci_interp_1sto_all ( w, wc, kctw, iflo, ifuo, jflo, jfuo, kflw, kfuw, 'w' ) 2436 2437 IF ( ( rans_mode_parent .AND. rans_mode ) .OR. & 2438 ( .NOT. rans_mode_parent .AND. .NOT. rans_mode .AND. & 4364 2439 .NOT. constant_diffusion ) ) THEN 4365 CALL pmci_interp_1sto_all ( e, ec, ico, jco, kco, r1xo, r2xo, r1yo, & 4366 r2yo, r1zo, r2zo, kcto, iflo, ifuo, & 4367 jflo, jfuo, kflo, kfuo, ijkfc_s, 'e' ) 2440 CALL pmci_interp_1sto_all ( e, ec, kcto, iflo, ifuo, jflo, jfuo, kflo, kfuo, 'e' ) 4368 2441 ENDIF 4369 2442 4370 2443 IF ( rans_mode_parent .AND. rans_mode .AND. rans_tke_e ) THEN 4371 CALL pmci_interp_1sto_all ( diss, dissc, ico, jco, kco, r1xo, r2xo,& 4372 r1yo, r2yo, r1zo, r2zo, kcto, iflo, ifuo,& 4373 jflo, jfuo, kflo, kfuo, ijkfc_s, 's' ) 2444 CALL pmci_interp_1sto_all ( diss, dissc, kcto, iflo, ifuo, jflo, jfuo, kflo, kfuo, 's' ) 4374 2445 ENDIF 4375 2446 4376 2447 IF ( .NOT. neutral ) THEN 4377 CALL pmci_interp_1sto_all ( pt, ptc, ico, jco, kco, r1xo, r2xo, & 4378 r1yo, r2yo, r1zo, r2zo, kcto, iflo, ifuo,& 4379 jflo, jfuo, kflo, kfuo, ijkfc_s, 's' ) 2448 CALL pmci_interp_1sto_all ( pt, ptc, kcto, iflo, ifuo, jflo, jfuo, kflo, kfuo, 's' ) 4380 2449 ENDIF 4381 2450 4382 2451 IF ( humidity ) THEN 4383 2452 4384 CALL pmci_interp_1sto_all ( q, q_c, ico, jco, kco, r1xo, r2xo, r1yo, & 4385 r2yo, r1zo, r2zo, kcto, iflo, ifuo, & 4386 jflo, jfuo, kflo, kfuo, ijkfc_s, 's' ) 2453 CALL pmci_interp_1sto_all ( q, q_c, kcto, iflo, ifuo, jflo, jfuo, kflo, kfuo, 's' ) 4387 2454 4388 2455 IF ( bulk_cloud_model .AND. microphysics_morrison ) THEN 4389 CALL pmci_interp_1sto_all ( qc, qcc, ico, jco, kco, r1xo, r2xo, & 4390 r1yo, r2yo, r1zo, r2zo, kcto, & 4391 iflo, ifuo, jflo, jfuo, kflo, kfuo, & 4392 ijkfc_s, 's' ) 4393 CALL pmci_interp_1sto_all ( nc, ncc, ico, jco, kco, r1xo, r2xo, & 4394 r1yo, r2yo, r1zo, r2zo, kcto, & 4395 iflo, ifuo, jflo, jfuo, kflo, kfuo, & 4396 ijkfc_s, 's' ) 2456 CALL pmci_interp_1sto_all ( qc, qcc, kcto, iflo, ifuo, jflo, jfuo, kflo, kfuo, 's' ) 2457 CALL pmci_interp_1sto_all ( nc, ncc, kcto, iflo, ifuo, jflo, jfuo, kflo, kfuo, 's' ) 4397 2458 ENDIF 4398 2459 4399 2460 IF ( bulk_cloud_model .AND. microphysics_seifert ) THEN 4400 CALL pmci_interp_1sto_all ( qr, qrc, ico, jco, kco, r1xo, r2xo, & 4401 r1yo, r2yo, r1zo, r2zo, kcto, & 4402 iflo, ifuo, jflo, jfuo, kflo, kfuo, & 4403 ijkfc_s, 's' ) 4404 CALL pmci_interp_1sto_all ( nr, nrc, ico, jco, kco, r1xo, r2xo, & 4405 r1yo, r2yo, r1zo, r2zo, kcto, & 4406 iflo, ifuo, jflo, jfuo, kflo, kfuo, & 4407 ijkfc_s, 's' ) 2461 CALL pmci_interp_1sto_all ( qr, qrc, kcto, iflo, ifuo, jflo, jfuo, kflo, kfuo, 's' ) 2462 CALL pmci_interp_1sto_all ( nr, nrc, kcto, iflo, ifuo, jflo, jfuo, kflo, kfuo, 's' ) 4408 2463 ENDIF 4409 2464 … … 4411 2466 4412 2467 IF ( passive_scalar ) THEN 4413 CALL pmci_interp_1sto_all ( s, sc, ico, jco, kco, r1xo, r2xo, r1yo, & 4414 r2yo, r1zo, r2zo, kcto, iflo, ifuo, & 4415 jflo, jfuo, kflo, kfuo, ijkfc_s, 's' ) 2468 CALL pmci_interp_1sto_all ( s, sc, kcto, iflo, ifuo, jflo, jfuo, kflo, kfuo, 's' ) 4416 2469 ENDIF 4417 2470 4418 2471 IF ( air_chemistry .AND. nest_chemistry ) THEN 4419 2472 DO n = 1, nspec 4420 CALL pmci_interp_1sto_all ( chem_species(n)%conc, & 4421 chem_spec_c(:,:,:,n), & 4422 ico, jco, kco, r1xo, r2xo, r1yo, & 4423 r2yo, r1zo, r2zo, kcto, iflo, ifuo, & 4424 jflo, jfuo, kflo, kfuo, ijkfc_s, 's' ) 2473 CALL pmci_interp_1sto_all ( chem_species(n)%conc, chem_spec_c(:,:,:,n), & 2474 kcto, iflo, ifuo, jflo, jfuo, kflo, kfuo, 's' ) 4425 2475 ENDDO 4426 2476 ENDIF … … 4460 2510 4461 2511 4462 SUBROUTINE pmci_interp_1sto_all( f, fc, ic, jc, kc, r1x, r2x, r1y, r2y, & 4463 r1z, r2z, kct, ifl, ifu, jfl, jfu, & 4464 kfl, kfu, ijkfc, var ) 2512 SUBROUTINE pmci_interp_1sto_all( f, fc, kct, ifl, ifu, jfl, jfu, kfl, kfu, var ) 4465 2513 ! 4466 2514 !-- Interpolation of the internal values for the child-domain initialization 4467 2515 IMPLICIT NONE 4468 2516 4469 CHARACTER(LEN=1), INTENT(IN) :: var !< 4470 4471 INTEGER(iwp), DIMENSION(nxlfc:nxrfc), INTENT(IN) :: ic !< 4472 INTEGER(iwp), DIMENSION(nysfc:nynfc), INTENT(IN) :: jc !< 4473 !AH INTEGER(iwp), DIMENSION(nzb:nzt+1), INTENT(IN) :: kc !< 4474 INTEGER(iwp), DIMENSION(nzb:nzt+kgsr), INTENT(IN) :: kc !< 4475 4476 REAL(wp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg), INTENT(INOUT) :: f !< 4477 REAL(wp), DIMENSION(0:cg%nz+1,jcs:jcn,icl:icr), INTENT(IN) :: fc !< 4478 REAL(wp), DIMENSION(nxlfc:nxrfc), INTENT(IN) :: r1x !< 4479 REAL(wp), DIMENSION(nxlfc:nxrfc), INTENT(IN) :: r2x !< 4480 REAL(wp), DIMENSION(nysfc:nynfc), INTENT(IN) :: r1y !< 4481 REAL(wp), DIMENSION(nysfc:nynfc), INTENT(IN) :: r2y !< 4482 REAL(wp), DIMENSION(nzb:nzt+kgsr), INTENT(IN) :: r1z !< 4483 REAL(wp), DIMENSION(nzb:nzt+kgsr), INTENT(IN) :: r2z !< 4484 4485 INTEGER(iwp) :: kct 4486 !AH INTEGER(iwp), DIMENSION(icl:icr), INTENT(IN) :: ifl !< Indicates start index of child cells belonging to certain parent cell - x direction 4487 !AH INTEGER(iwp), DIMENSION(icl:icr), INTENT(IN) :: ifu !< Indicates end index of child cells belonging to certain parent cell - x direction 4488 !AH INTEGER(iwp), DIMENSION(jcs:jcn), INTENT(IN) :: jfl !< Indicates start index of child cells belonging to certain parent cell - y direction 4489 !AH INTEGER(iwp), DIMENSION(jcs:jcn), INTENT(IN) :: jfu !< Indicates start index of child cells belonging to certain parent cell - y direction 2517 REAL(wp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg), INTENT(INOUT) :: f !< Child-grid array 2518 REAL(wp), DIMENSION(0:cg%nz+1,jcs:jcn,icl:icr), INTENT(IN) :: fc !< Parent-grid array 2519 INTEGER(iwp) :: kct !< The parent-grid index in z-direction just below the boundary value node 4490 2520 INTEGER(iwp), DIMENSION(icla:icra), INTENT(IN) :: ifl !< Indicates start index of child cells belonging to certain parent cell - x direction 4491 2521 INTEGER(iwp), DIMENSION(icla:icra), INTENT(IN) :: ifu !< Indicates end index of child cells belonging to certain parent cell - x direction 4492 2522 INTEGER(iwp), DIMENSION(jcsa:jcna), INTENT(IN) :: jfl !< Indicates start index of child cells belonging to certain parent cell - y direction 4493 INTEGER(iwp), DIMENSION(jcsa:jcna), INTENT(IN) :: jfu !< Indicates startindex of child cells belonging to certain parent cell - y direction2523 INTEGER(iwp), DIMENSION(jcsa:jcna), INTENT(IN) :: jfu !< Indicates end index of child cells belonging to certain parent cell - y direction 4494 2524 INTEGER(iwp), DIMENSION(0:cg%nz+1), INTENT(IN) :: kfl !< Indicates start index of child cells belonging to certain parent cell - z direction 4495 INTEGER(iwp), DIMENSION(0:cg%nz+1), INTENT(IN) :: kfu !< Indicates start index of child cells belonging to certain parent cell - z direction 4496 !AH 4497 ! INTEGER(iwp), DIMENSION(0:cg%nz+1,jcs:jcn,icl:icr), INTENT(IN) :: ijkfc !< number of child grid points contributing to a parent grid box 4498 INTEGER(iwp), DIMENSION(0:cg%nz+1,jcsa:jcna,icla:icra), INTENT(IN) :: ijkfc !< number of child grid points contributing to a parent grid box 4499 !AH 4500 2525 INTEGER(iwp), DIMENSION(0:cg%nz+1), INTENT(IN) :: kfu !< Indicates end index of child cells belonging to certain parent cell - z direction 2526 CHARACTER(LEN=1), INTENT(IN) :: var !< Variable symbol: 'u', 'v', 'w' or 's' 2527 ! 2528 !-- Local variables: 4501 2529 INTEGER(iwp) :: i !< 4502 2530 INTEGER(iwp) :: ib !< … … 4517 2545 INTEGER(iwp) :: me !< 4518 2546 INTEGER(iwp) :: n !< 4519 INTEGER(iwp) :: var_flag !<4520 2547 4521 2548 … … 4558 2585 jlast = nyn + 1 4559 2586 ENDIF 4560 ENDIF 4561 ! 4562 !-- Is masking needed here, think about it. 4563 IF ( var == 'u' ) THEN 4564 var_flag = 1 4565 ELSEIF ( var == 'v' ) THEN 4566 var_flag = 2 4567 ELSEIF ( var == 'w' ) THEN 4568 var_flag = 3 4569 ELSE 4570 var_flag = 0 4571 ENDIF 2587 ENDIF 4572 2588 4573 2589 f(:,:,:) = 0.0_wp … … 5044 3060 IF ( bc_dirichlet_l ) THEN 5045 3061 5046 CALL pmci_interp_1sto_lr( u, uc, icu, jco, kco, r1xu, r2xu, & 5047 r1yo, r2yo, r1zo, r2zo, & 5048 logc_u_l, logc_ratio_u_l, & 5049 logc_kbounds_u_l, nzt_topo_nestbc_l, & 5050 kcto, iflu, ifuu, jflo, jfuo, kflo, & 5051 kfuo, ijkfc_u, 'l', 'u' ) 5052 5053 CALL pmci_interp_1sto_lr( v, vc, ico, jcv, kco, r1xo, r2xo, & 5054 r1yv, r2yv, r1zo, r2zo, & 5055 logc_v_l, logc_ratio_v_l, & 5056 logc_kbounds_v_l, nzt_topo_nestbc_l, & 5057 kcto, iflo, ifuo, jflv, jfuv, kflo, & 5058 kfuo, ijkfc_v, 'l', 'v' ) 5059 5060 CALL pmci_interp_1sto_lr( w, wc, ico, jco, kcw, r1xo, r2xo, & 5061 r1yo, r2yo, r1zw, r2zw, & 5062 logc_w_l, logc_ratio_w_l, & 5063 logc_kbounds_w_l, nzt_topo_nestbc_l, & 5064 kctw, iflo, ifuo, jflo, jfuo, kflw, & 5065 kfuw, ijkfc_w, 'l', 'w' ) 5066 5067 IF ( ( rans_mode_parent .AND. rans_mode ) .OR. & 5068 ( .NOT. rans_mode_parent .AND. .NOT. rans_mode .AND. & 3062 CALL pmci_interp_1sto_lr( u, uc, kcto, jflo, jfuo, kflo, kfuo, 'l', 'u' ) 3063 CALL pmci_interp_1sto_lr( v, vc, kcto, jflv, jfuv, kflo, kfuo, 'l', 'v' ) 3064 CALL pmci_interp_1sto_lr( w, wc, kctw, jflo, jfuo, kflw, kfuw, 'l', 'w' ) 3065 3066 IF ( ( rans_mode_parent .AND. rans_mode ) .OR. & 3067 ( .NOT. rans_mode_parent .AND. .NOT. rans_mode .AND. & 5069 3068 .NOT. constant_diffusion ) ) THEN 5070 ! CALL pmci_interp_1sto_lr( e, ec, ico, jco, kco, r1xo, r2xo, & 5071 ! r1yo, r2yo, r1zo, r2zo, & 5072 ! logc_w_l, logc_ratio_w_l, & 5073 ! logc_kbounds_w_l, nzt_topo_nestbc_l, & 5074 ! kcto, iflo, ifuo, jflo, jfuo, kflo, & 5075 ! kfuo, ijkfc_s, 'l', 'e' ) 3069 ! CALL pmci_interp_1sto_lr( e, ec, kcto, jflo, jfuo, kflo, kfuo, 'l', 'e' ) 5076 3070 ! 5077 3071 !-- Interpolation of e is replaced by the Neumann condition. … … 5083 3077 5084 3078 IF ( rans_mode_parent .AND. rans_mode .AND. rans_tke_e ) THEN 5085 CALL pmci_interp_1sto_lr( diss, dissc, ico, jco, kco, r1xo, & 5086 r2xo, r1yo, r2yo, r1zo, r2zo, & 5087 logc_w_l, logc_ratio_w_l, & 5088 logc_kbounds_w_l, nzt_topo_nestbc_l, & 5089 kcto, iflo, ifuo, jflo, jfuo, kflo, & 5090 kfuo, ijkfc_s, 'l', 's' ) 3079 CALL pmci_interp_1sto_lr( diss, dissc, kcto, jflo, jfuo, kflo, kfuo, 'l', 's' ) 5091 3080 ENDIF 5092 3081 5093 3082 IF ( .NOT. neutral ) THEN 5094 CALL pmci_interp_1sto_lr( pt, ptc, ico, jco, kco, r1xo, r2xo, & 5095 r1yo, r2yo, r1zo, r2zo, & 5096 logc_w_l, logc_ratio_w_l, & 5097 logc_kbounds_w_l, nzt_topo_nestbc_l, & 5098 kcto, iflo, ifuo, jflo, jfuo, kflo, & 5099 kfuo, ijkfc_s, 'l', 's' ) 3083 CALL pmci_interp_1sto_lr( pt, ptc, kcto, jflo, jfuo, kflo, kfuo, 'l', 's' ) 5100 3084 ENDIF 5101 3085 5102 3086 IF ( humidity ) THEN 5103 3087 5104 CALL pmci_interp_1sto_lr( q, q_c, ico, jco, kco, r1xo, r2xo, & 5105 r1yo, r2yo, r1zo, r2zo, & 5106 logc_w_l, logc_ratio_w_l, & 5107 logc_kbounds_w_l, nzt_topo_nestbc_l, & 5108 kcto, iflo, ifuo, jflo, jfuo, kflo, & 5109 kfuo, ijkfc_s, 'l', 's' ) 3088 CALL pmci_interp_1sto_lr( q, q_c, kcto, jflo, jfuo, kflo, kfuo, 'l', 's' ) 5110 3089 5111 3090 IF ( bulk_cloud_model .AND. microphysics_morrison ) THEN 5112 CALL pmci_interp_1sto_lr( qc, qcc, ico, jco, kco, r1xo, & 5113 r2xo, r1yo, r2yo, r1zo, r2zo, & 5114 logc_w_l, logc_ratio_w_l, & 5115 logc_kbounds_w_l, & 5116 nzt_topo_nestbc_l, & 5117 kcto, iflo, ifuo, jflo, jfuo, & 5118 kflo, kfuo, ijkfc_s, 'l', 's' ) 5119 5120 CALL pmci_interp_1sto_lr( nc, ncc, ico, jco, kco, r1xo, & 5121 r2xo, r1yo, r2yo, r1zo, r2zo, & 5122 logc_w_l, logc_ratio_w_l, & 5123 logc_kbounds_w_l, & 5124 nzt_topo_nestbc_l, & 5125 kcto, iflo, ifuo, jflo, jfuo, & 5126 kflo, kfuo, ijkfc_s, 'l', 's' ) 3091 CALL pmci_interp_1sto_lr( qc, qcc, kcto, jflo, jfuo, kflo, kfuo, 'l', 's' ) 3092 CALL pmci_interp_1sto_lr( nc, ncc, kcto, jflo, jfuo, kflo, kfuo, 'l', 's' ) 5127 3093 ENDIF 5128 3094 5129 3095 IF ( bulk_cloud_model .AND. microphysics_seifert ) THEN 5130 CALL pmci_interp_1sto_lr( qr, qrc, ico, jco, kco, r1xo, & 5131 r2xo, r1yo, r2yo, r1zo, r2zo, & 5132 logc_w_l, logc_ratio_w_l, & 5133 logc_kbounds_w_l, & 5134 nzt_topo_nestbc_l, & 5135 kcto, iflo, ifuo, jflo, jfuo, & 5136 kflo, kfuo, ijkfc_s, 'l', 's' ) 5137 5138 CALL pmci_interp_1sto_lr( nr, nrc, ico, jco, kco, r1xo, & 5139 r2xo, r1yo, r2yo, r1zo, r2zo, & 5140 logc_w_l, logc_ratio_w_l, & 5141 logc_kbounds_w_l, & 5142 nzt_topo_nestbc_l, & 5143 kcto, iflo, ifuo, jflo, jfuo, & 5144 kflo, kfuo, ijkfc_s, 'l', 's' ) 3096 CALL pmci_interp_1sto_lr( qr, qrc, kcto, jflo, jfuo, kflo, kfuo, 'l', 's' ) 3097 CALL pmci_interp_1sto_lr( nr, nrc, kcto, jflo, jfuo, kflo, kfuo, 'l', 's' ) 5145 3098 ENDIF 5146 3099 … … 5148 3101 5149 3102 IF ( passive_scalar ) THEN 5150 CALL pmci_interp_1sto_lr( s, sc, ico, jco, kco, r1xo, r2xo, & 5151 r1yo, r2yo, r1zo, r2zo, & 5152 logc_w_l, logc_ratio_w_l, & 5153 logc_kbounds_w_l, & 5154 nzt_topo_nestbc_l, & 5155 kcto, iflo, ifuo, jflo, jfuo, & 5156 kflo, kfuo, ijkfc_s, 'l', 's' ) 3103 CALL pmci_interp_1sto_lr( s, sc, kcto, jflo, jfuo, kflo, kfuo, 'l', 's' ) 5157 3104 ENDIF 5158 3105 5159 3106 IF ( air_chemistry .AND. nest_chemistry ) THEN 5160 3107 DO n = 1, nspec 5161 CALL pmci_interp_1sto_lr( chem_species(n)%conc, & 5162 chem_spec_c(:,:,:,n), & 5163 ico, jco, kco, r1xo, r2xo, & 5164 r1yo, r2yo, r1zo, r2zo, & 5165 logc_w_l, logc_ratio_w_l, & 5166 logc_kbounds_w_l, & 5167 nzt_topo_nestbc_l, & 5168 kcto, iflo, ifuo, jflo, jfuo, & 5169 kflo, kfuo, ijkfc_s, 'l', 's' ) 3108 CALL pmci_interp_1sto_lr( chem_species(n)%conc, chem_spec_c(:,:,:,n), & 3109 kcto, jflo, jfuo, kflo, kfuo, 'l', 's' ) 5170 3110 ENDDO 5171 3111 ENDIF … … 5176 3116 IF ( bc_dirichlet_r ) THEN 5177 3117 5178 CALL pmci_interp_1sto_lr( u, uc, icu, jco, kco, r1xu, r2xu, & 5179 r1yo, r2yo, r1zo, r2zo, & 5180 logc_u_r, logc_ratio_u_r, & 5181 logc_kbounds_u_r, nzt_topo_nestbc_r, & 5182 kcto, iflu, ifuu, jflo, jfuo, kflo, & 5183 kfuo, ijkfc_u, 'r', 'u' ) 5184 5185 CALL pmci_interp_1sto_lr( v, vc, ico, jcv, kco, r1xo, r2xo, & 5186 r1yv, r2yv, r1zo, r2zo, & 5187 logc_v_r, logc_ratio_v_r, & 5188 logc_kbounds_v_r, nzt_topo_nestbc_r, & 5189 kcto, iflo, ifuo, jflv, jfuv, kflo, & 5190 kfuo, ijkfc_v, 'r', 'v' ) 5191 5192 CALL pmci_interp_1sto_lr( w, wc, ico, jco, kcw, r1xo, r2xo, & 5193 r1yo, r2yo, r1zw, r2zw, & 5194 logc_w_r, logc_ratio_w_r, & 5195 logc_kbounds_w_r, nzt_topo_nestbc_r, & 5196 kctw, iflo, ifuo, jflo, jfuo, kflw, & 5197 kfuw, ijkfc_w, 'r', 'w' ) 5198 5199 IF ( ( rans_mode_parent .AND. rans_mode ) .OR. & 5200 ( .NOT. rans_mode_parent .AND. .NOT. rans_mode .AND. & 3118 CALL pmci_interp_1sto_lr( u, uc, kcto, jflo, jfuo, kflo, kfuo, 'r', 'u' ) 3119 CALL pmci_interp_1sto_lr( v, vc, kcto, jflv, jfuv, kflo, kfuo, 'r', 'v' ) 3120 CALL pmci_interp_1sto_lr( w, wc, kctw, jflo, jfuo, kflw, kfuw, 'r', 'w' ) 3121 3122 IF ( ( rans_mode_parent .AND. rans_mode ) .OR. & 3123 ( .NOT. rans_mode_parent .AND. .NOT. rans_mode .AND. & 5201 3124 .NOT. constant_diffusion ) ) THEN 5202 ! CALL pmci_interp_1sto_lr( e, ec, ico, jco, kco, r1xo, r2xo, & 5203 ! r1yo,r2yo, r1zo, r2zo, & 5204 ! logc_w_r, logc_ratio_w_r, & 5205 ! logc_kbounds_w_r, nzt_topo_nestbc_r, & 5206 ! kcto, iflo, ifuo, jflo, jfuo, kflo, & 5207 ! kfuo, ijkfc_s, 'r', 'e' ) 3125 ! CALL pmci_interp_1sto_lr( e, ec, kcto, iflo, ifuo, jflo, jfuo, kflo, kfuo, 'r', 'e' ) 5208 3126 ! 5209 3127 !-- Interpolation of e is replaced by the Neumann condition. … … 5214 3132 5215 3133 IF ( rans_mode_parent .AND. rans_mode .AND. rans_tke_e ) THEN 5216 CALL pmci_interp_1sto_lr( diss, dissc, ico, jco, kco, r1xo, & 5217 r2xo, r1yo,r2yo, r1zo, r2zo, & 5218 logc_w_r, logc_ratio_w_r, & 5219 logc_kbounds_w_r, nzt_topo_nestbc_r, & 5220 kcto, iflo, ifuo, jflo, jfuo, kflo, & 5221 kfuo, ijkfc_s, 'r', 's' ) 3134 CALL pmci_interp_1sto_lr( diss, dissc, kcto, jflo, jfuo, kflo, kfuo, 'r', 's' ) 5222 3135 5223 3136 ENDIF 5224 3137 5225 3138 IF ( .NOT. neutral ) THEN 5226 CALL pmci_interp_1sto_lr( pt, ptc, ico, jco, kco, r1xo, r2xo, & 5227 r1yo, r2yo, r1zo, r2zo, & 5228 logc_w_r, logc_ratio_w_r, & 5229 logc_kbounds_w_r, nzt_topo_nestbc_r, & 5230 kcto, iflo, ifuo, jflo, jfuo, kflo, & 5231 kfuo, ijkfc_s, 'r', 's' ) 3139 CALL pmci_interp_1sto_lr( pt, ptc, kcto, jflo, jfuo, kflo, kfuo, 'r', 's' ) 5232 3140 ENDIF 5233 3141 5234 3142 IF ( humidity ) THEN 5235 CALL pmci_interp_1sto_lr( q, q_c, ico, jco, kco, r1xo, r2xo, & 5236 r1yo, r2yo, r1zo, r2zo, & 5237 logc_w_r, logc_ratio_w_r, & 5238 logc_kbounds_w_r, nzt_topo_nestbc_r, & 5239 kcto, iflo, ifuo, jflo, jfuo, kflo, & 5240 kfuo, ijkfc_s, 'r', 's' ) 3143 CALL pmci_interp_1sto_lr( q, q_c, kcto, jflo, jfuo, kflo, kfuo, 'r', 's' ) 5241 3144 5242 3145 IF ( bulk_cloud_model .AND. microphysics_morrison ) THEN 5243 5244 CALL pmci_interp_1sto_lr( qc, qcc, ico, jco, kco, r1xo, & 5245 r2xo, r1yo, r2yo, r1zo, r2zo, & 5246 logc_w_r, logc_ratio_w_r, & 5247 logc_kbounds_w_r, & 5248 nzt_topo_nestbc_r, & 5249 kcto, iflo, ifuo, jflo, jfuo, & 5250 kflo, kfuo, ijkfc_s, 'r', 's' ) 5251 5252 CALL pmci_interp_1sto_lr( nc, ncc, ico, jco, kco, r1xo, & 5253 r2xo, r1yo, r2yo, r1zo, r2zo, & 5254 logc_w_r, logc_ratio_w_r, & 5255 logc_kbounds_w_r, & 5256 nzt_topo_nestbc_r, & 5257 kcto, iflo, ifuo, jflo, jfuo, & 5258 kflo, kfuo, ijkfc_s, 'r', 's' ) 5259 3146 CALL pmci_interp_1sto_lr( qc, qcc, kcto, jflo, jfuo, kflo, kfuo, 'r', 's' ) 3147 CALL pmci_interp_1sto_lr( nc, ncc, kcto, jflo, jfuo, kflo, kfuo, 'r', 's' ) 5260 3148 ENDIF 5261 3149 5262 3150 IF ( bulk_cloud_model .AND. microphysics_seifert ) THEN 5263 5264 5265 CALL pmci_interp_1sto_lr( qr, qrc, ico, jco, kco, r1xo, & 5266 r2xo, r1yo, r2yo, r1zo, r2zo, & 5267 logc_w_r, logc_ratio_w_r, & 5268 logc_kbounds_w_r, & 5269 nzt_topo_nestbc_r, & 5270 kcto, iflo, ifuo, jflo, jfuo, & 5271 kflo, kfuo, ijkfc_s, & 5272 'r', 's' ) 5273 5274 CALL pmci_interp_1sto_lr( nr, nrc, ico, jco, kco, r1xo, & 5275 r2xo, r1yo, r2yo, r1zo, r2zo, & 5276 logc_w_r, logc_ratio_w_r, & 5277 logc_kbounds_w_r, & 5278 nzt_topo_nestbc_r, & 5279 kcto, iflo, ifuo, jflo, jfuo, & 5280 kflo, kfuo, ijkfc_s, 'r', 's' ) 5281 3151 CALL pmci_interp_1sto_lr( qr, qrc, kcto, jflo, jfuo, kflo, kfuo, 'r', 's' ) 3152 CALL pmci_interp_1sto_lr( nr, nrc, kcto, jflo, jfuo, kflo, kfuo, 'r', 's' ) 5282 3153 ENDIF 5283 3154 … … 5285 3156 5286 3157 IF ( passive_scalar ) THEN 5287 CALL pmci_interp_1sto_lr( s, sc, ico, jco, kco, r1xo, r2xo, & 5288 r1yo, r2yo, r1zo, r2zo, & 5289 logc_w_r, logc_ratio_w_r, & 5290 logc_kbounds_w_r, & 5291 nzt_topo_nestbc_r, & 5292 kcto, iflo, ifuo, jflo, jfuo, & 5293 kflo, kfuo, ijkfc_s, 'r', 's' ) 3158 CALL pmci_interp_1sto_lr( s, sc, kcto, jflo, jfuo, kflo, kfuo, 'r', 's' ) 5294 3159 ENDIF 5295 3160 5296 3161 IF ( air_chemistry .AND. nest_chemistry ) THEN 5297 3162 DO n = 1, nspec 5298 CALL pmci_interp_1sto_lr( chem_species(n)%conc, & 5299 chem_spec_c(:,:,:,n), & 5300 ico, jco, kco, r1xo, r2xo, & 5301 r1yo, r2yo, r1zo, r2zo, & 5302 logc_w_r, logc_ratio_w_r, & 5303 logc_kbounds_w_r, & 5304 nzt_topo_nestbc_r, & 5305 kcto, iflo, ifuo, jflo, jfuo, & 5306 kflo, kfuo, ijkfc_s, 'r', 's' ) 3163 CALL pmci_interp_1sto_lr( chem_species(n)%conc, chem_spec_c(:,:,:,n), & 3164 kcto, jflo, jfuo, kflo, kfuo, 'r', 's' ) 5307 3165 ENDDO 5308 3166 ENDIF … … 5312 3170 IF ( bc_dirichlet_s ) THEN 5313 3171 5314 CALL pmci_interp_1sto_sn( v, vc, ico, jcv, kco, r1xo, r2xo, & 5315 r1yv, r2yv, r1zo, r2zo, & 5316 logc_v_s, logc_ratio_v_s, & 5317 logc_kbounds_v_s, nzt_topo_nestbc_s, & 5318 kcto, iflo, ifuo, jflv, jfuv, kflo, & 5319 kfuo, ijkfc_v, 's', 'v' ) 5320 5321 CALL pmci_interp_1sto_sn( w, wc, ico, jco, kcw, r1xo, r2xo, & 5322 r1yo, r2yo, r1zw, r2zw, & 5323 logc_w_s, logc_ratio_w_s, & 5324 logc_kbounds_w_s, nzt_topo_nestbc_s, & 5325 kctw, iflo, ifuo, jflo, jfuo, kflw, & 5326 kfuw, ijkfc_w, 's','w' ) 5327 5328 CALL pmci_interp_1sto_sn( u, uc, icu, jco, kco, r1xu, r2xu, & 5329 r1yo, r2yo, r1zo, r2zo, & 5330 logc_u_s, logc_ratio_u_s, & 5331 logc_kbounds_u_s, nzt_topo_nestbc_s, & 5332 kcto, iflu, ifuu, jflo, jfuo, kflo, & 5333 kfuo, ijkfc_u, 's', 'u' ) 3172 CALL pmci_interp_1sto_sn( v, vc, kcto, iflo, ifuo, kflo, kfuo, 's', 'v' ) 3173 CALL pmci_interp_1sto_sn( w, wc, kctw, iflo, ifuo, kflw, kfuw, 's', 'w' ) 3174 CALL pmci_interp_1sto_sn( u, uc, kcto, iflu, ifuu, kflo, kfuo, 's', 'u' ) 5334 3175 5335 3176 IF ( ( rans_mode_parent .AND. rans_mode ) .OR. & 5336 3177 ( .NOT. rans_mode_parent .AND. .NOT. rans_mode .AND. & 5337 3178 .NOT. constant_diffusion ) ) THEN 5338 ! CALL pmci_interp_1sto_sn( e, ec, ico, jco, kco, r1xo, r2xo, & 5339 ! r1yo, r2yo, r1zo, r2zo, & 5340 ! logc_w_s, logc_ratio_w_s, & 5341 ! logc_kbounds_w_s, nzt_topo_nestbc_s, & 5342 ! kcto, iflo, ifuo, jflo, jfuo, kflo, & 5343 ! kfuo, ijkfc_s, 's', 'e' ) 3179 ! CALL pmci_interp_1sto_sn( e, ec, kcto, iflo, ifuo, kflo, kfuo, 's', 'e' ) 5344 3180 ! 5345 3181 !-- Interpolation of e is replaced by the Neumann condition. … … 5350 3186 5351 3187 IF ( rans_mode_parent .AND. rans_mode .AND. rans_tke_e ) THEN 5352 CALL pmci_interp_1sto_sn( diss, dissc, ico, jco, kco, r1xo, & 5353 r2xo, r1yo, r2yo, r1zo, r2zo, & 5354 logc_w_s, logc_ratio_w_s, & 5355 logc_kbounds_w_s, nzt_topo_nestbc_s, & 5356 kcto, iflo, ifuo, jflo, jfuo, kflo, & 5357 kfuo, ijkfc_s, 's', 's' ) 3188 CALL pmci_interp_1sto_sn( diss, dissc, kcto, iflo, ifuo, kflo, kfuo, 's', 's' ) 5358 3189 ENDIF 5359 3190 5360 3191 IF ( .NOT. neutral ) THEN 5361 CALL pmci_interp_1sto_sn( pt, ptc, ico, jco, kco, r1xo, r2xo, & 5362 r1yo, r2yo, r1zo, r2zo, & 5363 logc_w_s, logc_ratio_w_s, & 5364 logc_kbounds_w_s, nzt_topo_nestbc_s, & 5365 kcto, iflo, ifuo, jflo, jfuo, kflo, & 5366 kfuo, ijkfc_s, 's', 's' ) 3192 CALL pmci_interp_1sto_sn( pt, ptc, kcto, iflo, ifuo, kflo, kfuo, 's', 's' ) 5367 3193 ENDIF 5368 3194 5369 3195 IF ( humidity ) THEN 5370 CALL pmci_interp_1sto_sn( q, q_c, ico, jco, kco, r1xo, r2xo, & 5371 r1yo,r2yo, r1zo, r2zo, & 5372 logc_w_s, logc_ratio_w_s, & 5373 logc_kbounds_w_s, nzt_topo_nestbc_s, & 5374 kcto, iflo, ifuo, jflo, jfuo, kflo, & 5375 kfuo, ijkfc_s, 's', 's' ) 3196 CALL pmci_interp_1sto_sn( q, q_c, kcto, iflo, ifuo, kflo, kfuo, 's', 's' ) 5376 3197 5377 3198 IF ( bulk_cloud_model .AND. microphysics_morrison ) THEN 5378 5379 CALL pmci_interp_1sto_sn( qc, qcc, ico, jco, kco, r1xo, & 5380 r2xo, r1yo,r2yo, r1zo, r2zo, & 5381 logc_w_s, logc_ratio_w_s, & 5382 logc_kbounds_w_s, & 5383 nzt_topo_nestbc_s, & 5384 kcto, iflo, ifuo, jflo, jfuo, & 5385 kflo, kfuo, ijkfc_s, 's', 's' ) 5386 5387 CALL pmci_interp_1sto_sn( nc, ncc, ico, jco, kco, r1xo, & 5388 r2xo, r1yo,r2yo, r1zo, r2zo, & 5389 logc_w_s, logc_ratio_w_s, & 5390 logc_kbounds_w_s, & 5391 nzt_topo_nestbc_s, & 5392 kcto, iflo, ifuo, jflo, jfuo, & 5393 kflo, kfuo, ijkfc_s, 's', 's' ) 5394 3199 CALL pmci_interp_1sto_sn( qc, qcc, kcto, iflo, ifuo, kflo, kfuo, 's', 's' ) 3200 CALL pmci_interp_1sto_sn( nc, ncc, kcto, iflo, ifuo, kflo, kfuo, 's', 's' ) 5395 3201 ENDIF 5396 3202 5397 3203 IF ( bulk_cloud_model .AND. microphysics_seifert ) THEN 5398 5399 CALL pmci_interp_1sto_sn( qr, qrc, ico, jco, kco, r1xo, & 5400 r2xo, r1yo,r2yo, r1zo, r2zo, & 5401 logc_w_s, logc_ratio_w_s, & 5402 logc_kbounds_w_s, & 5403 nzt_topo_nestbc_s, & 5404 kcto, iflo, ifuo, jflo, jfuo, & 5405 kflo, kfuo, ijkfc_s, 's', 's' ) 5406 5407 CALL pmci_interp_1sto_sn( nr, nrc, ico, jco, kco, r1xo, & 5408 r2xo, r1yo,r2yo, r1zo, r2zo, & 5409 logc_w_s, logc_ratio_w_s, & 5410 logc_kbounds_w_s, & 5411 nzt_topo_nestbc_s, & 5412 kcto, iflo, ifuo, jflo, jfuo, & 5413 kflo, kfuo, ijkfc_s, 's', 's' ) 5414 3204 CALL pmci_interp_1sto_sn( qr, qrc, kcto, iflo, ifuo, kflo, kfuo, 's', 's' ) 3205 CALL pmci_interp_1sto_sn( nr, nrc, kcto, iflo, ifuo, kflo, kfuo, 's', 's' ) 5415 3206 ENDIF 5416 3207 … … 5418 3209 5419 3210 IF ( passive_scalar ) THEN 5420 CALL pmci_interp_1sto_sn( s, sc, ico, jco, kco, r1xo, r2xo, & 5421 r1yo,r2yo, r1zo, r2zo, & 5422 logc_w_s, logc_ratio_w_s, & 5423 logc_kbounds_w_s, & 5424 nzt_topo_nestbc_s, & 5425 kcto, iflo, ifuo, jflo, jfuo, & 5426 kflo, kfuo, ijkfc_s, 's', 's' ) 3211 CALL pmci_interp_1sto_sn( s, sc, kcto, iflo, ifuo, kflo, kfuo, 's', 's' ) 5427 3212 ENDIF 5428 3213 5429 3214 IF ( air_chemistry .AND. nest_chemistry ) THEN 5430 3215 DO n = 1, nspec 5431 CALL pmci_interp_1sto_sn( chem_species(n)%conc, & 5432 chem_spec_c(:,:,:,n), & 5433 ico, jco, kco, r1xo, r2xo, & 5434 r1yo, r2yo, r1zo, r2zo, & 5435 logc_w_s, logc_ratio_w_s, & 5436 logc_kbounds_w_s, & 5437 nzt_topo_nestbc_s, & 5438 kcto, iflo, ifuo, jflo, jfuo, & 5439 kflo, kfuo, ijkfc_s, 's', 's' ) 3216 CALL pmci_interp_1sto_sn( chem_species(n)%conc, chem_spec_c(:,:,:,n), & 3217 kcto, iflo, ifuo, kflo, kfuo, 's', 's' ) 5440 3218 ENDDO 5441 3219 ENDIF … … 5445 3223 IF ( bc_dirichlet_n ) THEN 5446 3224 5447 CALL pmci_interp_1sto_sn( u, uc, icu, jco, kco, r1xu, r2xu, & 5448 r1yo, r2yo, r1zo, r2zo, & 5449 logc_u_n, logc_ratio_u_n, & 5450 logc_kbounds_u_n, nzt_topo_nestbc_n, & 5451 kcto, iflu, ifuu, jflo, jfuo, kflo, & 5452 kfuo, ijkfc_u, 'n', 'u' ) 5453 5454 CALL pmci_interp_1sto_sn( v, vc, ico, jcv, kco, r1xo, r2xo, & 5455 r1yv, r2yv, r1zo, r2zo, & 5456 logc_v_n, logc_ratio_v_n, & 5457 logc_kbounds_v_n, nzt_topo_nestbc_n, & 5458 kcto, iflo, ifuo, jflv, jfuv, kflo, & 5459 kfuo, ijkfc_v, 'n', 'v' ) 5460 5461 CALL pmci_interp_1sto_sn( w, wc, ico, jco, kcw, r1xo, r2xo, & 5462 r1yo, r2yo, r1zw, r2zw, & 5463 logc_w_n, logc_ratio_w_n, & 5464 logc_kbounds_w_n, nzt_topo_nestbc_n, & 5465 kctw, iflo, ifuo, jflo, jfuo, kflw, & 5466 kfuw, ijkfc_w, 'n', 'w' ) 5467 5468 IF ( ( rans_mode_parent .AND. rans_mode ) .OR. & 5469 ( .NOT. rans_mode_parent .AND. .NOT. rans_mode .AND. & 3225 CALL pmci_interp_1sto_sn( v, vc, kcto, iflo, ifuo, kflo, kfuo, 'n', 'v' ) 3226 CALL pmci_interp_1sto_sn( w, wc, kctw, iflo, ifuo, kflw, kfuw, 'n', 'w' ) 3227 CALL pmci_interp_1sto_sn( u, uc, kcto, iflu, ifuu, kflo, kfuo, 'n', 'u' ) 3228 3229 IF ( ( rans_mode_parent .AND. rans_mode ) .OR. & 3230 ( .NOT. rans_mode_parent .AND. .NOT. rans_mode .AND. & 5470 3231 .NOT. constant_diffusion ) ) THEN 5471 ! CALL pmci_interp_1sto_sn( e, ec, ico, jco, kco, r1xo, r2xo, & 5472 ! r1yo, r2yo, r1zo, r2zo, & 5473 ! logc_w_n, logc_ratio_w_n, & 5474 ! logc_kbounds_w_n, nzt_topo_nestbc_n, & 5475 ! kcto, iflo, ifuo, jflo, jfuo, kflo, & 5476 ! kfuo, ijkfc_s, 'n', 'e' ) 3232 ! CALL pmci_interp_1sto_sn( e, ec, kcto, iflo, ifuo, kflo, kfuo, 'n', 'e' ) 5477 3233 ! 5478 3234 !-- Interpolation of e is replaced by the Neumann condition. … … 5483 3239 5484 3240 IF ( rans_mode_parent .AND. rans_mode .AND. rans_tke_e ) THEN 5485 CALL pmci_interp_1sto_sn( diss, dissc, ico, jco, kco, r1xo, & 5486 r2xo, r1yo, r2yo, r1zo, r2zo, & 5487 logc_w_n, logc_ratio_w_n, & 5488 logc_kbounds_w_n, nzt_topo_nestbc_n, & 5489 kcto, iflo, ifuo, jflo, jfuo, kflo, & 5490 kfuo, ijkfc_s, 'n', 's' ) 5491 3241 CALL pmci_interp_1sto_sn( diss, dissc, kcto, iflo, ifuo, kflo, kfuo, 'n', 's' ) 5492 3242 ENDIF 5493 3243 5494 3244 IF ( .NOT. neutral ) THEN 5495 CALL pmci_interp_1sto_sn( pt, ptc, ico, jco, kco, r1xo, r2xo, & 5496 r1yo, r2yo, r1zo, r2zo, & 5497 logc_w_n, logc_ratio_w_n, & 5498 logc_kbounds_w_n, nzt_topo_nestbc_n, & 5499 kcto, iflo, ifuo, jflo, jfuo, kflo, & 5500 kfuo, ijkfc_s, 'n', 's' ) 3245 CALL pmci_interp_1sto_sn( pt, ptc, kcto, iflo, ifuo, kflo, kfuo, 'n', 's' ) 5501 3246 ENDIF 5502 3247 5503 3248 IF ( humidity ) THEN 5504 CALL pmci_interp_1sto_sn( q, q_c, ico, jco, kco, r1xo, r2xo, & 5505 r1yo, r2yo, r1zo, r2zo, & 5506 logc_w_n, logc_ratio_w_n, & 5507 logc_kbounds_w_n, nzt_topo_nestbc_n, & 5508 kcto, iflo, ifuo, jflo, jfuo, kflo, & 5509 kfuo, ijkfc_s, 'n', 's' ) 3249 CALL pmci_interp_1sto_sn( q, q_c, kcto, iflo, ifuo, kflo, kfuo, 'n', 's' ) 5510 3250 5511 3251 IF ( bulk_cloud_model .AND. microphysics_morrison ) THEN 5512 5513 CALL pmci_interp_1sto_sn( qc, qcc, ico, jco, kco, r1xo, & 5514 r2xo, r1yo, r2yo, r1zo, r2zo, & 5515 logc_w_n, logc_ratio_w_n, & 5516 logc_kbounds_w_n, & 5517 nzt_topo_nestbc_n, & 5518 kcto, iflo, ifuo, jflo, jfuo, & 5519 kflo, kfuo, ijkfc_s, 'n', 's' ) 5520 5521 CALL pmci_interp_1sto_sn( nc, ncc, ico, jco, kco, r1xo, & 5522 r2xo, r1yo, r2yo, r1zo, r2zo, & 5523 logc_u_n, logc_ratio_u_n, & 5524 logc_kbounds_w_n, & 5525 nzt_topo_nestbc_n, & 5526 kcto, iflo, ifuo, jflo, jfuo, & 5527 kflo, kfuo, ijkfc_s, 'n', 's' ) 5528 3252 CALL pmci_interp_1sto_sn( qc, qcc, kcto, iflo, ifuo, kflo, kfuo, 'n', 's' ) 3253 CALL pmci_interp_1sto_sn( nc, ncc, kcto, iflo, ifuo, kflo, kfuo, 'n', 's' ) 5529 3254 ENDIF 5530 3255 5531 3256 IF ( bulk_cloud_model .AND. microphysics_seifert ) THEN 5532 5533 CALL pmci_interp_1sto_sn( qr, qrc, ico, jco, kco, r1xo, & 5534 r2xo, r1yo, r2yo, r1zo, r2zo, & 5535 logc_w_n, logc_ratio_w_n, & 5536 logc_kbounds_w_n, & 5537 nzt_topo_nestbc_n, & 5538 kcto, iflo, ifuo, jflo, jfuo, & 5539 kflo, kfuo, ijkfc_s, 'n', 's' ) 5540 5541 CALL pmci_interp_1sto_sn( nr, nrc, ico, jco, kco, r1xo, & 5542 r2xo, r1yo, r2yo, r1zo, r2zo, & 5543 logc_w_n, logc_ratio_w_n, & 5544 logc_kbounds_w_n, & 5545 nzt_topo_nestbc_n, & 5546 kcto, iflo, ifuo, jflo, jfuo, & 5547 kflo, kfuo, ijkfc_s, 'n', 's' ) 5548 3257 CALL pmci_interp_1sto_sn( qr, qrc, kcto, iflo, ifuo, kflo, kfuo, 'n', 's' ) 3258 CALL pmci_interp_1sto_sn( nr, nrc, kcto, iflo, ifuo, kflo, kfuo, 'n', 's' ) 5549 3259 ENDIF 5550 3260 … … 5552 3262 5553 3263 IF ( passive_scalar ) THEN 5554 CALL pmci_interp_1sto_sn( s, sc, ico, jco, kco, r1xo, r2xo, & 5555 r1yo, r2yo, r1zo, r2zo, & 5556 logc_w_n, logc_ratio_w_n, & 5557 logc_kbounds_w_n, & 5558 nzt_topo_nestbc_n, & 5559 kcto, iflo, ifuo, jflo, jfuo, & 5560 kflo, kfuo, ijkfc_s, 'n', 's' ) 3264 CALL pmci_interp_1sto_sn( s, sc, kcto, iflo, ifuo, kflo, kfuo, 'n', 's' ) 5561 3265 ENDIF 5562 3266 5563 3267 IF ( air_chemistry .AND. nest_chemistry ) THEN 5564 3268 DO n = 1, nspec 5565 CALL pmci_interp_1sto_sn( chem_species(n)%conc, & 5566 chem_spec_c(:,:,:,n), & 5567 ico, jco, kco, r1xo, r2xo, & 5568 r1yo, r2yo, r1zo, r2zo, & 5569 logc_w_n, logc_ratio_w_n, & 5570 logc_kbounds_w_n, & 5571 nzt_topo_nestbc_n, & 5572 kcto, iflo, ifuo, jflo, jfuo, & 5573 kflo, kfuo, ijkfc_s, 'n', 's' ) 3269 CALL pmci_interp_1sto_sn( chem_species(n)%conc, chem_spec_c(:,:,:,n), & 3270 kcto, iflo, ifuo, kflo, kfuo, 'n', 's' ) 5574 3271 ENDDO 5575 3272 ENDIF … … 5579 3276 ! 5580 3277 !-- All PEs are top-border PEs 5581 CALL pmci_interp_1sto_t( w, wc, ico, jco, kcw, r1xo, r2xo, r1yo, & 5582 r2yo, r1zw, r2zw, kctw, iflo, ifuo, & 5583 jflo, jfuo, kflw, kfuw, ijkfc_w, 'w' ) 5584 CALL pmci_interp_1sto_t( u, uc, icu, jco, kco, r1xu, r2xu, r1yo, & 5585 r2yo, r1zo, r2zo, kcto, iflu, ifuu, & 5586 jflo, jfuo, kflo, kfuo, ijkfc_u, 'u' ) 5587 CALL pmci_interp_1sto_t( v, vc, ico, jcv, kco, r1xo, r2xo, r1yv, & 5588 r2yv, r1zo, r2zo, kcto, iflo, ifuo, & 5589 jflv, jfuv, kflo, kfuo, ijkfc_v, 'v' ) 5590 3278 CALL pmci_interp_1sto_t( w, wc, kctw, iflo, ifuo, jflo, jfuo, 'w' ) 3279 CALL pmci_interp_1sto_t( u, uc, kcto, iflu, ifuu, jflo, jfuo, 'u' ) 3280 CALL pmci_interp_1sto_t( v, vc, kcto, iflo, ifuo, jflv, jfuv, 'v' ) 5591 3281 5592 3282 IF ( ( rans_mode_parent .AND. rans_mode ) .OR. & 5593 3283 ( .NOT. rans_mode_parent .AND. .NOT. rans_mode .AND. & 5594 3284 .NOT. constant_diffusion ) ) THEN 5595 ! CALL pmci_interp_1sto_t( e, ec, ico, jco, kco, r1xo, r2xo, r1yo, & 5596 ! r2yo, r1zo, r2zo, kcto, iflo, ifuo, & 5597 ! jflo, jfuo, kflo, kfuo, ijkfc_s, 'e' ) 3285 ! CALL pmci_interp_1sto_t( e, ec, kcto, iflo, ifuo, jflo, jfuo, 'e' ) 5598 3286 ! 5599 3287 !-- Interpolation of e is replaced by the Neumann condition. 5600 3288 e(nzt+1,nys:nyn,nxl:nxr) = e(nzt,nys:nyn,nxl:nxr) 5601 5602 3289 ENDIF 5603 3290 5604 3291 IF ( rans_mode_parent .AND. rans_mode .AND. rans_tke_e ) THEN 5605 CALL pmci_interp_1sto_t( diss, dissc, ico, jco, kco, r1xo, r2xo, & 5606 r1yo, r2yo, r1zo, r2zo, kcto, iflo, ifuo, & 5607 jflo, jfuo, kflo, kfuo, ijkfc_s, 's' ) 3292 CALL pmci_interp_1sto_t( diss, dissc, kcto, iflo, ifuo, jflo, jfuo, 's' ) 5608 3293 ENDIF 5609 3294 5610 3295 IF ( .NOT. neutral ) THEN 5611 CALL pmci_interp_1sto_t( pt, ptc, ico, jco, kco, r1xo, r2xo, & 5612 r1yo, r2yo, r1zo, r2zo, kcto, iflo, ifuo, & 5613 jflo, jfuo, kflo, kfuo, ijkfc_s, 's' ) 3296 CALL pmci_interp_1sto_t( pt, ptc, kcto, iflo, ifuo, jflo, jfuo, 's' ) 5614 3297 ENDIF 5615 3298 5616 3299 IF ( humidity ) THEN 5617 5618 CALL pmci_interp_1sto_t( q, q_c, ico, jco, kco, r1xo, r2xo, r1yo, & 5619 r2yo, r1zo, r2zo, kcto, iflo, ifuo, & 5620 jflo, jfuo, kflo, kfuo, ijkfc_s, 's' ) 5621 3300 CALL pmci_interp_1sto_t( q, q_c, kcto, iflo, ifuo, jflo, jfuo, 's' ) 5622 3301 IF ( bulk_cloud_model .AND. microphysics_morrison ) THEN 5623 5624 CALL pmci_interp_1sto_t( qc, qcc, ico, jco, kco, r1xo, r2xo, r1yo,& 5625 r2yo, r1zo, r2zo, kcto, iflo, ifuo, & 5626 jflo, jfuo, kflo, kfuo, ijkfc_s, 's' ) 5627 5628 CALL pmci_interp_1sto_t( nc, ncc, ico, jco, kco, r1xo, r2xo, r1yo,& 5629 r2yo, r1zo, r2zo, kcto, iflo, ifuo, & 5630 jflo, jfuo, kflo, kfuo, ijkfc_s, 's' ) 5631 3302 CALL pmci_interp_1sto_t( qc, qcc, kcto, iflo, ifuo, jflo, jfuo, 's' ) 3303 CALL pmci_interp_1sto_t( nc, ncc, kcto, iflo, ifuo, jflo, jfuo, 's' ) 5632 3304 ENDIF 5633 5634 3305 IF ( bulk_cloud_model .AND. microphysics_seifert ) THEN 5635 5636 5637 CALL pmci_interp_1sto_t( qr, qrc, ico, jco, kco, r1xo, r2xo, r1yo,& 5638 r2yo, r1zo, r2zo, kcto, iflo, ifuo, & 5639 jflo, jfuo, kflo, kfuo, ijkfc_s, 's' ) 5640 5641 CALL pmci_interp_1sto_t( nr, nrc, ico, jco, kco, r1xo, r2xo, r1yo,& 5642 r2yo, r1zo, r2zo, kcto, iflo, ifuo, & 5643 jflo, jfuo, kflo, kfuo, ijkfc_s, 's' ) 5644 3306 CALL pmci_interp_1sto_t( qr, qrc, kcto, iflo, ifuo, jflo, jfuo, 's' ) 3307 CALL pmci_interp_1sto_t( nr, nrc, kcto, iflo, ifuo, jflo, jfuo, 's' ) 5645 3308 ENDIF 5646 5647 3309 ENDIF 5648 3310 5649 3311 IF ( passive_scalar ) THEN 5650 CALL pmci_interp_1sto_t( s, sc, ico, jco, kco, r1xo, r2xo, r1yo, & 5651 r2yo, r1zo, r2zo, kcto, iflo, ifuo, & 5652 jflo, jfuo, kflo, kfuo, ijkfc_s, 's' ) 3312 CALL pmci_interp_1sto_t( s, sc, kcto, iflo, ifuo, jflo, jfuo, 's' ) 5653 3313 ENDIF 5654 3314 5655 3315 IF ( air_chemistry .AND. nest_chemistry ) THEN 5656 3316 DO n = 1, nspec 5657 CALL pmci_interp_1sto_t( chem_species(n)%conc, & 5658 chem_spec_c(:,:,:,n), & 5659 ico, jco, kco, r1xo, r2xo, & 5660 r1yo, r2yo, r1zo, r2zo, & 5661 kcto, iflo, ifuo, jflo, jfuo, & 5662 kflo, kfuo, ijkfc_s, 's' ) 3317 CALL pmci_interp_1sto_t( chem_species(n)%conc, chem_spec_c(:,:,:,n), & 3318 kcto, iflo, ifuo, jflo, jfuo, 's' ) 5663 3319 ENDDO 5664 3320 ENDIF … … 5674 3330 !-- Note that TKE is not anterpolated. 5675 3331 IMPLICIT NONE 5676 5677 3332 INTEGER(iwp) :: n !< running index for number of chemical species 5678 3333 5679 CALL pmci_anterp_tophat( u, uc, kcto, iflu, ifuu, jflo, jfuo, kflo, & 5680 kfuo, ijkfc_u, 'u' ) 5681 CALL pmci_anterp_tophat( v, vc, kcto, iflo, ifuo, jflv, jfuv, kflo, & 5682 kfuo, ijkfc_v, 'v' ) 5683 CALL pmci_anterp_tophat( w, wc, kctw, iflo, ifuo, jflo, jfuo, kflw, & 5684 kfuw, ijkfc_w, 'w' ) 3334 3335 CALL pmci_anterp_tophat( u, uc, kcto, iflu, ifuu, jflo, jfuo, kflo, kfuo, ijkfc_u, 'u' ) 3336 CALL pmci_anterp_tophat( v, vc, kcto, iflo, ifuo, jflv, jfuv, kflo, kfuo, ijkfc_v, 'v' ) 3337 CALL pmci_anterp_tophat( w, wc, kctw, iflo, ifuo, jflo, jfuo, kflw, kfuw, ijkfc_w, 'w' ) 5685 3338 ! 5686 3339 !-- Anterpolation of TKE and dissipation rate if parent and child are in 5687 3340 !-- RANS mode. 5688 3341 IF ( rans_mode_parent .AND. rans_mode ) THEN 5689 CALL pmci_anterp_tophat( e, ec, kcto, iflo, ifuo, jflo, jfuo, kflo, & 5690 kfuo, ijkfc_s, 'e' ) 3342 CALL pmci_anterp_tophat( e, ec, kcto, iflo, ifuo, jflo, jfuo, kflo, kfuo, ijkfc_s, 'e' ) 5691 3343 ! 5692 3344 !-- Anterpolation of dissipation rate only if TKE-e closure is applied. … … 5699 3351 5700 3352 IF ( .NOT. neutral ) THEN 5701 CALL pmci_anterp_tophat( pt, ptc, kcto, iflo, ifuo, jflo, jfuo, kflo, & 5702 kfuo, ijkfc_s, 'pt' ) 3353 CALL pmci_anterp_tophat( pt, ptc, kcto, iflo, ifuo, jflo, jfuo, kflo, kfuo, ijkfc_s, 'pt' ) 5703 3354 ENDIF 5704 3355 5705 3356 IF ( humidity ) THEN 5706 3357 5707 CALL pmci_anterp_tophat( q, q_c, kcto, iflo, ifuo, jflo, jfuo, kflo, & 5708 kfuo, ijkfc_s, 'q' ) 3358 CALL pmci_anterp_tophat( q, q_c, kcto, iflo, ifuo, jflo, jfuo, kflo, kfuo, ijkfc_s, 'q' ) 5709 3359 5710 3360 IF ( bulk_cloud_model .AND. microphysics_morrison ) THEN 5711 3361 5712 CALL pmci_anterp_tophat( qc, qcc, kcto, iflo, ifuo, jflo, jfuo, &3362 CALL pmci_anterp_tophat( qc, qcc, kcto, iflo, ifuo, jflo, jfuo, & 5713 3363 kflo, kfuo, ijkfc_s, 'qc' ) 5714 5715 CALL pmci_anterp_tophat( nc, ncc, kcto, iflo, ifuo, jflo, jfuo, &3364 3365 CALL pmci_anterp_tophat( nc, ncc, kcto, iflo, ifuo, jflo, jfuo, & 5716 3366 kflo, kfuo, ijkfc_s, 'nc' ) 5717 3367 … … 5720 3370 IF ( bulk_cloud_model .AND. microphysics_seifert ) THEN 5721 3371 5722 CALL pmci_anterp_tophat( qr, qrc, kcto, iflo, ifuo, jflo, jfuo, &3372 CALL pmci_anterp_tophat( qr, qrc, kcto, iflo, ifuo, jflo, jfuo, & 5723 3373 kflo, kfuo, ijkfc_s, 'qr' ) 5724 3374 5725 CALL pmci_anterp_tophat( nr, nrc, kcto, iflo, ifuo, jflo, jfuo, &3375 CALL pmci_anterp_tophat( nr, nrc, kcto, iflo, ifuo, jflo, jfuo, & 5726 3376 kflo, kfuo, ijkfc_s, 'nr' ) 5727 3377 … … 5731 3381 5732 3382 IF ( passive_scalar ) THEN 5733 CALL pmci_anterp_tophat( s, sc, kcto, iflo, ifuo, jflo, jfuo, kflo, & 5734 kfuo, ijkfc_s, 's' ) 3383 CALL pmci_anterp_tophat( s, sc, kcto, iflo, ifuo, jflo, jfuo, kflo, kfuo, ijkfc_s, 's' ) 5735 3384 ENDIF 5736 3385 5737 3386 IF ( air_chemistry .AND. nest_chemistry ) THEN 5738 3387 DO n = 1, nspec 5739 CALL pmci_anterp_tophat( chem_species(n)%conc, & 5740 chem_spec_c(:,:,:,n), & 5741 kcto, iflo, ifuo, jflo, jfuo, kflo, & 5742 kfuo, ijkfc_s, 's' ) 3388 CALL pmci_anterp_tophat( chem_species(n)%conc, chem_spec_c(:,:,:,n), & 3389 kcto, iflo, ifuo, jflo, jfuo, kflo, kfuo, ijkfc_s, 's' ) 5743 3390 ENDDO 5744 3391 ENDIF … … 5748 3395 5749 3396 5750 SUBROUTINE pmci_interp_1sto_lr( f, fc, ic, jc, kc, r1x, r2x, r1y, r2y, r1z, & 5751 r2z, logc, logc_ratio, logc_kbounds, & 5752 nzt_topo_nestbc, & 5753 kct, ifl, ifu, jfl, jfu, kfl, kfu, ijkfc, & 5754 edge, var ) 3397 SUBROUTINE pmci_interp_1sto_lr( f, fc, kct, jfl, jfu, kfl, kfu, edge, var ) 5755 3398 ! 5756 3399 !-- Interpolation of ghost-node values used as the child-domain boundary … … 5758 3401 IMPLICIT NONE 5759 3402 5760 INTEGER(iwp) :: nzt_topo_nestbc !< 5761 5762 REAL(wp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg), & 5763 INTENT(INOUT) :: f !< 5764 REAL(wp), DIMENSION(0:cg%nz+1,jcs:jcn,icl:icr), & 5765 INTENT(IN) :: fc !< 5766 REAL(wp), DIMENSION(1:2,0:ncorr-1,nzb:nzt_topo_nestbc,nys:nyn), & 5767 INTENT(IN) :: logc_ratio !< 5768 !AH REAL(wp), DIMENSION(nxlg:nxrg), INTENT(IN) :: r1x !< 5769 !AH REAL(wp), DIMENSION(nxlg:nxrg), INTENT(IN) :: r2x !< 5770 !AH REAL(wp), DIMENSION(nysg:nyng), INTENT(IN) :: r1y !< 5771 !AH REAL(wp), DIMENSION(nysg:nyng), INTENT(IN) :: r2y !< 5772 REAL(wp), DIMENSION(nxlfc:nxrfc), INTENT(IN) :: r1x !< 5773 REAL(wp), DIMENSION(nxlfc:nxrfc), INTENT(IN) :: r2x !< 5774 REAL(wp), DIMENSION(nysfc:nynfc), INTENT(IN) :: r1y !< 5775 REAL(wp), DIMENSION(nysfc:nynfc), INTENT(IN) :: r2y !< 5776 5777 !AH REAL(wp), DIMENSION(nzb:nzt+1), INTENT(IN) :: r1z !< 5778 !AH REAL(wp), DIMENSION(nzb:nzt+1), INTENT(IN) :: r2z !< 5779 REAL(wp), DIMENSION(nzb:nzt+kgsr), INTENT(IN) :: r1z !< 5780 REAL(wp), DIMENSION(nzb:nzt+kgsr), INTENT(IN) :: r2z !< 5781 5782 5783 INTEGER(iwp), DIMENSION(nxlfc:nxrfc), INTENT(IN) :: ic !< 5784 INTEGER(iwp), DIMENSION(nysfc:nynfc), INTENT(IN) :: jc !< 5785 !AH INTEGER(iwp), DIMENSION(nzb:nzt+1), INTENT(IN) :: kc !< 5786 INTEGER(iwp), DIMENSION(nzb:nzt+kgsr), INTENT(IN) :: kc !< 5787 INTEGER(iwp), DIMENSION(1:2,nzb:nzt_topo_nestbc,nys:nyn), & 5788 INTENT(IN) :: logc !< 5789 INTEGER(iwp), DIMENSION(1:2,nys:nyn), INTENT(IN) :: logc_kbounds !< 5790 5791 INTEGER(iwp) :: kct 5792 5793 !AH 5794 ! INTEGER(iwp), DIMENSION(icl:icr), INTENT(IN) :: ifl !< Indicates start index of child cells belonging to certain parent cell - x direction 5795 ! INTEGER(iwp), DIMENSION(icl:icr), INTENT(IN) :: ifu !< Indicates end index of child cells belonging to certain parent cell - x direction 5796 ! INTEGER(iwp), DIMENSION(jcs:jcn), INTENT(IN) :: jfl !< Indicates start index of child cells belonging to certain parent cell - y direction 5797 ! INTEGER(iwp), DIMENSION(jcs:jcn), INTENT(IN) :: jfu !< Indicates start index of child cells belonging to certain parent cell - y direction 5798 INTEGER(iwp), DIMENSION(icla:icra), INTENT(IN) :: ifl !< Indicates start index of child cells belonging to certain parent cell - x direction 5799 INTEGER(iwp), DIMENSION(icla:icra), INTENT(IN) :: ifu !< Indicates end index of child cells belonging to certain parent cell - x direction 5800 INTEGER(iwp), DIMENSION(jcsa:jcna), INTENT(IN) :: jfl !< Indicates start index of child cells belonging to certain parent cell - y direction 5801 INTEGER(iwp), DIMENSION(jcsa:jcna), INTENT(IN) :: jfu !< Indicates start index of child cells belonging to certain parent cell - y direction 5802 !AH 5803 5804 !AH INTEGER(iwp), DIMENSION(0:kct), INTENT(IN) :: kfl !< Indicates start index of child cells belonging to certain parent cell - z direction 5805 !AH INTEGER(iwp), DIMENSION(0:kct), INTENT(IN) :: kfu !< Indicates start index of child cells belonging to certain parent cell - z direction 5806 INTEGER(iwp), DIMENSION(0:cg%nz+1), INTENT(IN) :: kfl !< Indicates start index of child cells belonging to certain parent cell - z direction 5807 INTEGER(iwp), DIMENSION(0:cg%nz+1), INTENT(IN) :: kfu !< Indicates start index of child cells belonging to certain parent cell - z direction 5808 5809 !AH INTEGER(iwp), DIMENSION(0:kct,jcs:jcn,icl:icr), INTENT(IN) :: ijkfc !< number of child grid points contributing to a parent grid box 5810 !AH 5811 ! INTEGER(iwp), DIMENSION(0:cg%nz+1,jcs:jcn,icl:icr), INTENT(IN) :: ijkfc !< number of child grid points contributing to a parent grid box 5812 INTEGER(iwp), DIMENSION(0:cg%nz+1,jcsa:jcna,icla:icra), INTENT(IN) :: ijkfc !< number of child grid points contributing to a parent grid box 5813 !AH 5814 5815 CHARACTER(LEN=1), INTENT(IN) :: edge !< Edge symbol: 'l', 'r', 's' or 'n' 5816 CHARACTER(LEN=1), INTENT(IN) :: var !< Variable symbol: 'u', 'v', 'w' or 's' 5817 5818 INTEGER(iwp) :: i !< Lower bound of the running index ia 5819 INTEGER(iwp) :: ia !< i-index running over the parent-grid cell on the boundary 5820 INTEGER(iwp) :: iaw !< Reduced ia-index for workarr_lr 5821 INTEGER(iwp) :: iawbc !< iaw-index pointing to the boundary-value nodes (either 0 or igsr-1) 3403 REAL(wp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg), INTENT(INOUT) :: f !< Child-grid array 3404 REAL(wp), DIMENSION(0:cg%nz+1,jcs:jcn,icl:icr), INTENT(IN) :: fc !< Parent-grid array 3405 INTEGER(iwp) :: kct !< The parent-grid index in z-direction just below the boundary value node 3406 INTEGER(iwp), DIMENSION(jcsa:jcna), INTENT(IN) :: jfl !< Indicates start index of child cells belonging to certain parent cell - y direction 3407 INTEGER(iwp), DIMENSION(jcsa:jcna), INTENT(IN) :: jfu !< Indicates end index of child cells belonging to certain parent cell - y direction 3408 INTEGER(iwp), DIMENSION(0:cg%nz+1), INTENT(IN) :: kfl !< Indicates start index of child cells belonging to certain parent cell - z direction 3409 INTEGER(iwp), DIMENSION(0:cg%nz+1), INTENT(IN) :: kfu !< Indicates end index of child cells belonging to certain parent cell - z direction 3410 CHARACTER(LEN=1), INTENT(IN) :: edge !< Edge symbol: 'l' or 'r' 3411 CHARACTER(LEN=1), INTENT(IN) :: var !< Variable symbol: 'u', 'v', 'w' or 's' 3412 ! 3413 !-- Local variables: 5822 3414 INTEGER(iwp) :: ib !< Fixed i-index pointing to the node just behind the boundary-value node 5823 3415 INTEGER(iwp) :: ibc !< Fixed i-index pointing to the boundary-value nodes (either i or iend) 5824 3416 INTEGER(iwp) :: ibgp !< Index running over the redundant boundary ghost points in i-direction 5825 !AH INTEGER(iwp) :: ibeg !< i-index pointing to the starting point of workarr_lr in the i-direction5826 INTEGER(iwp) :: iend !< Upper bound of the running index ia5827 3417 INTEGER(iwp) :: ierr !< MPI error code 5828 INTEGER(iwp) :: ijk !< Running index for all child-grid cells within the anterpolation cell5829 INTEGER(iwp) :: iw !< i-index for wall_flags_05830 3418 INTEGER(iwp) :: j !< Running index in the y-direction 5831 INTEGER(iwp) :: jco !<5832 INTEGER(iwp) :: jcorr !<5833 INTEGER(iwp) :: jinc !<5834 INTEGER(iwp) :: jw !< j-index for wall_flags_05835 INTEGER(iwp) :: j1 !<5836 3419 INTEGER(iwp) :: k !< Running index in the z-direction 5837 INTEGER(iwp) :: k_wall !< Vertical index of topography top5838 INTEGER(iwp) :: kco !<5839 INTEGER(iwp) :: kcorr !<5840 INTEGER(iwp) :: kw !< k-index for wall_flags_05841 INTEGER(iwp) :: k1 !<5842 INTEGER(iwp) :: l !< Parent-grid running index in the x-direction5843 3420 INTEGER(iwp) :: lbeg !< l-index pointing to the starting point of workarrc_lr in the l-direction 5844 INTEGER(iwp) :: lp1 !< l+1 5845 INTEGER(iwp) :: loff !< l-offset needed on the right boundary to correctly refer to boundary ghost points 5846 INTEGER(iwp) :: lw !< Reduced l-index for workarrc_lr 3421 INTEGER(iwp) :: lw !< Reduced l-index for workarrc_lr pointing to the boundary ghost node 3422 INTEGER(iwp) :: lwp !< Reduced l-index for workarrc_lr pointing to the first prognostic node 5847 3423 INTEGER(iwp) :: m !< Parent-grid running index in the y-direction 5848 INTEGER(iwp) :: mnorthv !< Upshift by one for the upper bound of index m in case of var == 'v'5849 INTEGER(iwp) :: mp1 !< m+15850 3424 INTEGER(iwp) :: n !< Parent-grid running index in the z-direction 5851 INTEGER(iwp) :: np1 !< n+1 5852 INTEGER(iwp) :: ntopw !< Upshift by one for the upper bound of index n in case of var == 'w' 5853 INTEGER(iwp) :: var_flag !< Variable flag for BTEST( wall_flags_0 ) 5854 5855 REAL(wp) :: cellsum !< Sum of child-grid node values over the anterpolation cell 5856 REAL(wP) :: cellsumd !< Sum of differences over the anterpolation cell 5857 REAL(wp) :: fkj !< Intermediate result in trilinear interpolation 5858 REAL(wp) :: fkjp !< Intermediate result in trilinear interpolation 5859 REAL(wp) :: fkpj !< Intermediate result in trilinear interpolation 5860 REAL(wp) :: fkpjp !< Intermediate result in trilinear interpolation 5861 REAL(wp) :: fk !< Intermediate result in trilinear interpolation 5862 REAL(wp) :: fkp !< Intermediate result in trilinear interpolation 5863 REAL(wp) :: rcorr !< Average reversibility correction for the whole anterpolation cell 5864 REAL(wp) :: rcorr_ijk !< Reversibility correction distributed to the individual child-grid nodes 5865 5866 ! real(wp), parameter :: c1 = 2.0_wp / 6.0_wp 5867 ! real(wp), parameter :: c2 = 5.0_wp / 6.0_wp 5868 ! real(wp), parameter :: c3 = -1.0_wp / 6.0_wp 3425 REAL(wp) :: cb !< Interpolation coefficient for the boundary ghost node 3426 REAL(wp) :: cp !< Interpolation coefficient for the first prognostic node 3427 REAL(wp) :: f_interp_1 !< Value interpolated in x direction from the parent-grid data 3428 REAL(wp) :: f_interp_2 !< Auxiliary value interpolated in x direction from the parent-grid data 5869 3429 5870 3430 ! … … 5874 3434 !-- For u, nxl is a ghost node, but not for the other variables 5875 3435 IF ( var == 'u' ) THEN 5876 i = nxl5877 iend = nxl5878 3436 ibc = nxl 5879 3437 ib = ibc - 1 5880 iawbc = 05881 l = icl + 25882 3438 lw = 2 3439 lwp = lw ! This is redundant when var == 'u' 5883 3440 lbeg = icl 5884 loff = 05885 3441 ELSE 5886 i = nxl - igsr5887 iend = nxl - 15888 3442 ibc = nxl - 1 5889 3443 ib = ibc - 1 5890 iawbc = igsr-15891 l = icl + 15892 3444 lw = 1 3445 lwp = 2 5893 3446 lbeg = icl 5894 loff = 05895 3447 ENDIF 5896 3448 ELSEIF ( edge == 'r' ) THEN 5897 3449 IF ( var == 'u' ) THEN 5898 i = nxr + 15899 iend = nxr + 15900 3450 ibc = nxr + 1 5901 3451 ib = ibc + 1 5902 iawbc = 05903 l = icr - 15904 3452 lw = 1 3453 lwp = lw ! This is redundant when var == 'u' 5905 3454 lbeg = icr - 2 5906 loff = 05907 3455 ELSE 5908 i = nxr + 15909 iend = nxr + igsr5910 3456 ibc = nxr + 1 5911 3457 ib = ibc + 1 5912 iawbc = 05913 l = icr - 15914 3458 lw = 1 3459 lwp = 0 5915 3460 lbeg = icr - 2 5916 loff = 15917 3461 ENDIF 5918 3462 ENDIF 5919 5920 IF ( var == 'w' ) THEN 5921 ntopw = 1 3463 ! 3464 !-- Interpolation coefficients 3465 IF ( interpolation_scheme_lrsn == 1 ) THEN 3466 cb = 1.0_wp ! 1st-order upwind 3467 ELSE IF ( interpolation_scheme_lrsn == 2 ) THEN 3468 cb = 0.5_wp ! 2nd-order central 5922 3469 ELSE 5923 ntopw = 0 5924 ENDIF 5925 5926 IF ( var == 'v' ) THEN 5927 mnorthv = 0 5928 ELSE 5929 mnorthv = 1 5930 ENDIF 5931 5932 IF ( var == 'u' ) THEN 5933 var_flag = 1 5934 ELSEIF ( var == 'v' ) THEN 5935 var_flag = 2 5936 ELSEIF ( var == 'w' ) THEN 5937 var_flag = 3 5938 ELSE 5939 var_flag = 0 5940 ENDIF 3470 cb = 0.5_wp ! 2nd-order central (default) 3471 ENDIF 3472 cp = 1.0_wp - cb 5941 3473 ! 5942 3474 !-- Substitute the necessary parent-grid data to the work array workarrc_lr. … … 5978 3510 ENDIF 5979 3511 5980 IF ( var == 'v' ) THEN 3512 IF ( var == 'u' ) THEN 3513 3514 DO m = jcsw, jcnw 3515 DO n = 0, kct 3516 3517 DO j = jfl(m), jfu(m) 3518 DO k = kfl(n), kfu(n) 3519 f(k,j,ibc) = workarrc_lr(n,m,lw) 3520 ENDDO 3521 ENDDO 3522 3523 ENDDO 3524 ENDDO 3525 3526 ELSE IF ( var == 'v' ) THEN 5981 3527 5982 3528 DO m = jcsw, jcnw-1 5983 3529 DO n = 0, kct 5984 3530 ! 3531 !-- First interpolate to the flux point 3532 f_interp_1 = cb * workarrc_lr(n,m,lw) + cp * workarrc_lr(n,m,lwp) 3533 f_interp_2 = cb * workarrc_lr(n,m+1,lw) + cp * workarrc_lr(n,m+1,lwp) 3534 ! 5985 3535 !-- Use averages of the neighbouring matching grid-line values 5986 3536 DO j = jfl(m), jfl(m+1) 5987 f(kfl(n):kfu(n),j,ibc) = 0.5_wp * ( workarrc_lr(n,m,lw) & 5988 + workarrc_lr(n,m+1,lw) ) 3537 ! f(kfl(n):kfu(n),j,ibc) = 0.5_wp * ( workarrc_lr(n,m,lw) & 3538 ! + workarrc_lr(n,m+1,lw) ) 3539 f(kfl(n):kfu(n),j,ibc) = 0.5_wp * ( f_interp_1 + f_interp_2 ) 5989 3540 ENDDO 5990 3541 ! 5991 3542 !-- Then set the values along the matching grid-lines 5992 3543 IF ( MOD( jfl(m), jgsr ) == 0 ) THEN 5993 f(kfl(n):kfu(n),jfl(m),ibc) = workarrc_lr(n,m,lw) 3544 ! f(kfl(n):kfu(n),jfl(m),ibc) = workarrc_lr(n,m,lw) 3545 f(kfl(n):kfu(n),jfl(m),ibc) = f_interp_1 5994 3546 ENDIF 5995 3547 ENDDO … … 5998 3550 !-- Finally, set the values along the last matching grid-line 5999 3551 IF ( MOD( jfl(jcnw), jgsr ) == 0 ) THEN 3552 f_interp_1 = cb * workarrc_lr(n,jcnw,lw) + cp * workarrc_lr(n,jcnw,lwp) 6000 3553 DO n = 0, kct 6001 f(kfl(n):kfu(n),jfl(jcnw),ibc) = workarrc_lr(n,jcnw,lw) 3554 ! f(kfl(n):kfu(n),jfl(jcnw),ibc) = workarrc_lr(n,jcnw,lw) 3555 f(kfl(n):kfu(n),jfl(jcnw),ibc) = f_interp_1 6002 3556 ENDDO 6003 3557 ENDIF … … 6020 3574 DO n = 0, kct + 1 ! It is important to go up to kct+1 6021 3575 ! 3576 !-- Interpolate to the flux point 3577 f_interp_1 = cb * workarrc_lr(n,m,lw) + cp * workarrc_lr(n,m,lwp) 3578 ! 6022 3579 !-- First substitute only the matching-node values 6023 f(kfu(n),jfl(m):jfu(m),ibc) = workarrc_lr(n,m,lw) 3580 ! f(kfu(n),jfl(m):jfu(m),ibc) = workarrc_lr(n,m,lw) 3581 f(kfu(n),jfl(m):jfu(m),ibc) = f_interp_1 6024 3582 6025 3583 ENDDO … … 6038 3596 ENDDO 6039 3597 6040 ELSE ! u or scalars3598 ELSE ! any scalar 6041 3599 6042 3600 DO m = jcsw, jcnw 6043 3601 DO n = 0, kct 6044 3602 ! 3603 !-- Interpolate to the flux point 3604 f_interp_1 = cb * workarrc_lr(n,m,lw) + cp * workarrc_lr(n,m,lwp) 6045 3605 DO j = jfl(m), jfu(m) 6046 3606 DO k = kfl(n), kfu(n) 6047 f(k,j,ibc) = workarrc_lr(n,m,lw) 3607 ! f(k,j,ibc) = workarrc_lr(n,m,lw) 3608 f(k,j,ibc) = f_interp_1 6048 3609 ENDDO 6049 3610 ENDDO … … 6069 3630 6070 3631 6071 SUBROUTINE pmci_interp_1sto_sn( f, fc, ic, jc, kc, r1x, r2x, r1y, r2y, r1z, & 6072 r2z, logc, logc_ratio, logc_kbounds, & 6073 nzt_topo_nestbc, & 6074 kct, ifl, ifu, jfl, jfu, kfl, kfu, ijkfc, & 6075 edge, var ) 6076 3632 SUBROUTINE pmci_interp_1sto_sn( f, fc, kct, ifl, ifu, kfl, kfu, edge, var ) 6077 3633 ! 6078 3634 !-- Interpolation of ghost-node values used as the child-domain boundary … … 6080 3636 IMPLICIT NONE 6081 3637 6082 INTEGER(iwp) :: nzt_topo_nestbc !< 6083 6084 REAL(wp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg), & 6085 INTENT(INOUT) :: f !< 6086 REAL(wp), DIMENSION(0:cg%nz+1,jcs:jcn,icl:icr), & 6087 INTENT(IN) :: fc !< 6088 REAL(wp), DIMENSION(1:2,0:ncorr-1,nzb:nzt_topo_nestbc,nxl:nxr), & 6089 INTENT(IN) :: logc_ratio !< 6090 REAL(wp), DIMENSION(nxlfc:nxrfc), INTENT(IN) :: r1x !< 6091 REAL(wp), DIMENSION(nxlfc:nxrfc), INTENT(IN) :: r2x !< 6092 REAL(wp), DIMENSION(nysfc:nynfc), INTENT(IN) :: r1y !< 6093 REAL(wp), DIMENSION(nysfc:nynfc), INTENT(IN) :: r2y !< 6094 !AH REAL(wp), DIMENSION(nzb:nzt+1), INTENT(IN) :: r1z !< 6095 !AH REAL(wp), DIMENSION(nzb:nzt+1), INTENT(IN) :: r2z !< 6096 REAL(wp), DIMENSION(nzb:nzt+kgsr), INTENT(IN) :: r1z !< 6097 REAL(wp), DIMENSION(nzb:nzt+kgsr), INTENT(IN) :: r2z !< 6098 6099 6100 INTEGER(iwp), DIMENSION(nxlfc:nxrfc), INTENT(IN) :: ic !< 6101 INTEGER(iwp), DIMENSION(nysfc:nynfc), INTENT(IN) :: jc !< 6102 !AH INTEGER(iwp), DIMENSION(nzb:nzt+1), INTENT(IN) :: kc !< 6103 INTEGER(iwp), DIMENSION(nzb:nzt+kgsr), INTENT(IN) :: kc !< 6104 INTEGER(iwp), DIMENSION(1:2,nzb:nzt_topo_nestbc,nxl:nxr), & 6105 INTENT(IN) :: logc !< 6106 INTEGER(iwp), DIMENSION(1:2,nxl:nxr), INTENT(IN) :: logc_kbounds !< 6107 6108 INTEGER(iwp) :: kct 6109 !AH 6110 ! INTEGER(iwp), DIMENSION(icl:icr), INTENT(IN) :: ifl !< Indicates start index of child cells belonging to certain parent cell - x direction 6111 ! INTEGER(iwp), DIMENSION(icl:icr), INTENT(IN) :: ifu !< Indicates end index of child cells belonging to certain parent cell - x direction 6112 ! INTEGER(iwp), DIMENSION(jcs:jcn), INTENT(IN) :: jfl !< Indicates start index of child cells belonging to certain parent cell - y direction 6113 ! INTEGER(iwp), DIMENSION(jcs:jcn), INTENT(IN) :: jfu !< Indicates start index of child cells belonging to certain parent cell - y direction 6114 INTEGER(iwp), DIMENSION(icla:icra), INTENT(IN) :: ifl !< Indicates start index of child cells belonging to certain parent cell - x direction 6115 INTEGER(iwp), DIMENSION(icla:icra), INTENT(IN) :: ifu !< Indicates end index of child cells belonging to certain parent cell - x direction 6116 INTEGER(iwp), DIMENSION(jcsa:jcna), INTENT(IN) :: jfl !< Indicates start index of child cells belonging to certain parent cell - y direction 6117 INTEGER(iwp), DIMENSION(jcsa:jcna), INTENT(IN) :: jfu !< Indicates start index of child cells belonging to certain parent cell - y direction 6118 !AH 6119 6120 !AH INTEGER(iwp), DIMENSION(0:kct), INTENT(IN) :: kfl !< Indicates start index of child cells belonging to certain parent cell - z direction 6121 !AH INTEGER(iwp), DIMENSION(0:kct), INTENT(IN) :: kfu !< Indicates start index of child cells belonging to certain parent cell - z direction 6122 INTEGER(iwp), DIMENSION(0:cg%nz+1), INTENT(IN) :: kfl !< Indicates start index of child cells belonging to certain parent cell - z direction 6123 INTEGER(iwp), DIMENSION(0:cg%nz+1), INTENT(IN) :: kfu !< Indicates start index of child cells belonging to certain parent cell - z direction 6124 !AH INTEGER(iwp), DIMENSION(0:kct,jcs:jcn,icl:icr), INTENT(IN) :: ijkfc !< number of child grid points contributing to a parent grid box 6125 !AH 6126 ! INTEGER(iwp), DIMENSION(0:cg%nz+1,jcs:jcn,icl:icr), INTENT(IN) :: ijkfc !< number of child grid points contributing to a parent grid box 6127 INTEGER(iwp), DIMENSION(0:cg%nz+1,jcsa:jcna,icla:icra), INTENT(IN) :: ijkfc !< number of child grid points contributing to a parent grid box 6128 !AH 6129 6130 CHARACTER(LEN=1), INTENT(IN) :: edge !< Edge symbol: 'l', 'r', 's' or 'n' 3638 REAL(wp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg), INTENT(INOUT) :: f !< Child-grid array 3639 REAL(wp), DIMENSION(0:cg%nz+1,jcs:jcn,icl:icr), INTENT(IN) :: fc !< Parent-grid array 3640 INTEGER(iwp) :: kct !< The parent-grid index in z-direction just below the boundary value node 3641 INTEGER(iwp), DIMENSION(icla:icra), INTENT(IN) :: ifl !< Indicates start index of child cells belonging to certain parent cell - x direction 3642 INTEGER(iwp), DIMENSION(icla:icra), INTENT(IN) :: ifu !< Indicates end index of child cells belonging to certain parent cell - x direction 3643 INTEGER(iwp), DIMENSION(0:cg%nz+1), INTENT(IN) :: kfl !< Indicates start index of child cells belonging to certain parent cell - z direction 3644 INTEGER(iwp), DIMENSION(0:cg%nz+1), INTENT(IN) :: kfu !< Indicates end index of child cells belonging to certain parent cell - z direction 3645 CHARACTER(LEN=1), INTENT(IN) :: edge !< Edge symbol: 's' or 'n' 6131 3646 CHARACTER(LEN=1), INTENT(IN) :: var !< Variable symbol: 'u', 'v', 'w' or 's' 6132 3647 ! 3648 !-- Local variables: 6133 3649 INTEGER(iwp) :: i !< Running index in the x-direction 6134 INTEGER(iwp) :: iinc !<6135 INTEGER(iwp) :: icorr !<6136 INTEGER(iwp) :: ico !<6137 3650 INTEGER(iwp) :: ierr !< MPI error code 6138 INTEGER(iwp) :: ijk !< Running index for all child-grid cells within the anterpolation cell6139 INTEGER(iwp) :: iw !< i-index for wall_flags_06140 INTEGER(iwp) :: i1 !<6141 INTEGER(iwp) :: j !< Lower bound of the running index ja6142 INTEGER(iwp) :: ja !< Index in y-direction running over the parent-grid cell on the boundary6143 INTEGER(iwp) :: jaw !< Reduced ja-index for workarr_sn6144 INTEGER(iwp) :: jawbc !< jaw-index pointing to the boundary-value nodes (either 0 or jgsr-1)6145 !AH INTEGER(iwp) :: jbeg !< j-index pointing to the starting point of workarr_sn in the j-direction6146 3651 INTEGER(iwp) :: jb !< Fixed j-index pointing to the node just behind the boundary-value node 6147 3652 INTEGER(iwp) :: jbc !< Fixed j-index pointing to the boundary-value nodes (either j or jend) 6148 3653 INTEGER(iwp) :: jbgp !< Index running over the redundant boundary ghost points in j-direction 6149 INTEGER(iwp) :: jend !< Upper bound of the running index ja6150 INTEGER(iwp) :: jw !< j-index for wall_flags_06151 3654 INTEGER(iwp) :: k !< Running index in the z-direction 6152 INTEGER(iwp) :: k_wall !< Vertical index of topography top6153 INTEGER(iwp) :: kcorr !<6154 INTEGER(iwp) :: kco !<6155 INTEGER(iwp) :: kw !< k-index for wall_flags_06156 INTEGER(iwp) :: k1 !<6157 3655 INTEGER(iwp) :: l !< Parent-grid running index in the x-direction 6158 INTEGER(iwp) :: lp1 !< l+16159 INTEGER(iwp) :: lrightu !< Upshift by one for the upper bound of index l in case of var == 'u'6160 INTEGER(iwp) :: m !< Parent-grid running index in the y-direction6161 3656 INTEGER(iwp) :: mbeg !< m-index pointing to the starting point of workarrc_sn in the m-direction 6162 INTEGER(iwp) :: moff !< m-offset needed on the north boundary to correctly refer to boundary ghost points 6163 INTEGER(iwp) :: mp1 !< m+1 6164 INTEGER(iwp) :: mw !< Reduced m-index for workarrc_sn 3657 INTEGER(iwp) :: mw !< Reduced m-index for workarrc_sn pointing to the boundary ghost node 3658 INTEGER(iwp) :: mwp !< Reduced m-index for workarrc_sn pointing to the first prognostic node 6165 3659 INTEGER(iwp) :: n !< Parent-grid running index in the z-direction 6166 INTEGER(iwp) :: np1 !< n+1 6167 INTEGER(iwp) :: ntopw !< Upshift by one for the upper bound of index n in case of var == 'w' 6168 INTEGER(iwp) :: var_flag !< Variable flag for BTEST( wall_flags_0 ) 6169 6170 REAL(wp) :: cellsum !< Sum of child-grid node values over the anterpolation cell 6171 REAL(wp) :: cellsumd !< Sum of differences over the anterpolation cell 6172 REAL(wp) :: fk !< Intermediate result in trilinear interpolation 6173 REAL(wp) :: fkj !< Intermediate result in trilinear interpolation 6174 REAL(wp) :: fkjp !< Intermediate result in trilinear interpolation 6175 REAL(wp) :: fkpj !< Intermediate result in trilinear interpolation 6176 REAL(wp) :: fkpjp !< Intermediate result in trilinear interpolation 6177 REAL(wp) :: fkp !< Intermediate result in trilinear interpolation 6178 REAL(wp) :: rcorr !< Average reversibility correction for the whole anterpolation cell 6179 REAL(wp) :: rcorr_ijk !< Reversibility correction distributed to the individual child-grid nodes 6180 6181 ! real(wp), parameter :: c1 = 2.0_wp / 6.0_wp 6182 ! real(wp), parameter :: c2 = 5.0_wp / 6.0_wp 6183 ! real(wp), parameter :: c3 = -1.0_wp / 6.0_wp 3660 REAL(wp) :: cb !< Interpolation coefficient for the boundary ghost node 3661 REAL(wp) :: cp !< Interpolation coefficient for the first prognostic node 3662 REAL(wp) :: f_interp_1 !< Value interpolated in y direction from the parent-grid data 3663 REAL(wp) :: f_interp_2 !< Auxiliary value interpolated in y direction from the parent-grid data 6184 3664 6185 3665 ! … … 6189 3669 !-- For v, nys is a ghost node, but not for the other variables 6190 3670 IF ( var == 'v' ) THEN 6191 j = nys6192 jend = nys6193 jawbc = 06194 3671 jbc = nys 6195 3672 jb = jbc - 1 6196 m = jcs + 26197 3673 mw = 2 3674 mwp = 2 ! This is redundant when var == 'v' 6198 3675 mbeg = jcs 6199 moff = 06200 3676 ELSE 6201 j = nys - jgsr6202 jend = nys - 16203 jawbc = jgsr - 16204 3677 jbc = nys - 1 6205 3678 jb = jbc - 1 6206 m = jcs + 16207 3679 mw = 1 3680 mwp = 2 6208 3681 mbeg = jcs 6209 moff = 06210 3682 ENDIF 6211 3683 ELSEIF ( edge == 'n' ) THEN 6212 3684 IF ( var == 'v' ) THEN 6213 j = nyn + 16214 jend = nyn + 16215 jawbc = 06216 3685 jbc = nyn + 1 6217 3686 jb = jbc + 1 6218 m = jcn - 16219 3687 mw = 1 3688 mwp = 0 ! This is redundant when var == 'v' 6220 3689 mbeg = jcn - 2 6221 moff = 06222 3690 ELSE 6223 j = nyn + 16224 jend = nyn + jgsr6225 jawbc = 06226 3691 jbc = nyn + 1 6227 3692 jb = jbc + 1 6228 m = jcn - 16229 3693 mw = 1 3694 mwp = 0 6230 3695 mbeg = jcn - 2 6231 moff = 16232 3696 ENDIF 6233 3697 ENDIF 6234 6235 IF ( var == 'w' ) THEN 6236 ntopw = 1 3698 ! 3699 !-- Interpolation coefficients 3700 IF ( interpolation_scheme_lrsn == 1 ) THEN 3701 cb = 1.0_wp ! 1st-order upwind 3702 ELSE IF ( interpolation_scheme_lrsn == 2 ) THEN 3703 cb = 0.5_wp ! 2nd-order central 6237 3704 ELSE 6238 ntopw = 0 6239 ENDIF 6240 6241 IF ( var == 'u' ) THEN 6242 lrightu = 0 6243 ELSE 6244 lrightu = 1 6245 ENDIF 6246 6247 IF ( var == 'u' ) THEN 6248 var_flag = 1 6249 ELSEIF ( var == 'v' ) THEN 6250 var_flag = 2 6251 ELSEIF ( var == 'w' ) THEN 6252 var_flag = 3 6253 ELSE 6254 var_flag = 0 6255 ENDIF 3705 cb = 0.5_wp ! 2nd-order central (default) 3706 ENDIF 3707 cp = 1.0_wp - cb 6256 3708 ! 6257 3709 !-- Substitute the necessary parent-grid data to the work array workarrc_sn. … … 6293 3745 ENDIF 6294 3746 6295 IF ( var == 'u' ) THEN 3747 IF ( var == 'v' ) THEN 3748 3749 DO l = iclw, icrw 3750 DO n = 0, kct 3751 3752 DO i = ifl(l), ifu(l) 3753 DO k = kfl(n), kfu(n) 3754 f(k,jbc,i) = workarrc_sn(n,mw,l) 3755 ENDDO 3756 ENDDO 3757 3758 ENDDO 3759 ENDDO 3760 3761 ELSE IF ( var == 'u' ) THEN 6296 3762 6297 3763 DO l = iclw, icrw-1 6298 DO n = 0, kct 3764 DO n = 0, kct 3765 ! 3766 !-- First interpolate to the flux point 3767 f_interp_1 = cb * workarrc_sn(n,mw,l) + cp * workarrc_sn(n,mwp,l) 3768 f_interp_2 = cb * workarrc_sn(n,mw,l+1) + cp * workarrc_sn(n,mwp,l+1) 6299 3769 ! 6300 3770 !-- Use averages of the neighbouring matching grid-line values 6301 3771 DO i = ifl(l), ifl(l+1) 6302 f(kfl(n):kfu(n),jbc,i) = 0.5_wp * ( workarrc_sn(n,mw,l) & 6303 + workarrc_sn(n,mw,l+1) ) 3772 ! f(kfl(n):kfu(n),jbc,i) = 0.5_wp * ( workarrc_sn(n,mw,l) & 3773 ! + workarrc_sn(n,mw,l+1) ) 3774 f(kfl(n):kfu(n),jbc,i) = 0.5_wp * ( f_interp_1 + f_interp_2 ) 6304 3775 ENDDO 6305 3776 ! 6306 3777 !-- Then set the values along the matching grid-lines 6307 3778 IF ( MOD( ifl(l), igsr ) == 0 ) THEN 6308 f(kfl(n):kfu(n),jbc,ifl(l)) = workarrc_sn(n,mw,l) 3779 ! f(kfl(n):kfu(n),jbc,ifl(l)) = workarrc_sn(n,mw,l) 3780 f(kfl(n):kfu(n),jbc,ifl(l)) = f_interp_1 6309 3781 ENDIF 6310 3782 … … 6314 3786 !-- Finally, set the values along the last matching grid-line 6315 3787 IF ( MOD( ifl(icrw), igsr ) == 0 ) THEN 3788 f_interp_1 = cb * workarrc_sn(n,mw,icrw) + cp * workarrc_sn(n,mwp,icrw) 6316 3789 DO n = 0, kct 6317 f(kfl(n):kfu(n),jbc,ifl(icrw)) = workarrc_sn(n,mw,icrw) 3790 ! f(kfl(n):kfu(n),jbc,ifl(icrw)) = workarrc_sn(n,mw,icrw) 3791 f(kfl(n):kfu(n),jbc,ifl(icrw)) = f_interp_1 6318 3792 ENDDO 6319 3793 ENDIF … … 6335 3809 DO l = iclw, icrw 6336 3810 DO n = 0, kct + 1 ! It is important to go up to kct+1 3811 ! 3812 !-- Interpolate to the flux point 3813 f_interp_1 = cb * workarrc_sn(n,mw,l) + cp * workarrc_sn(n,mwp,l) 6337 3814 ! 6338 3815 !-- First substitute only the matching-node values 6339 f(kfu(n),jbc,ifl(l):ifu(l)) = workarrc_sn(n,mw,l) 3816 ! f(kfu(n),jbc,ifl(l):ifu(l)) = workarrc_sn(n,mw,l) 3817 f(kfu(n),jbc,ifl(l):ifu(l)) = f_interp_1 6340 3818 6341 3819 ENDDO … … 6354 3832 ENDDO 6355 3833 6356 ELSE ! v or scalars3834 ELSE ! Any scalar 6357 3835 6358 3836 DO l = iclw, icrw 6359 3837 DO n = 0, kct 6360 3838 ! 3839 !-- Interpolate to the flux point 3840 f_interp_1 = cb * workarrc_sn(n,mw,l) + cp * workarrc_sn(n,mwp,l) 6361 3841 DO i = ifl(l), ifu(l) 6362 3842 DO k = kfl(n), kfu(n) 6363 f(k,jbc,i) = workarrc_sn(n,mw,l) 3843 ! f(k,jbc,i) = workarrc_sn(n,mw,l) 3844 f(k,jbc,i) = f_interp_1 6364 3845 ENDDO 6365 3846 ENDDO … … 6385 3866 6386 3867 6387 SUBROUTINE pmci_interp_1sto_t( f, fc, ic, jc, kc, r1x, r2x, r1y, r2y, & 6388 r1z, r2z, kct, ifl, ifu, jfl, jfu, kfl, kfu, & 6389 ijkfc, var ) 6390 3868 SUBROUTINE pmci_interp_1sto_t( f, fc, kct, ifl, ifu, jfl, jfu, var ) 6391 3869 ! 6392 3870 !-- Interpolation of ghost-node values used as the child-domain boundary … … 6394 3872 IMPLICIT NONE 6395 3873 6396 REAL(wp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg), & 6397 INTENT(INOUT) :: f !< Child-grid array 6398 REAL(wp), DIMENSION(0:cg%nz+1,jcs:jcn,icl:icr), & 6399 INTENT(IN) :: fc !< Parent-grid array 6400 REAL(wp), DIMENSION(nxlfc:nxrfc), INTENT(IN) :: r1x !< 6401 REAL(wp), DIMENSION(nxlfc:nxrfc), INTENT(IN) :: r2x !< 6402 REAL(wp), DIMENSION(nysfc:nynfc), INTENT(IN) :: r1y !< 6403 REAL(wp), DIMENSION(nysfc:nynfc), INTENT(IN) :: r2y !< 6404 !AH REAL(wp), DIMENSION(nzb:nzt+1), INTENT(IN) :: r1z !< 6405 !AH REAL(wp), DIMENSION(nzb:nzt+1), INTENT(IN) :: r2z !< 6406 REAL(wp), DIMENSION(nzb:nzt+kgsr), INTENT(IN) :: r1z !< 6407 REAL(wp), DIMENSION(nzb:nzt+kgsr), INTENT(IN) :: r2z !< 6408 6409 6410 INTEGER(iwp), DIMENSION(nxlfc:nxrfc), INTENT(IN) :: ic !< 6411 INTEGER(iwp), DIMENSION(nysfc:nynfc), INTENT(IN) :: jc !< 6412 !AH INTEGER(iwp), DIMENSION(nzb:nzt+1), INTENT(IN) :: kc !< 6413 INTEGER(iwp), DIMENSION(nzb:nzt+kgsr), INTENT(IN) :: kc !< 6414 6415 INTEGER(iwp) :: kct 6416 !AH 6417 ! INTEGER(iwp), DIMENSION(icl:icr), INTENT(IN) :: ifl !< Indicates start index of child cells belonging to certain parent cell - x direction 6418 ! INTEGER(iwp), DIMENSION(icl:icr), INTENT(IN) :: ifu !< Indicates end index of child cells belonging to certain parent cell - x direction 6419 ! INTEGER(iwp), DIMENSION(jcs:jcn), INTENT(IN) :: jfl !< Indicates start index of child cells belonging to certain parent cell - y direction 6420 ! INTEGER(iwp), DIMENSION(jcs:jcn), INTENT(IN) :: jfu !< Indicates start index of child cells belonging to certain parent cell - y direction 6421 INTEGER(iwp), DIMENSION(icla:icra), INTENT(IN) :: ifl !< Indicates start index of child cells belonging to certain parent cell - x direction 6422 INTEGER(iwp), DIMENSION(icla:icra), INTENT(IN) :: ifu !< Indicates end index of child cells belonging to certain parent cell - x direction 6423 INTEGER(iwp), DIMENSION(jcsa:jcna), INTENT(IN) :: jfl !< Indicates start index of child cells belonging to certain parent cell - y direction 6424 INTEGER(iwp), DIMENSION(jcsa:jcna), INTENT(IN) :: jfu !< Indicates start index of child cells belonging to certain parent cell - y direction 6425 !AH INTEGER(iwp), DIMENSION(0:kct), INTENT(IN) :: kfl !< Indicates start index of child cells belonging to certain parent cell - z direction 6426 !AH INTEGER(iwp), DIMENSION(0:kct), INTENT(IN) :: kfu !< Indicates start index of child cells belonging to certain parent cell - z direction 6427 INTEGER(iwp), DIMENSION(0:cg%nz+1), INTENT(IN) :: kfl !< Indicates start index of child cells belonging to certain parent cell - z direction 6428 INTEGER(iwp), DIMENSION(0:cg%nz+1), INTENT(IN) :: kfu !< Indicates start index of child cells belonging to certain parent cell - z direction 6429 !AH INTEGER(iwp), DIMENSION(0:kct,jcs:jcn,icl:icr), INTENT(IN) :: ijkfc !< number of child grid points contributing to a parent grid box 6430 !AH 6431 ! INTEGER(iwp), DIMENSION(0:cg%nz+1,jcs:jcn,icl:icr), INTENT(IN) :: ijkfc !< number of child grid points contributing to a parent grid box 6432 INTEGER(iwp), DIMENSION(0:cg%nz+1,jcsa:jcna,icla:icra), INTENT(IN) :: ijkfc !< number of child grid points contributing to a parent grid box 6433 !AH 6434 6435 CHARACTER(LEN=1), INTENT(IN) :: var !< 6436 6437 INTEGER(iwp) :: i !< 6438 INTEGER(iwp) :: ib !< 6439 INTEGER(iwp) :: iclc !< Lower i-index limit for copying fc-data to workarrc_t 6440 INTEGER(iwp) :: icrc !< Upper i-index limit for copying fc-data to workarrc_t 6441 INTEGER(iwp) :: ie !< 6442 INTEGER(iwp) :: ierr !< MPI error code 6443 INTEGER(iwp) :: ijk !< 6444 INTEGER(iwp) :: iw !< 6445 INTEGER(iwp) :: j !< 6446 INTEGER(iwp) :: jb !< 6447 INTEGER(iwp) :: jcsc !< Lower j-index limit for copying fc-data to workarrc_t 6448 INTEGER(iwp) :: jcnc !< Upper j-index limit for copying fc-data to workarrc_t 6449 INTEGER(iwp) :: je !< 6450 INTEGER(iwp) :: jw !< 6451 INTEGER(iwp) :: k !< Vertical child-grid index fixed to the boundary-value level 6452 INTEGER(iwp) :: ka !< Running vertical child-grid index 6453 INTEGER(iwp) :: kw !< 6454 INTEGER(iwp) :: l !< Parent-grid index in x-direction 6455 INTEGER(iwp) :: lp1 !< l+1 6456 INTEGER(iwp) :: m !< Parent-grid index in y-direction 6457 INTEGER(iwp) :: mp1 !< m+1 6458 INTEGER(iwp) :: n !< Parent-grid work array index in z-direction 6459 INTEGER(iwp) :: np1 !< n+1 6460 INTEGER(iwp) :: noff !< n-offset needed on the top boundary to correctly refer to boundary ghost points 6461 INTEGER(iwp) :: nw !< n-index for workarrc_t 6462 INTEGER(iwp) :: var_flag !< 6463 6464 REAL(wp) :: cellsum !< 6465 REAL(wp) :: cellsumd !< 6466 REAL(wp) :: fac 6467 REAL(wp) :: fk !< 6468 REAL(wp) :: fkj !< 6469 REAL(wp) :: fkjp !< 6470 REAL(wp) :: fkpj !< 6471 REAL(wp) :: fkpjp !< 6472 REAL(wp) :: fkp !< 6473 REAL(wp) :: f_interp !< 6474 REAL(wp) :: rcorr !< 6475 REAL(wp) :: rcorr_ijk !< 6476 6477 ! real(wp), parameter :: c1 = 2.0_wp / 6.0_wp 6478 ! real(wp), parameter :: c2 = 5.0_wp / 6.0_wp 6479 ! real(wp), parameter :: c3 = -1.0_wp / 6.0_wp 3874 REAL(wp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg), INTENT(INOUT) :: f !< Child-grid array 3875 REAL(wp), DIMENSION(0:cg%nz+1,jcs:jcn,icl:icr), INTENT(IN) :: fc !< Parent-grid array 3876 INTEGER(iwp), DIMENSION(icla:icra), INTENT(IN) :: ifl !< Indicates start index of child cells belonging to certain parent cell - x direction 3877 INTEGER(iwp), DIMENSION(icla:icra), INTENT(IN) :: ifu !< Indicates end index of child cells belonging to certain parent cell - x direction 3878 INTEGER(iwp), DIMENSION(jcsa:jcna), INTENT(IN) :: jfl !< Indicates start index of child cells belonging to certain parent cell - y direction 3879 INTEGER(iwp), DIMENSION(jcsa:jcna), INTENT(IN) :: jfu !< Indicates end index of child cells belonging to certain parent cell - y direction 3880 INTEGER(iwp) :: kct !< The parent-grid index in z-direction just below the boundary value node 3881 CHARACTER(LEN=1), INTENT(IN) :: var !< Variable symbol: 'u', 'v', 'w' or 's' 3882 ! 3883 !-- Local variables: 3884 REAL(wp) :: c31 !< Interpolation coefficient for the 3rd-order WS scheme 3885 REAL(wp) :: c32 !< Interpolation coefficient for the 3rd-order WS scheme 3886 REAL(wp) :: c33 !< Interpolation coefficient for the 3rd-order WS scheme 3887 REAL(wp) :: f_interp_1 !< Value interpolated in z direction from the parent-grid data 3888 REAL(wp) :: f_interp_2 !< Auxiliary value interpolated in z direction from the parent-grid data 3889 INTEGER(iwp) :: i !< Child-grid index in x-direction 3890 INTEGER(iwp) :: iclc !< Lower i-index limit for copying fc-data to workarrc_t 3891 INTEGER(iwp) :: icrc !< Upper i-index limit for copying fc-data to workarrc_t 3892 INTEGER(iwp) :: ierr !< MPI error code 3893 INTEGER(iwp) :: j !< Child-grid index in y-direction 3894 INTEGER(iwp) :: jcsc !< Lower j-index limit for copying fc-data to workarrc_t 3895 INTEGER(iwp) :: jcnc !< Upper j-index limit for copying fc-data to workarrc_t 3896 INTEGER(iwp) :: k !< Vertical child-grid index fixed to the boundary-value level 3897 INTEGER(iwp) :: l !< Parent-grid index in x-direction 3898 INTEGER(iwp) :: m !< Parent-grid index in y-direction 3899 INTEGER(iwp) :: nw !< Reduced n-index for workarrc_t pointing to the boundary ghost node 6480 3900 6481 3901 6482 3902 IF ( var == 'w' ) THEN 6483 3903 k = nzt 6484 noff = 06485 3904 ELSE 6486 3905 k = nzt + 1 6487 noff = 16488 3906 ENDIF 6489 6490 IF ( var == 'u' ) THEN 6491 var_flag = 1 6492 ELSEIF ( var == 'v' ) THEN 6493 var_flag = 2 6494 ELSEIF ( var == 'w' ) THEN 6495 var_flag = 3 6496 ELSE 6497 var_flag = 0 6498 ENDIF 6499 n = kc(k) + noff ! Chance this to get rid of kc. 6500 nw = noff 6501 ! write(9,"(a1,2x,5(i3,2x))") var, k, kc(k), noff, n, nw 6502 ! flush(9) 3907 nw = 1 3908 ! 3909 !-- Interpolation coefficients 3910 IF ( interpolation_scheme_t == 1 ) THEN 3911 c31 = 0.0_wp ! 1st-order upwind 3912 c32 = 1.0_wp 3913 c33 = 0.0_wp 3914 ELSE IF ( interpolation_scheme_t == 2 ) THEN 3915 c31 = 0.5_wp ! 2nd-order central 3916 c32 = 0.5_wp 3917 c33 = 0.0_wp 3918 ELSE 3919 c31 = 2.0_wp / 6.0_wp ! 3rd-order WS upwind biased (default) 3920 c32 = 5.0_wp / 6.0_wp 3921 c33 = -1.0_wp / 6.0_wp 3922 ENDIF 6503 3923 ! 6504 3924 !-- Substitute the necessary parent-grid data to the work array. … … 6523 3943 ENDIF 6524 3944 workarrc_t = 0.0_wp 6525 workarrc_t( 0:2,jcsc:jcnc,iclc:icrc) = fc(kc(k):kc(k)+2,jcsc:jcnc,iclc:icrc)3945 workarrc_t(-2:3,jcsc:jcnc,iclc:icrc) = fc(kct-2:kct+3,jcsc:jcnc,iclc:icrc) 6526 3946 ! 6527 3947 !-- Left-right exchange if more than one PE subdomain in the x-direction. … … 6567 3987 #endif 6568 3988 6569 IF ( var == 'u' ) THEN 3989 IF ( var == 'w' ) THEN 3990 DO l = iclw, icrw 3991 DO m = jcsw, jcnw 3992 3993 DO i = ifl(l), ifu(l) 3994 DO j = jfl(m), jfu(m) 3995 f(k,j,i) = workarrc_t(nw,m,l) 3996 ENDDO 3997 ENDDO 3998 3999 ENDDO 4000 ENDDO 4001 4002 ELSE IF ( var == 'u' ) THEN 6570 4003 6571 4004 DO l = iclw, icrw-1 6572 4005 DO m = jcsw, jcnw 6573 4006 ! 4007 !-- First interpolate to the flux point using the 3rd-order WS scheme 4008 f_interp_1 = c31 * workarrc_t(nw-1,m,l) + c32 * workarrc_t(nw,m,l) + c33 * workarrc_t(nw+1,m,l) 4009 f_interp_2 = c31 * workarrc_t(nw-1,m,l+1) + c32 * workarrc_t(nw,m,l+1) + c33 * workarrc_t(nw+1,m,l+1) 4010 ! 6574 4011 !-- Use averages of the neighbouring matching grid-line values 6575 4012 DO i = ifl(l), ifl(l+1) 6576 f(k,jfl(m):jfu(m),i) = 0.5_wp * ( workarrc_t(nw,m,l) & 6577 + workarrc_t(nw,m,l+1) ) 4013 ! f(k,jfl(m):jfu(m),i) = 0.5_wp * ( workarrc_t(nw,m,l) & 4014 ! + workarrc_t(nw,m,l+1) ) 4015 f(k,jfl(m):jfu(m),i) = 0.5_wp * ( f_interp_1 + f_interp_2 ) 6578 4016 ENDDO 6579 4017 ! 6580 4018 !-- Then set the values along the matching grid-lines 6581 4019 IF ( MOD( ifl(l), igsr ) == 0 ) THEN 6582 f(k,jfl(m):jfu(m),ifl(l)) = workarrc_t(nw,m,l) 4020 ! 4021 !-- First interpolate to the flux point using the 3rd-order WS scheme 4022 f_interp_1 = c31 * workarrc_t(nw-1,m,l) + c32 * workarrc_t(nw,m,l) + c33 * workarrc_t(nw+1,m,l) 4023 ! f(k,jfl(m):jfu(m),ifl(l)) = workarrc_t(nw,m,l) 4024 f(k,jfl(m):jfu(m),ifl(l)) = f_interp_1 6583 4025 ENDIF 6584 4026 … … 6589 4031 IF ( MOD( ifl(icrw), igsr ) == 0 ) THEN 6590 4032 DO m = jcsw, jcnw 6591 f(k,jfl(m):jfu(m),ifl(icrw)) = workarrc_t(nw,m,icrw) 4033 ! 4034 !-- First interpolate to the flux point using the 3rd-order WS scheme 4035 f_interp_1 = c31 * workarrc_t(nw-1,m,icrw) + c32 * workarrc_t(nw,m,icrw) + c33 * workarrc_t(nw+1,m,icrw) 4036 ! f(k,jfl(m):jfu(m),ifl(icrw)) = workarrc_t(nw,m,icrw) 4037 f(k,jfl(m):jfu(m),ifl(icrw)) = f_interp_1 6592 4038 ENDDO 6593 4039 ENDIF … … 6610 4056 DO m = jcsw, jcnw-1 6611 4057 ! 4058 !-- First interpolate to the flux point using the 3rd-order WS scheme 4059 f_interp_1 = c31 * workarrc_t(nw-1,m,l) + c32 * workarrc_t(nw,m,l) + c33 * workarrc_t(nw+1,m,l) 4060 f_interp_2 = c31 * workarrc_t(nw-1,m+1,l) + c32 * workarrc_t(nw,m+1,l) + c33 * workarrc_t(nw+1,m+1,l) 4061 ! 6612 4062 !-- Use averages of the neighbouring matching grid-line values 6613 DO j = jfl(m), jfl(m+1) 6614 f(k,j,ifl(l):ifu(l)) = 0.5_wp * ( workarrc_t(nw,m,l) & 6615 + workarrc_t(nw,m+1,l) ) 4063 DO j = jfl(m), jfl(m+1) 4064 ! f(k,j,ifl(l):ifu(l)) = 0.5_wp * ( workarrc_t(nw,m,l) & 4065 ! + workarrc_t(nw,m+1,l) ) 4066 f(k,j,ifl(l):ifu(l)) = 0.5_wp * ( f_interp_1 + f_interp_2 ) 6616 4067 ENDDO 6617 4068 ! 6618 4069 !-- Then set the values along the matching grid-lines 6619 4070 IF ( MOD( jfl(m), jgsr ) == 0 ) THEN 6620 f(k,jfl(m),ifl(l):ifu(l)) = workarrc_t(nw,m,l) 4071 f_interp_1 = c31 * workarrc_t(nw-1,m,l) + c32 * workarrc_t(nw,m,l) + c33 * workarrc_t(nw+1,m,l) 4072 ! f(k,jfl(m),ifl(l):ifu(l)) = workarrc_t(nw,m,l) 4073 f(k,jfl(m),ifl(l):ifu(l)) = f_interp_1 6621 4074 ENDIF 6622 4075 … … 6625 4078 ENDDO 6626 4079 ! 6627 !-- Finally, set the values along the last matching grid-line 4080 !-- Finally, set the values along the last matching grid-line 6628 4081 IF ( MOD( jfl(jcnw), jgsr ) == 0 ) THEN 6629 4082 DO l = iclw, icrw 6630 f(k,jfl(jcnw),ifl(l):ifu(l)) = workarrc_t(nw,jcnw,l) 4083 ! 4084 !-- First interpolate to the flux point using the 3rd-order WS scheme 4085 f_interp_1 = c31 * workarrc_t(nw-1,jcnw,l) + c32 * workarrc_t(nw,jcnw,l) + c33 * workarrc_t(nw+1,jcnw,l) 4086 ! f(k,jfl(jcnw),ifl(l):ifu(l)) = workarrc_t(nw,jcnw,l) 4087 f(k,jfl(jcnw),ifl(l):ifu(l)) = f_interp_1 6631 4088 ENDDO 6632 4089 ENDIF … … 6644 4101 ENDIF 6645 4102 6646 ELSE ! w or any scalar4103 ELSE ! any scalar variable 6647 4104 6648 4105 DO l = iclw, icrw 6649 4106 DO m = jcsw, jcnw 6650 4107 ! 6651 !-- 3rd-order upwind biased interpolation. 6652 ! IF ( w(k,jfl(m),ifl(l)) < 0.0_wp ) THEN 6653 ! f_interp = c1 * workarrc_t(0,m,l) + c2 * workarrc_t(1,m,l) + c3 * workarrc_t(2,m,l) 6654 ! ELSE 6655 ! f_interp = workarrc_t(nw,m,l) 6656 ! ENDIF 4108 !-- First interpolate to the flux point using the 3rd-order WS scheme 4109 f_interp_1 = c31 * workarrc_t(nw-1,m,l) + c32 * workarrc_t(nw,m,l) + c33 * workarrc_t(nw+1,m,l) 6657 4110 DO i = ifl(l), ifu(l) 6658 4111 DO j = jfl(m), jfu(m) 6659 f(k,j,i) = workarrc_t(nw,m,l) 4112 ! f(k,j,i) = workarrc_t(nw,m,l) 4113 f(k,j,i) = f_interp_1 6660 4114 ENDDO 6661 4115 ENDDO … … 6675 4129 6676 4130 6677 SUBROUTINE pmci_interp_tril_lr( f, fc, ic, jc, kc, r1x, r2x, r1y, r2y, r1z, & 6678 r2z, logc, logc_ratio, logc_kbounds, & 6679 nzt_topo_nestbc, & 6680 kct, ifl, ifu, jfl, jfu, kfl, kfu, ijkfc, & 6681 edge, var ) 6682 ! 6683 !-- Interpolation of ghost-node values used as the child-domain boundary 6684 !-- conditions. This subroutine handles the left and right boundaries. It is 6685 !-- based on trilinear interpolation. 4131 SUBROUTINE pmci_anterp_tophat( f, fc, kct, ifl, ifu, jfl, jfu, kfl, kfu, ijkfc, var ) 4132 ! 4133 !-- Anterpolation of internal-node values to be used as the parent-domain 4134 !-- values. This subroutine is based on the first-order numerical 4135 !-- integration of the child-grid values contained within the anterpolation 4136 !-- cell. 6686 4137 6687 4138 IMPLICIT NONE 6688 4139 6689 INTEGER(iwp) :: nzt_topo_nestbc !< 6690 6691 REAL(wp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg), & 6692 INTENT(INOUT) :: f !< 6693 REAL(wp), DIMENSION(0:cg%nz+1,jcs:jcn,icl:icr), & 6694 INTENT(IN) :: fc !< 6695 REAL(wp), DIMENSION(1:2,0:ncorr-1,nzb:nzt_topo_nestbc,nys:nyn), & 6696 INTENT(IN) :: logc_ratio !< 6697 !AH REAL(wp), DIMENSION(nxlg:nxrg), INTENT(IN) :: r1x !< 6698 !AH REAL(wp), DIMENSION(nxlg:nxrg), INTENT(IN) :: r2x !< 6699 !AH REAL(wp), DIMENSION(nysg:nyng), INTENT(IN) :: r1y !< 6700 !AH REAL(wp), DIMENSION(nysg:nyng), INTENT(IN) :: r2y !< 6701 REAL(wp), DIMENSION(nxlfc:nxrfc), INTENT(IN) :: r1x !< 6702 REAL(wp), DIMENSION(nxlfc:nxrfc), INTENT(IN) :: r2x !< 6703 REAL(wp), DIMENSION(nysfc:nynfc), INTENT(IN) :: r1y !< 6704 REAL(wp), DIMENSION(nysfc:nynfc), INTENT(IN) :: r2y !< 6705 6706 !AH REAL(wp), DIMENSION(nzb:nzt+1), INTENT(IN) :: r1z !< 6707 !AH REAL(wp), DIMENSION(nzb:nzt+1), INTENT(IN) :: r2z !< 6708 REAL(wp), DIMENSION(nzb:nzt+kgsr), INTENT(IN) :: r1z !< 6709 REAL(wp), DIMENSION(nzb:nzt+kgsr), INTENT(IN) :: r2z !< 6710 6711 6712 INTEGER(iwp), DIMENSION(nxlfc:nxrfc), INTENT(IN) :: ic !< 6713 INTEGER(iwp), DIMENSION(nysfc:nynfc), INTENT(IN) :: jc !< 6714 !AH INTEGER(iwp), DIMENSION(nzb:nzt+1), INTENT(IN) :: kc !< 6715 INTEGER(iwp), DIMENSION(nzb:nzt+kgsr), INTENT(IN) :: kc !< 6716 INTEGER(iwp), DIMENSION(1:2,nzb:nzt_topo_nestbc,nys:nyn), & 6717 INTENT(IN) :: logc !< 6718 INTEGER(iwp), DIMENSION(1:2,nys:nyn), INTENT(IN) :: logc_kbounds !< 6719 6720 INTEGER(iwp) :: kct 6721 6722 !AH 6723 ! INTEGER(iwp), DIMENSION(icl:icr), INTENT(IN) :: ifl !< Indicates start index of child cells belonging to certain parent cell - x direction 6724 ! INTEGER(iwp), DIMENSION(icl:icr), INTENT(IN) :: ifu !< Indicates end index of child cells belonging to certain parent cell - x direction 6725 ! INTEGER(iwp), DIMENSION(jcs:jcn), INTENT(IN) :: jfl !< Indicates start index of child cells belonging to certain parent cell - y direction 6726 ! INTEGER(iwp), DIMENSION(jcs:jcn), INTENT(IN) :: jfu !< Indicates start index of child cells belonging to certain parent cell - y direction 4140 REAL(wp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg), INTENT(IN) :: f !< Child-grid array 4141 REAL(wp), DIMENSION(0:cg%nz+1,jcs:jcn,icl:icr), INTENT(INOUT) :: fc !< Parent-grid array 4142 INTEGER(iwp), DIMENSION(0:cg%nz+1,jcsa:jcna,icla:icra), INTENT(IN) :: ijkfc !< number of child grid points contributing to a parent grid box 4143 INTEGER(iwp), INTENT(IN) :: kct !< Top boundary index for anterpolation along z 6727 4144 INTEGER(iwp), DIMENSION(icla:icra), INTENT(IN) :: ifl !< Indicates start index of child cells belonging to certain parent cell - x direction 6728 4145 INTEGER(iwp), DIMENSION(icla:icra), INTENT(IN) :: ifu !< Indicates end index of child cells belonging to certain parent cell - x direction 6729 4146 INTEGER(iwp), DIMENSION(jcsa:jcna), INTENT(IN) :: jfl !< Indicates start index of child cells belonging to certain parent cell - y direction 6730 INTEGER(iwp), DIMENSION(jcsa:jcna), INTENT(IN) :: jfu !< Indicates start index of child cells belonging to certain parent cell - y direction 6731 !AH 6732 6733 !AH INTEGER(iwp), DIMENSION(0:kct), INTENT(IN) :: kfl !< Indicates start index of child cells belonging to certain parent cell - z direction 6734 !AH INTEGER(iwp), DIMENSION(0:kct), INTENT(IN) :: kfu !< Indicates start index of child cells belonging to certain parent cell - z direction 6735 INTEGER(iwp), DIMENSION(0:cg%nz+1), INTENT(IN) :: kfl !< Indicates start index of child cells belonging to certain parent cell - z direction 6736 INTEGER(iwp), DIMENSION(0:cg%nz+1), INTENT(IN) :: kfu !< Indicates start index of child cells belonging to certain parent cell - z direction 6737 6738 !AH INTEGER(iwp), DIMENSION(0:kct,jcs:jcn,icl:icr), INTENT(IN) :: ijkfc !< number of child grid points contributing to a parent grid box 6739 !AH 6740 ! INTEGER(iwp), DIMENSION(0:cg%nz+1,jcs:jcn,icl:icr), INTENT(IN) :: ijkfc !< number of child grid points contributing to a parent grid box 6741 INTEGER(iwp), DIMENSION(0:cg%nz+1,jcsa:jcna,icla:icra), INTENT(IN) :: ijkfc !< number of child grid points contributing to a parent grid box 6742 !AH 6743 6744 CHARACTER(LEN=1), INTENT(IN) :: edge !< Edge symbol: 'l', 'r', 's' or 'n' 6745 CHARACTER(LEN=1), INTENT(IN) :: var !< Variable symbol: 'u', 'v', 'w' or 's' 6746 6747 INTEGER(iwp) :: i !< Lower bound of the running index ia 6748 INTEGER(iwp) :: ia !< i-index running over the parent-grid cell on the boundary 6749 INTEGER(iwp) :: iaw !< Reduced ia-index for workarr_lr 6750 INTEGER(iwp) :: iawbc !< iaw-index pointing to the boundary-value nodes (either 0 or igsr-1) 6751 INTEGER(iwp) :: ibc !< Fixed i-index pointing to the boundary-value nodes (either i or iend) 6752 !AH INTEGER(iwp) :: ibeg !< i-index pointing to the starting point of workarr_lr in the i-direction 6753 INTEGER(iwp) :: iend !< Upper bound of the running index ia 6754 INTEGER(iwp) :: ierr !< MPI error code 6755 INTEGER(iwp) :: ijk !< Running index for all child-grid cells within the anterpolation cell 6756 INTEGER(iwp) :: iw !< i-index for wall_flags_0 6757 INTEGER(iwp) :: j !< Running index in the y-direction 6758 INTEGER(iwp) :: jco !< 6759 INTEGER(iwp) :: jcorr !< 6760 INTEGER(iwp) :: jinc !< 6761 INTEGER(iwp) :: jw !< j-index for wall_flags_0 6762 INTEGER(iwp) :: j1 !< 6763 INTEGER(iwp) :: k !< Running index in the z-direction 6764 INTEGER(iwp) :: k_wall !< Vertical index of topography top 6765 INTEGER(iwp) :: kco !< 6766 INTEGER(iwp) :: kcorr !< 6767 INTEGER(iwp) :: kw !< k-index for wall_flags_0 6768 INTEGER(iwp) :: k1 !< 6769 INTEGER(iwp) :: l !< Parent-grid running index in the x-direction 6770 INTEGER(iwp) :: lbeg !< l-index pointing to the starting point of workarrc_lr in the l-direction 6771 INTEGER(iwp) :: lp1 !< l+1 6772 INTEGER(iwp) :: loff !< l-offset needed on the right boundary to correctly refer to boundary ghost points 6773 INTEGER(iwp) :: lw !< Reduced l-index for workarrc_lr 6774 INTEGER(iwp) :: m !< Parent-grid running index in the y-direction 6775 INTEGER(iwp) :: mnorthv !< Upshift by one for the upper bound of index m in case of var == 'v' 6776 INTEGER(iwp) :: mp1 !< m+1 6777 INTEGER(iwp) :: n !< Parent-grid running index in the z-direction 6778 INTEGER(iwp) :: np1 !< n+1 6779 INTEGER(iwp) :: ntopw !< Upshift by one for the upper bound of index n in case of var == 'w' 6780 INTEGER(iwp) :: var_flag !< Variable flag for BTEST( wall_flags_0 ) 6781 6782 REAL(wp) :: cellsum !< Sum of child-grid node values over the anterpolation cell 6783 REAL(wP) :: cellsumd !< Sum of differences over the anterpolation cell 6784 REAL(wp) :: fkj !< Intermediate result in trilinear interpolation 6785 REAL(wp) :: fkjp !< Intermediate result in trilinear interpolation 6786 REAL(wp) :: fkpj !< Intermediate result in trilinear interpolation 6787 REAL(wp) :: fkpjp !< Intermediate result in trilinear interpolation 6788 REAL(wp) :: fk !< Intermediate result in trilinear interpolation 6789 REAL(wp) :: fkp !< Intermediate result in trilinear interpolation 6790 REAL(wp) :: rcorr !< Average reversibility correction for the whole anterpolation cell 6791 REAL(wp) :: rcorr_ijk !< Reversibility correction distributed to the individual child-grid nodes 6792 6793 ! 6794 !-- Check which edge is to be handled 6795 IF ( edge == 'l' ) THEN 6796 ! 6797 !-- For u, nxl is a ghost node, but not for the other variables 6798 IF ( var == 'u' ) THEN 6799 i = nxl 6800 iend = nxl 6801 ibc = nxl 6802 iawbc = 0 6803 lbeg = icl 6804 loff = 0 6805 ELSE 6806 i = nxl - igsr 6807 iend = nxl - 1 6808 ibc = nxl - 1 6809 iawbc = igsr-1 6810 lbeg = icl 6811 loff = 0 4147 INTEGER(iwp), DIMENSION(jcsa:jcna), INTENT(IN) :: jfu !< Indicates end index of child cells belonging to certain parent cell - y direction 4148 INTEGER(iwp), DIMENSION(0:cg%nz+1), INTENT(IN) :: kfl !< Indicates start index of child cells belonging to certain parent cell - z direction 4149 INTEGER(iwp), DIMENSION(0:cg%nz+1), INTENT(IN) :: kfu !< Indicates end index of child cells belonging to certain parent cell - z direction 4150 CHARACTER(LEN=*), INTENT(IN) :: var !< Variable symbol: 'u', 'v', 'w' or 's' 4151 ! 4152 !-- Local variables: 4153 REAL(wp) :: cellsum !< sum of respective child cells belonging to parent cell 4154 INTEGER(iwp) :: i !< Running index x-direction - child grid 4155 INTEGER(iwp) :: iclant !< Left boundary index for anterpolation along x 4156 INTEGER(iwp) :: icrant !< Right boundary index for anterpolation along x 4157 INTEGER(iwp) :: j !< Running index y-direction - child grid 4158 INTEGER(iwp) :: jcnant !< North boundary index for anterpolation along y 4159 INTEGER(iwp) :: jcsant !< South boundary index for anterpolation along y 4160 INTEGER(iwp) :: k !< Running index z-direction - child grid 4161 INTEGER(iwp) :: kcb = 0 !< Bottom boundary index for anterpolation along z 4162 INTEGER(iwp) :: kctant !< Top boundary index for anterpolation along z 4163 INTEGER(iwp) :: l !< Running index x-direction - parent grid 4164 INTEGER(iwp) :: m !< Running index y-direction - parent grid 4165 INTEGER(iwp) :: n !< Running index z-direction - parent grid 4166 INTEGER(iwp) :: var_flag !< bit number used to flag topography on respective grid 4167 4168 ! 4169 !-- Define the index bounds iclant, icrant, jcsant and jcnant. 4170 !-- Note that kcb is simply zero and kct enters here as a parameter and it is 4171 !-- determined in pmci_init_anterp_tophat. 4172 !-- Please note, grid points used also for interpolation (from parent to 4173 !-- child) are excluded in anterpolation, e.g. anterpolation is only from 4174 !-- nzb:kct-1, as kct is used for interpolation. 4175 iclant = icl 4176 icrant = icr 4177 jcsant = jcs 4178 jcnant = jcn 4179 kctant = kct - 1 4180 4181 kcb = 0 4182 IF ( nesting_mode /= 'vertical' ) THEN 4183 IF ( bc_dirichlet_l ) THEN 4184 iclant = icl + 3 6812 4185 ENDIF 6813 ELSEIF ( edge == 'r' ) THEN 6814 IF ( var == 'u' ) THEN 6815 i = nxr + 1 6816 iend = nxr + 1 6817 ibc = nxr + 1 6818 iawbc = 0 6819 lbeg = icr - 2 6820 loff = 0 6821 ELSE 6822 i = nxr + 1 6823 iend = nxr + igsr 6824 ibc = nxr + 1 6825 iawbc = 0 6826 lbeg = icr - 2 6827 loff = 1 4186 IF ( bc_dirichlet_r ) THEN 4187 icrant = icr - 3 6828 4188 ENDIF 6829 4189 4190 IF ( bc_dirichlet_s ) THEN 4191 jcsant = jcs + 3 4192 ENDIF 4193 IF ( bc_dirichlet_n ) THEN 4194 jcnant = jcn - 3 4195 ENDIF 6830 4196 ENDIF 6831 6832 IF ( var == 'w' ) THEN 6833 ntopw = 1 6834 ELSE 6835 ntopw = 0 6836 ENDIF 6837 6838 IF ( var == 'v' ) THEN 6839 mnorthv = 0 6840 ELSE 6841 mnorthv = 1 6842 ENDIF 6843 4197 ! 4198 !-- Set masking bit for topography flags 6844 4199 IF ( var == 'u' ) THEN 6845 4200 var_flag = 1 … … 6851 4206 var_flag = 0 6852 4207 ENDIF 6853 6854 !AH 6855 ! 6856 !-- Substitute the necessary parent-grid data to the work array workarrc_lr. 6857 workarrc_lr = 0.0_wp 6858 IF ( pdims(2) > 1 ) THEN 6859 #if defined( __parallel ) 6860 IF ( nys == 0 ) THEN 6861 workarrc_lr(0:cg%nz+1,jcsw:jcnw-1,0:2) & 6862 = fc(0:cg%nz+1,jcsw:jcnw-1,lbeg:lbeg+2) 6863 ELSE IF ( nyn == ny ) THEN 6864 workarrc_lr(0:cg%nz+1,jcsw+1:jcnw,0:2) & 6865 = fc(0:cg%nz+1,jcsw+1:jcnw,lbeg:lbeg+2) 6866 ELSE 6867 workarrc_lr(0:cg%nz+1,jcsw+1:jcnw-1,0:2) & 6868 = fc(0:cg%nz+1,jcsw+1:jcnw-1,lbeg:lbeg+2) 6869 ENDIF 6870 ! 6871 !-- South-north exchange if more than one PE subdomain in the y-direction. 6872 !-- Note that in case of 3-D nesting the south (psouth == MPI_PROC_NULL) 6873 !-- and north (pnorth == MPI_PROC_NULL) boundaries are not exchanged 6874 !-- because the nest domain is not cyclic. 6875 !-- From south to north 6876 CALL MPI_SENDRECV( workarrc_lr(0,jcsw+1,0), 1, & 6877 workarrc_lr_exchange_type, psouth, 0, & 6878 workarrc_lr(0,jcnw,0), 1, & 6879 workarrc_lr_exchange_type, pnorth, 0, & 6880 comm2d, status, ierr ) 6881 ! 6882 !-- From north to south 6883 CALL MPI_SENDRECV( workarrc_lr(0,jcnw-1,0), 1, & 6884 workarrc_lr_exchange_type, pnorth, 1, & 6885 workarrc_lr(0,jcsw,0), 1, & 6886 workarrc_lr_exchange_type, psouth, 1, & 6887 comm2d, status, ierr ) 6888 #endif 6889 ELSE 6890 workarrc_lr(0:cg%nz+1,jcsw:jcnw,0:2) & 6891 = fc(0:cg%nz+1,jcsw:jcnw,lbeg:lbeg+2) 6892 ENDIF 6893 ! 6894 !AH 6895 workarr_lr = 0.0_wp 6896 6897 DO ia = i, iend 6898 iaw = ia - i 6899 DO j = nys-1, nyn+1 6900 !AH DO j = nys, nyn 6901 ! 6902 !-- Determine vertical index of topography top at grid point (j,i) 6903 !AH k_wall = get_topography_top_index_ji( j, i, TRIM( var ) ) 6904 DO k = nzb, nzt+1 !k_wall, nzt+1 6905 !AH l = ic(ia) - ic(i) 6906 l = ic(ia) - lbeg 6907 lp1 = MIN( l + 1, 2 ) ! If l+1 > 2 (l=ic(nxr+1)-lbeg), r1x = 1 and r2x = 0 6908 m = jc(j) 6909 mp1 = MIN( m + 1, jcnw ) ! If m+1 > jcn (m=jc(nyn+1)), r1y = 1 and r2y = 0 6910 n = kc(k) 6911 np1 = n + 1 6912 6913 !AH 6914 ! fkj = r1x(i) * fc(n,m,l) + r2x(i) * fc(n,m,l+1) 6915 ! fkjp = r1x(i) * fc(n,m+1,l) + r2x(i) * fc(n,m+1,l+1) 6916 ! fkpj = r1x(i) * fc(n+1,m,l) + r2x(i) * fc(n+1,m,l+1) 6917 ! fkpjp = r1x(i) * fc(n+1,m+1,l) + r2x(i) * fc(n+1,m+1,l+1) 6918 !AH 6919 6920 fkj = r1x(ia) * workarrc_lr(n,m,l) + r2x(ia) * workarrc_lr(n,m,lp1) 6921 fkjp = r1x(ia) * workarrc_lr(n,mp1,l) + r2x(ia) * workarrc_lr(n,mp1,lp1) 6922 fkpj = r1x(ia) * workarrc_lr(np1,m,l) + r2x(ia) * workarrc_lr(np1,m,lp1) 6923 fkpjp = r1x(ia) * workarrc_lr(np1,mp1,l) + r2x(ia) * workarrc_lr(np1,mp1,lp1) 6924 6925 fk = r1y(j) * fkj + r2y(j) * fkjp 6926 fkp = r1y(j) * fkpj + r2y(j) * fkpjp 6927 6928 !AH 6929 ! f(k,j,i) = r1z(k) * fk + r2z(k) * fkp 6930 workarr_lr(k,j,iaw) = r1z(k) * fk + r2z(k) * fkp 6931 6932 ! if ( ( edge == 'l' ) .and. ( ia == ibc ) ) then 6933 ! write(9,"('pmci_interp_tril_lr: ',a2,2x,11(i4,2x),7(e12.5,2x))") var, k, j, ia, ibc, iaw, n, m, l, np1, mp1, lp1, & 6934 ! workarr_lr(k,j,iaw), r1x(ia), r2x(ia), workarrc_lr(n,m,l), workarrc_lr(n,mp1,l), workarrc_lr(np1,m,l), workarrc_lr(np1,mp1,l) 6935 ! flush(9) 6936 ! endif 6937 6938 !AH 6939 4208 ! 4209 !-- Note that ii, jj, and kk are coarse-grid indices and i,j, and k 4210 !-- are fine-grid indices. 4211 DO l = iclant, icrant 4212 DO m = jcsant, jcnant 4213 ! 4214 !-- For simplicity anterpolate within buildings and under elevated 4215 !-- terrain too 4216 DO n = kcb, kctant 4217 cellsum = 0.0_wp 4218 DO i = ifl(l), ifu(l) 4219 DO j = jfl(m), jfu(m) 4220 DO k = kfl(n), kfu(n) 4221 cellsum = cellsum + MERGE( f(k,j,i), 0.0_wp, & 4222 BTEST( wall_flags_0(k,j,i), var_flag ) ) 4223 ENDDO 4224 ENDDO 4225 ENDDO 4226 ! 4227 !-- In case all child grid points are inside topography, i.e. 4228 !-- ijkfc and cellsum are zero, also parent solution would have 4229 !-- zero values at that grid point, which may cause problems in 4230 !-- particular for the temperature. Therefore, in case cellsum is 4231 !-- zero, keep the parent solution at this point. 4232 4233 IF ( ijkfc(n,m,l) /= 0 ) THEN 4234 fc(n,m,l) = cellsum / REAL( ijkfc(n,m,l), KIND=wp ) 4235 ENDIF 4236 6940 4237 ENDDO 6941 4238 ENDDO 6942 4239 ENDDO 6943 ! 6944 !-- Generalized log-law-correction algorithm. 6945 !-- Doubly two-dimensional index arrays logc(1:2,:,:) and log-ratio arrays 6946 !-- logc_ratio(1:2,0:ncorr-1,:,:) have been precomputed in subroutine 6947 !-- pmci_init_loglaw_correction. 6948 ! 6949 !-- Solid surface below the node 6950 IF ( constant_flux_layer .AND. ( var == 'u' .OR. var == 'v' ) ) THEN 6951 DO j = nys, nyn 6952 ! 6953 !-- Determine vertical index of topography top at grid point (j,i) 6954 k_wall = get_topography_top_index_ji( j, i, TRIM ( var ) ) 6955 6956 k = k_wall+1 6957 IF ( ( logc(1,k,j) /= 0 ) .AND. ( logc(2,k,j) == 0 ) ) THEN 6958 k1 = logc(1,k,j) 6959 DO kcorr = 0, ncorr - 1 6960 kco = k + kcorr 6961 !AH f(kco,j,i) = logc_ratio(1,kcorr,k,j) * f(k1,j,i) 6962 ENDDO 6963 ENDIF 6964 ENDDO 6965 ENDIF 6966 ! 6967 !-- In case of non-flat topography, also vertical walls and corners need to be 6968 !-- treated. Only single and double wall nodes are corrected. Triple and 6969 !-- higher-multiple wall nodes are not corrected as the log law would not be 6970 !-- valid anyway in such locations. 6971 IF ( topography /= 'flat' ) THEN 6972 6973 IF ( constant_flux_layer .AND. ( var == 'u' .OR. var == 'w' ) ) THEN 6974 ! 6975 !-- Solid surface only on south/north side of the node 6976 DO j = nys, nyn 6977 DO k = logc_kbounds(1,j), logc_kbounds(2,j) 6978 IF ( ( logc(2,k,j) /= 0 ) .AND. ( logc(1,k,j) == 0 ) ) THEN 6979 ! 6980 !-- Direction of the wall-normal index is carried in as the 6981 !-- sign of logc 6982 jinc = SIGN( 1, logc(2,k,j) ) 6983 j1 = ABS( logc(2,k,j) ) 6984 DO jcorr = 0, ncorr-1 6985 jco = j + jinc * jcorr 6986 IF ( jco >= nys .AND. jco <= nyn ) THEN 6987 !AH f(k,jco,i) = logc_ratio(2,jcorr,k,j) * f(k,j1,i) 6988 ENDIF 6989 ENDDO 6990 ENDIF 6991 ENDDO 6992 ENDDO 6993 ENDIF 6994 ! 6995 !-- Solid surface on both below and on south/north side of the node 6996 IF ( constant_flux_layer .AND. var == 'u' ) THEN 6997 DO j = nys, nyn 6998 k = logc_kbounds(1,j) 6999 IF ( ( logc(2,k,j) /= 0 ) .AND. ( logc(1,k,j) /= 0 ) ) THEN 7000 k1 = logc(1,k,j) 7001 jinc = SIGN( 1, logc(2,k,j) ) 7002 j1 = ABS( logc(2,k,j) ) 7003 DO jcorr = 0, ncorr-1 7004 jco = j + jinc * jcorr 7005 IF ( jco >= nys .AND. jco <= nyn ) THEN 7006 DO kcorr = 0, ncorr-1 7007 kco = k + kcorr 7008 !AH f(kco,jco,i) = 0.5_wp * ( logc_ratio(1,kcorr,k,j) * & 7009 !AH f(k1,j,i) & 7010 !AH + logc_ratio(2,jcorr,k,j) * & 7011 !AH f(k,j1,i) ) 7012 ENDDO 7013 ENDIF 7014 ENDDO 7015 ENDIF 7016 ENDDO 7017 ENDIF 7018 7019 ENDIF ! ( topography /= 'flat' ) 7020 ! 7021 !-- Apply the reversibility correction. 7022 7023 ! if ( var == 'u' ) then 7024 7025 l = ic(ibc) + loff 7026 lw = 1 7027 ! write(9,"('pmci_interp_tril_lr: edge, var, l, i, iend, ifl(l), ifu(l) = ',2(a2,2x),5(i4,2x))") & 7028 ! edge, var, l, i, iend, ifl(l), ifu(l) 7029 ! flush(9) 7030 !AH DO m = jcsw+1, jcnw-1 7031 DO m = jcsw + 1, jcnw - mnorthv ! mnorthv = 0 for v and 1 for all others 7032 DO n = 0, kct + ntopw ! ntopw = 1 for w and 0 for all others 7033 ijk = 1 7034 cellsum = 0.0_wp 7035 cellsumd = 0.0_wp 7036 ! 7037 !-- Note that the index name i must not be used here as a loop 7038 !-- index name since i is the constant boundary index, hence 7039 !-- the name ia. 7040 DO ia = ifl(l), ifu(l) 7041 iaw = ia - i 7042 iw = MAX( MIN( ia, nx+1 ), -1 ) 7043 DO j = jfl(m), jfu(m) 7044 jw = MAX( MIN( j, ny+1 ), -1 ) 7045 DO k = kfl(n), kfu(n) 7046 kw = MIN( k, nzt+1 ) 7047 !AH 7048 ! cellsum = cellsum + MERGE( f(k,j,ia), 0.0_wp, & 7049 ! BTEST( wall_flags_0(kw,jw,iw), var_flag ) ) 7050 cellsum = cellsum + MERGE( workarr_lr(k,j,iaw), 0.0_wp, & 7051 BTEST( wall_flags_0(kw,jw,iw), var_flag ) ) 7052 !AH 7053 7054 !AH celltmpd(ijk) = ABS( fc(n,m,l) - f(k,j,ia) ) 7055 !AH celltmpd(ijk) = ABS( workarrc_lr(n,m,lw) - f(k,j,ia) ) 7056 celltmpd(ijk) = ABS( workarrc_lr(n,m,lw) - workarr_lr(k,j,iaw) ) 7057 cellsumd = cellsumd + MERGE( celltmpd(ijk), & 7058 0.0_wp, BTEST( wall_flags_0(kw,jw,iw), var_flag ) ) 7059 7060 ! write(9,"('lr1: ',a1,2x,8(i4,2x),5(e12.5,2x))") var, n, m, l, k, j, ia, iaw, ijk, & 7061 ! workarrc_lr(n,m,lw), workarr_lr(k,j,iaw), cellsum, celltmpd(ijk), cellsumd 7062 ! flush(9) 7063 7064 ijk = ijk + 1 7065 ENDDO 7066 ENDDO 7067 ENDDO 7068 7069 IF ( ijkfc(n,m,l) /= 0 ) THEN 7070 cellsum = cellsum / REAL( ijkfc(n,m,l), KIND=wp ) 7071 ! rcorr = fc(n,m,l) - cellsum 7072 rcorr = workarrc_lr(n,m,lw) - cellsum 7073 cellsumd = cellsumd / REAL( ijkfc(n,m,l), KIND=wp ) 7074 ELSE 7075 cellsum = 0.0_wp 7076 rcorr = 0.0_wp 7077 cellsumd = 1.0_wp 7078 celltmpd = 1.0_wp 7079 ENDIF 7080 ! 7081 !-- Distribute the correction term to the child nodes according to 7082 !-- their relative difference to the parent value such that the 7083 !-- node with the largest difference gets the largest share of the 7084 !-- correction. The distribution is skipped if rcorr is negligibly 7085 !-- small in order to avoid division by zero. 7086 IF ( ABS(rcorr) < 0.000001_wp ) THEN 7087 cellsumd = 1.0_wp 7088 celltmpd = 1.0_wp 7089 ENDIF 7090 7091 ijk = 1 7092 DO ia = ifl(l), ifu(l) 7093 !AH iaw = ia - ifl(l) 7094 iaw = ia - i 7095 DO j = jfl(m), jfu(m) 7096 DO k = kfl(n), kfu(n) 7097 rcorr_ijk = rcorr * celltmpd(ijk) / cellsumd 7098 !AH f(k,j,ia) = f(k,j,ia) + rcorr_ijk 7099 workarr_lr(k,j,iaw) = workarr_lr(k,j,iaw) + rcorr_ijk 7100 7101 ! write(9,"('lr2: ',a1,2x,9(i4,2x),4(e12.5,2x))") var, n, m, l, k, j, ia, iaw, ijk, ijkfc(n,m,l), & 7102 ! rcorr, rcorr_ijk, workarr_lr(k,j,iaw), workarrc_lr(n,m,lw) 7103 ! flush(9) 7104 7105 ijk = ijk + 1 7106 ENDDO 7107 ENDDO 7108 ENDDO 7109 ! 7110 !-- Velocity components tangential to the boundary need special 7111 !-- treatment because their anterpolation cells are flat in their 7112 !-- direction and hence do not cover all the child-grid boundary nodes. 7113 !-- These components are next linearly interpolated to those child-grid 7114 !-- boundary nodes which are not covered by the anterpolation cells. 7115 IF ( ( var == 'w' ) .AND. ( n > 0 ) ) THEN 7116 DO k = kfu(n-1)+1, kfl(n)-1 7117 IF ( k <= nzt ) THEN 7118 DO j = jfl(m), jfu(m) 7119 IF ( ( j >= nys ) .AND. ( j <= nyn+1 ) ) THEN 7120 !AH 7121 ! f(k,j,ia) = r1z(k) * f(kfu(n-1),j,ia) & 7122 ! + r2z(k) * f(kfl(n),j,ia) 7123 workarr_lr(k,j,iawbc) = & 7124 r1z(k) * workarr_lr(kfu(n-1),j,iawbc) & 7125 + r2z(k) * workarr_lr(kfl(n),j,iawbc) 7126 7127 ! write(9,"('lr3: ',a1,2x,7(i4,2x),3(e12.5,2x))") var, n, m, l, k, j, iawbc, ibc, & 7128 ! workarr_lr(k-1,j,iawbc), workarr_lr(k,j,iawbc), workarr_lr(k+1,j,iawbc) 7129 ! flush(9) 7130 7131 !AH 7132 ENDIF 7133 ENDDO 7134 ENDIF 7135 ENDDO 7136 ENDIF 7137 7138 IF ( ( var == 'v' ) .AND. ( m > jcsw ) ) THEN 7139 DO j = jfu(m-1)+1, jfl(m)-1 7140 IF ( ( j >= nys ) .AND. ( j <= nyn+1 ) ) THEN 7141 DO k = kfl(n), kfu(n) 7142 IF ( k <= nzt+1 ) THEN 7143 !AH 7144 ! f(k,j,ia) = r1y(j) * f(k,jfu(m-1),ia) & 7145 ! + r2y(j) * f(k,jfl(m),ia) 7146 workarr_lr(k,j,iawbc) = & 7147 r1y(j) * workarr_lr(k,jfu(m-1),iawbc) & 7148 + r2y(j) * workarr_lr(k,jfl(m),iawbc) 7149 7150 ! write(9,"('lr4: ',a1,2x,7(i4,2x),3(e12.5,2x))") var, n, m, l, k, j, iawbc, ibc, & 7151 ! workarr_lr(k,j-1,iawbc), workarr_lr(k,j,iawbc), workarr_lr(k,j+1,iawbc) 7152 ! flush(9) 7153 7154 !AH 7155 ENDIF 7156 ENDDO 7157 ENDIF 7158 ENDDO 7159 ENDIF 7160 7161 ENDDO ! n 7162 ENDDO ! m 7163 7164 ! endif ! var 7165 7166 ! 7167 !-- Finally substitute the boundary values. 7168 f(nzb:nzt+1,nys:nyn,ibc) = workarr_lr(nzb:nzt+1,nys:nyn,iawbc) 7169 7170 ! do k = 0, 2 7171 ! do j = nys, nyn 7172 ! if ( edge == 'l' ) then 7173 ! write(9,"('lr5: ',2(a2,2x),4(i4,2x),4(e12.5,2x))") edge, var, k, j, ibc, iawbc, & 7174 ! workarr_lr(k,j,iawbc), f(k,j,ibc), f(k,j,ibc+1), f(k,j,ibc+2) 7175 ! else if ( edge == 'r' ) then 7176 ! write(9,"('lr5: ',2(a2,2x),4(i4,2x),4(e12.5,2x))") edge, var, k, j, ibc, iawbc, & 7177 ! f(k,j,ibc-2), f(k,j,ibc-1), f(k,j,ibc), workarr_lr(k,j,iawbc) 7178 ! endif 7179 ! enddo 7180 ! enddo 7181 ! flush(9) 7182 7183 END SUBROUTINE pmci_interp_tril_lr 7184 7185 7186 7187 SUBROUTINE pmci_interp_tril_sn( f, fc, ic, jc, kc, r1x, r2x, r1y, r2y, r1z, & 7188 r2z, logc, logc_ratio, logc_kbounds, & 7189 nzt_topo_nestbc, & 7190 kct, ifl, ifu, jfl, jfu, kfl, kfu, ijkfc, & 7191 edge, var ) 7192 7193 ! 7194 !-- Interpolation of ghost-node values used as the child-domain boundary 7195 !-- conditions. This subroutine handles the south and north boundaries. 7196 !-- This subroutine is based on trilinear interpolation. 7197 7198 IMPLICIT NONE 7199 7200 INTEGER(iwp) :: nzt_topo_nestbc !< 7201 7202 REAL(wp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg), & 7203 INTENT(INOUT) :: f !< 7204 REAL(wp), DIMENSION(0:cg%nz+1,jcs:jcn,icl:icr), & 7205 INTENT(IN) :: fc !< 7206 REAL(wp), DIMENSION(1:2,0:ncorr-1,nzb:nzt_topo_nestbc,nxl:nxr), & 7207 INTENT(IN) :: logc_ratio !< 7208 REAL(wp), DIMENSION(nxlfc:nxrfc), INTENT(IN) :: r1x !< 7209 REAL(wp), DIMENSION(nxlfc:nxrfc), INTENT(IN) :: r2x !< 7210 REAL(wp), DIMENSION(nysfc:nynfc), INTENT(IN) :: r1y !< 7211 REAL(wp), DIMENSION(nysfc:nynfc), INTENT(IN) :: r2y !< 7212 !AH REAL(wp), DIMENSION(nzb:nzt+1), INTENT(IN) :: r1z !< 7213 !AH REAL(wp), DIMENSION(nzb:nzt+1), INTENT(IN) :: r2z !< 7214 REAL(wp), DIMENSION(nzb:nzt+kgsr), INTENT(IN) :: r1z !< 7215 REAL(wp), DIMENSION(nzb:nzt+kgsr), INTENT(IN) :: r2z !< 7216 7217 7218 INTEGER(iwp), DIMENSION(nxlfc:nxrfc), INTENT(IN) :: ic !< 7219 INTEGER(iwp), DIMENSION(nysfc:nynfc), INTENT(IN) :: jc !< 7220 !AH INTEGER(iwp), DIMENSION(nzb:nzt+1), INTENT(IN) :: kc !< 7221 INTEGER(iwp), DIMENSION(nzb:nzt+kgsr), INTENT(IN) :: kc !< 7222 INTEGER(iwp), DIMENSION(1:2,nzb:nzt_topo_nestbc,nxl:nxr), & 7223 INTENT(IN) :: logc !< 7224 INTEGER(iwp), DIMENSION(1:2,nxl:nxr), INTENT(IN) :: logc_kbounds !< 7225 7226 INTEGER(iwp) :: kct 7227 !AH 7228 ! INTEGER(iwp), DIMENSION(icl:icr), INTENT(IN) :: ifl !< Indicates start index of child cells belonging to certain parent cell - x direction 7229 ! INTEGER(iwp), DIMENSION(icl:icr), INTENT(IN) :: ifu !< Indicates end index of child cells belonging to certain parent cell - x direction 7230 ! INTEGER(iwp), DIMENSION(jcs:jcn), INTENT(IN) :: jfl !< Indicates start index of child cells belonging to certain parent cell - y direction 7231 ! INTEGER(iwp), DIMENSION(jcs:jcn), INTENT(IN) :: jfu !< Indicates start index of child cells belonging to certain parent cell - y direction 7232 INTEGER(iwp), DIMENSION(icla:icra), INTENT(IN) :: ifl !< Indicates start index of child cells belonging to certain parent cell - x direction 7233 INTEGER(iwp), DIMENSION(icla:icra), INTENT(IN) :: ifu !< Indicates end index of child cells belonging to certain parent cell - x direction 7234 INTEGER(iwp), DIMENSION(jcsa:jcna), INTENT(IN) :: jfl !< Indicates start index of child cells belonging to certain parent cell - y direction 7235 INTEGER(iwp), DIMENSION(jcsa:jcna), INTENT(IN) :: jfu !< Indicates start index of child cells belonging to certain parent cell - y direction 7236 !AH 7237 7238 !AH INTEGER(iwp), DIMENSION(0:kct), INTENT(IN) :: kfl !< Indicates start index of child cells belonging to certain parent cell - z direction 7239 !AH INTEGER(iwp), DIMENSION(0:kct), INTENT(IN) :: kfu !< Indicates start index of child cells belonging to certain parent cell - z direction 7240 INTEGER(iwp), DIMENSION(0:cg%nz+1), INTENT(IN) :: kfl !< Indicates start index of child cells belonging to certain parent cell - z direction 7241 INTEGER(iwp), DIMENSION(0:cg%nz+1), INTENT(IN) :: kfu !< Indicates start index of child cells belonging to certain parent cell - z direction 7242 !AH INTEGER(iwp), DIMENSION(0:kct,jcs:jcn,icl:icr), INTENT(IN) :: ijkfc !< number of child grid points contributing to a parent grid box 7243 !AH 7244 ! INTEGER(iwp), DIMENSION(0:cg%nz+1,jcs:jcn,icl:icr), INTENT(IN) :: ijkfc !< number of child grid points contributing to a parent grid box 7245 INTEGER(iwp), DIMENSION(0:cg%nz+1,jcsa:jcna,icla:icra), INTENT(IN) :: ijkfc !< number of child grid points contributing to a parent grid box 7246 !AH 7247 7248 CHARACTER(LEN=1), INTENT(IN) :: edge !< Edge symbol: 'l', 'r', 's' or 'n' 7249 CHARACTER(LEN=1), INTENT(IN) :: var !< Variable symbol: 'u', 'v', 'w' or 's' 7250 7251 INTEGER(iwp) :: i !< Running index in the x-direction 7252 INTEGER(iwp) :: iinc !< 7253 INTEGER(iwp) :: icorr !< 7254 INTEGER(iwp) :: ico !< 7255 INTEGER(iwp) :: ierr !< MPI error code 7256 INTEGER(iwp) :: ijk !< Running index for all child-grid cells within the anterpolation cell 7257 INTEGER(iwp) :: iw !< i-index for wall_flags_0 7258 INTEGER(iwp) :: i1 !< 7259 INTEGER(iwp) :: j !< Lower bound of the running index ja 7260 INTEGER(iwp) :: ja !< Index in y-direction running over the parent-grid cell on the boundary 7261 INTEGER(iwp) :: jaw !< Reduced ja-index for workarr_sn 7262 INTEGER(iwp) :: jawbc !< jaw-index pointing to the boundary-value nodes (either 0 or jgsr-1) 7263 !AH INTEGER(iwp) :: jbeg !< j-index pointing to the starting point of workarr_sn in the j-direction 7264 INTEGER(iwp) :: jbc !< Fixed j-index pointing to the boundary-value nodes (either j or jend) 7265 INTEGER(iwp) :: jend !< Upper bound of the running index ja 7266 INTEGER(iwp) :: jw !< j-index for wall_flags_0 7267 INTEGER(iwp) :: k !< Running index in the z-direction 7268 INTEGER(iwp) :: k_wall !< Vertical index of topography top 7269 INTEGER(iwp) :: kcorr !< 7270 INTEGER(iwp) :: kco !< 7271 INTEGER(iwp) :: kw !< k-index for wall_flags_0 7272 INTEGER(iwp) :: k1 !< 7273 INTEGER(iwp) :: l !< Parent-grid running index in the x-direction 7274 INTEGER(iwp) :: lp1 !< l+1 7275 INTEGER(iwp) :: lrightu !< Upshift by one for the upper bound of index l in case of var == 'u' 7276 INTEGER(iwp) :: m !< Parent-grid running index in the y-direction 7277 INTEGER(iwp) :: mbeg !< m-index pointing to the starting point of workarrc_sn in the m-direction 7278 INTEGER(iwp) :: moff !< m-offset needed on the north boundary to correctly refer to boundary ghost points 7279 INTEGER(iwp) :: mp1 !< m+1 7280 INTEGER(iwp) :: mw !< Reduced m-index for workarrc_sn 7281 INTEGER(iwp) :: n !< Parent-grid running index in the z-direction 7282 INTEGER(iwp) :: np1 !< n+1 7283 INTEGER(iwp) :: ntopw !< Upshift by one for the upper bound of index n in case of var == 'w' 7284 INTEGER(iwp) :: var_flag !< Variable flag for BTEST( wall_flags_0 ) 7285 7286 REAL(wp) :: cellsum !< Sum of child-grid node values over the anterpolation cell 7287 REAL(wp) :: cellsumd !< Sum of differences over the anterpolation cell 7288 REAL(wp) :: fk !< Intermediate result in trilinear interpolation 7289 REAL(wp) :: fkj !< Intermediate result in trilinear interpolation 7290 REAL(wp) :: fkjp !< Intermediate result in trilinear interpolation 7291 REAL(wp) :: fkpj !< Intermediate result in trilinear interpolation 7292 REAL(wp) :: fkpjp !< Intermediate result in trilinear interpolation 7293 REAL(wp) :: fkp !< Intermediate result in trilinear interpolation 7294 REAL(wp) :: rcorr !< Average reversibility correction for the whole anterpolation cell 7295 REAL(wp) :: rcorr_ijk !< Reversibility correction distributed to the individual child-grid nodes 7296 7297 ! 7298 !-- Check which edge is to be handled: south or north 7299 IF ( edge == 's' ) THEN 7300 ! 7301 !-- For v, nys is a ghost node, but not for the other variables 7302 IF ( var == 'v' ) THEN 7303 j = nys 7304 jend = nys 7305 jawbc = 0 7306 jbc = nys 7307 mbeg = jcs 7308 moff = 0 7309 ELSE 7310 j = nys - jgsr 7311 jend = nys - 1 7312 jawbc = jgsr - 1 7313 jbc = nys - 1 7314 mbeg = jcs 7315 moff = 0 7316 ENDIF 7317 ELSEIF ( edge == 'n' ) THEN 7318 IF ( var == 'v' ) THEN 7319 j = nyn + 1 7320 jend = nyn + 1 7321 jawbc = 0 7322 jbc = nyn + 1 7323 mbeg = jcn - 2 7324 moff = 0 7325 ELSE 7326 j = nyn + 1 7327 jend = nyn + jgsr 7328 jawbc = 0 7329 jbc = nyn + 1 7330 mbeg = jcn - 2 7331 moff = 1 7332 ENDIF 7333 ENDIF 7334 7335 IF ( var == 'w' ) THEN 7336 ntopw = 1 7337 ELSE 7338 ntopw = 0 7339 ENDIF 7340 7341 IF ( var == 'u' ) THEN 7342 lrightu = 0 7343 ELSE 7344 lrightu = 1 7345 ENDIF 7346 7347 IF ( var == 'u' ) THEN 7348 var_flag = 1 7349 ELSEIF ( var == 'v' ) THEN 7350 var_flag = 2 7351 ELSEIF ( var == 'w' ) THEN 7352 var_flag = 3 7353 ELSE 7354 var_flag = 0 7355 ENDIF 7356 !AH 7357 ! 7358 !-- Substitute the necessary parent-grid data to the work array workarrc_sn. 7359 workarrc_sn = 0.0_wp 7360 IF ( pdims(1) > 1 ) THEN 7361 #if defined( __parallel ) 7362 IF ( nxl == 0 ) THEN ! if ( bc_dirichlet_l ) 7363 workarrc_sn(0:cg%nz+1,0:2,iclw:icrw-1) & 7364 = fc(0:cg%nz+1,mbeg:mbeg+2,iclw:icrw-1) 7365 ELSE IF ( nxr == nx ) THEN ! if ( bc_dirichlet_r ) 7366 workarrc_sn(0:cg%nz+1,0:2,iclw+1:icrw) & 7367 = fc(0:cg%nz+1,mbeg:mbeg+2,iclw+1:icrw) 7368 ELSE 7369 workarrc_sn(0:cg%nz+1,0:2,iclw+1:icrw-1) & 7370 = fc(0:cg%nz+1,mbeg:mbeg+2,iclw+1:icrw-1) 7371 ENDIF 7372 ! 7373 !-- Left-right exchange if more than one PE subdomain in the x-direction. 7374 !-- Note that in case of 3-D nesting the left (pleft == MPI_PROC_NULL) and 7375 !-- right (pright == MPI_PROC_NULL) boundaries are not exchanged because 7376 !-- the nest domain is not cyclic. 7377 !-- From left to right 7378 CALL MPI_SENDRECV( workarrc_sn(0,0,iclw+1), 1, & 7379 workarrc_sn_exchange_type, pleft, 0, & 7380 workarrc_sn(0,0,icrw), 1, & 7381 workarrc_sn_exchange_type, pright, 0, & 7382 comm2d, status, ierr ) 7383 ! 7384 !-- From right to left 7385 CALL MPI_SENDRECV( workarrc_sn(0,0,icrw-1), 1, & 7386 workarrc_sn_exchange_type, pright, 1, & 7387 workarrc_sn(0,0,iclw), 1, & 7388 workarrc_sn_exchange_type, pleft, 1, & 7389 comm2d, status, ierr ) 7390 #endif 7391 ELSE 7392 workarrc_sn(0:cg%nz+1,0:2,iclw+1:icrw-1) & 7393 = fc(0:cg%nz+1,mbeg:mbeg+2,iclw+1:icrw-1) 7394 ENDIF 7395 ! 7396 !AH 7397 7398 workarr_sn = 0.0_wp 7399 7400 DO i = nxl-1, nxr+1 7401 !AH DO i = nxl, nxr 7402 DO ja = j, jend 7403 jaw = ja - j 7404 DO k = nzb, nzt+1 7405 l = ic(i) 7406 lp1 = MIN( l + 1, icrw ) ! If l+1 > icr (l=ic(nxr+1)), r1x = 1 and r2x = 0 7407 !AH m = jc(ja) - jc(j) 7408 m = jc(ja) - mbeg 7409 mp1 = MIN( m + 1, 2 ) ! If m+1 > 2 (m=jc(nyn+1)-mbeg), r1y = 1 and r2y = 0 7410 n = kc(k) 7411 np1 = n + 1 7412 !AH 7413 ! fkj = r1x(i) * fc(n,m,l) + r2x(i) * fc(n,m,l+1) 7414 ! fkjp = r1x(i) * fc(n,m+1,l) + r2x(i) * fc(n,m+1,l+1) 7415 ! fkpj = r1x(i) * fc(n+1,m,l) + r2x(i) * fc(n+1,m,l+1) 7416 ! fkpjp = r1x(i) * fc(n+1,m+1,l) + r2x(i) * fc(n+1,m+1,l+1) 7417 !AH 7418 fkj = r1x(i) * workarrc_sn(n,m,l) + r2x(i) * workarrc_sn(n,m,lp1) 7419 fkjp = r1x(i) * workarrc_sn(n,mp1,l) + r2x(i) * workarrc_sn(n,mp1,lp1) 7420 fkpj = r1x(i) * workarrc_sn(np1,m,l) + r2x(i) * workarrc_sn(np1,m,lp1) 7421 fkpjp = r1x(i) * workarrc_sn(np1,mp1,l) + r2x(i) * workarrc_sn(np1,mp1,lp1) 7422 7423 fk = r1y(ja) * fkj + r2y(ja) * fkjp 7424 fkp = r1y(ja) * fkpj + r2y(ja) * fkpjp 7425 !AH 7426 ! f(k,j,i) = r1z(k) * fk + r2z(k) * fkp 7427 workarr_sn(k,jaw,i) = r1z(k) * fk + r2z(k) * fkp 7428 7429 ! if ( ( edge == 's' ) .and. ( ja == jbc ) ) then 7430 ! write(9,"('pmci_interp_tril_sn: ',a2,2x,11(i4,2x),1(e12.5,2x))") var, k, ja, i, jbc, jaw, n, m, l, np1, mp1, lp1, & 7431 ! workarr_sn(k,jaw,i) 7432 ! flush(9) 7433 ! endif 7434 7435 !AH 7436 ENDDO 7437 ENDDO 7438 ENDDO 7439 ! 7440 !-- Generalized log-law-correction algorithm. 7441 !-- Multiply two-dimensional index arrays logc(1:2,:,:) and log-ratio arrays 7442 !-- logc_ratio(1:2,0:ncorr-1,:,:) have been precomputed in subroutine 7443 !-- pmci_init_loglaw_correction. 7444 ! 7445 !-- Solid surface below the node 7446 IF ( constant_flux_layer .AND. ( var == 'u' .OR. var == 'v' ) ) THEN 7447 DO i = nxl, nxr 7448 ! 7449 !-- Determine vertical index of topography top at grid point (j,i) 7450 k_wall = get_topography_top_index_ji( j, i, TRIM( var ) ) 7451 7452 k = k_wall + 1 7453 IF ( ( logc(1,k,i) /= 0 ) .AND. ( logc(2,k,i) == 0 ) ) THEN 7454 k1 = logc(1,k,i) 7455 DO kcorr = 0, ncorr-1 7456 kco = k + kcorr 7457 !AH f(kco,j,i) = logc_ratio(1,kcorr,k,i) * f(k1,j,i) 7458 ENDDO 7459 ENDIF 7460 ENDDO 7461 ENDIF 7462 ! 7463 !-- In case of non-flat topography, also vertical walls and corners need to be 7464 !-- treated. Only single and double wall nodes are corrected. 7465 !-- Triple and higher-multiple wall nodes are not corrected as it would be 7466 !-- extremely complicated and the log law would not be valid anyway in such 7467 !-- locations. 7468 IF ( topography /= 'flat' ) THEN 7469 7470 IF ( constant_flux_layer .AND. ( var == 'v' .OR. var == 'w' ) ) THEN 7471 DO i = nxl, nxr 7472 DO k = logc_kbounds(1,i), logc_kbounds(2,i) 7473 ! 7474 !-- Solid surface only on left/right side of the node 7475 IF ( ( logc(2,k,i) /= 0 ) .AND. ( logc(1,k,i) == 0 ) ) THEN 7476 ! 7477 !-- Direction of the wall-normal index is carried in as the 7478 !-- sign of logc 7479 iinc = SIGN( 1, logc(2,k,i) ) 7480 i1 = ABS( logc(2,k,i) ) 7481 DO icorr = 0, ncorr-1 7482 ico = i + iinc * icorr 7483 IF ( ico >= nxl .AND. ico <= nxr ) THEN 7484 !AH f(k,j,ico) = logc_ratio(2,icorr,k,i) * f(k,j,i1) 7485 ENDIF 7486 ENDDO 7487 ENDIF 7488 ENDDO 7489 ENDDO 7490 ENDIF 7491 ! 7492 !-- Solid surface on both below and on left/right side of the node 7493 IF ( constant_flux_layer .AND. var == 'v' ) THEN 7494 DO i = nxl, nxr 7495 k = logc_kbounds(1,i) 7496 IF ( ( logc(2,k,i) /= 0 ) .AND. ( logc(1,k,i) /= 0 ) ) THEN 7497 k1 = logc(1,k,i) 7498 iinc = SIGN( 1, logc(2,k,i) ) 7499 i1 = ABS( logc(2,k,i) ) 7500 DO icorr = 0, ncorr-1 7501 ico = i + iinc * icorr 7502 IF ( ico >= nxl .AND. ico <= nxr ) THEN 7503 DO kcorr = 0, ncorr-1 7504 kco = k + kcorr 7505 !AH f(kco,j,ico) = 0.5_wp * ( logc_ratio(1,kcorr,k,i) * & 7506 !AH f(k1,j,i) & 7507 !AH + logc_ratio(2,icorr,k,i) * & 7508 !AH f(k,j,i1) ) 7509 ENDDO 7510 ENDIF 7511 ENDDO 7512 ENDIF 7513 ENDDO 7514 ENDIF 7515 7516 ENDIF ! ( topography /= 'flat' ) 7517 ! 7518 !-- Apply the reversibility correction. 7519 7520 ! if ( var == 'u' ) then 7521 7522 m = jc(jbc) + moff 7523 mw = 1 7524 ! write(9,"('pmci_interp_tril_sn: edge, var, m, j, jend, jfl(m), jfu(m) = ',2(a2,2x),5(i4,2x))") & 7525 ! edge, var, m, j, jend, jfl(m), jfu(m) 7526 ! flush(9) 7527 !AH DO l = iclw+1, icrw-1 7528 DO l = iclw + 1, icrw - lrightu ! lrightu = 0 for u and 1 for all others 7529 DO n = 0, kct + ntopw ! ntopw = 1 for w and 0 for all others 7530 ijk = 1 7531 cellsum = 0.0_wp 7532 cellsumd = 0.0_wp 7533 DO i = ifl(l), ifu(l) 7534 iw = MAX( MIN( i, nx+1 ), -1 ) 7535 DO ja = jfl(m), jfu(m) 7536 jaw = ja - j 7537 jw = MAX( MIN( ja, ny+1 ), -1 ) 7538 DO k = kfl(n), kfu(n) 7539 kw = MIN( k, nzt+1 ) 7540 !AH cellsum = cellsum + MERGE( f(k,ja,i), 0.0_wp, & 7541 !AH BTEST( wall_flags_0(kw,jw,iw), var_flag ) ) 7542 cellsum = cellsum + MERGE( workarr_sn(k,jaw,i), 0.0_wp, & 7543 BTEST( wall_flags_0(kw,jw,iw), var_flag ) ) 7544 !AH celltmpd(ijk) = ABS( fc(n,m,l) - f(k,ja,i) ) 7545 !AH celltmpd(ijk) = ABS( workarrc_sn(n,mw,l) - f(k,ja,i) ) 7546 celltmpd(ijk) = ABS( workarrc_sn(n,mw,l) - workarr_sn(k,jaw,i) ) 7547 cellsumd = cellsumd + MERGE( celltmpd(ijk), & 7548 0.0_wp, BTEST( wall_flags_0(kw,jw,iw), var_flag ) ) 7549 7550 ! write(9,"('sn1: ',a1,2x,8(i4,2x),5(e12.5,2x))") var, n, m, l, k, ja, i, jaw, ijk, & 7551 ! workarrc_sn(n,mw,l), workarr_sn(k,jaw,i), cellsum, celltmpd(ijk), cellsumd 7552 ! flush(9) 7553 7554 ijk = ijk + 1 7555 ENDDO 7556 ENDDO 7557 ENDDO 7558 7559 IF ( ijkfc(n,m,l) /= 0 ) THEN 7560 cellsum = cellsum / REAL( ijkfc(n,m,l), KIND=wp ) 7561 !AH rcorr = fc(n,m,l) - cellsum 7562 rcorr = workarrc_sn(n,mw,l) - cellsum 7563 cellsumd = cellsumd / REAL( ijkfc(n,m,l), KIND=wp ) 7564 ELSE 7565 cellsum = 0.0_wp 7566 rcorr = 0.0_wp 7567 cellsumd = 1.0_wp 7568 celltmpd = 1.0_wp 7569 ENDIF 7570 ! 7571 !-- Distribute the correction term to the child nodes according to 7572 !-- their relative difference to the parent value such that the 7573 !-- node with the largest difference gets the largest share of the 7574 !-- correction. The distribution is skipped if rcorr is negligibly 7575 !-- small in order to avoid division by zero. 7576 IF ( ABS(rcorr) < 0.000001_wp ) THEN 7577 cellsumd = 1.0_wp 7578 celltmpd = 1.0_wp 7579 ENDIF 7580 7581 ijk = 1 7582 DO i = ifl(l), ifu(l) 7583 DO ja = jfl(m), jfu(m) 7584 !AH jaw = ja - jfl(m) 7585 jaw = ja - j 7586 DO k = kfl(n), kfu(n) 7587 rcorr_ijk = rcorr * celltmpd(ijk) / cellsumd 7588 !AH f(k,ja,i) = f(k,ja,i) + rcorr_ijk 7589 workarr_sn(k,jaw,i) = workarr_sn(k,jaw,i) + rcorr_ijk 7590 7591 ! write(9,"('sn2: ',a1,2x,9(i4,2x),4(e12.5,2x))") var, n, m, l, k, ja, i, jaw, ijk, ijkfc(n,m,l), & 7592 ! rcorr, rcorr_ijk, workarr_sn(k,jaw,i), workarrc_sn(n,mw,l) 7593 ! flush(9) 7594 7595 ijk = ijk + 1 7596 ENDDO 7597 ENDDO 7598 ENDDO 7599 ! 7600 !-- Velocity components tangential to the boundary need special 7601 !-- treatment because their anterpolation cells are flat in their 7602 !-- direction and hence do not cover all the child-grid boundary nodes. 7603 !-- These components are next linearly interpolated to those child-grid 7604 !-- boundary nodes which are not covered by the anterpolation cells. 7605 IF ( ( var == 'w' ) .AND. ( n > 0 ) ) THEN 7606 DO k = kfu(n-1)+1, kfl(n)-1 7607 IF ( k <= nzt ) THEN 7608 DO i = ifl(l), ifu(l) 7609 IF ( ( i >= nxl ) .AND. ( i <= nxr+1 ) ) THEN 7610 !AH f(k,ja,i) = r1z(k) * f(kfu(n-1),ja,i) & 7611 !AH + r2z(k) * f(kfl(n),ja,i) 7612 workarr_sn(k,jawbc,i) = & 7613 r1z(k) * workarr_sn(kfu(n-1),jawbc,i) + & 7614 r2z(k) * workarr_sn(kfl(n),jawbc,i) 7615 7616 ! write(9,"('sn3: ',a1,2x,7(i4,2x),3(e12.5,2x))") var, n, m, l, k, jawbc, i, jbc, & 7617 ! workarr_sn(k-1,jawbc,i), workarr_sn(k,jawbc,i), workarr_sn(k+1,jawbc,i) 7618 ! flush(9) 7619 7620 ENDIF 7621 ENDDO 7622 ENDIF 7623 ENDDO 7624 ENDIF 7625 7626 IF ( ( var == 'u' ) .AND. ( l > iclw ) ) THEN 7627 DO i = ifu(l-1)+1, ifl(l)-1 7628 IF ( ( i >= nxl ) .AND. ( i <= nxr+1 ) ) THEN 7629 DO k = kfl(n), kfu(n) 7630 IF ( k <= nzt+1 ) THEN 7631 !AH f(k,ja,i) = r1x(i) * f(k,ja,ifu(l-1)) & 7632 !AH + r2x(i) * f(k,ja,ifl(l)) 7633 workarr_sn(k,jawbc,i) = & 7634 r1x(i) * workarr_sn(k,jawbc,ifu(l-1)) + & 7635 r2x(i) * workarr_sn(k,jawbc,ifl(l)) 7636 7637 ! write(9,"('sn4: ',a1,2x,7(i4,2x),3(e12.5,2x))") var, n, m, l, k, jawbc, i, jbc, & 7638 ! workarr_sn(k,jawbc,i-1), workarr_sn(k,jawbc,i), workarr_sn(k,jawbc,i+1) 7639 ! flush(9) 7640 7641 ENDIF 7642 ENDDO 7643 ENDIF 7644 ENDDO 7645 ENDIF 7646 7647 ENDDO ! n 7648 ENDDO ! l 7649 7650 ! endif ! var 7651 7652 ! 7653 !-- Finally substitute the boundary values. 7654 f(nzb:nzt+1,jbc,nxl:nxr) = workarr_sn(nzb:nzt+1,jawbc,nxl:nxr) 7655 7656 ! do k = 0, 2 7657 ! do i = nxl, nxr 7658 ! if ( edge == 's' ) then 7659 ! write(9,"('sn5: ',2(a2,2x),4(i4,2x),4(e12.5,2x))") edge, var, k, i, jbc, jawbc, & 7660 ! workarr_sn(k,jawbc,i), f(k,jbc,i), f(k,jbc+1,i), f(k,jbc+2,i) 7661 ! else if ( edge == 'n' ) then 7662 ! write(9,"('sn5: ',2(a2,2x),4(i4,2x),4(e12.5,2x))") edge, var, k, i, jbc, jawbc, & 7663 ! f(k,jbc-2,i), f(k,jbc-1,i), f(k,jbc,i), workarr_sn(k,jawbc,i) 7664 ! endif 7665 ! enddo 7666 ! enddo 7667 ! flush(9) 7668 7669 END SUBROUTINE pmci_interp_tril_sn 7670 7671 7672 7673 SUBROUTINE pmci_interp_tril_t( f, fc, ic, jc, kc, r1x, r2x, r1y, r2y, & 7674 r1z, r2z, kct, ifl, ifu, jfl, jfu, kfl, kfu, & 7675 ijkfc, var ) 7676 7677 ! 7678 !-- Interpolation of ghost-node values used as the child-domain boundary 7679 !-- conditions. This subroutine handles the top boundary. 7680 !-- This subroutine is based on trilinear interpolation. 7681 7682 IMPLICIT NONE 7683 7684 REAL(wp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg), & 7685 INTENT(INOUT) :: f !< Child-grid array 7686 REAL(wp), DIMENSION(0:cg%nz+1,jcs:jcn,icl:icr), & 7687 INTENT(IN) :: fc !< Parent-grid array 7688 REAL(wp), DIMENSION(nxlfc:nxrfc), INTENT(IN) :: r1x !< 7689 REAL(wp), DIMENSION(nxlfc:nxrfc), INTENT(IN) :: r2x !< 7690 REAL(wp), DIMENSION(nysfc:nynfc), INTENT(IN) :: r1y !< 7691 REAL(wp), DIMENSION(nysfc:nynfc), INTENT(IN) :: r2y !< 7692 !AH REAL(wp), DIMENSION(nzb:nzt+1), INTENT(IN) :: r1z !< 7693 !AH REAL(wp), DIMENSION(nzb:nzt+1), INTENT(IN) :: r2z !< 7694 REAL(wp), DIMENSION(nzb:nzt+kgsr), INTENT(IN) :: r1z !< 7695 REAL(wp), DIMENSION(nzb:nzt+kgsr), INTENT(IN) :: r2z !< 7696 7697 7698 INTEGER(iwp), DIMENSION(nxlfc:nxrfc), INTENT(IN) :: ic !< 7699 INTEGER(iwp), DIMENSION(nysfc:nynfc), INTENT(IN) :: jc !< 7700 !AH INTEGER(iwp), DIMENSION(nzb:nzt+1), INTENT(IN) :: kc !< 7701 INTEGER(iwp), DIMENSION(nzb:nzt+kgsr), INTENT(IN) :: kc !< 7702 7703 INTEGER(iwp) :: kct 7704 !AH 7705 ! INTEGER(iwp), DIMENSION(icl:icr), INTENT(IN) :: ifl !< Indicates start index of child cells belonging to certain parent cell - x direction 7706 ! INTEGER(iwp), DIMENSION(icl:icr), INTENT(IN) :: ifu !< Indicates end index of child cells belonging to certain parent cell - x direction 7707 ! INTEGER(iwp), DIMENSION(jcs:jcn), INTENT(IN) :: jfl !< Indicates start index of child cells belonging to certain parent cell - y direction 7708 ! INTEGER(iwp), DIMENSION(jcs:jcn), INTENT(IN) :: jfu !< Indicates start index of child cells belonging to certain parent cell - y direction 7709 INTEGER(iwp), DIMENSION(icla:icra), INTENT(IN) :: ifl !< Indicates start index of child cells belonging to certain parent cell - x direction 7710 INTEGER(iwp), DIMENSION(icla:icra), INTENT(IN) :: ifu !< Indicates end index of child cells belonging to certain parent cell - x direction 7711 INTEGER(iwp), DIMENSION(jcsa:jcna), INTENT(IN) :: jfl !< Indicates start index of child cells belonging to certain parent cell - y direction 7712 INTEGER(iwp), DIMENSION(jcsa:jcna), INTENT(IN) :: jfu !< Indicates start index of child cells belonging to certain parent cell - y direction 7713 !AH INTEGER(iwp), DIMENSION(0:kct), INTENT(IN) :: kfl !< Indicates start index of child cells belonging to certain parent cell - z direction 7714 !AH INTEGER(iwp), DIMENSION(0:kct), INTENT(IN) :: kfu !< Indicates start index of child cells belonging to certain parent cell - z direction 7715 INTEGER(iwp), DIMENSION(0:cg%nz+1), INTENT(IN) :: kfl !< Indicates start index of child cells belonging to certain parent cell - z direction 7716 INTEGER(iwp), DIMENSION(0:cg%nz+1), INTENT(IN) :: kfu !< Indicates start index of child cells belonging to certain parent cell - z direction 7717 !AH INTEGER(iwp), DIMENSION(0:kct,jcs:jcn,icl:icr), INTENT(IN) :: ijkfc !< number of child grid points contributing to a parent grid box 7718 !AH 7719 ! INTEGER(iwp), DIMENSION(0:cg%nz+1,jcs:jcn,icl:icr), INTENT(IN) :: ijkfc !< number of child grid points contributing to a parent grid box 7720 INTEGER(iwp), DIMENSION(0:cg%nz+1,jcsa:jcna,icla:icra), INTENT(IN) :: ijkfc !< number of child grid points contributing to a parent grid box 7721 !AH 7722 7723 CHARACTER(LEN=1), INTENT(IN) :: var !< 7724 7725 INTEGER(iwp) :: i !< 7726 INTEGER(iwp) :: ib !< 7727 INTEGER(iwp) :: iclc !< Lower i-index limit for copying fc-data to workarrc_t 7728 INTEGER(iwp) :: icrc !< Upper i-index limit for copying fc-data to workarrc_t 7729 INTEGER(iwp) :: ie !< 7730 INTEGER(iwp) :: ierr !< MPI error code 7731 INTEGER(iwp) :: ijk !< 7732 INTEGER(iwp) :: iw !< 7733 INTEGER(iwp) :: j !< 7734 INTEGER(iwp) :: jb !< 7735 INTEGER(iwp) :: jcsc !< Lower j-index limit for copying fc-data to workarrc_t 7736 INTEGER(iwp) :: jcnc !< Upper j-index limit for copying fc-data to workarrc_t 7737 INTEGER(iwp) :: je !< 7738 INTEGER(iwp) :: jw !< 7739 INTEGER(iwp) :: k !< Vertical child-grid index fixed to the boundary-value level 7740 INTEGER(iwp) :: ka !< Running vertical child-grid index 7741 INTEGER(iwp) :: kw !< 7742 INTEGER(iwp) :: l !< Parent-grid index in x-direction 7743 INTEGER(iwp) :: lp1 !< l+1 7744 INTEGER(iwp) :: m !< Parent-grid index in y-direction 7745 INTEGER(iwp) :: mp1 !< m+1 7746 INTEGER(iwp) :: n !< Parent-grid work array index in z-direction 7747 INTEGER(iwp) :: np1 !< n+1 7748 INTEGER(iwp) :: noff !< n-offset needed on the top boundary to correctly refer to boundary ghost points 7749 INTEGER(iwp) :: nw !< n-index for workarrc_t 7750 INTEGER(iwp) :: var_flag !< 7751 7752 REAL(wp) :: cellsum !< 7753 REAL(wp) :: cellsumd !< 7754 REAL(wp) :: fk !< 7755 REAL(wp) :: fkj !< 7756 REAL(wp) :: fkjp !< 7757 REAL(wp) :: fkpj !< 7758 REAL(wp) :: fkpjp !< 7759 REAL(wp) :: fkp !< 7760 REAL(wp) :: rcorr !< 7761 REAL(wp) :: rcorr_ijk !< 7762 7763 integer(iwp) :: kend 7764 7765 7766 IF ( var == 'w' ) THEN 7767 k = nzt 7768 noff = 0 7769 kend = nzt 7770 ELSE 7771 k = nzt + 1 7772 noff = 1 7773 kend = nzt+kgsr 7774 ENDIF 7775 ! 7776 !-- These exceedings by one are needed only to avoid stripes 7777 !-- and spots in visualization. They have no effect on the 7778 !-- actual solution. 7779 ! 7780 !AH These loop bounds lead to overflows with the current reduced icl, icr, jcs, jcn 7781 !AH ib = nxl-1 7782 !AH ie = nxr+1 7783 !AH jb = nys-1 7784 !AH je = nyn+1 7785 ib = nxl 7786 ie = nxr 7787 jb = nys 7788 je = nyn 7789 7790 IF ( var == 'u' ) THEN 7791 var_flag = 1 7792 ie = nxr + 1 ! Needed for finishing interpolation for u 7793 ELSEIF ( var == 'v' ) THEN 7794 var_flag = 2 7795 je = nyn + 1 ! Needed for finishing interpolation for v 7796 ELSEIF ( var == 'w' ) THEN 7797 var_flag = 3 7798 ELSE 7799 var_flag = 0 7800 ENDIF 7801 7802 !AH DO i = ib, ie 7803 !AH DO j = jb, je 7804 !AH l = ic(i) 7805 !AH m = jc(j) 7806 !AH n = kc(k) 7807 !AH fkj = r1x(i) * fc(n,m,l) + r2x(i) * fc(n,m,l+1) 7808 !AH fkjp = r1x(i) * fc(n,m+1,l) + r2x(i) * fc(n,m+1,l+1) 7809 !AH fkpj = r1x(i) * fc(n+1,m,l) + r2x(i) * fc(n+1,m,l+1) 7810 !AH fkpjp = r1x(i) * fc(n+1,m+1,l) + r2x(i) * fc(n+1,m+1,l+1) 7811 !AH fk = r1y(j) * fkj + r2y(j) * fkjp 7812 !AH fkp = r1y(j) * fkpj + r2y(j) * fkpjp 7813 !AH f(k,j,i) = r1z(k) * fk + r2z(k) * fkp 7814 !AH ENDDO 7815 !AH ENDDO 7816 7817 ! write(9,"('workarrc_t kbounds: ',a2,2x,5(i3,2x))") var, k, kend, kc(k), kc(kend), cg%nz+1 7818 ! flush(9) 7819 !AH 7820 ! 7821 !-- Substitute the necessary parent-grid data to the work array. 7822 !-- Note that the dimension of workarrc_t is (0:2,jcsw:jcnw,iclw:icrw), 7823 !-- And the jc?w and ic?w-index bounds depend on the location of the PE- 7824 !-- subdomain relative to the side boundaries. 7825 iclc = iclw + 1 7826 icrc = icrw - 1 7827 jcsc = jcsw + 1 7828 jcnc = jcnw - 1 7829 IF ( bc_dirichlet_l ) THEN 7830 iclc = iclw 7831 ENDIF 7832 IF ( bc_dirichlet_r ) THEN 7833 icrc = icrw 7834 ENDIF 7835 IF ( bc_dirichlet_s ) THEN 7836 jcsc = jcsw 7837 ENDIF 7838 IF ( bc_dirichlet_n ) THEN 7839 jcnc = jcnw 7840 ENDIF 7841 workarrc_t = 0.0_wp 7842 workarrc_t(0:2,jcsc:jcnc,iclc:icrc) & 7843 = fc(kc(k):kc(k)+2,jcsc:jcnc,iclc:icrc) 7844 ! 7845 !-- Left-right exchange if more than one PE subdomain in the x-direction. 7846 !-- Note that in case of 3-D nesting the left and right boundaries are 7847 !-- not exchanged because the nest domain is not cyclic. 7848 #if defined( __parallel ) 7849 IF ( pdims(1) > 1 ) THEN 7850 ! 7851 !-- From left to right 7852 CALL MPI_SENDRECV( workarrc_t(0,jcsw,iclw+1), 1, & 7853 workarrc_t_exchange_type_y, pleft, 0, & 7854 workarrc_t(0,jcsw,icrw), 1, & 7855 workarrc_t_exchange_type_y, pright, 0, & 7856 comm2d, status, ierr ) 7857 ! 7858 !-- From right to left 7859 CALL MPI_SENDRECV( workarrc_t(0,jcsw,icrw-1), 1, & 7860 workarrc_t_exchange_type_y, pright, 1, & 7861 workarrc_t(0,jcsw,iclw), 1, & 7862 workarrc_t_exchange_type_y, pleft, 1, & 7863 comm2d, status, ierr ) 7864 ENDIF 7865 ! 7866 !-- South-north exchange if more than one PE subdomain in the y-direction. 7867 !-- Note that in case of 3-D nesting the south and north boundaries are 7868 !-- not exchanged because the nest domain is not cyclic. 7869 IF ( pdims(2) > 1 ) THEN 7870 ! 7871 !-- From south to north 7872 CALL MPI_SENDRECV( workarrc_t(0,jcsw+1,iclw), 1, & 7873 workarrc_t_exchange_type_x, psouth, 2, & 7874 workarrc_t(0,jcnw,iclw), 1, & 7875 workarrc_t_exchange_type_x, pnorth, 2, & 7876 comm2d, status, ierr ) 7877 ! 7878 !-- From north to south 7879 CALL MPI_SENDRECV( workarrc_t(0,jcnw-1,iclw), 1, & 7880 workarrc_t_exchange_type_x, pnorth, 3, & 7881 workarrc_t(0,jcsw,iclw), 1, & 7882 workarrc_t_exchange_type_x, psouth, 3, & 7883 comm2d, status, ierr ) 7884 ENDIF 7885 #endif 7886 ! 7887 !AH 7888 7889 workarr_t = 0.0_wp 7890 7891 DO i = ib, ie 7892 DO j = jb, je 7893 DO ka = k, kend 7894 l = ic(i) 7895 lp1 = MIN( l + 1, icrw ) ! If l+1 > icr (l=ic(nxr+1)), r1x = 1 and r2x = 0 7896 m = jc(j) 7897 mp1 = MIN( m + 1, jcnw ) ! If m+1 > jcn (m=jc(nyn+1)), r1y = 1 and r2y = 0 7898 !AH 7899 ! n = kc(ka) 7900 n = kc(ka) - kc(k) 7901 np1 = n + 1 7902 !AH 7903 ! fkj = r1x(i) * fc(n,m,l) + r2x(i) * fc(n,m,l+1) 7904 ! fkjp = r1x(i) * fc(n,m+1,l) + r2x(i) * fc(n,m+1,l+1) 7905 ! fkpj = r1x(i) * fc(n+1,m,l) + r2x(i) * fc(n+1,m,l+1) 7906 ! fkpjp = r1x(i) * fc(n+1,m+1,l) + r2x(i) * fc(n+1,m+1,l+1) 7907 !AH 7908 fkj = r1x(i) * workarrc_t(n,m,l) + r2x(i) * workarrc_t(n,m,lp1) 7909 fkjp = r1x(i) * workarrc_t(n,mp1,l) + r2x(i) * workarrc_t(n,mp1,lp1) 7910 fkpj = r1x(i) * workarrc_t(np1,m,l) + r2x(i) * workarrc_t(np1,m,lp1) 7911 fkpjp = r1x(i) * workarrc_t(np1,mp1,l) + r2x(i) * workarrc_t(np1,mp1,lp1) 7912 !AH 7913 fk = r1y(j) * fkj + r2y(j) * fkjp 7914 fkp = r1y(j) * fkpj + r2y(j) * fkpjp 7915 workarr_t(ka,j,i) = r1z(ka) * fk + r2z(ka) * fkp 7916 7917 ENDDO 7918 ENDDO 7919 ENDDO 7920 7921 !AH! 7922 !AH!-- Just fill up the redundant second ghost-node layer for w. 7923 !AH IF ( var == 'w' ) THEN 7924 !AH f(nzt+1,:,:) = f(nzt,:,:) 7925 !AH ENDIF 7926 ! 7927 !-- Apply the reversibility correction. 7928 n = kc(k) + noff 7929 nw = 0 7930 !AH DO l = icl-1, icr+1 7931 DO l = iclw, icrw 7932 !AH DO m = jcs-1, jcn+1 7933 DO m = jcsw, jcnw 7934 ijk = 1 7935 cellsum = 0.0_wp 7936 cellsumd = 0.0_wp 7937 DO i = ifl(l), ifu(l) 7938 iw = MAX( MIN( i, nx+1 ), -1 ) 7939 IF ( ( i >= nxl ) .AND. ( i <= nxr+1 ) ) THEN 7940 DO j = jfl(m), jfu(m) 7941 jw = MAX( MIN( j, ny+1 ), -1 ) 7942 IF ( ( j >= nys ) .AND. ( j <= nyn+1 ) ) THEN 7943 DO ka = kfl(n), kfu(n) 7944 kw = MIN( ka, nzt+1 ) 7945 !AH cellsum = cellsum + MERGE( f(ka,j,i), 0.0_wp, & 7946 cellsum = cellsum + MERGE( workarr_t(ka,j,i), 0.0_wp, & 7947 BTEST( wall_flags_0(kw,jw,iw), var_flag ) ) 7948 ! cellsum = cellsum + workarr_t(ka,j,i) 7949 !AH celltmpd(ijk) = ABS( fc(n,m,l) - f(ka,j,i) ) 7950 !AH 7951 ! celltmpd(ijk) = ABS( fc(n,m,l) - workarr_t(ka,j,i) ) 7952 celltmpd(ijk) = ABS( workarrc_t(nw,m,l) - workarr_t(ka,j,i) ) 7953 !AH 7954 cellsumd = cellsumd + MERGE( celltmpd(ijk), & 7955 0.0_wp, BTEST( wall_flags_0(kw,jw,iw), var_flag ) ) 7956 ijk = ijk + 1 7957 ENDDO 7958 ENDIF 7959 ENDDO 7960 ENDIF 7961 ENDDO 7962 7963 IF ( ijkfc(n,m,l) /= 0 ) THEN 7964 cellsum = cellsum / REAL( ijkfc(n,m,l), KIND=wp ) 7965 !AH 7966 ! rcorr = fc(n,m,l) - cellsum 7967 rcorr = workarrc_t(nw,m,l) - cellsum 7968 !AH 7969 cellsumd = cellsumd / REAL( ijkfc(n,m,l), KIND=wp ) 7970 ELSE 7971 cellsum = 0.0_wp 7972 rcorr = 0.0_wp 7973 cellsumd = 1.0_wp 7974 celltmpd = 1.0_wp 7975 ENDIF 7976 ! 7977 !-- Distribute the correction term to the child nodes according to 7978 !-- their relative difference to the parent value such that the 7979 !-- node with the largest difference gets the largest share of the 7980 !-- correction. The distribution is skipped if rcorr is negligibly 7981 !-- small in order to avoid division by zero. 7982 IF ( ABS(rcorr) < 0.000001_wp ) THEN 7983 cellsumd = 1.0_wp 7984 celltmpd = 1.0_wp 7985 ENDIF 7986 7987 ijk = 1 7988 DO i = ifl(l), ifu(l) 7989 IF ( ( i >= nxl ) .AND. ( i <= nxr+1 ) ) THEN 7990 DO j = jfl(m), jfu(m) 7991 IF ( ( j >= nys ) .AND. ( j <= nyn+1 ) ) THEN 7992 DO ka = kfl(n), kfu(n) 7993 rcorr_ijk = rcorr * celltmpd(ijk) / cellsumd 7994 !AH f(ka,j,i) = f(ka,j,i) + rcorr_ijk 7995 workarr_t(ka,j,i) = workarr_t(ka,j,i) + rcorr_ijk 7996 7997 ! if ( i == 128 .and. var == 'u' ) then 7998 ! write(9,"('t2: ', 8(i4,2x),3(e12.5,2x))") nw, m, l, ka, j, i, ifl(l), ifu(l), & 7999 ! rcorr, rcorr_ijk, workarr_t(ka,j,i) 8000 ! flush(9) 8001 ! endif 8002 8003 ijk = ijk + 1 8004 ENDDO 8005 ENDIF 8006 ENDDO 8007 ENDIF 8008 ENDDO 8009 ! 8010 !-- Velocity components tangential to the boundary need special 8011 !-- "finishing" because their anterpolation cells are flat in their 8012 !-- direction and hence do not cover all the child-grid boundary nodes. 8013 !-- These components are next linearly interpolated to those child-grid 8014 !-- boundary nodes which are not covered by the anterpolation cells. 8015 IF ( ( var == 'v' ) .AND. ( m > jcs ) ) THEN 8016 DO j = jfu(m-1)+1, jfl(m)-1 8017 IF ( ( j >= nys ) .AND. ( j <= nyn+1 ) ) THEN 8018 DO i = ifl(l), ifu(l) 8019 IF ( ( i >= nxl ) .AND. ( i <= nxr+1 ) ) THEN 8020 DO ka = kfl(n), kfu(n) ! This loop should be removed and fixed k-value be used instead 8021 !AH f(ka,j,i) = r1y(j) * f(ka,jfu(m-1),i) & 8022 !AH + r2y(j) * f(ka,jfl(m),i) 8023 workarr_t(ka,j,i) = r1y(j) * workarr_t(ka,jfu(m-1),i) & 8024 + r2y(j) * workarr_t(ka,jfl(m),i) 8025 ENDDO 8026 ENDIF 8027 ENDDO 8028 ENDIF 8029 ENDDO 8030 ENDIF 8031 8032 IF ( ( var == 'u' ) .AND. ( l > icl ) ) THEN 8033 DO i = ifu(l-1)+1, ifl(l)-1 8034 IF ( ( i >= nxl ) .AND. ( i <= nxr+1 ) ) THEN 8035 DO j = jfl(m), jfu(m) 8036 IF ( ( j >= nys ) .AND. ( j <= nyn+1 ) ) THEN 8037 DO ka = kfl(n), kfu(n) ! This loop should be removed and fixed k-value be used instead 8038 !AH f(ka,j,i) = r1x(i) * f(ka,j,ifu(l-1)) + & 8039 !AH r2x(i) * f(ka,j,ifl(l)) 8040 workarr_t(ka,j,i) = r1x(i) * workarr_t(ka,j,ifu(l-1)) & 8041 + r2x(i) * workarr_t(ka,j,ifl(l)) 8042 8043 ! if ( i == 127 ) then 8044 ! write(9,"('t4: ', 8(i4,2x),3(e12.5,2x))") nw, m, l, ka, j, ifu(l-1), i, ifl(l), & 8045 ! workarr_t(ka,j,ifu(l-1)), workarr_t(ka,j,i), workarr_t(ka,j,ifl(l)) 8046 ! flush(9) 8047 ! endif 8048 8049 ENDDO 8050 ENDIF 8051 ENDDO 8052 ENDIF 8053 ENDDO 8054 ENDIF 8055 8056 ENDDO ! m 8057 ENDDO ! l 8058 ! 8059 !-- Finally substitute the boundary values. 8060 f(k,nys:nyn,nxl:nxr) = workarr_t(k,nys:nyn,nxl:nxr) 8061 IF ( var == 'w' ) THEN 8062 f(k+1,nys:nyn,nxl:nxr) = f(k,nys:nyn,nxl:nxr) 8063 ENDIF 8064 8065 END SUBROUTINE pmci_interp_tril_t 8066 8067 8068 8069 SUBROUTINE pmci_anterp_tophat( f, fc, kct, ifl, ifu, jfl, jfu, kfl, kfu, & 8070 ijkfc, var ) 8071 ! 8072 !-- Anterpolation of internal-node values to be used as the parent-domain 8073 !-- values. This subroutine is based on the first-order numerical 8074 !-- integration of the fine-grid values contained within the coarse-grid 8075 !-- cell. 8076 8077 IMPLICIT NONE 8078 8079 CHARACTER(LEN=*), INTENT(IN) :: var !< identifyer for treated variable 8080 8081 !AH INTEGER(iwp), DIMENSION(0:kct,jcs:jcn,icl:icr), INTENT(IN) :: ijkfc !< number of child grid points contributing to a parent grid box 8082 !AH 8083 ! INTEGER(iwp), DIMENSION(0:cg%nz+1,jcs:jcn,icl:icr), INTENT(IN) :: ijkfc !< number of child grid points contributing to a parent grid box 8084 INTEGER(iwp), DIMENSION(0:cg%nz+1,jcsa:jcna,icla:icra), INTENT(IN) :: ijkfc !< number of child grid points contributing to a parent grid box 8085 !AH 8086 8087 INTEGER(iwp) :: i !< Running index x-direction - fine-grid 8088 INTEGER(iwp) :: iclant !< Left boundary index for anterpolation along x 8089 INTEGER(iwp) :: icrant !< Right boundary index for anterpolation along x 8090 INTEGER(iwp) :: ii !< Running index x-direction - coarse grid 8091 INTEGER(iwp) :: j !< Running index y-direction - fine-grid 8092 INTEGER(iwp) :: jcnant !< North boundary index for anterpolation along y 8093 INTEGER(iwp) :: jcsant !< South boundary index for anterpolation along y 8094 INTEGER(iwp) :: jj !< Running index y-direction - coarse grid 8095 INTEGER(iwp) :: k !< Running index z-direction - fine-grid 8096 INTEGER(iwp) :: kcb = 0 !< Bottom boundary index for anterpolation along z 8097 INTEGER(iwp) :: kctant !< Top boundary index for anterpolation along z 8098 INTEGER(iwp) :: kk !< Running index z-direction - coarse grid 8099 INTEGER(iwp) :: var_flag !< bit number used to flag topography on respective grid 8100 8101 INTEGER(iwp), INTENT(IN) :: kct !< Top boundary index for anterpolation along z 8102 8103 !AH 8104 ! INTEGER(iwp), DIMENSION(icl:icr), INTENT(IN) :: ifl !< Indicates start index of child cells belonging to certain parent cell - x direction 8105 ! INTEGER(iwp), DIMENSION(icl:icr), INTENT(IN) :: ifu !< Indicates end index of child cells belonging to certain parent cell - x direction 8106 ! INTEGER(iwp), DIMENSION(jcs:jcn), INTENT(IN) :: jfl !< Indicates start index of child cells belonging to certain parent cell - y direction 8107 ! INTEGER(iwp), DIMENSION(jcs:jcn), INTENT(IN) :: jfu !< Indicates start index of child cells belonging to certain parent cell - y direction 8108 INTEGER(iwp), DIMENSION(icla:icra), INTENT(IN) :: ifl !< Indicates start index of child cells belonging to certain parent cell - x direction 8109 INTEGER(iwp), DIMENSION(icla:icra), INTENT(IN) :: ifu !< Indicates end index of child cells belonging to certain parent cell - x direction 8110 INTEGER(iwp), DIMENSION(jcsa:jcna), INTENT(IN) :: jfl !< Indicates start index of child cells belonging to certain parent cell - y direction 8111 INTEGER(iwp), DIMENSION(jcsa:jcna), INTENT(IN) :: jfu !< Indicates start index of child cells belonging to certain parent cell - y direction 8112 !AH 8113 8114 !AH INTEGER(iwp), DIMENSION(0:kct), INTENT(IN) :: kfl !< Indicates start index of child cells belonging to certain parent cell - z direction 8115 !AH INTEGER(iwp), DIMENSION(0:kct), INTENT(IN) :: kfu !< Indicates start index of child cells belonging to certain parent cell - z direction 8116 INTEGER(iwp), DIMENSION(0:cg%nz+1), INTENT(IN) :: kfl !< Indicates start index of child cells belonging to certain parent cell - z direction 8117 INTEGER(iwp), DIMENSION(0:cg%nz+1), INTENT(IN) :: kfu !< Indicates start index of child cells belonging to certain parent cell - z direction 8118 8119 REAL(wp) :: cellsum !< sum of respective child cells belonging to parent cell 8120 REAL(wp) :: fra !< relaxation faction 8121 8122 REAL(wp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg), INTENT(IN) :: f !< Treated variable - child domain 8123 REAL(wp), DIMENSION(0:cg%nz+1,jcs:jcn,icl:icr), INTENT(INOUT) :: fc !< Treated variable - parent domain 8124 8125 ! 8126 !-- Define the index bounds iclant, icrant, jcsant and jcnant. 8127 !-- Note that kcb is simply zero and kct enters here as a parameter and it is 8128 !-- determined in pmci_init_anterp_tophat. 8129 !-- Please note, grid points used also for interpolation (from parent to 8130 !-- child) are excluded in anterpolation, e.g. anterpolation is only from 8131 !-- nzb:kct-1, as kct is used for interpolation. 8132 iclant = icl 8133 icrant = icr 8134 jcsant = jcs 8135 jcnant = jcn 8136 kctant = kct - 1 8137 8138 kcb = 0 8139 IF ( nesting_mode /= 'vertical' ) THEN 8140 IF ( bc_dirichlet_l ) THEN 8141 iclant = icl + 3 8142 ENDIF 8143 IF ( bc_dirichlet_r ) THEN 8144 icrant = icr - 3 8145 ENDIF 8146 8147 IF ( bc_dirichlet_s ) THEN 8148 jcsant = jcs + 3 8149 ENDIF 8150 IF ( bc_dirichlet_n ) THEN 8151 jcnant = jcn - 3 8152 ENDIF 8153 ENDIF 8154 ! 8155 !-- Set masking bit for topography flags 8156 IF ( var == 'u' ) THEN 8157 var_flag = 1 8158 ELSEIF ( var == 'v' ) THEN 8159 var_flag = 2 8160 ELSEIF ( var == 'w' ) THEN 8161 var_flag = 3 8162 ELSE 8163 var_flag = 0 8164 ENDIF 8165 ! 8166 !-- Note that ii, jj, and kk are coarse-grid indices and i,j, and k 8167 !-- are fine-grid indices. 8168 DO ii = iclant, icrant 8169 DO jj = jcsant, jcnant 8170 ! 8171 !-- For simplicity anterpolate within buildings and under elevated 8172 !-- terrain too 8173 DO kk = kcb, kctant !kct - 1 8174 cellsum = 0.0_wp 8175 DO i = ifl(ii), ifu(ii) 8176 DO j = jfl(jj), jfu(jj) 8177 DO k = kfl(kk), kfu(kk) 8178 cellsum = cellsum + MERGE( f(k,j,i), 0.0_wp, & 8179 BTEST( wall_flags_0(k,j,i), var_flag ) ) 8180 ENDDO 8181 ENDDO 8182 ENDDO 8183 ! 8184 !-- Spatial under-relaxation. 8185 !-- The relaxation buffer zones are no longer needed with 8186 !-- the new reversible interpolation algorithm. 23.10.2018. 8187 ! fra = frax(ii) * fray(jj) * fraz(kk) 8188 ! 8189 !-- In case all child grid points are inside topography, i.e. 8190 !-- ijkfc and cellsum are zero, also parent solution would have 8191 !-- zero values at that grid point, which may cause problems in 8192 !-- particular for the temperature. Therefore, in case cellsum is 8193 !-- zero, keep the parent solution at this point. 8194 8195 IF ( ijkfc(kk,jj,ii) /= 0 ) THEN 8196 !AH fc(kk,jj,ii) = ( 1.0_wp - fra ) * fc(kk,jj,ii) + & 8197 !AH fra * cellsum / & 8198 !AH REAL( ijkfc(kk,jj,ii), KIND=wp ) 8199 fc(kk,jj,ii) = cellsum / REAL( ijkfc(kk,jj,ii), KIND=wp ) 8200 ENDIF 8201 8202 ENDDO 8203 ENDDO 8204 ENDDO 8205 8206 END SUBROUTINE pmci_anterp_tophat 4240 4241 END SUBROUTINE pmci_anterp_tophat 8207 4242 8208 4243 #endif
Note: See TracChangeset
for help on using the changeset viewer.
