Changeset 1933 for palm/trunk/SOURCE/pmc_interface_mod.f90
- Timestamp:
- Jun 13, 2016 7:12:51 AM (8 years ago)
- File:
-
- 1 edited
-
palm/trunk/SOURCE/pmc_interface_mod.f90 (modified) (164 diffs)
Legend:
- Unmodified
- Added
- Removed
-
palm/trunk/SOURCE/pmc_interface_mod.f90
r1928 r1933 1 1 MODULE pmc_interface 2 2 3 !------------------------------------------------------------------------------ !3 !-------------------------------------------------------------------------------! 4 4 ! This file is part of PALM. 5 5 ! … … 16 16 ! 17 17 ! Copyright 1997-2016 Leibniz Universitaet Hannover 18 !------------------------------------------------------------------------------ !18 !-------------------------------------------------------------------------------! 19 19 ! 20 20 ! Current revisions: … … 26 26 ! $Id$ 27 27 ! 28 ! 1927 2016-06-07 11:56:53Z hellstea 29 ! Error check for overlapping parallel nests added 28 ! 1901 2016-05-04 15:39:38Z raasch 29 ! Initial version of purely vertical nesting introduced. 30 ! Code clean up. The words server/client changed to parent/child. 30 31 ! 31 32 ! 1900 2016-05-04 15:27:53Z raasch … … 62 63 ! introduction of different datatransfer modes, 63 64 ! further formatting cleanup, parameter checks added (including mismatches 64 ! between root and client model settings),65 ! between root and nest model settings), 65 66 ! +routine pmci_check_setting_mismatches 66 67 ! comm_world_nesting introduced … … 106 107 ! Domain nesting interface routines. The low-level inter-domain communication 107 108 ! is conducted by the PMC-library routines. 108 !------------------------------------------------------------------------------ !109 !-------------------------------------------------------------------------------! 109 110 110 111 #if defined( __nopointer ) 111 USE arrays_3d, &112 ONLY: dzu, dzw, e, e_p, pt, pt_p, q, q_p, u, u_p, v, v_p, w, w_p, zu, &112 USE arrays_3d, & 113 ONLY: dzu, dzw, e, e_p, pt, pt_p, q, q_p, u, u_p, v, v_p, w, w_p, zu, & 113 114 zw, z0 114 115 #else 115 USE arrays_3d, &116 ONLY: dzu, dzw, e, e_p, e_1, e_2, pt, pt_p, pt_1, pt_2, q, q_p, q_1, &117 q_2, u, u_p, u_1, u_2, v, v_p, v_1, v_2, w, w_p, w_1, w_2, zu, &116 USE arrays_3d, & 117 ONLY: dzu, dzw, e, e_p, e_1, e_2, pt, pt_p, pt_1, pt_2, q, q_p, q_1, & 118 q_2, u, u_p, u_1, u_2, v, v_p, v_1, v_2, w, w_p, w_1, w_2, zu, & 118 119 zw, z0 119 120 #endif 120 121 121 USE control_parameters, &122 ONLY: coupling_char, dt_3d, dz, humidity, message_string, &123 nest_bound_l, nest_bound_r, nest_bound_s, nest_bound_n, &124 nest_domain, neutral, passive_scalar, simulated_time, &122 USE control_parameters, & 123 ONLY: coupling_char, dt_3d, dz, humidity, message_string, & 124 nest_bound_l, nest_bound_r, nest_bound_s, nest_bound_n, & 125 nest_domain, neutral, passive_scalar, simulated_time, & 125 126 topography, volume_flow 126 127 127 USE cpulog, &128 USE cpulog, & 128 129 ONLY: cpu_log, log_point_s 129 130 130 USE grid_variables, &131 USE grid_variables, & 131 132 ONLY: dx, dy 132 133 133 USE indices, &134 ONLY: nbgp, nx, nxl, nxlg, nxlu, nxr, nxrg, ny, nyn, nyng, nys, nysg, &135 nysv, nz, nzb, nzb_s_inner, nzb_u_inner, nzb_u_outer, &134 USE indices, & 135 ONLY: nbgp, nx, nxl, nxlg, nxlu, nxr, nxrg, ny, nyn, nyng, nys, nysg, & 136 nysv, nz, nzb, nzb_s_inner, nzb_u_inner, nzb_u_outer, & 136 137 nzb_v_inner, nzb_v_outer, nzb_w_inner, nzb_w_outer, nzt 137 138 … … 145 146 #endif 146 147 147 USE pegrid, &148 ONLY: collective_wait, comm1dx, comm1dy, comm2d, myid, myidx, myidy, &148 USE pegrid, & 149 ONLY: collective_wait, comm1dx, comm1dy, comm2d, myid, myidx, myidy, & 149 150 numprocs 150 151 151 USE pmc_c lient,&152 ONLY: pmc_c lientinit, pmc_c_clear_next_array_list,&153 pmc_c_getnextarray, pmc_c_get_2d_index_list, pmc_c_getbuffer, &154 pmc_c_putbuffer, pmc_c_setind_and_allocmem, &152 USE pmc_child, & 153 ONLY: pmc_childinit, pmc_c_clear_next_array_list, & 154 pmc_c_getnextarray, pmc_c_get_2d_index_list, pmc_c_getbuffer, & 155 pmc_c_putbuffer, pmc_c_setind_and_allocmem, & 155 156 pmc_c_set_dataarray, pmc_set_dataarray_name 156 157 157 USE pmc_general, &158 USE pmc_general, & 158 159 ONLY: da_namelen 159 160 160 USE pmc_handle_communicator, &161 ONLY: pmc_get_model_info, pmc_init_model, pmc_is_rootmodel, &162 pmc_no_namelist_found, pmc_ server_for_client163 164 USE pmc_mpi_wrapper, &165 ONLY: pmc_bcast, pmc_recv_from_c lient, pmc_recv_from_server,&166 pmc_send_to_c lient, pmc_send_to_server167 168 USE pmc_ server,&169 ONLY: pmc_ serverinit, pmc_s_clear_next_array_list, pmc_s_fillbuffer,&170 pmc_s_getdata_from_buffer, pmc_s_getnextarray, &171 pmc_s_setind_and_allocmem, pmc_s_set_active_data_array, &161 USE pmc_handle_communicator, & 162 ONLY: pmc_get_model_info, pmc_init_model, pmc_is_rootmodel, & 163 pmc_no_namelist_found, pmc_parent_for_child 164 165 USE pmc_mpi_wrapper, & 166 ONLY: pmc_bcast, pmc_recv_from_child, pmc_recv_from_parent, & 167 pmc_send_to_child, pmc_send_to_parent 168 169 USE pmc_parent, & 170 ONLY: pmc_parentinit, pmc_s_clear_next_array_list, pmc_s_fillbuffer, & 171 pmc_s_getdata_from_buffer, pmc_s_getnextarray, & 172 pmc_s_setind_and_allocmem, pmc_s_set_active_data_array, & 172 173 pmc_s_set_dataarray, pmc_s_set_2d_index_list 173 174 … … 180 181 ! 181 182 !-- Constants 182 INTEGER(iwp), PARAMETER :: c lient_to_server= 2 !:183 INTEGER(iwp), PARAMETER :: server_to_client= 1 !:183 INTEGER(iwp), PARAMETER :: child_to_parent = 2 !: 184 INTEGER(iwp), PARAMETER :: parent_to_child = 1 !: 184 185 185 186 ! … … 196 197 !: parameter for data- 197 198 !: transfer mode 198 CHARACTER(LEN= 7), SAVE :: nesting_mode = 'two-way' !: steering parameter199 CHARACTER(LEN=8), SAVE :: nesting_mode = 'two-way' !: steering parameter 199 200 !: for 1- or 2-way nesting 200 201 … … 216 217 217 218 ! 218 !-- C lientcoarse data arrays219 !-- Child coarse data arrays 219 220 INTEGER(iwp), DIMENSION(5) :: coarse_bound !: 220 221 … … 237 238 238 239 ! 239 !-- C lient interpolation coefficients and client-array indices to be precomputed240 !-- and stored.240 !-- Child interpolation coefficients and child-array indices to be 241 !-- precomputed and stored. 241 242 INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:) :: ico !: 242 243 INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:) :: icu !: … … 259 260 260 261 ! 261 !-- C lientindex arrays and log-ratio arrays for the log-law near-wall262 !-- Child index arrays and log-ratio arrays for the log-law near-wall 262 263 !-- corrections. These are not truly 3-D arrays but multiple 2-D arrays. 263 264 INTEGER(iwp), SAVE :: ncorr !: 4th dimension of the log_ratio-arrays … … 313 314 314 315 ! 315 !-- C lient-array indices to be precomputed and stored for anterpolation.316 !-- Child-array indices to be precomputed and stored for anterpolation. 316 317 INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:) :: iflu !: 317 318 INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:) :: ifuu !: … … 363 364 END INTERFACE 364 365 365 INTERFACE pmci_c lient_initialize366 MODULE PROCEDURE pmci_c lient_initialize366 INTERFACE pmci_child_initialize 367 MODULE PROCEDURE pmci_child_initialize 367 368 END INTERFACE 368 369 … … 387 388 END INTERFACE 388 389 389 INTERFACE pmci_ server_initialize390 MODULE PROCEDURE pmci_ server_initialize390 INTERFACE pmci_parent_initialize 391 MODULE PROCEDURE pmci_parent_initialize 391 392 END INTERFACE 392 393 … … 395 396 END INTERFACE pmci_set_swaplevel 396 397 397 PUBLIC anterp_relax_length_l, anterp_relax_length_r, &398 anterp_relax_length_s, anterp_relax_length_n, &399 anterp_relax_length_t, c lient_to_server, comm_world_nesting,&400 cpl_id, nested_run, nesting_datatransfer_mode, nesting_mode, &401 server_to_client402 PUBLIC pmci_c lient_initialize398 PUBLIC anterp_relax_length_l, anterp_relax_length_r, & 399 anterp_relax_length_s, anterp_relax_length_n, & 400 anterp_relax_length_t, child_to_parent, comm_world_nesting, & 401 cpl_id, nested_run, nesting_datatransfer_mode, nesting_mode, & 402 parent_to_child 403 PUBLIC pmci_child_initialize 403 404 PUBLIC pmci_datatrans 404 405 PUBLIC pmci_ensure_nest_mass_conservation 405 406 PUBLIC pmci_init 406 407 PUBLIC pmci_modelconfiguration 407 PUBLIC pmci_ server_initialize408 PUBLIC pmci_parent_initialize 408 409 PUBLIC pmci_synchronize 409 410 PUBLIC pmci_set_swaplevel … … 415 416 SUBROUTINE pmci_init( world_comm ) 416 417 417 USE control_parameters, &418 USE control_parameters, & 418 419 ONLY: message_string 419 420 … … 429 430 430 431 431 CALL pmc_init_model( world_comm, nesting_datatransfer_mode, nesting_mode, &432 CALL pmc_init_model( world_comm, nesting_datatransfer_mode, nesting_mode, & 432 433 pmc_status ) 433 434 … … 445 446 ! 446 447 !-- Check steering parameter values 447 IF ( TRIM( nesting_mode ) /= 'one-way' .AND. & 448 TRIM( nesting_mode ) /= 'two-way' ) & 448 IF ( TRIM( nesting_mode ) /= 'one-way' .AND. & 449 TRIM( nesting_mode ) /= 'two-way' .AND. & 450 TRIM( nesting_mode ) /= 'vertical' ) & 449 451 THEN 450 452 message_string = 'illegal nesting mode: ' // TRIM( nesting_mode ) … … 452 454 ENDIF 453 455 454 IF ( TRIM( nesting_datatransfer_mode ) /= 'cascade' .AND. &455 TRIM( nesting_datatransfer_mode ) /= 'mixed' .AND. &456 TRIM( nesting_datatransfer_mode ) /= 'overlap' ) &456 IF ( TRIM( nesting_datatransfer_mode ) /= 'cascade' .AND. & 457 TRIM( nesting_datatransfer_mode ) /= 'mixed' .AND. & 458 TRIM( nesting_datatransfer_mode ) /= 'overlap' ) & 457 459 THEN 458 message_string = 'illegal nesting datatransfer mode: ' &460 message_string = 'illegal nesting datatransfer mode: ' & 459 461 // TRIM( nesting_datatransfer_mode ) 460 462 CALL message( 'pmci_init', 'PA0418', 3, 2, 0, 6, 0 ) … … 468 470 !-- Get some variables required by the pmc-interface (and in some cases in the 469 471 !-- PALM code out of the pmci) out of the pmc-core 470 CALL pmc_get_model_info( comm_world_nesting = comm_world_nesting, &471 cpl_id = cpl_id, cpl_parent_id = cpl_parent_id, &472 cpl_name = cpl_name, npe_total = cpl_npe_total, &473 lower_left_x = lower_left_coord_x, &472 CALL pmc_get_model_info( comm_world_nesting = comm_world_nesting, & 473 cpl_id = cpl_id, cpl_parent_id = cpl_parent_id, & 474 cpl_name = cpl_name, npe_total = cpl_npe_total, & 475 lower_left_x = lower_left_coord_x, & 474 476 lower_left_y = lower_left_coord_y ) 475 477 ! … … 513 515 CALL pmci_setup_coordinates 514 516 ! 515 !-- Initialize the c lient (must be called before pmc_setup_server)516 CALL pmci_setup_c lient517 ! 518 !-- Initialize PMC Server519 CALL pmci_setup_ server520 ! 521 !-- Check for mismatches between settings of master and c lientvariables522 !-- (e.g., all c lientshave to follow the end_time settings of the root master)517 !-- Initialize the child (must be called before pmc_setup_parent) 518 CALL pmci_setup_child 519 ! 520 !-- Initialize PMC parent 521 CALL pmci_setup_parent 522 ! 523 !-- Check for mismatches between settings of master and child variables 524 !-- (e.g., all children have to follow the end_time settings of the root master) 523 525 CALL pmci_check_setting_mismatches 524 526 … … 529 531 530 532 531 SUBROUTINE pmci_setup_ server533 SUBROUTINE pmci_setup_parent 532 534 533 535 #if defined( __parallel ) … … 536 538 CHARACTER(LEN=32) :: myname 537 539 538 INTEGER(iwp) :: c lient_id!:540 INTEGER(iwp) :: child_id !: 539 541 INTEGER(iwp) :: ierr !: 540 542 INTEGER(iwp) :: i !: … … 558 560 REAL(wp) :: dx_cl !: 559 561 REAL(wp) :: dy_cl !: 562 REAL(wp) :: left_limit !: 563 REAL(wp) :: north_limit !: 564 REAL(wp) :: right_limit !: 565 REAL(wp) :: south_limit !: 560 566 REAL(wp) :: xez !: 561 567 REAL(wp) :: yez !: … … 568 574 569 575 ! 570 ! Initialize the pmc server571 CALL pmc_ serverinit576 ! Initialize the pmc parent 577 CALL pmc_parentinit 572 578 573 579 ! 574 580 !-- Corners of all children of the present parent 575 IF ( ( SIZE( pmc_ server_for_client) - 1 > 0 ) .AND. myid == 0 ) THEN576 ALLOCATE( ch_xl(1:SIZE( pmc_ server_for_client) - 1) )577 ALLOCATE( ch_xr(1:SIZE( pmc_ server_for_client) - 1) )578 ALLOCATE( ch_ys(1:SIZE( pmc_ server_for_client) - 1) )579 ALLOCATE( ch_yn(1:SIZE( pmc_ server_for_client) - 1) )581 IF ( ( SIZE( pmc_parent_for_child ) - 1 > 0 ) .AND. myid == 0 ) THEN 582 ALLOCATE( ch_xl(1:SIZE( pmc_parent_for_child ) - 1) ) 583 ALLOCATE( ch_xr(1:SIZE( pmc_parent_for_child ) - 1) ) 584 ALLOCATE( ch_ys(1:SIZE( pmc_parent_for_child ) - 1) ) 585 ALLOCATE( ch_yn(1:SIZE( pmc_parent_for_child ) - 1) ) 580 586 ENDIF 581 587 582 588 ! 583 589 !-- Get coordinates from all children 584 DO m = 1, SIZE( pmc_ server_for_client) - 1585 586 c lient_id = pmc_server_for_client(m)590 DO m = 1, SIZE( pmc_parent_for_child ) - 1 591 592 child_id = pmc_parent_for_child(m) 587 593 IF ( myid == 0 ) THEN 588 594 589 CALL pmc_recv_from_c lient( client_id, val, size(val), 0, 123, ierr )590 CALL pmc_recv_from_c lient( client_id, fval, size(fval), 0, 124, ierr )595 CALL pmc_recv_from_child( child_id, val, size(val), 0, 123, ierr ) 596 CALL pmc_recv_from_child( child_id, fval, size(fval), 0, 124, ierr ) 591 597 592 598 nx_cl = val(1) … … 598 604 599 605 ! 600 !-- Find the highest client level in the coarse grid for the reduced z606 !-- Find the highest nest level in the coarse grid for the reduced z 601 607 !-- transfer 602 608 DO k = 1, nz … … 612 618 ALLOCATE( cl_coord_y(-nbgp:ny_cl+nbgp) ) 613 619 614 CALL pmc_recv_from_c lient( client_id, cl_coord_x, SIZE( cl_coord_x ),&620 CALL pmc_recv_from_child( child_id, cl_coord_x, SIZE( cl_coord_x ), & 615 621 0, 11, ierr ) 616 CALL pmc_recv_from_c lient( client_id, cl_coord_y, SIZE( cl_coord_y ),&622 CALL pmc_recv_from_child( child_id, cl_coord_y, SIZE( cl_coord_y ), & 617 623 0, 12, ierr ) 618 ! WRITE ( 0, * ) 'receive from pmc Client ', client_id, nx_cl, ny_cl624 ! WRITE ( 0, * ) 'receive from pmc child ', child_id, nx_cl, ny_cl 619 625 620 626 define_coarse_grid_real(1) = lower_left_coord_x … … 631 637 632 638 ! 633 !-- Check that the c lient domain is completely inside the serverdomain.639 !-- Check that the child domain matches parent domain. 634 640 nomatch = 0 635 xez = ( nbgp + 1 ) * dx 636 yez = ( nbgp + 1 ) * dy 637 IF ( ( cl_coord_x(0) < define_coarse_grid_real(1) + xez ) .OR. & 638 ( cl_coord_x(nx_cl+1) > define_coarse_grid_real(5) - xez ) .OR. & 639 ( cl_coord_y(0) < define_coarse_grid_real(2) + yez ) .OR. & 640 ( cl_coord_y(ny_cl+1) > define_coarse_grid_real(6) - yez ) ) & 641 THEN 642 nomatch = 1 641 IF ( nesting_mode == 'vertical' ) THEN 642 right_limit = define_coarse_grid_real(5) 643 north_limit = define_coarse_grid_real(6) 644 IF ( ( cl_coord_x(nx_cl+1) /= right_limit ) .OR. & 645 ( cl_coord_y(ny_cl+1) /= north_limit ) ) THEN 646 nomatch = 1 647 ENDIF 648 ELSE 649 650 ! 651 !-- Check that the children domain is completely inside the parent domain. 652 xez = ( nbgp + 1 ) * dx 653 yez = ( nbgp + 1 ) * dy 654 left_limit = lower_left_coord_x + xez 655 right_limit = define_coarse_grid_real(5) - xez 656 south_limit = lower_left_coord_y + yez 657 north_limit = define_coarse_grid_real(6) - yez 658 IF ( ( cl_coord_x(0) < left_limit ) .OR. & 659 ( cl_coord_x(nx_cl+1) > right_limit ) .OR. & 660 ( cl_coord_y(0) < south_limit ) .OR. & 661 ( cl_coord_y(ny_cl+1) > north_limit ) ) THEN 662 nomatch = 1 663 ENDIF 643 664 ENDIF 644 665 … … 646 667 !-- Check that parallel nest domains, if any, do not overlap. 647 668 nest_overlap = 0 648 IF ( SIZE( pmc_ server_for_client) - 1 > 0 ) THEN669 IF ( SIZE( pmc_parent_for_child ) - 1 > 0 ) THEN 649 670 ch_xl(m) = cl_coord_x(-nbgp) 650 671 ch_xr(m) = cl_coord_x(nx_cl+nbgp) … … 654 675 IF ( m > 1 ) THEN 655 676 DO mm = 1, m-1 656 IF ( ( ch_xl(m) < ch_xr(mm) .OR. ch_xr(m) > ch_xl(mm) ) .AND. & 657 ( ch_ys(m) < ch_yn(mm) .OR. ch_yn(m) > ch_ys(mm) ) ) THEN 677 IF ( ( ch_xl(m) < ch_xr(mm) .OR. & 678 ch_xr(m) > ch_xl(mm) ) .AND. & 679 ( ch_ys(m) < ch_yn(mm) .OR. & 680 ch_yn(m) > ch_ys(mm) ) ) THEN 658 681 nest_overlap = 1 659 682 ENDIF … … 667 690 ! 668 691 !-- Send coarse grid information to child 669 CALL pmc_send_to_c lient( client_id, define_coarse_grid_real,&670 SIZE( define_coarse_grid_real ), 0, 21, &692 CALL pmc_send_to_child( child_id, define_coarse_grid_real, & 693 SIZE( define_coarse_grid_real ), 0, 21, & 671 694 ierr ) 672 CALL pmc_send_to_c lient( client_id, define_coarse_grid_int, 3, 0,&695 CALL pmc_send_to_child( child_id, define_coarse_grid_int, 3, 0, & 673 696 22, ierr ) 674 697 675 698 ! 676 699 !-- Send local grid to child 677 CALL pmc_send_to_c lient( client_id, coord_x, nx+1+2*nbgp, 0, 24,&700 CALL pmc_send_to_child( child_id, coord_x, nx+1+2*nbgp, 0, 24, & 678 701 ierr ) 679 CALL pmc_send_to_c lient( client_id, coord_y, ny+1+2*nbgp, 0, 25,&702 CALL pmc_send_to_child( child_id, coord_y, ny+1+2*nbgp, 0, 25, & 680 703 ierr ) 681 704 682 705 ! 683 706 !-- Also send the dzu-, dzw-, zu- and zw-arrays here 684 CALL pmc_send_to_c lient( client_id, dzu, nz_cl+1, 0, 26, ierr )685 CALL pmc_send_to_c lient( client_id, dzw, nz_cl+1, 0, 27, ierr )686 CALL pmc_send_to_c lient( client_id, zu, nz_cl+2, 0, 28, ierr )687 CALL pmc_send_to_c lient( client_id, zw, nz_cl+2, 0, 29, ierr )707 CALL pmc_send_to_child( child_id, dzu, nz_cl+1, 0, 26, ierr ) 708 CALL pmc_send_to_child( child_id, dzw, nz_cl+1, 0, 27, ierr ) 709 CALL pmc_send_to_child( child_id, zu, nz_cl+2, 0, 28, ierr ) 710 CALL pmc_send_to_child( child_id, zw, nz_cl+2, 0, 29, ierr ) 688 711 689 712 ENDIF … … 691 714 CALL MPI_BCAST( nomatch, 1, MPI_INTEGER, 0, comm2d, ierr ) 692 715 IF ( nomatch /= 0 ) THEN 693 WRITE ( message_string, * ) 'Error: nested child domain does ', &716 WRITE ( message_string, * ) 'Error: nested child domain does ', & 694 717 'not fit into its parent domain' 695 CALL message( 'pmc _palm_setup_server', 'PA0425', 3, 2, 0, 6, 0 )718 CALL message( 'pmci_setup_parent', 'PA0425', 3, 2, 0, 6, 0 ) 696 719 ENDIF 697 720 … … 700 723 WRITE ( message_string, * ) 'Nested parallel child ', & 701 724 'domains overlap' 702 CALL message( 'pmc _palm_setup_server', 'PA0426', 3, 2, 0, 6, 0 )725 CALL message( 'pmci_setup_parent', 'PA0426', 3, 2, 0, 6, 0 ) 703 726 ENDIF 704 727 … … 710 733 711 734 ! 712 !-- Include couple arrays into servercontent735 !-- Include couple arrays into parent content 713 736 !-- TO_DO: Klaus: please give a more meaningful comment 714 737 CALL pmc_s_clear_next_array_list 715 DO WHILE ( pmc_s_getnextarray( c lient_id, myname ) )716 CALL pmci_set_array_pointer( myname, c lient_id = client_id,&738 DO WHILE ( pmc_s_getnextarray( child_id, myname ) ) 739 CALL pmci_set_array_pointer( myname, child_id = child_id, & 717 740 nz_cl = nz_cl ) 718 741 ENDDO 719 CALL pmc_s_setind_and_allocmem( c lient_id )742 CALL pmc_s_setind_and_allocmem( child_id ) 720 743 ENDDO 721 744 722 IF ( ( SIZE( pmc_ server_for_client) - 1 > 0 ) .AND. myid == 0 ) THEN745 IF ( ( SIZE( pmc_parent_for_child ) - 1 > 0 ) .AND. myid == 0 ) THEN 723 746 DEALLOCATE( ch_xl ) 724 747 DEALLOCATE( ch_xr ) … … 747 770 INTEGER(iwp) :: px !: 748 771 INTEGER(iwp) :: py !: 749 INTEGER(iwp) :: server_pe !:772 INTEGER(iwp) :: parent_pe !: 750 773 751 774 INTEGER(iwp), DIMENSION(2) :: scoord !: … … 757 780 IF ( myid == 0 ) THEN 758 781 !-- TO_DO: Klaus: give more specific comment what size_of_array stands for 759 CALL pmc_recv_from_c lient( client_id, size_of_array, 2, 0, 40, ierr )782 CALL pmc_recv_from_child( child_id, size_of_array, 2, 0, 40, ierr ) 760 783 ALLOCATE( coarse_bound_all(size_of_array(1),size_of_array(2)) ) 761 CALL pmc_recv_from_c lient( client_id, coarse_bound_all,&762 784 CALL pmc_recv_from_child( child_id, coarse_bound_all, & 785 SIZE( coarse_bound_all ), 0, 41, ierr ) 763 786 764 787 ! … … 783 806 ic = 0 784 807 ! 785 !-- Loop over all c lientPEs808 !-- Loop over all children PEs 786 809 DO k = 1, size_of_array(2) 787 810 ! 788 !-- Area along y required by actual c lientPE811 !-- Area along y required by actual child PE 789 812 DO j = coarse_bound_all(3,k), coarse_bound_all(4,k) 790 813 ! 791 !-- Area along x required by actual c lientPE814 !-- Area along x required by actual child PE 792 815 DO i = coarse_bound_all(1,k), coarse_bound_all(2,k) 793 816 … … 796 819 scoord(1) = px 797 820 scoord(2) = py 798 CALL MPI_CART_RANK( comm2d, scoord, server_pe, ierr )821 CALL MPI_CART_RANK( comm2d, scoord, parent_pe, ierr ) 799 822 800 823 ic = ic + 1 801 824 ! 802 !-- First index in serverarray825 !-- First index in parent array 803 826 index_list(1,ic) = i - ( px * nrx ) + 1 + nbgp 804 827 ! 805 !-- Second index in serverarray828 !-- Second index in parent array 806 829 index_list(2,ic) = j - ( py * nry ) + 1 + nbgp 807 830 ! 808 !-- x index of c lientcoarse grid831 !-- x index of child coarse grid 809 832 index_list(3,ic) = i - coarse_bound_all(1,k) + 1 810 833 ! 811 !-- y index of c lientcoarse grid834 !-- y index of child coarse grid 812 835 index_list(4,ic) = j - coarse_bound_all(3,k) + 1 813 836 ! 814 !-- PE number of c lient837 !-- PE number of child 815 838 index_list(5,ic) = k - 1 816 839 ! 817 !-- PE number of server818 index_list(6,ic) = server_pe840 !-- PE number of parent 841 index_list(6,ic) = parent_pe 819 842 820 843 ENDDO … … 823 846 ! 824 847 !-- TO_DO: Klaus: comment what is done here 825 CALL pmc_s_set_2d_index_list( c lient_id, index_list(:,1:ic) )848 CALL pmc_s_set_2d_index_list( child_id, index_list(:,1:ic) ) 826 849 827 850 ELSE … … 829 852 !-- TO_DO: Klaus: comment why this dummy allocation is required 830 853 ALLOCATE( index_list(6,1) ) 831 CALL pmc_s_set_2d_index_list( c lient_id, index_list )854 CALL pmc_s_set_2d_index_list( child_id, index_list ) 832 855 ENDIF 833 856 … … 837 860 838 861 #endif 839 END SUBROUTINE pmci_setup_ server840 841 842 843 SUBROUTINE pmci_setup_c lient862 END SUBROUTINE pmci_setup_parent 863 864 865 866 SUBROUTINE pmci_setup_child 844 867 845 868 #if defined( __parallel ) … … 867 890 ! 868 891 !-- TO_DO: describe what is happening in this if-clause 869 !-- Root Model does not have Server and is not a client892 !-- Root model does not have a parent and is not a child 870 893 IF ( .NOT. pmc_is_rootmodel() ) THEN 871 894 872 CALL pmc_c lientinit895 CALL pmc_childinit 873 896 ! 874 897 !-- Here AND ONLY HERE the arrays are defined, which actualy will be 875 !-- exchanged between c lient and server.898 !-- exchanged between child and parent. 876 899 !-- If a variable is removed, it only has to be removed from here. 877 900 !-- Please check, if the arrays are in the list of POSSIBLE exchange arrays 878 901 !-- in subroutines: 879 !-- pmci_set_array_pointer (for serverarrays)880 !-- pmci_create_c lient_arrays (for clientarrays)902 !-- pmci_set_array_pointer (for parent arrays) 903 !-- pmci_create_child_arrays (for child arrays) 881 904 CALL pmc_set_dataarray_name( 'coarse', 'u' ,'fine', 'u', ierr ) 882 905 CALL pmc_set_dataarray_name( 'coarse', 'v' ,'fine', 'v', ierr ) … … 893 916 894 917 ! 895 !-- Send grid to server918 !-- Send grid to parent 896 919 val(1) = nx 897 920 val(2) = ny … … 903 926 IF ( myid == 0 ) THEN 904 927 905 CALL pmc_send_to_ server( val, SIZE( val ), 0, 123, ierr )906 CALL pmc_send_to_ server( fval, SIZE( fval ), 0, 124, ierr )907 CALL pmc_send_to_ server( coord_x, nx + 1 + 2 * nbgp, 0, 11, ierr )908 CALL pmc_send_to_ server( coord_y, ny + 1 + 2 * nbgp, 0, 12, ierr )928 CALL pmc_send_to_parent( val, SIZE( val ), 0, 123, ierr ) 929 CALL pmc_send_to_parent( fval, SIZE( fval ), 0, 124, ierr ) 930 CALL pmc_send_to_parent( coord_x, nx + 1 + 2 * nbgp, 0, 11, ierr ) 931 CALL pmc_send_to_parent( coord_y, ny + 1 + 2 * nbgp, 0, 12, ierr ) 909 932 910 933 ! 911 934 !-- Receive Coarse grid information. 912 935 !-- TO_DO: find shorter and more meaningful name for define_coarse_grid_real 913 CALL pmc_recv_from_ server( define_coarse_grid_real, &936 CALL pmc_recv_from_parent( define_coarse_grid_real, & 914 937 SIZE(define_coarse_grid_real), 0, 21, ierr ) 915 CALL pmc_recv_from_ server( define_coarse_grid_int, 3, 0, 22, ierr )938 CALL pmc_recv_from_parent( define_coarse_grid_int, 3, 0, 22, ierr ) 916 939 ! 917 940 !-- Debug-printouts - keep them 918 ! WRITE(0,*) 'Coarse grid from Server'941 ! WRITE(0,*) 'Coarse grid from parent ' 919 942 ! WRITE(0,*) 'startx_tot = ',define_coarse_grid_real(1) 920 943 ! WRITE(0,*) 'starty_tot = ',define_coarse_grid_real(2) … … 929 952 ENDIF 930 953 931 CALL MPI_BCAST( define_coarse_grid_real, SIZE(define_coarse_grid_real), &954 CALL MPI_BCAST( define_coarse_grid_real, SIZE(define_coarse_grid_real), & 932 955 MPI_REAL, 0, comm2d, ierr ) 933 956 CALL MPI_BCAST( define_coarse_grid_int, 3, MPI_INTEGER, 0, comm2d, ierr ) … … 941 964 942 965 ! 943 !-- Get servercoordinates on coarse grid966 !-- Get parent coordinates on coarse grid 944 967 ALLOCATE( cg%coord_x(-nbgp:cg%nx+nbgp) ) 945 968 ALLOCATE( cg%coord_y(-nbgp:cg%ny+nbgp) ) … … 951 974 952 975 ! 953 !-- Get coarse grid coordinates and val es of the z-direction from server976 !-- Get coarse grid coordinates and values of the z-direction from the parent 954 977 IF ( myid == 0) THEN 955 978 956 CALL pmc_recv_from_ server( cg%coord_x, cg%nx+1+2*nbgp, 0, 24, ierr )957 CALL pmc_recv_from_ server( cg%coord_y, cg%ny+1+2*nbgp, 0, 25, ierr )958 CALL pmc_recv_from_ server( cg%dzu, cg%nz + 1, 0, 26, ierr )959 CALL pmc_recv_from_ server( cg%dzw, cg%nz + 1, 0, 27, ierr )960 CALL pmc_recv_from_ server( cg%zu, cg%nz + 2, 0, 28, ierr )961 CALL pmc_recv_from_ server( cg%zw, cg%nz + 2, 0, 29, ierr )979 CALL pmc_recv_from_parent( cg%coord_x, cg%nx+1+2*nbgp, 0, 24, ierr ) 980 CALL pmc_recv_from_parent( cg%coord_y, cg%ny+1+2*nbgp, 0, 25, ierr ) 981 CALL pmc_recv_from_parent( cg%dzu, cg%nz + 1, 0, 26, ierr ) 982 CALL pmc_recv_from_parent( cg%dzw, cg%nz + 1, 0, 27, ierr ) 983 CALL pmc_recv_from_parent( cg%zu, cg%nz + 2, 0, 28, ierr ) 984 CALL pmc_recv_from_parent( cg%zw, cg%nz + 2, 0, 29, ierr ) 962 985 963 986 ENDIF … … 980 1003 981 1004 ! 982 !-- Include couple arrays into c lientcontent983 !-- TO_DO: Klaus: better explain the above comment (what is c lientcontent?)1005 !-- Include couple arrays into child content 1006 !-- TO_DO: Klaus: better explain the above comment (what is child content?) 984 1007 CALL pmc_c_clear_next_array_list 985 1008 DO WHILE ( pmc_c_getnextarray( myname ) ) 986 !-- TO_DO: Klaus, why the c -arrays are still up to cg%nz??987 CALL pmci_create_c lient_arrays ( myname, icl, icr, jcs, jcn, cg%nz )1009 !-- TO_DO: Klaus, why the child-arrays are still up to cg%nz?? 1010 CALL pmci_create_child_arrays ( myname, icl, icr, jcs, jcn, cg%nz ) 988 1011 ENDDO 989 1012 CALL pmc_c_setind_and_allocmem 990 1013 991 1014 ! 992 !-- Precompute interpolation coefficients and c lient-array indices1015 !-- Precompute interpolation coefficients and child-array indices 993 1016 CALL pmci_init_interp_tril 994 1017 … … 1002 1025 1003 1026 ! 1004 !-- Two-way coupling .1027 !-- Two-way coupling for general and vertical nesting. 1005 1028 !-- Precompute the index arrays and relaxation functions for the 1006 1029 !-- anterpolation 1007 IF ( nesting_mode == 'two-way' ) THEN 1030 IF ( TRIM( nesting_mode ) == 'two-way' .OR. & 1031 nesting_mode == 'vertical' ) THEN 1008 1032 CALL pmci_init_anterp_tophat 1009 1033 ENDIF … … 1097 1121 !-- Note that MPI_Gather receives data from all processes in the rank order 1098 1122 !-- TO_DO: refer to the line where this fact becomes important 1099 CALL MPI_GATHER( coarse_bound, 5, MPI_INTEGER, coarse_bound_all, 5, &1123 CALL MPI_GATHER( coarse_bound, 5, MPI_INTEGER, coarse_bound_all, 5, & 1100 1124 MPI_INTEGER, 0, comm2d, ierr ) 1101 1125 … … 1103 1127 size_of_array(1) = SIZE( coarse_bound_all, 1 ) 1104 1128 size_of_array(2) = SIZE( coarse_bound_all, 2 ) 1105 CALL pmc_send_to_ server( size_of_array, 2, 0, 40, ierr )1106 CALL pmc_send_to_ server( coarse_bound_all, SIZE( coarse_bound_all ),&1129 CALL pmc_send_to_parent( size_of_array, 2, 0, 40, ierr ) 1130 CALL pmc_send_to_parent( coarse_bound_all, SIZE( coarse_bound_all ), & 1107 1131 0, 41, ierr ) 1108 1132 ENDIF … … 1114 1138 SUBROUTINE pmci_init_interp_tril 1115 1139 ! 1116 !-- Precomputation of the interpolation coefficients and c lient-array indices1140 !-- Precomputation of the interpolation coefficients and child-array indices 1117 1141 !-- to be used by the interpolation routines interp_tril_lr, interp_tril_ns 1118 1142 !-- and interp_tril_t. … … 1167 1191 ! 1168 1192 !-- Note that the node coordinates xfs... and xcs... are relative to the 1169 !-- lower-left-bottom corner of the fc-array, not the actual c lientdomain1193 !-- lower-left-bottom corner of the fc-array, not the actual child domain 1170 1194 !-- corner 1171 1195 DO i = nxlg, nxrg … … 1262 1286 DO i = nxl-1, nxl 1263 1287 DO j = nys, nyn 1264 nzt_topo_nestbc_l = MAX( nzt_topo_nestbc_l, nzb_u_inner(j,i), &1288 nzt_topo_nestbc_l = MAX( nzt_topo_nestbc_l, nzb_u_inner(j,i), & 1265 1289 nzb_v_inner(j,i), nzb_w_inner(j,i) ) 1266 1290 ENDDO … … 1273 1297 i = nxr + 1 1274 1298 DO j = nys, nyn 1275 nzt_topo_nestbc_r = MAX( nzt_topo_nestbc_r, nzb_u_inner(j,i), &1299 nzt_topo_nestbc_r = MAX( nzt_topo_nestbc_r, nzb_u_inner(j,i), & 1276 1300 nzb_v_inner(j,i), nzb_w_inner(j,i) ) 1277 1301 ENDDO … … 1283 1307 DO j = nys-1, nys 1284 1308 DO i = nxl, nxr 1285 nzt_topo_nestbc_s = MAX( nzt_topo_nestbc_s, nzb_u_inner(j,i), &1309 nzt_topo_nestbc_s = MAX( nzt_topo_nestbc_s, nzb_u_inner(j,i), & 1286 1310 nzb_v_inner(j,i), nzb_w_inner(j,i) ) 1287 1311 ENDDO … … 1294 1318 j = nyn + 1 1295 1319 DO i = nxl, nxr 1296 nzt_topo_nestbc_n = MAX( nzt_topo_nestbc_n, nzb_u_inner(j,i), &1320 nzt_topo_nestbc_n = MAX( nzt_topo_nestbc_n, nzb_u_inner(j,i), & 1297 1321 nzb_v_inner(j,i), nzb_w_inner(j,i) ) 1298 1322 ENDDO … … 1303 1327 !-- Then determine the maximum number of near-wall nodes per wall point based 1304 1328 !-- on the grid-spacing ratios. 1305 nzt_topo_max = MAX( nzt_topo_nestbc_l, nzt_topo_nestbc_r, &1329 nzt_topo_max = MAX( nzt_topo_nestbc_l, nzt_topo_nestbc_r, & 1306 1330 nzt_topo_nestbc_s, nzt_topo_nestbc_n ) 1307 1331 … … 1343 1367 k = kb + 1 1344 1368 wall_index = kb 1345 CALL pmci_define_loglaw_correction_parameters( lc, lcr, k, j, &1369 CALL pmci_define_loglaw_correction_parameters( lc, lcr, k, j, & 1346 1370 inc, wall_index, z0(j,i), kb, direction, ncorr ) 1347 1371 logc_u_l(1,k,j) = lc … … 1354 1378 k = kb + 1 1355 1379 wall_index = kb 1356 CALL pmci_define_loglaw_correction_parameters( lc, lcr, k, j, &1380 CALL pmci_define_loglaw_correction_parameters( lc, lcr, k, j, & 1357 1381 inc, wall_index, z0(j,i), kb, direction, ncorr ) 1358 1382 logc_v_l(1,k,j) = lc … … 1385 1409 k = kb + 1 1386 1410 wall_index = kb 1387 CALL pmci_define_loglaw_correction_parameters( lc, lcr, k, j, &1411 CALL pmci_define_loglaw_correction_parameters( lc, lcr, k, j, & 1388 1412 inc, wall_index, z0(j,i), kb, direction, ncorr ) 1389 1413 logc_u_r(1,k,j) = lc … … 1396 1420 k = kb + 1 1397 1421 wall_index = kb 1398 CALL pmci_define_loglaw_correction_parameters( lc, lcr, k, j, &1422 CALL pmci_define_loglaw_correction_parameters( lc, lcr, k, j, & 1399 1423 inc, wall_index, z0(j,i), kb, direction, ncorr ) 1400 1424 logc_v_r(1,k,j) = lc … … 1428 1452 k = kb + 1 1429 1453 wall_index = kb 1430 CALL pmci_define_loglaw_correction_parameters( lc, lcr, k, j, &1454 CALL pmci_define_loglaw_correction_parameters( lc, lcr, k, j, & 1431 1455 inc, wall_index, z0(j,i), kb, direction, ncorr ) 1432 1456 logc_u_s(1,k,i) = lc … … 1439 1463 k = kb + 1 1440 1464 wall_index = kb 1441 CALL pmci_define_loglaw_correction_parameters( lc, lcr, k, j, &1465 CALL pmci_define_loglaw_correction_parameters( lc, lcr, k, j, & 1442 1466 inc, wall_index, z0(j,i), kb, direction, ncorr ) 1443 1467 logc_v_s(1,k,i) = lc … … 1471 1495 k = kb + 1 1472 1496 wall_index = kb 1473 CALL pmci_define_loglaw_correction_parameters( lc, lcr, k, j, &1497 CALL pmci_define_loglaw_correction_parameters( lc, lcr, k, j, & 1474 1498 inc, wall_index, z0(j,i), kb, direction, ncorr ) 1475 1499 logc_u_n(1,k,i) = lc … … 1482 1506 k = kb + 1 1483 1507 wall_index = kb 1484 CALL pmci_define_loglaw_correction_parameters( lc, lcr, k, j, &1508 CALL pmci_define_loglaw_correction_parameters( lc, lcr, k, j, & 1485 1509 inc, wall_index, z0(j,i), kb, direction, ncorr ) 1486 1510 logc_v_n(1,k,i) = lc … … 1502 1526 1503 1527 ALLOCATE( logc_w_l(1:2,nzb:nzt_topo_nestbc_l,nys:nyn) ) 1504 ALLOCATE( logc_ratio_w_l(1:2,0:ncorr-1,nzb:nzt_topo_nestbc_l, &1528 ALLOCATE( logc_ratio_w_l(1:2,0:ncorr-1,nzb:nzt_topo_nestbc_l, & 1505 1529 nys:nyn) ) 1506 1530 … … 1513 1537 !-- Wall for u on the south side, but not on the north side 1514 1538 i = 0 1515 IF ( ( nzb_u_outer(j,i) > nzb_u_outer(j+1,i) ) .AND. &1516 ( nzb_u_outer(j,i) == nzb_u_outer(j-1,i) ) ) &1539 IF ( ( nzb_u_outer(j,i) > nzb_u_outer(j+1,i) ) .AND. & 1540 ( nzb_u_outer(j,i) == nzb_u_outer(j-1,i) ) ) & 1517 1541 THEN 1518 1542 inc = 1 1519 1543 wall_index = j 1520 CALL pmci_define_loglaw_correction_parameters( lc, lcr, &1544 CALL pmci_define_loglaw_correction_parameters( lc, lcr, & 1521 1545 k, j, inc, wall_index, z0(j,i), kb, direction, ncorr ) 1522 1546 ! … … 1531 1555 !-- Wall for u on the north side, but not on the south side 1532 1556 i = 0 1533 IF ( ( nzb_u_outer(j,i) > nzb_u_outer(j-1,i) ) .AND. &1557 IF ( ( nzb_u_outer(j,i) > nzb_u_outer(j-1,i) ) .AND. & 1534 1558 ( nzb_u_outer(j,i) == nzb_u_outer(j+1,i) ) ) THEN 1535 1559 inc = -1 1536 1560 wall_index = j + 1 1537 CALL pmci_define_loglaw_correction_parameters( lc, lcr, &1561 CALL pmci_define_loglaw_correction_parameters( lc, lcr, & 1538 1562 k, j, inc, wall_index, z0(j,i), kb, direction, ncorr ) 1539 1563 ! … … 1548 1572 !-- Wall for w on the south side, but not on the north side. 1549 1573 i = -1 1550 IF ( ( nzb_w_outer(j,i) > nzb_w_outer(j+1,i) ) .AND. &1574 IF ( ( nzb_w_outer(j,i) > nzb_w_outer(j+1,i) ) .AND. & 1551 1575 ( nzb_w_outer(j,i) == nzb_w_outer(j-1,i) ) ) THEN 1552 1576 inc = 1 1553 1577 wall_index = j 1554 CALL pmci_define_loglaw_correction_parameters( lc, lcr, &1578 CALL pmci_define_loglaw_correction_parameters( lc, lcr, & 1555 1579 k, j, inc, wall_index, z0(j,i), kb, direction, ncorr ) 1556 1580 ! … … 1565 1589 !-- Wall for w on the north side, but not on the south side. 1566 1590 i = -1 1567 IF ( ( nzb_w_outer(j,i) > nzb_w_outer(j-1,i) ) .AND. &1591 IF ( ( nzb_w_outer(j,i) > nzb_w_outer(j-1,i) ) .AND. & 1568 1592 ( nzb_w_outer(j,i) == nzb_w_outer(j+1,i) ) ) THEN 1569 1593 inc = -1 1570 1594 wall_index = j+1 1571 CALL pmci_define_loglaw_correction_parameters( lc, lcr, &1595 CALL pmci_define_loglaw_correction_parameters( lc, lcr, & 1572 1596 k, j, inc, wall_index, z0(j,i), kb, direction, ncorr ) 1573 1597 ! … … 1589 1613 1590 1614 ALLOCATE( logc_w_r(1:2,nzb:nzt_topo_nestbc_r,nys:nyn) ) 1591 ALLOCATE( logc_ratio_w_r(1:2,0:ncorr-1,nzb:nzt_topo_nestbc_r, &1615 ALLOCATE( logc_ratio_w_r(1:2,0:ncorr-1,nzb:nzt_topo_nestbc_r, & 1592 1616 nys:nyn) ) 1593 1617 logc_w_r = 0 … … 1600 1624 ! 1601 1625 !-- Wall for u on the south side, but not on the north side 1602 IF ( ( nzb_u_outer(j,i) > nzb_u_outer(j+1,i) ) .AND. &1626 IF ( ( nzb_u_outer(j,i) > nzb_u_outer(j+1,i) ) .AND. & 1603 1627 ( nzb_u_outer(j,i) == nzb_u_outer(j-1,i) ) ) THEN 1604 1628 inc = 1 1605 1629 wall_index = j 1606 CALL pmci_define_loglaw_correction_parameters( lc, lcr, &1630 CALL pmci_define_loglaw_correction_parameters( lc, lcr, & 1607 1631 k, j, inc, wall_index, z0(j,i), kb, direction, ncorr ) 1608 1632 ! … … 1616 1640 ! 1617 1641 !-- Wall for u on the north side, but not on the south side 1618 IF ( ( nzb_u_outer(j,i) > nzb_u_outer(j-1,i) ) .AND. &1642 IF ( ( nzb_u_outer(j,i) > nzb_u_outer(j-1,i) ) .AND. & 1619 1643 ( nzb_u_outer(j,i) == nzb_u_outer(j+1,i) ) ) THEN 1620 1644 inc = -1 1621 1645 wall_index = j+1 1622 CALL pmci_define_loglaw_correction_parameters( lc, lcr, &1646 CALL pmci_define_loglaw_correction_parameters( lc, lcr, & 1623 1647 k, j, inc, wall_index, z0(j,i), kb, direction, ncorr ) 1624 1648 ! … … 1632 1656 ! 1633 1657 !-- Wall for w on the south side, but not on the north side 1634 IF ( ( nzb_w_outer(j,i) > nzb_w_outer(j+1,i) ) .AND. &1658 IF ( ( nzb_w_outer(j,i) > nzb_w_outer(j+1,i) ) .AND. & 1635 1659 ( nzb_w_outer(j,i) == nzb_w_outer(j-1,i) ) ) THEN 1636 1660 inc = 1 1637 1661 wall_index = j 1638 CALL pmci_define_loglaw_correction_parameters( lc, lcr, &1662 CALL pmci_define_loglaw_correction_parameters( lc, lcr, & 1639 1663 k, j, inc, wall_index, z0(j,i), kb, direction, ncorr ) 1640 1664 ! … … 1648 1672 ! 1649 1673 !-- Wall for w on the north side, but not on the south side 1650 IF ( ( nzb_w_outer(j,i) > nzb_w_outer(j-1,i) ) .AND. &1674 IF ( ( nzb_w_outer(j,i) > nzb_w_outer(j-1,i) ) .AND. & 1651 1675 ( nzb_w_outer(j,i) == nzb_w_outer(j+1,i) ) ) THEN 1652 1676 inc = -1 1653 1677 wall_index = j+1 1654 CALL pmci_define_loglaw_correction_parameters( lc, lcr, &1678 CALL pmci_define_loglaw_correction_parameters( lc, lcr, & 1655 1679 k, j, inc, wall_index, z0(j,i), kb, direction, ncorr ) 1656 1680 … … 1673 1697 1674 1698 ALLOCATE( logc_w_s(1:2,nzb:nzt_topo_nestbc_s,nxl:nxr) ) 1675 ALLOCATE( logc_ratio_w_s(1:2,0:ncorr-1,nzb:nzt_topo_nestbc_s, &1699 ALLOCATE( logc_ratio_w_s(1:2,0:ncorr-1,nzb:nzt_topo_nestbc_s, & 1676 1700 nxl:nxr) ) 1677 1701 logc_w_s = 0 … … 1684 1708 !-- Wall for v on the left side, but not on the right side 1685 1709 j = 0 1686 IF ( ( nzb_v_outer(j,i) > nzb_v_outer(j,i+1) ) .AND. &1710 IF ( ( nzb_v_outer(j,i) > nzb_v_outer(j,i+1) ) .AND. & 1687 1711 ( nzb_v_outer(j,i) == nzb_v_outer(j,i-1) ) ) THEN 1688 1712 inc = 1 1689 1713 wall_index = i 1690 CALL pmci_define_loglaw_correction_parameters( lc, lcr, &1714 CALL pmci_define_loglaw_correction_parameters( lc, lcr, & 1691 1715 k, i, inc, wall_index, z0(j,i), kb, direction, ncorr ) 1692 1716 ! … … 1701 1725 !-- Wall for v on the right side, but not on the left side 1702 1726 j = 0 1703 IF ( ( nzb_v_outer(j,i) > nzb_v_outer(j,i-1) ) .AND. &1727 IF ( ( nzb_v_outer(j,i) > nzb_v_outer(j,i-1) ) .AND. & 1704 1728 ( nzb_v_outer(j,i) == nzb_v_outer(j,i+1) ) ) THEN 1705 1729 inc = -1 1706 1730 wall_index = i+1 1707 CALL pmci_define_loglaw_correction_parameters( lc, lcr, &1731 CALL pmci_define_loglaw_correction_parameters( lc, lcr, & 1708 1732 k, i, inc, wall_index, z0(j,i), kb, direction, ncorr ) 1709 1733 ! … … 1718 1742 !-- Wall for w on the left side, but not on the right side 1719 1743 j = -1 1720 IF ( ( nzb_w_outer(j,i) > nzb_w_outer(j,i+1) ) .AND. &1744 IF ( ( nzb_w_outer(j,i) > nzb_w_outer(j,i+1) ) .AND. & 1721 1745 ( nzb_w_outer(j,i) == nzb_w_outer(j,i-1) ) ) THEN 1722 1746 inc = 1 1723 1747 wall_index = i 1724 CALL pmci_define_loglaw_correction_parameters( lc, lcr, &1748 CALL pmci_define_loglaw_correction_parameters( lc, lcr, & 1725 1749 k, i, inc, wall_index, z0(j,i), kb, direction, ncorr ) 1726 1750 ! … … 1735 1759 !-- Wall for w on the right side, but not on the left side 1736 1760 j = -1 1737 IF ( ( nzb_w_outer(j,i) > nzb_w_outer(j,i-1) ) .AND. &1761 IF ( ( nzb_w_outer(j,i) > nzb_w_outer(j,i-1) ) .AND. & 1738 1762 ( nzb_w_outer(j,i) == nzb_w_outer(j,i+1) ) ) THEN 1739 1763 inc = -1 1740 1764 wall_index = i+1 1741 CALL pmci_define_loglaw_correction_parameters( lc, lcr, &1765 CALL pmci_define_loglaw_correction_parameters( lc, lcr, & 1742 1766 k, i, inc, wall_index, z0(j,i), kb, direction, ncorr ) 1743 1767 ! … … 1759 1783 1760 1784 ALLOCATE( logc_w_n(1:2,nzb:nzt_topo_nestbc_n, nxl:nxr) ) 1761 ALLOCATE( logc_ratio_w_n(1:2,0:ncorr-1,nzb:nzt_topo_nestbc_n, &1785 ALLOCATE( logc_ratio_w_n(1:2,0:ncorr-1,nzb:nzt_topo_nestbc_n, & 1762 1786 nxl:nxr) ) 1763 1787 logc_w_n = 0 … … 1770 1794 ! 1771 1795 !-- Wall for v on the left side, but not on the right side 1772 IF ( ( nzb_v_outer(j,i) > nzb_v_outer(j,i+1) ) .AND. &1796 IF ( ( nzb_v_outer(j,i) > nzb_v_outer(j,i+1) ) .AND. & 1773 1797 ( nzb_v_outer(j,i) == nzb_v_outer(j,i-1) ) ) THEN 1774 1798 inc = 1 1775 1799 wall_index = i 1776 CALL pmci_define_loglaw_correction_parameters( lc, lcr, &1800 CALL pmci_define_loglaw_correction_parameters( lc, lcr, & 1777 1801 k, i, inc, wall_index, z0(j,i), kb, direction, ncorr ) 1778 1802 ! … … 1786 1810 ! 1787 1811 !-- Wall for v on the right side, but not on the left side 1788 IF ( ( nzb_v_outer(j,i) > nzb_v_outer(j,i-1) ) .AND. &1812 IF ( ( nzb_v_outer(j,i) > nzb_v_outer(j,i-1) ) .AND. & 1789 1813 ( nzb_v_outer(j,i) == nzb_v_outer(j,i+1) ) ) THEN 1790 1814 inc = -1 1791 1815 wall_index = i + 1 1792 CALL pmci_define_loglaw_correction_parameters( lc, lcr, &1816 CALL pmci_define_loglaw_correction_parameters( lc, lcr, & 1793 1817 k, i, inc, wall_index, z0(j,i), kb, direction, ncorr ) 1794 1818 ! … … 1802 1826 ! 1803 1827 !-- Wall for w on the left side, but not on the right side 1804 IF ( ( nzb_w_outer(j,i) > nzb_w_outer(j,i+1) ) .AND. &1828 IF ( ( nzb_w_outer(j,i) > nzb_w_outer(j,i+1) ) .AND. & 1805 1829 ( nzb_w_outer(j,i) == nzb_w_outer(j,i-1) ) ) THEN 1806 1830 inc = 1 1807 1831 wall_index = i 1808 CALL pmci_define_loglaw_correction_parameters( lc, lcr, &1832 CALL pmci_define_loglaw_correction_parameters( lc, lcr, & 1809 1833 k, i, inc, wall_index, z0(j,i), kb, direction, ncorr ) 1810 1834 ! … … 1818 1842 ! 1819 1843 !-- Wall for w on the right side, but not on the left side 1820 IF ( ( nzb_w_outer(j,i) > nzb_w_outer(j,i-1) ) .AND. &1844 IF ( ( nzb_w_outer(j,i) > nzb_w_outer(j,i-1) ) .AND. & 1821 1845 ( nzb_w_outer(j,i) == nzb_w_outer(j,i+1) ) ) THEN 1822 1846 inc = -1 1823 1847 wall_index = i+1 1824 CALL pmci_define_loglaw_correction_parameters( lc, lcr, &1848 CALL pmci_define_loglaw_correction_parameters( lc, lcr, & 1825 1849 k, i, inc, wall_index, z0(j,i), kb, direction, ncorr ) 1826 1850 ! … … 1843 1867 1844 1868 1845 SUBROUTINE pmci_define_loglaw_correction_parameters( lc, lcr, k, ij, inc, &1869 SUBROUTINE pmci_define_loglaw_correction_parameters( lc, lcr, k, ij, inc, & 1846 1870 wall_index, z0_l, kb, direction, ncorr ) 1847 1871 … … 1897 1921 corr_index = ij + lcorr ! In this case (direction = 2) ij is j 1898 1922 IF ( lcorr == 0 ) THEN 1899 CALL pmci_find_logc_pivot_j( lc, logvelc1, ij, wall_index, &1923 CALL pmci_find_logc_pivot_j( lc, logvelc1, ij, wall_index, & 1900 1924 z0_l, inc ) 1901 1925 ENDIF … … 1905 1929 !-- valid in both directions 1906 1930 IF ( inc * corr_index < inc * lc ) THEN 1907 lcr(alcorr) = LOG( ABS( coord_y(corr_index) + 0.5_wp * dy &1908 - coord_y(wall_index) ) / z0_l ) &1931 lcr(alcorr) = LOG( ABS( coord_y(corr_index) + 0.5_wp * dy & 1932 - coord_y(wall_index) ) / z0_l ) & 1909 1933 / logvelc1 1910 1934 more = .TRUE. … … 1924 1948 corr_index = ij + lcorr ! In this case (direction = 3) ij is i 1925 1949 IF ( lcorr == 0 ) THEN 1926 CALL pmci_find_logc_pivot_i( lc, logvelc1, ij, wall_index, &1950 CALL pmci_find_logc_pivot_i( lc, logvelc1, ij, wall_index, & 1927 1951 z0_l, inc ) 1928 1952 ENDIF … … 1931 1955 !-- valid in both directions 1932 1956 IF ( inc * corr_index < inc * lc ) THEN 1933 lcr(alcorr) = LOG( ABS( coord_x(corr_index) + 0.5_wp * dx &1934 - coord_x(wall_index) ) / z0_l ) &1957 lcr(alcorr) = LOG( ABS( coord_x(corr_index) + 0.5_wp * dx & 1958 - coord_x(wall_index) ) / z0_l ) & 1935 1959 / logvelc1 1936 1960 more = .TRUE. … … 1963 1987 INTEGER(iwp) :: k1 !: 1964 1988 1965 REAL(wp), INTENT(OUT) :: logzc1 !:1989 REAL(wp), INTENT(OUT) :: logzc1 !: 1966 1990 REAL(wp), INTENT(IN) :: z0_l !: 1967 1991 … … 2072 2096 SUBROUTINE pmci_init_anterp_tophat 2073 2097 ! 2074 !-- Precomputation of the c lient-array indices for2098 !-- Precomputation of the child-array indices for 2075 2099 !-- corresponding coarse-grid array index and the 2076 2100 !-- Under-relaxation coefficients to be used by anterp_tophat. … … 2148 2172 DO ii = icl, icr 2149 2173 i = istart 2150 DO WHILE ( ( coord_x(i) < cg%coord_x(ii) - 0.5_wp * cg%dx ) .AND. &2174 DO WHILE ( ( coord_x(i) < cg%coord_x(ii) - 0.5_wp * cg%dx ) .AND. & 2151 2175 ( i < nxrg ) ) 2152 2176 i = i + 1 2153 2177 ENDDO 2154 2178 iflu(ii) = MIN( MAX( i, nxlg ), nxrg ) 2155 DO WHILE ( ( coord_x(i) < cg%coord_x(ii) + 0.5_wp * cg%dx ) .AND. &2179 DO WHILE ( ( coord_x(i) < cg%coord_x(ii) + 0.5_wp * cg%dx ) .AND. & 2156 2180 ( i < nxrg ) ) 2157 2181 i = i + 1 … … 2166 2190 DO ii = icl, icr 2167 2191 i = istart 2168 DO WHILE ( ( coord_x(i) + 0.5_wp * dx < cg%coord_x(ii) ) .AND. &2192 DO WHILE ( ( coord_x(i) + 0.5_wp * dx < cg%coord_x(ii) ) .AND. & 2169 2193 ( i < nxrg ) ) 2170 2194 i = i + 1 2171 2195 ENDDO 2172 2196 iflo(ii) = MIN( MAX( i, nxlg ), nxrg ) 2173 DO WHILE ( ( coord_x(i) + 0.5_wp * dx < cg%coord_x(ii) + cg%dx ) &2197 DO WHILE ( ( coord_x(i) + 0.5_wp * dx < cg%coord_x(ii) + cg%dx ) & 2174 2198 .AND. ( i < nxrg ) ) 2175 2199 i = i + 1 … … 2184 2208 DO jj = jcs, jcn 2185 2209 j = jstart 2186 DO WHILE ( ( coord_y(j) < cg%coord_y(jj) - 0.5_wp * cg%dy ) .AND. &2210 DO WHILE ( ( coord_y(j) < cg%coord_y(jj) - 0.5_wp * cg%dy ) .AND. & 2187 2211 ( j < nyng ) ) 2188 2212 j = j + 1 2189 2213 ENDDO 2190 2214 jflv(jj) = MIN( MAX( j, nysg ), nyng ) 2191 DO WHILE ( ( coord_y(j) < cg%coord_y(jj) + 0.5_wp * cg%dy ) .AND. &2215 DO WHILE ( ( coord_y(j) < cg%coord_y(jj) + 0.5_wp * cg%dy ) .AND. & 2192 2216 ( j < nyng ) ) 2193 2217 j = j + 1 … … 2202 2226 DO jj = jcs, jcn 2203 2227 j = jstart 2204 DO WHILE ( ( coord_y(j) + 0.5_wp * dy < cg%coord_y(jj) ) .AND. &2228 DO WHILE ( ( coord_y(j) + 0.5_wp * dy < cg%coord_y(jj) ) .AND. & 2205 2229 ( j < nyng ) ) 2206 2230 j = j + 1 2207 2231 ENDDO 2208 2232 jflo(jj) = MIN( MAX( j, nysg ), nyng ) 2209 DO WHILE ( ( coord_y(j) + 0.5_wp * dy < cg%coord_y(jj) + cg%dy ) &2233 DO WHILE ( ( coord_y(j) + 0.5_wp * dy < cg%coord_y(jj) + cg%dy ) & 2210 2234 .AND. ( j < nyng ) ) 2211 2235 j = j + 1 … … 2222 2246 DO kk = 1, kctw 2223 2247 k = kstart 2224 DO WHILE ( ( zw(k) < cg%zw(kk) - 0.5_wp * cg%dzw(kk) ) .AND. &2248 DO WHILE ( ( zw(k) < cg%zw(kk) - 0.5_wp * cg%dzw(kk) ) .AND. & 2225 2249 ( k < nzt ) ) 2226 2250 k = k + 1 2227 2251 ENDDO 2228 2252 kflw(kk) = MIN( MAX( k, 1 ), nzt + 1 ) 2229 DO WHILE ( ( zw(k) < cg%zw(kk) + 0.5_wp * cg%dzw(kk+1) ) .AND. &2253 DO WHILE ( ( zw(k) < cg%zw(kk) + 0.5_wp * cg%dzw(kk+1) ) .AND. & 2230 2254 ( k < nzt ) ) 2231 2255 k = k + 1 … … 2242 2266 DO kk = 1, kctu 2243 2267 k = kstart 2244 DO WHILE ( ( zu(k) < cg%zu(kk) - 0.5_wp * cg%dzu(kk) ) .AND. &2268 DO WHILE ( ( zu(k) < cg%zu(kk) - 0.5_wp * cg%dzu(kk) ) .AND. & 2245 2269 ( k < nzt ) ) 2246 2270 k = k + 1 2247 2271 ENDDO 2248 2272 kflo(kk) = MIN( MAX( k, 1 ), nzt + 1 ) 2249 DO WHILE ( ( zu(k) < cg%zu(kk) + 0.5_wp * cg%dzu(kk+1) ) .AND. &2273 DO WHILE ( ( zu(k) < cg%zu(kk) + 0.5_wp * cg%dzu(kk+1) ) .AND. & 2250 2274 ( k < nzt ) ) 2251 2275 k = k + 1 … … 2272 2296 !-- Spatial under-relaxation coefficients 2273 2297 ALLOCATE( frax(icl:icr) ) 2274 2275 DO ii = icl, icr2276 IF ( nest_bound_l ) THEN2277 xi = ( MAX( 0.0_wp, ( cg%coord_x(ii) - lower_left_coord_x ) ) / &2278 anterp_relax_length_l )**42279 ELSEIF ( nest_bound_r ) THEN2280 xi = ( MAX( 0.0_wp, ( lower_left_coord_x + ( nx + 1 ) * dx - &2281 cg%coord_x(ii) ) ) / &2282 anterp_relax_length_r )**42283 ELSE2284 xi = 999999.9_wp2285 ENDIF2286 frax(ii) = xi / ( 1.0_wp + xi )2287 ENDDO2288 2289 2298 ALLOCATE( fray(jcs:jcn) ) 2290 2291 DO jj = jcs, jcn 2292 IF ( nest_bound_s ) THEN 2293 eta = ( MAX( 0.0_wp, ( cg%coord_y(jj) - lower_left_coord_y ) ) / & 2294 anterp_relax_length_s )**4 2295 ELSEIF ( nest_bound_n ) THEN 2296 eta = ( MAX( 0.0_wp, ( lower_left_coord_y + ( ny + 1 ) * dy - & 2297 cg%coord_y(jj)) ) / & 2298 anterp_relax_length_n )**4 2299 ELSE 2300 eta = 999999.9_wp 2301 ENDIF 2302 fray(jj) = eta / ( 1.0_wp + eta ) 2303 ENDDO 2299 2300 frax(icl:icr) = 1.0_wp 2301 fray(jcs:jcn) = 1.0_wp 2302 2303 IF ( nesting_mode /= 'vertical' ) THEN 2304 DO ii = icl, icr 2305 IF ( nest_bound_l ) THEN 2306 xi = ( MAX( 0.0_wp, ( cg%coord_x(ii) - & 2307 lower_left_coord_x ) ) / anterp_relax_length_l )**4 2308 ELSEIF ( nest_bound_r ) THEN 2309 xi = ( MAX( 0.0_wp, ( lower_left_coord_x + ( nx + 1 ) * dx - & 2310 cg%coord_x(ii) ) ) / & 2311 anterp_relax_length_r )**4 2312 ELSE 2313 xi = 999999.9_wp 2314 ENDIF 2315 frax(ii) = xi / ( 1.0_wp + xi ) 2316 ENDDO 2317 2318 2319 DO jj = jcs, jcn 2320 IF ( nest_bound_s ) THEN 2321 eta = ( MAX( 0.0_wp, ( cg%coord_y(jj) - & 2322 lower_left_coord_y ) ) / anterp_relax_length_s )**4 2323 ELSEIF ( nest_bound_n ) THEN 2324 eta = ( MAX( 0.0_wp, ( lower_left_coord_y + ( ny + 1 ) * dy - & 2325 cg%coord_y(jj)) ) / & 2326 anterp_relax_length_n )**4 2327 ELSE 2328 eta = 999999.9_wp 2329 ENDIF 2330 fray(jj) = eta / ( 1.0_wp + eta ) 2331 ENDDO 2332 ENDIF 2304 2333 2305 2334 ALLOCATE( fraz(0:kctu) ) … … 2347 2376 height = zu(k) - zu(nzb_s_inner(j,i)) 2348 2377 fw = EXP( -cfw * height / glsf ) 2349 tkefactor_l(k,j) = c_tkef * ( fw0 * fw + ( 1.0_wp - fw ) * &2378 tkefactor_l(k,j) = c_tkef * ( fw0 * fw + ( 1.0_wp - fw ) * & 2350 2379 ( glsf / glsc )**p23 ) 2351 2380 ENDDO … … 2365 2394 height = zu(k) - zu(nzb_s_inner(j,i)) 2366 2395 fw = EXP( -cfw * height / glsf ) 2367 tkefactor_r(k,j) = c_tkef * ( fw0 * fw + ( 1.0_wp - fw ) * &2396 tkefactor_r(k,j) = c_tkef * ( fw0 * fw + ( 1.0_wp - fw ) * & 2368 2397 ( glsf / glsc )**p23 ) 2369 2398 ENDDO … … 2383 2412 height = zu(k) - zu(nzb_s_inner(j,i)) 2384 2413 fw = EXP( -cfw*height / glsf ) 2385 tkefactor_s(k,i) = c_tkef * ( fw0 * fw + ( 1.0_wp - fw ) * &2414 tkefactor_s(k,i) = c_tkef * ( fw0 * fw + ( 1.0_wp - fw ) * & 2386 2415 ( glsf / glsc )**p23 ) 2387 2416 ENDDO … … 2401 2430 height = zu(k) - zu(nzb_s_inner(j,i)) 2402 2431 fw = EXP( -cfw * height / glsf ) 2403 tkefactor_n(k,i) = c_tkef * ( fw0 * fw + ( 1.0_wp - fw ) * &2432 tkefactor_n(k,i) = c_tkef * ( fw0 * fw + ( 1.0_wp - fw ) * & 2404 2433 ( glsf / glsc )**p23 ) 2405 2434 ENDDO … … 2417 2446 height = zu(k) - zu(nzb_s_inner(j,i)) 2418 2447 fw = EXP( -cfw * height / glsf ) 2419 tkefactor_t(j,i) = c_tkef * ( fw0 * fw + ( 1.0_wp - fw ) * &2448 tkefactor_t(j,i) = c_tkef * ( fw0 * fw + ( 1.0_wp - fw ) * & 2420 2449 ( glsf / glsc )**p23 ) 2421 2450 ENDDO … … 2425 2454 2426 2455 #endif 2427 END SUBROUTINE pmci_setup_c lient2456 END SUBROUTINE pmci_setup_child 2428 2457 2429 2458 … … 2456 2485 2457 2486 2458 SUBROUTINE pmci_set_array_pointer( name, c lient_id, nz_cl )2487 SUBROUTINE pmci_set_array_pointer( name, child_id, nz_cl ) 2459 2488 2460 2489 IMPLICIT NONE 2461 2490 2462 INTEGER, INTENT(IN) :: c lient_id!:2491 INTEGER, INTENT(IN) :: child_id !: 2463 2492 INTEGER, INTENT(IN) :: nz_cl !: 2464 2493 CHARACTER(LEN=*), INTENT(IN) :: name !: … … 2493 2522 #if defined( __nopointer ) 2494 2523 IF ( ASSOCIATED( p_3d ) ) THEN 2495 CALL pmc_s_set_dataarray( c lient_id, p_3d, nz_cl, nz )2524 CALL pmc_s_set_dataarray( child_id, p_3d, nz_cl, nz ) 2496 2525 ELSEIF ( ASSOCIATED( p_2d ) ) THEN 2497 CALL pmc_s_set_dataarray( c lient_id, p_2d )2526 CALL pmc_s_set_dataarray( child_id, p_2d ) 2498 2527 ELSE 2499 2528 ! … … 2501 2530 IF ( myid == 0 .AND. cpl_id == 1 ) THEN 2502 2531 2503 message_string = 'pointer for array "' // TRIM( name ) // &2532 message_string = 'pointer for array "' // TRIM( name ) // & 2504 2533 '" can''t be associated' 2505 2534 CALL message( 'pmci_set_array_pointer', 'PA0117', 3, 2, 0, 6, 0 ) … … 2519 2548 2520 2549 IF ( ASSOCIATED( p_3d ) ) THEN 2521 CALL pmc_s_set_dataarray( c lient_id, p_3d, nz_cl, nz,&2550 CALL pmc_s_set_dataarray( child_id, p_3d, nz_cl, nz, & 2522 2551 array_2 = p_3d_sec ) 2523 2552 ELSEIF ( ASSOCIATED( p_2d ) ) THEN 2524 CALL pmc_s_set_dataarray( c lient_id, p_2d )2553 CALL pmc_s_set_dataarray( child_id, p_2d ) 2525 2554 ELSE 2526 2555 ! … … 2528 2557 IF ( myid == 0 .AND. cpl_id == 1 ) THEN 2529 2558 2530 message_string = 'pointer for array "' // TRIM( name ) // &2559 message_string = 'pointer for array "' // TRIM( name ) // & 2531 2560 '" can''t be associated' 2532 2561 CALL message( 'pmci_set_array_pointer', 'PA0117', 3, 2, 0, 6, 0 ) … … 2545 2574 2546 2575 2547 SUBROUTINE pmci_create_c lient_arrays( name, is, ie, js, je, nzc )2576 SUBROUTINE pmci_create_child_arrays( name, is, ie, js, je, nzc ) 2548 2577 2549 2578 IMPLICIT NONE … … 2599 2628 ELSE 2600 2629 ! 2601 !-- Give only one message for the first c lientdomain2630 !-- Give only one message for the first child domain 2602 2631 IF ( myid == 0 .AND. cpl_id == 2 ) THEN 2603 2632 2604 message_string = 'pointer for array "' // TRIM( name ) // &2633 message_string = 'pointer for array "' // TRIM( name ) // & 2605 2634 '" can''t be associated' 2606 CALL message( 'pmci_create_c lient_arrays', 'PA0170', 3, 2, 0, 6, 0 )2635 CALL message( 'pmci_create_child_arrays', 'PA0170', 3, 2, 0, 6, 0 ) 2607 2636 ELSE 2608 2637 ! … … 2613 2642 2614 2643 #endif 2615 END SUBROUTINE pmci_create_client_arrays 2616 2617 2618 2619 SUBROUTINE pmci_server_initialize 2620 !-- TO_DO: add general explanations about what this subroutine does 2644 END SUBROUTINE pmci_create_child_arrays 2645 2646 2647 2648 SUBROUTINE pmci_parent_initialize 2649 2650 ! 2651 !-- Send data for the children in order to let them create initial 2652 !-- conditions by interpolating the parent-domain fields. 2621 2653 #if defined( __parallel ) 2622 2654 IMPLICIT NONE 2623 2655 2624 INTEGER(iwp) :: c lient_id!:2656 INTEGER(iwp) :: child_id !: 2625 2657 INTEGER(iwp) :: m !: 2626 2658 2627 REAL(wp) :: waittime !:2628 2629 2630 DO m = 1, SIZE( pmc_ server_for_client) - 12631 c lient_id = pmc_server_for_client(m)2632 CALL pmc_s_fillbuffer( c lient_id, waittime=waittime )2659 REAL(wp) :: waittime !: 2660 2661 2662 DO m = 1, SIZE( pmc_parent_for_child ) - 1 2663 child_id = pmc_parent_for_child(m) 2664 CALL pmc_s_fillbuffer( child_id, waittime=waittime ) 2633 2665 ENDDO 2634 2666 2635 2667 #endif 2636 END SUBROUTINE pmci_server_initialize 2637 2638 2639 2640 SUBROUTINE pmci_client_initialize 2641 !-- TO_DO: add general explanations about what this subroutine does 2668 END SUBROUTINE pmci_parent_initialize 2669 2670 2671 2672 SUBROUTINE pmci_child_initialize 2673 2674 ! 2675 !-- Create initial conditions for the current child domain by interpolating 2676 !-- the parent-domain fields. 2642 2677 #if defined( __parallel ) 2643 2678 IMPLICIT NONE … … 2650 2685 INTEGER(iwp) :: jcs !: 2651 2686 2652 REAL(wp) :: waittime !:2653 2654 ! 2655 !-- Root id is never a c lient2687 REAL(wp) :: waittime !: 2688 2689 ! 2690 !-- Root id is never a child 2656 2691 IF ( cpl_id > 1 ) THEN 2657 2692 2658 2693 ! 2659 !-- C lient domain boundaries in the serverindex space2694 !-- Child domain boundaries in the parent index space 2660 2695 icl = coarse_bound(1) 2661 2696 icr = coarse_bound(2) … … 2664 2699 2665 2700 ! 2666 !-- Get data from server2701 !-- Get data from the parent 2667 2702 CALL pmc_c_getbuffer( waittime = waittime ) 2668 2703 2669 2704 ! 2670 2705 !-- The interpolation. 2671 CALL pmci_interp_tril_all ( u, uc, icu, jco, kco, r1xu, r2xu, r1yo, &2706 CALL pmci_interp_tril_all ( u, uc, icu, jco, kco, r1xu, r2xu, r1yo, & 2672 2707 r2yo, r1zo, r2zo, nzb_u_inner, 'u' ) 2673 CALL pmci_interp_tril_all ( v, vc, ico, jcv, kco, r1xo, r2xo, r1yv, &2708 CALL pmci_interp_tril_all ( v, vc, ico, jcv, kco, r1xo, r2xo, r1yv, & 2674 2709 r2yv, r1zo, r2zo, nzb_v_inner, 'v' ) 2675 CALL pmci_interp_tril_all ( w, wc, ico, jco, kcw, r1xo, r2xo, r1yo, &2710 CALL pmci_interp_tril_all ( w, wc, ico, jco, kcw, r1xo, r2xo, r1yo, & 2676 2711 r2yo, r1zw, r2zw, nzb_w_inner, 'w' ) 2677 CALL pmci_interp_tril_all ( e, ec, ico, jco, kco, r1xo, r2xo, r1yo, &2712 CALL pmci_interp_tril_all ( e, ec, ico, jco, kco, r1xo, r2xo, r1yo, & 2678 2713 r2yo, r1zo, r2zo, nzb_s_inner, 'e' ) 2679 2714 IF ( .NOT. neutral ) THEN 2680 CALL pmci_interp_tril_all ( pt, ptc, ico, jco, kco, r1xo, r2xo, &2715 CALL pmci_interp_tril_all ( pt, ptc, ico, jco, kco, r1xo, r2xo, & 2681 2716 r1yo, r2yo, r1zo, r2zo, nzb_s_inner, 's' ) 2682 2717 ENDIF 2683 2718 IF ( humidity .OR. passive_scalar ) THEN 2684 CALL pmci_interp_tril_all ( q, qc, ico, jco, kco, r1xo, r2xo, r1yo, &2719 CALL pmci_interp_tril_all ( q, qc, ico, jco, kco, r1xo, r2xo, r1yo, & 2685 2720 r2yo, r1zo, r2zo, nzb_s_inner, 's' ) 2686 2721 ENDIF … … 2710 2745 2711 2746 2712 SUBROUTINE pmci_interp_tril_all( f, fc, ic, jc, kc, r1x, r2x, r1y, r2y, &2747 SUBROUTINE pmci_interp_tril_all( f, fc, ic, jc, kc, r1x, r2x, r1y, r2y, & 2713 2748 r1z, r2z, kb, var ) 2714 2749 ! 2715 !-- Interpolation of the internal values for the c lient-domain initialization2750 !-- Interpolation of the internal values for the child-domain initialization 2716 2751 !-- This subroutine is based on trilinear interpolation. 2717 2752 !-- Coding based on interp_tril_lr/sn/t … … 2739 2774 2740 2775 REAL(wp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg), INTENT(INOUT) :: f !: 2741 REAL(wp), DIMENSION(0:cg%nz+1,jcs:jcn,icl:icr), INTENT(IN) :: fc !:2776 REAL(wp), DIMENSION(0:cg%nz+1,jcs:jcn,icl:icr), INTENT(IN) :: fc !: 2742 2777 REAL(wp), DIMENSION(nxlg:nxrg), INTENT(IN) :: r1x !: 2743 2778 REAL(wp), DIMENSION(nxlg:nxrg), INTENT(IN) :: r2x !: … … 2762 2797 jb = nys 2763 2798 je = nyn 2764 IF ( nest_bound_l ) THEN 2765 ib = nxl - 1 2766 ! 2767 !-- For u, nxl is a ghost node, but not for the other variables 2768 IF ( var == 'u' ) THEN 2769 ib = nxl 2799 IF ( nesting_mode /= 'vertical' ) THEN 2800 IF ( nest_bound_l ) THEN 2801 ib = nxl - 1 2802 ! 2803 !-- For u, nxl is a ghost node, but not for the other variables 2804 IF ( var == 'u' ) THEN 2805 ib = nxl 2806 ENDIF 2770 2807 ENDIF 2771 ENDIF2772 IF ( nest_bound_s ) THEN2773 jb = nys - 1 2774 ! 2775 !-- For v, nys is a ghost node, but not for the other variables 2776 IF ( var == 'v' ) THEN2777 jb = nys2808 IF ( nest_bound_s ) THEN 2809 jb = nys - 1 2810 ! 2811 !-- For v, nys is a ghost node, but not for the other variables 2812 IF ( var == 'v' ) THEN 2813 jb = nys 2814 ENDIF 2778 2815 ENDIF 2779 ENDIF 2780 IF ( nest_bound_r ) THEN 2781 ie = nxr + 1 2782 ENDIF 2783 IF ( nest_bound_n ) THEN 2784 je = nyn + 1 2785 ENDIF 2786 2816 IF ( nest_bound_r ) THEN 2817 ie = nxr + 1 2818 ENDIF 2819 IF ( nest_bound_n ) THEN 2820 je = nyn + 1 2821 ENDIF 2822 ENDIF 2787 2823 ! 2788 2824 !-- Trilinear interpolation. … … 2828 2864 k = kb(j,i) + 1 2829 2865 DO WHILE ( zu(k) < zuc1 ) 2830 logratio = ( LOG( ( zu(k) - zu(kb(j,i)) ) / z0(j,i)) ) / logzuc1 2866 logratio = ( LOG( ( zu(k) - zu(kb(j,i)) ) / z0(j,i)) ) / & 2867 logzuc1 2831 2868 f(k,j,i) = logratio * f(k1,j,i) 2832 2869 k = k + 1 … … 2849 2886 2850 2887 #endif 2851 END SUBROUTINE pmci_c lient_initialize2888 END SUBROUTINE pmci_child_initialize 2852 2889 2853 2890 … … 2855 2892 SUBROUTINE pmci_check_setting_mismatches 2856 2893 ! 2857 !-- Check for mismatches between settings of master and c lientvariables2858 !-- (e.g., all c lientshave to follow the end_time settings of the root model).2894 !-- Check for mismatches between settings of master and child variables 2895 !-- (e.g., all children have to follow the end_time settings of the root model). 2859 2896 !-- The root model overwrites variables in the other models, so these variables 2860 2897 !-- only need to be set once in file PARIN. … … 2862 2899 #if defined( __parallel ) 2863 2900 2864 USE control_parameters, &2901 USE control_parameters, & 2865 2902 ONLY: dt_restart, end_time, message_string, restart_time, time_restart 2866 2903 … … 2884 2921 IF ( .NOT. pmc_is_rootmodel() ) THEN 2885 2922 IF ( end_time /= end_time_root ) THEN 2886 WRITE( message_string, * ) 'mismatch between root model and ', &2887 'c lient settings & end_time(root) = ', end_time_root,&2888 ' & end_time(c lient) = ', end_time, ' & client value is set',&2923 WRITE( message_string, * ) 'mismatch between root model and ', & 2924 'child settings & end_time(root) = ', end_time_root, & 2925 ' & end_time(child) = ', end_time, ' & child value is set', & 2889 2926 ' to root value' 2890 CALL message( 'pmci_check_setting_mismatches', 'PA0419', 0, 1, 0, 6, &2927 CALL message( 'pmci_check_setting_mismatches', 'PA0419', 0, 1, 0, 6, & 2891 2928 0 ) 2892 2929 end_time = end_time_root … … 2901 2938 IF ( .NOT. pmc_is_rootmodel() ) THEN 2902 2939 IF ( restart_time /= restart_time_root ) THEN 2903 WRITE( message_string, * ) 'mismatch between root model and ', &2904 'c lient settings & restart_time(root) = ', restart_time_root,&2905 ' & restart_time(c lient) = ', restart_time, ' & client ',&2940 WRITE( message_string, * ) 'mismatch between root model and ', & 2941 'child settings & restart_time(root) = ', restart_time_root, & 2942 ' & restart_time(child) = ', restart_time, ' & child ', & 2906 2943 'value is set to root value' 2907 CALL message( 'pmci_check_setting_mismatches', 'PA0419', 0, 1, 0, 6, &2944 CALL message( 'pmci_check_setting_mismatches', 'PA0419', 0, 1, 0, 6, & 2908 2945 0 ) 2909 2946 restart_time = restart_time_root … … 2918 2955 IF ( .NOT. pmc_is_rootmodel() ) THEN 2919 2956 IF ( dt_restart /= dt_restart_root ) THEN 2920 WRITE( message_string, * ) 'mismatch between root model and ', &2921 'c lient settings & dt_restart(root) = ', dt_restart_root,&2922 ' & dt_restart(c lient) = ', dt_restart, ' & client ',&2957 WRITE( message_string, * ) 'mismatch between root model and ', & 2958 'child settings & dt_restart(root) = ', dt_restart_root, & 2959 ' & dt_restart(child) = ', dt_restart, ' & child ', & 2923 2960 'value is set to root value' 2924 CALL message( 'pmci_check_setting_mismatches', 'PA0419', 0, 1, 0, 6, &2961 CALL message( 'pmci_check_setting_mismatches', 'PA0419', 0, 1, 0, 6, & 2925 2962 0 ) 2926 2963 dt_restart = dt_restart_root … … 2935 2972 IF ( .NOT. pmc_is_rootmodel() ) THEN 2936 2973 IF ( time_restart /= time_restart_root ) THEN 2937 WRITE( message_string, * ) 'mismatch between root model and ', &2938 'c lient settings & time_restart(root) = ', time_restart_root,&2939 ' & time_restart(c lient) = ', time_restart, ' & client ',&2974 WRITE( message_string, * ) 'mismatch between root model and ', & 2975 'child settings & time_restart(root) = ', time_restart_root, & 2976 ' & time_restart(child) = ', time_restart, ' & child ', & 2940 2977 'value is set to root value' 2941 CALL message( 'pmci_check_setting_mismatches', 'PA0419', 0, 1, 0, 6, &2978 CALL message( 'pmci_check_setting_mismatches', 'PA0419', 0, 1, 0, 6, & 2942 2979 0 ) 2943 2980 time_restart = time_restart_root … … 2953 2990 SUBROUTINE pmci_ensure_nest_mass_conservation 2954 2991 2955 #if defined( __parallel )2956 2992 ! 2957 2993 !-- Adjust the volume-flow rate through the top boundary so that the net volume … … 2959 2995 IMPLICIT NONE 2960 2996 2961 INTEGER(iwp) :: i !:2962 INTEGER(iwp) :: ierr !:2963 INTEGER(iwp) :: j !:2964 INTEGER(iwp) :: k !:2997 INTEGER(iwp) :: i !: 2998 INTEGER(iwp) :: ierr !: 2999 INTEGER(iwp) :: j !: 3000 INTEGER(iwp) :: k !: 2965 3001 2966 3002 REAL(wp) :: dxdy !: … … 2996 3032 #if defined( __parallel ) 2997 3033 IF ( collective_wait ) CALL MPI_BARRIER( comm2d, ierr ) 2998 CALL MPI_ALLREDUCE( volume_flow_l(1), volume_flow(1), 1, MPI_REAL, &3034 CALL MPI_ALLREDUCE( volume_flow_l(1), volume_flow(1), 1, MPI_REAL, & 2999 3035 MPI_SUM, comm2d, ierr ) 3000 3036 #else … … 3029 3065 #if defined( __parallel ) 3030 3066 IF ( collective_wait ) CALL MPI_BARRIER( comm2d, ierr ) 3031 CALL MPI_ALLREDUCE( volume_flow_l(2), volume_flow(2), 1, MPI_REAL, &3067 CALL MPI_ALLREDUCE( volume_flow_l(2), volume_flow(2), 1, MPI_REAL, & 3032 3068 MPI_SUM, comm2d, ierr ) 3033 3069 #else … … 3049 3085 #if defined( __parallel ) 3050 3086 IF ( collective_wait ) CALL MPI_BARRIER( comm2d, ierr ) 3051 CALL MPI_ALLREDUCE( volume_flow_l(3), volume_flow(3), 1, MPI_REAL, &3087 CALL MPI_ALLREDUCE( volume_flow_l(3), volume_flow(3), 1, MPI_REAL, & 3052 3088 MPI_SUM, comm2d, ierr ) 3053 3089 #else … … 3066 3102 ENDDO 3067 3103 3068 #endif3069 3104 END SUBROUTINE pmci_ensure_nest_mass_conservation 3070 3105 … … 3101 3136 IMPLICIT NONE 3102 3137 3103 INTEGER(iwp), INTENT(IN) :: swaplevel !: swaplevel (1 or 2) of PALM's3104 !: timestep3105 3106 INTEGER(iwp) :: c lient_id!:3107 INTEGER(iwp) :: m !:3108 3109 DO m = 1, SIZE( pmc_ server_for_client)-13110 c lient_id = pmc_server_for_client(m)3111 CALL pmc_s_set_active_data_array( c lient_id, swaplevel )3138 INTEGER(iwp), INTENT(IN) :: swaplevel !: swaplevel (1 or 2) of PALM's 3139 !: timestep 3140 3141 INTEGER(iwp) :: child_id !: 3142 INTEGER(iwp) :: m !: 3143 3144 DO m = 1, SIZE( pmc_parent_for_child )-1 3145 child_id = pmc_parent_for_child(m) 3146 CALL pmc_s_set_active_data_array( child_id, swaplevel ) 3112 3147 ENDDO 3113 3148 … … 3131 3166 INTEGER(iwp) :: istat !: 3132 3167 3133 CHARACTER(LEN=*), INTENT(IN) :: local_nesting_mode3134 3135 IF ( local_nesting_mode== 'one-way' ) THEN3136 3137 CALL pmci_c lient_datatrans( server_to_client)3138 CALL pmci_ server_datatrans( server_to_client)3168 CHARACTER(LEN=*), INTENT(IN) :: local_nesting_mode 3169 3170 IF ( TRIM( local_nesting_mode ) == 'one-way' ) THEN 3171 3172 CALL pmci_child_datatrans( parent_to_child ) 3173 CALL pmci_parent_datatrans( parent_to_child ) 3139 3174 3140 3175 ELSE 3141 3176 3142 IF 3143 3144 CALL pmci_c lient_datatrans( server_to_client)3145 CALL pmci_ server_datatrans( server_to_client)3146 3147 CALL pmci_ server_datatrans( client_to_server)3148 CALL pmci_c lient_datatrans( client_to_server)3149 3150 ELSEIF ( nesting_datatransfer_mode == 'overlap') THEN3151 3152 CALL pmci_ server_datatrans( server_to_client)3153 CALL pmci_c lient_datatrans( server_to_client)3154 3155 CALL pmci_c lient_datatrans( client_to_server)3156 CALL pmci_ server_datatrans( client_to_server)3157 3158 ELSEIF 3159 3160 CALL pmci_ server_datatrans( server_to_client)3161 CALL pmci_c lient_datatrans( server_to_client)3162 3163 CALL pmci_ server_datatrans( client_to_server)3164 CALL pmci_c lient_datatrans( client_to_server)3177 IF( nesting_datatransfer_mode == 'cascade' ) THEN 3178 3179 CALL pmci_child_datatrans( parent_to_child ) 3180 CALL pmci_parent_datatrans( parent_to_child ) 3181 3182 CALL pmci_parent_datatrans( child_to_parent ) 3183 CALL pmci_child_datatrans( child_to_parent ) 3184 3185 ELSEIF( nesting_datatransfer_mode == 'overlap') THEN 3186 3187 CALL pmci_parent_datatrans( parent_to_child ) 3188 CALL pmci_child_datatrans( parent_to_child ) 3189 3190 CALL pmci_child_datatrans( child_to_parent ) 3191 CALL pmci_parent_datatrans( child_to_parent ) 3192 3193 ELSEIF( TRIM( nesting_datatransfer_mode ) == 'mixed' ) THEN 3194 3195 CALL pmci_parent_datatrans( parent_to_child ) 3196 CALL pmci_child_datatrans( parent_to_child ) 3197 3198 CALL pmci_parent_datatrans( child_to_parent ) 3199 CALL pmci_child_datatrans( child_to_parent ) 3165 3200 3166 3201 ENDIF … … 3173 3208 3174 3209 3175 SUBROUTINE pmci_ server_datatrans( direction )3210 SUBROUTINE pmci_parent_datatrans( direction ) 3176 3211 3177 3212 IMPLICIT NONE 3178 3213 3179 INTEGER(iwp), INTENT(IN) :: direction !:3214 INTEGER(iwp), INTENT(IN) :: direction !: 3180 3215 3181 3216 #if defined( __parallel ) 3182 INTEGER(iwp) :: c lient_id!:3217 INTEGER(iwp) :: child_id !: 3183 3218 INTEGER(iwp) :: i !: 3184 3219 INTEGER(iwp) :: j !: … … 3191 3226 3192 3227 3193 DO m = 1, SIZE( PMC_Server_for_Client )-13194 c lient_id = PMC_Server_for_Client(m)3228 DO m = 1, SIZE( pmc_parent_for_child ) - 1 3229 child_id = pmc_parent_for_child(m) 3195 3230 3196 IF ( direction == server_to_client) THEN3197 CALL cpu_log( log_point_s(71), 'pmc serversend', 'start' )3198 CALL pmc_s_fillbuffer( c lient_id )3199 CALL cpu_log( log_point_s(71), 'pmc serversend', 'stop' )3231 IF ( direction == parent_to_child ) THEN 3232 CALL cpu_log( log_point_s(71), 'pmc parent send', 'start' ) 3233 CALL pmc_s_fillbuffer( child_id ) 3234 CALL cpu_log( log_point_s(71), 'pmc parent send', 'stop' ) 3200 3235 ELSE 3201 3236 ! 3202 !-- Communication from c lient to server3203 CALL cpu_log( log_point_s(72), 'pmc serverrecv', 'start' )3204 c lient_id = pmc_server_for_client(m)3205 CALL pmc_s_getdata_from_buffer( c lient_id )3206 CALL cpu_log( log_point_s(72), 'pmc serverrecv', 'stop' )3237 !-- Communication from child to parent 3238 CALL cpu_log( log_point_s(72), 'pmc parent recv', 'start' ) 3239 child_id = pmc_parent_for_child(m) 3240 CALL pmc_s_getdata_from_buffer( child_id ) 3241 CALL cpu_log( log_point_s(72), 'pmc parent recv', 'stop' ) 3207 3242 3208 3243 ! … … 3234 3269 3235 3270 #endif 3236 END SUBROUTINE pmci_ server_datatrans3237 3238 3239 3240 SUBROUTINE pmci_c lient_datatrans( direction )3271 END SUBROUTINE pmci_parent_datatrans 3272 3273 3274 3275 SUBROUTINE pmci_child_datatrans( direction ) 3241 3276 3242 3277 IMPLICIT NONE … … 3258 3293 IF ( cpl_id > 1 ) THEN 3259 3294 ! 3260 !-- C lient domain boundaries in the serverindice space.3295 !-- Child domain boundaries in the parent indice space. 3261 3296 icl = coarse_bound(1) 3262 3297 icr = coarse_bound(2) … … 3264 3299 jcn = coarse_bound(4) 3265 3300 3266 IF ( direction == server_to_client) THEN3267 3268 CALL cpu_log( log_point_s(73), 'pmc c lientrecv', 'start' )3301 IF ( direction == parent_to_child ) THEN 3302 3303 CALL cpu_log( log_point_s(73), 'pmc child recv', 'start' ) 3269 3304 CALL pmc_c_getbuffer( ) 3270 CALL cpu_log( log_point_s(73), 'pmc c lientrecv', 'stop' )3305 CALL cpu_log( log_point_s(73), 'pmc child recv', 'stop' ) 3271 3306 3272 3307 CALL cpu_log( log_point_s(75), 'pmc interpolation', 'start' ) … … 3276 3311 ELSE 3277 3312 ! 3278 !-- direction == c lient_to_server3313 !-- direction == child_to_parent 3279 3314 CALL cpu_log( log_point_s(76), 'pmc anterpolation', 'start' ) 3280 3315 CALL pmci_anterpolation 3281 3316 CALL cpu_log( log_point_s(76), 'pmc anterpolation', 'stop' ) 3282 3317 3283 CALL cpu_log( log_point_s(74), 'pmc c lientsend', 'start' )3318 CALL cpu_log( log_point_s(74), 'pmc child send', 'start' ) 3284 3319 CALL pmc_c_putbuffer( ) 3285 CALL cpu_log( log_point_s(74), 'pmc c lientsend', 'stop' )3320 CALL cpu_log( log_point_s(74), 'pmc child send', 'stop' ) 3286 3321 3287 3322 ENDIF … … 3297 3332 3298 3333 ! 3299 !-- Add IF-condition here: IF not vertical nesting 3334 !-- In case of vertical nesting no interpolation is needed for the 3335 !-- horizontal boundaries 3336 IF ( nesting_mode /= 'vertical' ) THEN 3337 3338 ! 3300 3339 !-- Left border pe: 3301 IF ( nest_bound_l ) THEN 3302 CALL pmci_interp_tril_lr( u, uc, icu, jco, kco, r1xu, r2xu, r1yo, & 3303 r2yo, r1zo, r2zo, nzb_u_inner, logc_u_l, & 3304 logc_ratio_u_l, nzt_topo_nestbc_l, 'l', & 3305 'u' ) 3306 CALL pmci_interp_tril_lr( v, vc, ico, jcv, kco, r1xo, r2xo, r1yv, & 3307 r2yv, r1zo, r2zo, nzb_v_inner, logc_v_l, & 3308 logc_ratio_v_l, nzt_topo_nestbc_l, 'l', & 3309 'v' ) 3310 CALL pmci_interp_tril_lr( w, wc, ico, jco, kcw, r1xo, r2xo, r1yo, & 3311 r2yo, r1zw, r2zw, nzb_w_inner, logc_w_l, & 3312 logc_ratio_w_l, nzt_topo_nestbc_l, 'l', & 3313 'w' ) 3314 CALL pmci_interp_tril_lr( e, ec, ico, jco, kco, r1xo, r2xo, r1yo, & 3315 r2yo, r1zo, r2zo, nzb_s_inner, logc_u_l, & 3316 logc_ratio_u_l, nzt_topo_nestbc_l, 'l', & 3317 'e' ) 3318 IF ( .NOT. neutral ) THEN 3319 CALL pmci_interp_tril_lr( pt, ptc, ico, jco, kco, r1xo, r2xo, & 3320 r1yo, r2yo, r1zo, r2zo, nzb_s_inner, & 3321 logc_u_l, logc_ratio_u_l, & 3322 nzt_topo_nestbc_l, 'l', 's' ) 3323 ENDIF 3324 IF ( humidity .OR. passive_scalar ) THEN 3325 CALL pmci_interp_tril_lr( q, qc, ico, jco, kco, r1xo, r2xo, r1yo, & 3326 r2yo, r1zo, r2zo, nzb_s_inner, & 3327 logc_u_l, logc_ratio_u_l, & 3328 nzt_topo_nestbc_l, 'l', 's' ) 3329 ENDIF 3330 3331 IF ( nesting_mode == 'one-way' ) THEN 3332 CALL pmci_extrap_ifoutflow_lr( u, nzb_u_inner, 'l', 'u' ) 3333 CALL pmci_extrap_ifoutflow_lr( v, nzb_v_inner, 'l', 'v' ) 3334 CALL pmci_extrap_ifoutflow_lr( w, nzb_w_inner, 'l', 'w' ) 3335 CALL pmci_extrap_ifoutflow_lr( e, nzb_s_inner, 'l', 'e' ) 3340 IF ( nest_bound_l ) THEN 3341 CALL pmci_interp_tril_lr( u, uc, icu, jco, kco, r1xu, r2xu, & 3342 r1yo, r2yo, r1zo, r2zo, nzb_u_inner, & 3343 logc_u_l, logc_ratio_u_l, & 3344 nzt_topo_nestbc_l, 'l', 'u' ) 3345 CALL pmci_interp_tril_lr( v, vc, ico, jcv, kco, r1xo, r2xo, & 3346 r1yv, r2yv, r1zo, r2zo, nzb_v_inner, & 3347 logc_v_l, logc_ratio_v_l, & 3348 nzt_topo_nestbc_l, 'l', 'v' ) 3349 CALL pmci_interp_tril_lr( w, wc, ico, jco, kcw, r1xo, r2xo, & 3350 r1yo, r2yo, r1zw, r2zw, nzb_w_inner, & 3351 logc_w_l, logc_ratio_w_l, & 3352 nzt_topo_nestbc_l, 'l', 'w' ) 3353 CALL pmci_interp_tril_lr( e, ec, ico, jco, kco, r1xo, r2xo, & 3354 r1yo, r2yo, r1zo, r2zo, nzb_s_inner, & 3355 logc_u_l, logc_ratio_u_l, & 3356 nzt_topo_nestbc_l, 'l', 'e' ) 3336 3357 IF ( .NOT. neutral ) THEN 3337 CALL pmci_extrap_ifoutflow_lr( pt,nzb_s_inner, 'l', 's' ) 3358 CALL pmci_interp_tril_lr( pt, ptc, ico, jco, kco, r1xo, r2xo, & 3359 r1yo, r2yo, r1zo, r2zo, nzb_s_inner, & 3360 logc_u_l, logc_ratio_u_l, & 3361 nzt_topo_nestbc_l, 'l', 's' ) 3338 3362 ENDIF 3339 3363 IF ( humidity .OR. passive_scalar ) THEN 3340 CALL pmci_extrap_ifoutflow_lr( q, nzb_s_inner, 'l', 's' ) 3364 CALL pmci_interp_tril_lr( q, qc, ico, jco, kco, r1xo, r2xo, & 3365 r1yo, r2yo, r1zo, r2zo, nzb_s_inner, & 3366 logc_u_l, logc_ratio_u_l, & 3367 nzt_topo_nestbc_l, 'l', 's' ) 3341 3368 ENDIF 3369 3370 IF ( TRIM( nesting_mode ) == 'one-way' ) THEN 3371 CALL pmci_extrap_ifoutflow_lr( u, nzb_u_inner, 'l', 'u' ) 3372 CALL pmci_extrap_ifoutflow_lr( v, nzb_v_inner, 'l', 'v' ) 3373 CALL pmci_extrap_ifoutflow_lr( w, nzb_w_inner, 'l', 'w' ) 3374 CALL pmci_extrap_ifoutflow_lr( e, nzb_s_inner, 'l', 'e' ) 3375 IF ( .NOT. neutral ) THEN 3376 CALL pmci_extrap_ifoutflow_lr( pt,nzb_s_inner, 'l', 's' ) 3377 ENDIF 3378 IF ( humidity .OR. passive_scalar ) THEN 3379 CALL pmci_extrap_ifoutflow_lr( q, nzb_s_inner, 'l', 's' ) 3380 ENDIF 3381 ENDIF 3382 3342 3383 ENDIF 3343 3384 3344 ENDIF 3345 ! 3346 !-- Right border pe 3347 IF ( nest_bound_r ) THEN 3348 CALL pmci_interp_tril_lr( u, uc, icu, jco, kco, r1xu, r2xu, r1yo, & 3349 r2yo, r1zo, r2zo, nzb_u_inner, logc_u_r, & 3350 logc_ratio_u_r, nzt_topo_nestbc_r, 'r', & 3351 'u' ) 3352 CALL pmci_interp_tril_lr( v, vc, ico, jcv, kco, r1xo, r2xo, r1yv, & 3353 r2yv, r1zo, r2zo, nzb_v_inner, logc_v_r, & 3354 logc_ratio_v_r, nzt_topo_nestbc_r, 'r', & 3355 'v' ) 3356 CALL pmci_interp_tril_lr( w, wc, ico, jco, kcw, r1xo, r2xo, r1yo, & 3357 r2yo, r1zw, r2zw, nzb_w_inner, logc_w_r, & 3358 logc_ratio_w_r, nzt_topo_nestbc_r, 'r', & 3359 'w' ) 3360 CALL pmci_interp_tril_lr( e, ec, ico, jco, kco, r1xo, r2xo, r1yo, & 3361 r2yo, r1zo, r2zo, nzb_s_inner, logc_u_r, & 3362 logc_ratio_u_r, nzt_topo_nestbc_r, 'r', & 3363 'e' ) 3364 IF ( .NOT. neutral ) THEN 3365 CALL pmci_interp_tril_lr( pt, ptc, ico, jco, kco, r1xo, r2xo, & 3366 r1yo, r2yo, r1zo, r2zo, nzb_s_inner, & 3367 logc_u_r, logc_ratio_u_r, & 3368 nzt_topo_nestbc_r, 'r', 's' ) 3369 ENDIF 3370 IF ( humidity .OR. passive_scalar ) THEN 3371 CALL pmci_interp_tril_lr( q, qc, ico, jco, kco, r1xo, r2xo, r1yo, & 3372 r2yo, r1zo, r2zo, nzb_s_inner, & 3373 logc_u_r, logc_ratio_u_r, & 3374 nzt_topo_nestbc_r, 'r', 's' ) 3375 ENDIF 3376 3377 IF ( nesting_mode == 'one-way' ) THEN 3378 CALL pmci_extrap_ifoutflow_lr( u, nzb_u_inner, 'r', 'u' ) 3379 CALL pmci_extrap_ifoutflow_lr( v, nzb_v_inner, 'r', 'v' ) 3380 CALL pmci_extrap_ifoutflow_lr( w, nzb_w_inner, 'r', 'w' ) 3381 CALL pmci_extrap_ifoutflow_lr( e, nzb_s_inner, 'r', 'e' ) 3385 ! 3386 !-- Right border pe 3387 IF ( nest_bound_r ) THEN 3388 CALL pmci_interp_tril_lr( u, uc, icu, jco, kco, r1xu, r2xu, & 3389 r1yo, r2yo, r1zo, r2zo, nzb_u_inner, & 3390 logc_u_r, logc_ratio_u_r, & 3391 nzt_topo_nestbc_r, 'r', 'u' ) 3392 CALL pmci_interp_tril_lr( v, vc, ico, jcv, kco, r1xo, r2xo, & 3393 r1yv, r2yv, r1zo, r2zo, nzb_v_inner, & 3394 logc_v_r, logc_ratio_v_r, & 3395 nzt_topo_nestbc_r, 'r', 'v' ) 3396 CALL pmci_interp_tril_lr( w, wc, ico, jco, kcw, r1xo, r2xo, & 3397 r1yo, r2yo, r1zw, r2zw, nzb_w_inner, & 3398 logc_w_r, logc_ratio_w_r, & 3399 nzt_topo_nestbc_r, 'r', 'w' ) 3400 CALL pmci_interp_tril_lr( e, ec, ico, jco, kco, r1xo, r2xo, & 3401 r1yo,r2yo, r1zo, r2zo, nzb_s_inner, & 3402 logc_u_r, logc_ratio_u_r, & 3403 nzt_topo_nestbc_r, 'r', 'e' ) 3382 3404 IF ( .NOT. neutral ) THEN 3383 CALL pmci_extrap_ifoutflow_lr( pt,nzb_s_inner, 'r', 's' ) 3405 CALL pmci_interp_tril_lr( pt, ptc, ico, jco, kco, r1xo, r2xo, & 3406 r1yo, r2yo, r1zo, r2zo, nzb_s_inner, & 3407 logc_u_r, logc_ratio_u_r, & 3408 nzt_topo_nestbc_r, 'r', 's' ) 3384 3409 ENDIF 3385 3410 IF ( humidity .OR. passive_scalar ) THEN 3386 CALL pmci_extrap_ifoutflow_lr( q, nzb_s_inner, 'r', 's' ) 3411 CALL pmci_interp_tril_lr( q, qc, ico, jco, kco, r1xo, r2xo, & 3412 r1yo, r2yo, r1zo, r2zo, nzb_s_inner, & 3413 logc_u_r, logc_ratio_u_r, & 3414 nzt_topo_nestbc_r, 'r', 's' ) 3387 3415 ENDIF 3416 3417 IF ( TRIM( nesting_mode ) == 'one-way' ) THEN 3418 CALL pmci_extrap_ifoutflow_lr( u, nzb_u_inner, 'r', 'u' ) 3419 CALL pmci_extrap_ifoutflow_lr( v, nzb_v_inner, 'r', 'v' ) 3420 CALL pmci_extrap_ifoutflow_lr( w, nzb_w_inner, 'r', 'w' ) 3421 CALL pmci_extrap_ifoutflow_lr( e, nzb_s_inner, 'r', 'e' ) 3422 IF ( .NOT. neutral ) THEN 3423 CALL pmci_extrap_ifoutflow_lr( pt,nzb_s_inner, 'r', 's' ) 3424 ENDIF 3425 IF ( humidity .OR. passive_scalar ) THEN 3426 CALL pmci_extrap_ifoutflow_lr( q, nzb_s_inner, 'r', 's' ) 3427 ENDIF 3428 ENDIF 3429 3388 3430 ENDIF 3389 3431 3390 ENDIF 3391 ! 3392 !-- South border pe 3393 IF ( nest_bound_s ) THEN 3394 CALL pmci_interp_tril_sn( u, uc, icu, jco, kco, r1xu, r2xu, r1yo, & 3395 r2yo, r1zo, r2zo, nzb_u_inner, logc_u_s, & 3396 logc_ratio_u_s, nzt_topo_nestbc_s, 's', & 3397 'u' ) 3398 CALL pmci_interp_tril_sn( v, vc, ico, jcv, kco, r1xo, r2xo, r1yv, & 3399 r2yv, r1zo, r2zo, nzb_v_inner, logc_v_s, & 3400 logc_ratio_v_s, nzt_topo_nestbc_s, 's', & 3401 'v' ) 3402 CALL pmci_interp_tril_sn( w, wc, ico, jco, kcw, r1xo, r2xo, r1yo, & 3403 r2yo, r1zw, r2zw, nzb_w_inner, logc_w_s, & 3404 logc_ratio_w_s, nzt_topo_nestbc_s, 's', & 3405 'w' ) 3406 CALL pmci_interp_tril_sn( e, ec, ico, jco, kco, r1xo, r2xo, r1yo, & 3407 r2yo, r1zo, r2zo, nzb_s_inner, logc_u_s, & 3408 logc_ratio_u_s, nzt_topo_nestbc_s, 's', & 3409 'e' ) 3410 IF ( .NOT. neutral ) THEN 3411 CALL pmci_interp_tril_sn( pt, ptc, ico, jco, kco, r1xo, r2xo, & 3412 r1yo, r2yo, r1zo, r2zo, nzb_s_inner, & 3413 logc_u_s, logc_ratio_u_s, & 3414 nzt_topo_nestbc_s, 's', 's' ) 3415 ENDIF 3416 IF ( humidity .OR. passive_scalar ) THEN 3417 CALL pmci_interp_tril_sn( q, qc, ico, jco, kco, r1xo, r2xo, r1yo, & 3418 r2yo, r1zo, r2zo, nzb_s_inner, & 3419 logc_u_s, logc_ratio_u_s, & 3420 nzt_topo_nestbc_s, 's', 's' ) 3421 ENDIF 3422 3423 IF ( nesting_mode == 'one-way' ) THEN 3424 CALL pmci_extrap_ifoutflow_sn( u, nzb_u_inner, 's', 'u' ) 3425 CALL pmci_extrap_ifoutflow_sn( v, nzb_v_inner, 's', 'v' ) 3426 CALL pmci_extrap_ifoutflow_sn( w, nzb_w_inner, 's', 'w' ) 3427 CALL pmci_extrap_ifoutflow_sn( e, nzb_s_inner, 's', 'e' ) 3432 ! 3433 !-- South border pe 3434 IF ( nest_bound_s ) THEN 3435 CALL pmci_interp_tril_sn( u, uc, icu, jco, kco, r1xu, r2xu, & 3436 r1yo, r2yo, r1zo, r2zo, nzb_u_inner, & 3437 logc_u_s, logc_ratio_u_s, & 3438 nzt_topo_nestbc_s, 's', 'u' ) 3439 CALL pmci_interp_tril_sn( v, vc, ico, jcv, kco, r1xo, r2xo, & 3440 r1yv, r2yv, r1zo, r2zo, nzb_v_inner, & 3441 logc_v_s, logc_ratio_v_s, & 3442 nzt_topo_nestbc_s, 's', 'v' ) 3443 CALL pmci_interp_tril_sn( w, wc, ico, jco, kcw, r1xo, r2xo, & 3444 r1yo, r2yo, r1zw, r2zw, nzb_w_inner, & 3445 logc_w_s, logc_ratio_w_s, & 3446 nzt_topo_nestbc_s, 's','w' ) 3447 CALL pmci_interp_tril_sn( e, ec, ico, jco, kco, r1xo, r2xo, & 3448 r1yo, r2yo, r1zo, r2zo, nzb_s_inner, & 3449 logc_u_s, logc_ratio_u_s, & 3450 nzt_topo_nestbc_s, 's', 'e' ) 3428 3451 IF ( .NOT. neutral ) THEN 3429 CALL pmci_extrap_ifoutflow_sn( pt,nzb_s_inner, 's', 's' ) 3452 CALL pmci_interp_tril_sn( pt, ptc, ico, jco, kco, r1xo, r2xo, & 3453 r1yo, r2yo, r1zo, r2zo, nzb_s_inner, & 3454 logc_u_s, logc_ratio_u_s, & 3455 nzt_topo_nestbc_s, 's', 's' ) 3430 3456 ENDIF 3431 3457 IF ( humidity .OR. passive_scalar ) THEN 3432 CALL pmci_extrap_ifoutflow_sn( q, nzb_s_inner, 's', 's' ) 3458 CALL pmci_interp_tril_sn( q, qc, ico, jco, kco, r1xo, r2xo, & 3459 r1yo,r2yo, r1zo, r2zo, nzb_s_inner, & 3460 logc_u_s, logc_ratio_u_s, & 3461 nzt_topo_nestbc_s, 's', 's' ) 3433 3462 ENDIF 3463 3464 IF ( TRIM( nesting_mode ) == 'one-way' ) THEN 3465 CALL pmci_extrap_ifoutflow_sn( u, nzb_u_inner, 's', 'u' ) 3466 CALL pmci_extrap_ifoutflow_sn( v, nzb_v_inner, 's', 'v' ) 3467 CALL pmci_extrap_ifoutflow_sn( w, nzb_w_inner, 's', 'w' ) 3468 CALL pmci_extrap_ifoutflow_sn( e, nzb_s_inner, 's', 'e' ) 3469 IF ( .NOT. neutral ) THEN 3470 CALL pmci_extrap_ifoutflow_sn( pt,nzb_s_inner, 's', 's' ) 3471 ENDIF 3472 IF ( humidity .OR. passive_scalar ) THEN 3473 CALL pmci_extrap_ifoutflow_sn( q, nzb_s_inner, 's', 's' ) 3474 ENDIF 3475 ENDIF 3476 3434 3477 ENDIF 3435 3478 3436 ENDIF 3437 ! 3438 !-- North border pe 3439 IF ( nest_bound_n ) THEN 3440 CALL pmci_interp_tril_sn( u, uc, icu, jco, kco, r1xu, r2xu, r1yo, & 3441 r2yo, r1zo, r2zo, nzb_u_inner, logc_u_n, & 3442 logc_ratio_u_n, nzt_topo_nestbc_n, 'n', & 3443 'u' ) 3444 CALL pmci_interp_tril_sn( v, vc, ico, jcv, kco, r1xo, r2xo, r1yv, & 3445 r2yv, r1zo, r2zo, nzb_v_inner, logc_v_n, & 3446 logc_ratio_v_n, nzt_topo_nestbc_n, 'n', & 3447 'v' ) 3448 CALL pmci_interp_tril_sn( w, wc, ico, jco, kcw, r1xo, r2xo, r1yo, & 3449 r2yo, r1zw, r2zw, nzb_w_inner, logc_w_n, & 3450 logc_ratio_w_n, nzt_topo_nestbc_n, 'n', & 3451 'w' ) 3452 CALL pmci_interp_tril_sn( e, ec, ico, jco, kco, r1xo, r2xo, r1yo, & 3453 r2yo, r1zo, r2zo, nzb_s_inner, logc_u_n, & 3454 logc_ratio_u_n, nzt_topo_nestbc_n, 'n', & 3455 'e' ) 3456 IF ( .NOT. neutral ) THEN 3457 CALL pmci_interp_tril_sn( pt, ptc, ico, jco, kco, r1xo, r2xo, & 3458 r1yo, r2yo, r1zo, r2zo, nzb_s_inner, & 3459 logc_u_n, logc_ratio_u_n, & 3460 nzt_topo_nestbc_n, 'n', 's' ) 3461 ENDIF 3462 IF ( humidity .OR. passive_scalar ) THEN 3463 CALL pmci_interp_tril_sn( q, qc, ico, jco, kco, r1xo, r2xo, r1yo, & 3464 r2yo, r1zo, r2zo, nzb_s_inner, & 3465 logc_u_n, logc_ratio_u_n, & 3466 nzt_topo_nestbc_n, 'n', 's' ) 3467 ENDIF 3468 3469 IF ( nesting_mode == 'one-way' ) THEN 3470 CALL pmci_extrap_ifoutflow_sn( u, nzb_u_inner, 'n', 'u' ) 3471 CALL pmci_extrap_ifoutflow_sn( v, nzb_v_inner, 'n', 'v' ) 3472 CALL pmci_extrap_ifoutflow_sn( w, nzb_w_inner, 'n', 'w' ) 3473 CALL pmci_extrap_ifoutflow_sn( e, nzb_s_inner, 'n', 'e' ) 3479 ! 3480 !-- North border pe 3481 IF ( nest_bound_n ) THEN 3482 CALL pmci_interp_tril_sn( u, uc, icu, jco, kco, r1xu, r2xu, & 3483 r1yo, r2yo, r1zo, r2zo, nzb_u_inner, & 3484 logc_u_n, logc_ratio_u_n, & 3485 nzt_topo_nestbc_n, 'n', 'u' ) 3486 CALL pmci_interp_tril_sn( v, vc, ico, jcv, kco, r1xo, r2xo, & 3487 r1yv, r2yv, r1zo, r2zo, nzb_v_inner, & 3488 logc_v_n, logc_ratio_v_n, & 3489 nzt_topo_nestbc_n, 'n', 'v' ) 3490 CALL pmci_interp_tril_sn( w, wc, ico, jco, kcw, r1xo, r2xo, & 3491 r1yo, r2yo, r1zw, r2zw, nzb_w_inner, & 3492 logc_w_n, logc_ratio_w_n, & 3493 nzt_topo_nestbc_n, 'n', 'w' ) 3494 CALL pmci_interp_tril_sn( e, ec, ico, jco, kco, r1xo, r2xo, & 3495 r1yo, r2yo, r1zo, r2zo, nzb_s_inner, & 3496 logc_u_n, logc_ratio_u_n, & 3497 nzt_topo_nestbc_n, 'n', 'e' ) 3474 3498 IF ( .NOT. neutral ) THEN 3475 CALL pmci_extrap_ifoutflow_sn( pt,nzb_s_inner, 'n', 's' ) 3499 CALL pmci_interp_tril_sn( pt, ptc, ico, jco, kco, r1xo, r2xo, & 3500 r1yo, r2yo, r1zo, r2zo, nzb_s_inner, & 3501 logc_u_n, logc_ratio_u_n, & 3502 nzt_topo_nestbc_n, 'n', 's' ) 3476 3503 ENDIF 3477 3504 IF ( humidity .OR. passive_scalar ) THEN 3478 CALL pmci_extrap_ifoutflow_sn( q, nzb_s_inner, 'n', 's' ) 3505 CALL pmci_interp_tril_sn( q, qc, ico, jco, kco, r1xo, r2xo, & 3506 r1yo, r2yo, r1zo, r2zo, nzb_s_inner, & 3507 logc_u_n, logc_ratio_u_n, & 3508 nzt_topo_nestbc_n, 'n', 's' ) 3479 3509 ENDIF 3480 3510 3511 IF ( TRIM( nesting_mode ) == 'one-way' ) THEN 3512 CALL pmci_extrap_ifoutflow_sn( u, nzb_u_inner, 'n', 'u' ) 3513 CALL pmci_extrap_ifoutflow_sn( v, nzb_v_inner, 'n', 'v' ) 3514 CALL pmci_extrap_ifoutflow_sn( w, nzb_w_inner, 'n', 'w' ) 3515 CALL pmci_extrap_ifoutflow_sn( e, nzb_s_inner, 'n', 'e' ) 3516 IF ( .NOT. neutral ) THEN 3517 CALL pmci_extrap_ifoutflow_sn( pt,nzb_s_inner, 'n', 's' ) 3518 ENDIF 3519 IF ( humidity .OR. passive_scalar ) THEN 3520 CALL pmci_extrap_ifoutflow_sn( q, nzb_s_inner, 'n', 's' ) 3521 ENDIF 3522 3523 ENDIF 3524 3481 3525 ENDIF 3482 3526 3483 ENDIF 3527 ENDIF !: IF ( nesting_mode /= 'vertical' ) 3484 3528 3485 3529 ! 3486 3530 !-- All PEs are top-border PEs 3487 CALL pmci_interp_tril_t( u, uc, icu, jco, kco, r1xu, r2xu, r1yo, &3531 CALL pmci_interp_tril_t( u, uc, icu, jco, kco, r1xu, r2xu, r1yo, & 3488 3532 r2yo, r1zo, r2zo, 'u' ) 3489 CALL pmci_interp_tril_t( v, vc, ico, jcv, kco, r1xo, r2xo, r1yv, &3533 CALL pmci_interp_tril_t( v, vc, ico, jcv, kco, r1xo, r2xo, r1yv, & 3490 3534 r2yv, r1zo, r2zo, 'v' ) 3491 CALL pmci_interp_tril_t( w, wc, ico, jco, kcw, r1xo, r2xo, r1yo, &3535 CALL pmci_interp_tril_t( w, wc, ico, jco, kcw, r1xo, r2xo, r1yo, & 3492 3536 r2yo, r1zw, r2zw, 'w' ) 3493 CALL pmci_interp_tril_t( e, ec, ico, jco, kco, r1xo, r2xo, r1yo, &3537 CALL pmci_interp_tril_t( e, ec, ico, jco, kco, r1xo, r2xo, r1yo, & 3494 3538 r2yo, r1zo, r2zo, 'e' ) 3495 3539 IF ( .NOT. neutral ) THEN 3496 CALL pmci_interp_tril_t( pt, ptc, ico, jco, kco, r1xo, r2xo, r1yo, &3540 CALL pmci_interp_tril_t( pt, ptc, ico, jco, kco, r1xo, r2xo, r1yo, & 3497 3541 r2yo, r1zo, r2zo, 's' ) 3498 3542 ENDIF 3499 3543 IF ( humidity .OR. passive_scalar ) THEN 3500 CALL pmci_interp_tril_t( q, qc, ico, jco, kco, r1xo, r2xo, r1yo, &3544 CALL pmci_interp_tril_t( q, qc, ico, jco, kco, r1xo, r2xo, r1yo, & 3501 3545 r2yo, r1zo, r2zo, 's' ) 3502 3546 ENDIF 3503 3547 3504 IF ( nesting_mode== 'one-way' ) THEN3548 IF ( TRIM( nesting_mode ) == 'one-way' ) THEN 3505 3549 CALL pmci_extrap_ifoutflow_t( u, 'u' ) 3506 3550 CALL pmci_extrap_ifoutflow_t( v, 'v' ) … … 3513 3557 CALL pmci_extrap_ifoutflow_t( q, 's' ) 3514 3558 ENDIF 3515 ENDIF3559 ENDIF 3516 3560 3517 3561 END SUBROUTINE pmci_interpolation … … 3526 3570 IMPLICIT NONE 3527 3571 3528 CALL pmci_anterp_tophat( u, uc, kctu, iflu, ifuu, jflo, jfuo, kflo, &3572 CALL pmci_anterp_tophat( u, uc, kctu, iflu, ifuu, jflo, jfuo, kflo, & 3529 3573 kfuo, ijfc_u, 'u' ) 3530 CALL pmci_anterp_tophat( v, vc, kctu, iflo, ifuo, jflv, jfuv, kflo, &3574 CALL pmci_anterp_tophat( v, vc, kctu, iflo, ifuo, jflv, jfuv, kflo, & 3531 3575 kfuo, ijfc_v, 'v' ) 3532 CALL pmci_anterp_tophat( w, wc, kctw, iflo, ifuo, jflo, jfuo, kflw, &3576 CALL pmci_anterp_tophat( w, wc, kctw, iflo, ifuo, jflo, jfuo, kflw, & 3533 3577 kfuw, ijfc_s, 'w' ) 3534 3578 IF ( .NOT. neutral ) THEN 3535 CALL pmci_anterp_tophat( pt, ptc, kctu, iflo, ifuo, jflo, jfuo, kflo, &3579 CALL pmci_anterp_tophat( pt, ptc, kctu, iflo, ifuo, jflo, jfuo, kflo, & 3536 3580 kfuo, ijfc_s, 's' ) 3537 3581 ENDIF 3538 3582 IF ( humidity .OR. passive_scalar ) THEN 3539 CALL pmci_anterp_tophat( q, qc, kctu, iflo, ifuo, jflo, jfuo, kflo, &3583 CALL pmci_anterp_tophat( q, qc, kctu, iflo, ifuo, jflo, jfuo, kflo, & 3540 3584 kfuo, ijfc_s, 's' ) 3541 3585 ENDIF … … 3545 3589 3546 3590 3547 SUBROUTINE pmci_interp_tril_lr( f, fc, ic, jc, kc, r1x, r2x, r1y, r2y, r1z, &3548 r2z, kb, logc, logc_ratio, nzt_topo_nestbc, &3591 SUBROUTINE pmci_interp_tril_lr( f, fc, ic, jc, kc, r1x, r2x, r1y, r2y, r1z, & 3592 r2z, kb, logc, logc_ratio, nzt_topo_nestbc, & 3549 3593 edge, var ) 3550 3594 ! 3551 !-- Interpolation of ghost-node values used as the c lient-domain boundary3595 !-- Interpolation of ghost-node values used as the child-domain boundary 3552 3596 !-- conditions. This subroutine handles the left and right boundaries. It is 3553 3597 !-- based on trilinear interpolation. … … 3555 3599 IMPLICIT NONE 3556 3600 3557 REAL(wp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg), &3601 REAL(wp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg), & 3558 3602 INTENT(INOUT) :: f !: 3559 REAL(wp), DIMENSION(0:cg%nz+1,jcs:jcn,icl:icr), &3603 REAL(wp), DIMENSION(0:cg%nz+1,jcs:jcn,icl:icr), & 3560 3604 INTENT(IN) :: fc !: 3561 REAL(wp), DIMENSION(1:2,0:ncorr-1,nzb:nzt_topo_nestbc,nys:nyn), &3605 REAL(wp), DIMENSION(1:2,0:ncorr-1,nzb:nzt_topo_nestbc,nys:nyn), & 3562 3606 INTENT(IN) :: logc_ratio !: 3563 3607 REAL(wp), DIMENSION(nxlg:nxrg), INTENT(IN) :: r1x !: … … 3572 3616 INTEGER(iwp), DIMENSION(nysg:nyng,nxlg:nxrg), INTENT(IN) :: kb !: 3573 3617 INTEGER(iwp), DIMENSION(nzb:nzt+1), INTENT(IN) :: kc !: 3574 INTEGER(iwp), DIMENSION(1:2,nzb:nzt_topo_nestbc,nys:nyn), &3618 INTEGER(iwp), DIMENSION(1:2,nzb:nzt_topo_nestbc,nys:nyn), & 3575 3619 INTENT(IN) :: logc !: 3576 3620 INTEGER(iwp) :: nzt_topo_nestbc !: 3577 3621 3578 CHARACTER(LEN=1), INTENT(IN) :: edge !:3579 CHARACTER(LEN=1), INTENT(IN) :: var !:3622 CHARACTER(LEN=1), INTENT(IN) :: edge !: 3623 CHARACTER(LEN=1), INTENT(IN) :: var !: 3580 3624 3581 3625 INTEGER(iwp) :: i !: … … 3701 3745 DO kcorr = 0, ncorr-1 3702 3746 kco = k + kcorr 3703 f(kco,jco,i) = 0.5_wp * ( logc_ratio(1,kcorr,k,j) * &3704 f(k1,j,i) &3705 + logc_ratio(2,jcorr,k,j) * &3747 f(kco,jco,i) = 0.5_wp * ( logc_ratio(1,kcorr,k,j) * & 3748 f(k1,j,i) & 3749 + logc_ratio(2,jcorr,k,j) * & 3706 3750 f(k,j1,i) ) 3707 3751 ENDDO … … 3747 3791 3748 3792 3749 SUBROUTINE pmci_interp_tril_sn( f, fc, ic, jc, kc, r1x, r2x, r1y, r2y, r1z, &3750 r2z, kb, logc, logc_ratio, &3793 SUBROUTINE pmci_interp_tril_sn( f, fc, ic, jc, kc, r1x, r2x, r1y, r2y, r1z, & 3794 r2z, kb, logc, logc_ratio, & 3751 3795 nzt_topo_nestbc, edge, var ) 3752 3796 3753 3797 ! 3754 !-- Interpolation of ghost-node values used as the c lient-domain boundary3798 !-- Interpolation of ghost-node values used as the child-domain boundary 3755 3799 !-- conditions. This subroutine handles the south and north boundaries. 3756 3800 !-- This subroutine is based on trilinear interpolation. … … 3758 3802 IMPLICIT NONE 3759 3803 3760 REAL(wp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg), &3804 REAL(wp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg), & 3761 3805 INTENT(INOUT) :: f !: 3762 REAL(wp), DIMENSION(0:cg%nz+1,jcs:jcn,icl:icr), &3806 REAL(wp), DIMENSION(0:cg%nz+1,jcs:jcn,icl:icr), & 3763 3807 INTENT(IN) :: fc !: 3764 REAL(wp), DIMENSION(1:2,0:ncorr-1,nzb:nzt_topo_nestbc,nxl:nxr), &3808 REAL(wp), DIMENSION(1:2,0:ncorr-1,nzb:nzt_topo_nestbc,nxl:nxr), & 3765 3809 INTENT(IN) :: logc_ratio !: 3766 3810 REAL(wp), DIMENSION(nxlg:nxrg), INTENT(IN) :: r1x !: … … 3775 3819 INTEGER(iwp), DIMENSION(nysg:nyng,nxlg:nxrg), INTENT(IN) :: kb !: 3776 3820 INTEGER(iwp), DIMENSION(nzb:nzt+1), INTENT(IN) :: kc !: 3777 INTEGER(iwp), DIMENSION(1:2,nzb:nzt_topo_nestbc,nxl:nxr), &3821 INTEGER(iwp), DIMENSION(1:2,nzb:nzt_topo_nestbc,nxl:nxr), & 3778 3822 INTENT(IN) :: logc !: 3779 3823 INTEGER(iwp) :: nzt_topo_nestbc !: … … 3902 3946 DO kcorr = 0, ncorr-1 3903 3947 kco = k + kcorr 3904 f(kco,i,ico) = 0.5_wp * ( logc_ratio(1,kcorr,k,i) * &3948 f(kco,i,ico) = 0.5_wp * ( logc_ratio(1,kcorr,k,i) * & 3905 3949 f(k1,j,i) & 3906 + logc_ratio(2,icorr,k,i) * &3950 + logc_ratio(2,icorr,k,i) * & 3907 3951 f(k,j,i1) ) 3908 3952 ENDDO … … 3948 3992 3949 3993 3950 SUBROUTINE pmci_interp_tril_t( f, fc, ic, jc, kc, r1x, r2x, r1y, r2y, r1z, &3994 SUBROUTINE pmci_interp_tril_t( f, fc, ic, jc, kc, r1x, r2x, r1y, r2y, r1z, & 3951 3995 r2z, var ) 3952 3996 3953 3997 ! 3954 !-- Interpolation of ghost-node values used as the c lient-domain boundary3998 !-- Interpolation of ghost-node values used as the child-domain boundary 3955 3999 !-- conditions. This subroutine handles the top boundary. 3956 4000 !-- This subroutine is based on trilinear interpolation. … … 3958 4002 IMPLICIT NONE 3959 4003 3960 REAL(wp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg), &4004 REAL(wp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg), & 3961 4005 INTENT(INOUT) :: f !: 3962 REAL(wp), DIMENSION(0:cg%nz+1,jcs:jcn,icl:icr), &4006 REAL(wp), DIMENSION(0:cg%nz+1,jcs:jcn,icl:icr), & 3963 4007 INTENT(IN) :: fc !: 3964 4008 REAL(wp), DIMENSION(nxlg:nxrg), INTENT(IN) :: r1x !: … … 3969 4013 REAL(wp), DIMENSION(nzb:nzt+1), INTENT(IN) :: r2z !: 3970 4014 3971 INTEGER(iwp), DIMENSION(nxlg:nxrg), INTENT(IN) :: ic !:3972 INTEGER(iwp), DIMENSION(nysg:nyng), INTENT(IN) :: jc !:3973 INTEGER(iwp), DIMENSION(nzb:nzt+1), INTENT(IN) :: kc !:4015 INTEGER(iwp), DIMENSION(nxlg:nxrg), INTENT(IN) :: ic !: 4016 INTEGER(iwp), DIMENSION(nysg:nyng), INTENT(IN) :: jc !: 4017 INTEGER(iwp), DIMENSION(nzb:nzt+1), INTENT(IN) :: kc !: 3974 4018 3975 4019 CHARACTER(LEN=1), INTENT(IN) :: var !: … … 4038 4082 SUBROUTINE pmci_extrap_ifoutflow_lr( f, kb, edge, var ) 4039 4083 ! 4040 !-- After the interpolation of ghost-node values for the c lient-domain4084 !-- After the interpolation of ghost-node values for the child-domain 4041 4085 !-- boundary conditions, this subroutine checks if there is a local outflow 4042 4086 !-- through the boundary. In that case this subroutine overwrites the … … 4047 4091 IMPLICIT NONE 4048 4092 4049 CHARACTER(LEN=1), INTENT(IN) :: edge !:4050 CHARACTER(LEN=1), INTENT(IN) :: var !:4093 CHARACTER(LEN=1), INTENT(IN) :: edge !: 4094 CHARACTER(LEN=1), INTENT(IN) :: var !: 4051 4095 4052 4096 INTEGER(iwp) :: i !: … … 4116 4160 SUBROUTINE pmci_extrap_ifoutflow_sn( f, kb, edge, var ) 4117 4161 ! 4118 !-- After the interpolation of ghost-node values for the c lient-domain4162 !-- After the interpolation of ghost-node values for the child-domain 4119 4163 !-- boundary conditions, this subroutine checks if there is a local outflow 4120 4164 !-- through the boundary. In that case this subroutine overwrites the … … 4193 4237 SUBROUTINE pmci_extrap_ifoutflow_t( f, var ) 4194 4238 ! 4195 !-- Interpolation of ghost-node values used as the c lient-domain boundary4239 !-- Interpolation of ghost-node values used as the child-domain boundary 4196 4240 !-- conditions. This subroutine handles the top boundary. It is based on 4197 4241 !-- trilinear interpolation. … … 4208 4252 REAL(wp) :: vdotnor !: 4209 4253 4210 REAL(wp), DIMENSION(nzb:nzt+1,nys-nbgp:nyn+nbgp,nxl-nbgp:nxr+nbgp), &4254 REAL(wp), DIMENSION(nzb:nzt+1,nys-nbgp:nyn+nbgp,nxl-nbgp:nxr+nbgp), & 4211 4255 INTENT(INOUT) :: f !: 4212 4256 … … 4241 4285 4242 4286 4243 SUBROUTINE pmci_anterp_tophat( f, fc, kct, ifl, ifu, jfl, jfu, kfl, kfu, &4287 SUBROUTINE pmci_anterp_tophat( f, fc, kct, ifl, ifu, jfl, jfu, kfl, kfu, & 4244 4288 ijfc, var ) 4245 4289 ! 4246 !-- Anterpolation of internal-node values to be used as the server-domain4290 !-- Anterpolation of internal-node values to be used as the parent-domain 4247 4291 !-- values. This subroutine is based on the first-order numerical 4248 4292 !-- integration of the fine-grid values contained within the coarse-grid … … 4296 4340 !-- Note that kcb is simply zero and kct enters here as a parameter and it is 4297 4341 !-- determined in pmci_init_anterp_tophat 4298 IF ( nest_bound_l ) THEN 4299 IF ( var == 'u' ) THEN 4300 iclp = icl + nhll + 1 4301 ELSE 4342 4343 IF ( nesting_mode == 'vertical' ) THEN 4344 IF ( nest_bound_l ) THEN 4302 4345 iclp = icl + nhll 4303 4346 ENDIF 4304 ENDIF 4305 IF ( nest_bound_r ) THEN 4306 icrm = icr - nhlr 4307 ENDIF 4308 4309 IF ( nest_bound_s ) THEN 4310 IF ( var == 'v' ) THEN 4311 jcsp = jcs + nhls + 1 4312 ELSE 4347 IF ( nest_bound_r ) THEN 4348 icrm = icr - nhlr 4349 ENDIF 4350 IF ( nest_bound_s ) THEN 4313 4351 jcsp = jcs + nhls 4314 4352 ENDIF 4315 ENDIF 4316 IF ( nest_bound_n ) THEN 4317 jcnm = jcn - nhln 4318 ENDIF 4319 kcb = 0 4320 4353 IF ( nest_bound_n ) THEN 4354 jcnm = jcn - nhln 4355 ENDIF 4356 ELSE 4357 IF ( nest_bound_l ) THEN 4358 IF ( var == 'u' ) THEN 4359 iclp = icl + nhll + 1 4360 ELSE 4361 iclp = icl + nhll 4362 ENDIF 4363 ENDIF 4364 IF ( nest_bound_r ) THEN 4365 icrm = icr - nhlr 4366 ENDIF 4367 4368 IF ( nest_bound_s ) THEN 4369 IF ( var == 'v' ) THEN 4370 jcsp = jcs + nhls + 1 4371 ELSE 4372 jcsp = jcs + nhls 4373 ENDIF 4374 ENDIF 4375 IF ( nest_bound_n ) THEN 4376 jcnm = jcn - nhln 4377 ENDIF 4378 kcb = 0 4379 ENDIF 4380 4321 4381 ! 4322 4382 !-- Note that ii, jj, and kk are coarse-grid indices and i,j, and k … … 4349 4409 ENDIF 4350 4410 4351 fc(kk,jj,ii) = ( 1.0_wp - fra ) * fc(kk,jj,ii) + &4411 fc(kk,jj,ii) = ( 1.0_wp - fra ) * fc(kk,jj,ii) + & 4352 4412 fra * cellsum / REAL( nfc, KIND = wp ) 4353 4413 … … 4359 4419 4360 4420 #endif 4361 END SUBROUTINE pmci_c lient_datatrans4421 END SUBROUTINE pmci_child_datatrans 4362 4422 4363 4423 END MODULE pmc_interface
Note: See TracChangeset
for help on using the changeset viewer.
