Changeset 3681


Ignore:
Timestamp:
Jan 18, 2019 3:06:05 PM (3 years ago)
Author:
hellstea
Message:

Major update of pmc_interface_mod

Location:
palm/trunk
Files:
14 edited

Legend:

Unmodified
Added
Removed
  • palm/trunk/SOURCE/pmc_interface_mod.f90

    r3655 r3681  
    2525! -----------------
    2626! $Id$
     27! Linear interpolations are replaced by first order interpolations. The linear
     28! interpolation routines are still included but not called. In the child
     29! inititialization the interpolation is also changed to 1st order and the linear
     30! interpolation is not kept.
     31! Subroutine pmci_map_fine_to_coarse_grid is rewritten.
     32! Several changes in pmci_init_anterp_tophat.
     33! Child's parent-grid arrays (uc, vc,...) are made non-overlapping on the PE-
     34! subdomain boundaries in order to allow grid-spacing ratios higher than nbgp.
     35! Subroutine pmci_init_tkefactor is removed as unnecessary.
     36!
     37! 3655 2019-01-07 16:51:22Z knoop
    2738! Remove unused variable simulated_time
    2839!
     
    334345
    335346
    336    USE arrays_3d,                                                              &
     347    USE arrays_3d,                                                             &
    337348        ONLY:  diss, diss_2, dzu, dzw, e, e_p, e_2, nc, nc_2, nc_p, nr, nr_2,  &
    338349               pt, pt_2, q, q_2, qc, qc_2, qr, qr_2, s, s_2,                   &
     
    378389    USE pegrid,                                                                &
    379390        ONLY:  collective_wait, comm1dx, comm1dy, comm2d, myid, myidx, myidy,  &
    380                numprocs, pleft, pnorth, pright, psouth, status
     391               numprocs, pdims, pleft, pnorth, pright, psouth, status
    381392
    382393    USE pmc_child,                                                             &
     
    446457!
    447458!-- Geometry
    448     REAL(wp), SAVE                                    ::  area_t             !<
    449459    REAL(wp), SAVE, DIMENSION(:), ALLOCATABLE, PUBLIC ::  coord_x            !<
    450460    REAL(wp), SAVE, DIMENSION(:), ALLOCATABLE, PUBLIC ::  coord_y            !<
     
    455465!-- Children's parent-grid arrays
    456466    INTEGER(iwp), SAVE, DIMENSION(5), PUBLIC    ::  coarse_bound        !< subdomain index bounds for children's parent-grid arrays
    457     INTEGER(iwp), SAVE, DIMENSION(4), PUBLIC    ::  coarse_bound_anterp !< subdomain index bounds for anterpolation
    458 
    459     REAL(wp), SAVE                              ::  xexl           !<
    460     REAL(wp), SAVE                              ::  xexr           !<
    461     REAL(wp), SAVE                              ::  yexs           !<
    462     REAL(wp), SAVE                              ::  yexn           !<
    463     REAL(wp), SAVE, DIMENSION(:,:), ALLOCATABLE ::  tkefactor_l    !<
    464     REAL(wp), SAVE, DIMENSION(:,:), ALLOCATABLE ::  tkefactor_n    !<
    465     REAL(wp), SAVE, DIMENSION(:,:), ALLOCATABLE ::  tkefactor_r    !<
    466     REAL(wp), SAVE, DIMENSION(:,:), ALLOCATABLE ::  tkefactor_s    !<
    467     REAL(wp), SAVE, DIMENSION(:,:), ALLOCATABLE ::  tkefactor_t    !<
     467    INTEGER(iwp), SAVE, DIMENSION(4), PUBLIC    ::  coarse_bound_aux    !< subdomain index bounds for allocation of index-mapping and other auxiliary arrays
     468    INTEGER(iwp), SAVE, DIMENSION(4), PUBLIC    ::  coarse_bound_w      !< subdomain index bounds for children's parent-grid work arrays
    468469
    469470    REAL(wp), SAVE, DIMENSION(:,:,:), ALLOCATABLE, TARGET ::  dissc !< coarse grid array on child domain - dissipation rate
     
    493494    INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:) ::  kco    !<
    494495    INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:) ::  kcw    !<
     496    REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:)     ::  celltmpd !<
    495497    REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:)     ::  r1xo   !<
    496498    REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:)     ::  r2xo   !<
     
    505507    REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:)     ::  r1zw   !<
    506508    REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:)     ::  r2zw   !<
    507     REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:)     ::  celltmpd !<
     509
    508510!
    509511!-- Child index arrays and log-ratio arrays for the log-law near-wall
     
    547549    REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:,:,:)   ::  logc_ratio_w_s   !<
    548550!
    549 !-- Upper bounds for k in anterpolation.
    550     INTEGER(iwp), SAVE ::  kcto   !<
    551     INTEGER(iwp), SAVE ::  kctw   !<
     551    INTEGER(iwp), SAVE ::  igsr     !< Integer grid-spacing ratio in i-direction
     552    INTEGER(iwp), SAVE ::  jgsr     !< Integer grid-spacing ratio in j-direction
     553    INTEGER(iwp), SAVE ::  kgsr     !< Integer grid-spacing ratio in k-direction
     554    INTEGER(iwp), SAVE ::  kcto     !< Upper bound for k in anterpolation of variables other than w.
     555    INTEGER(iwp), SAVE ::  kctw     !< Upper bound for k in anterpolation of w.
     556    INTEGER(iwp), SAVE ::  nxlfc    !< Lower index limit in x-direction for fine-to-coarse index mapping and interpolaton coefficient arrays
     557    INTEGER(iwp), SAVE ::  nxrfc    !< Upper index limit in x-direction for fine-to-coarse index mapping and interpolaton coefficient arrays
     558    INTEGER(iwp), SAVE ::  nynfc    !< Upper index limit in y-direction for fine-to-coarse index mapping and interpolaton coefficient arrays
     559    INTEGER(iwp), SAVE ::  nysfc    !< Lower index limit in y-direction for fine-to-coarse index mapping and interpolaton coefficient arrays
    552560!
    553561!-- Upper bound for k in log-law correction in interpolation.
     
    556564    INTEGER(iwp), SAVE ::  nzt_topo_nestbc_r   !<
    557565    INTEGER(iwp), SAVE ::  nzt_topo_nestbc_s   !<
    558 !
    559 !-- Number of ghost nodes in coarse-grid arrays for i and j in anterpolation.
    560     INTEGER(iwp), SAVE ::  nhll   !<
    561     INTEGER(iwp), SAVE ::  nhlr   !<
    562     INTEGER(iwp), SAVE ::  nhls   !<
    563     INTEGER(iwp), SAVE ::  nhln   !<
    564566!
    565567!-- Spatial under-relaxation coefficients for anterpolation.
     
    633635    INTEGER(idp),ALLOCATABLE,DIMENSION(:,:),PUBLIC,TARGET    :: nr_part  !<
    634636    INTEGER(idp),ALLOCATABLE,DIMENSION(:,:),PUBLIC,TARGET    :: part_adr !<
     637
     638!AH
     639    REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: workarr_lr
     640    REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: workarr_sn
     641    REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: workarr_t
     642    REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: workarrc_lr
     643    REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: workarrc_sn
     644    REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: workarrc_t
     645    INTEGER(iwp) :: workarrc_lr_exchange_type
     646    INTEGER(iwp) :: workarrc_sn_exchange_type
     647    INTEGER(iwp) :: workarrc_t_exchange_type_x
     648    INTEGER(iwp) :: workarrc_t_exchange_type_y
     649!AH
    635650   
    636651    INTERFACE pmci_boundary_conds
     
    914929          nz_cl = nz
    915930!
    916 !--       Find the highest nest level in the coarse grid for the reduced z
     931!--       Find the highest nest level in the parent grid for the reduced z
    917932!--       transfer
    918933          DO  k = 1, nz                 
     
    11301145          CALL MPI_COMM_SIZE( comm1dy, npy, ierr )
    11311146!
    1132 !--       The +1 in index is because PALM starts with nx=0
     1147!--       Nrx is the same for all PEs and so is nry, thus there is no need to compute
     1148!--       them separately for each PE.
    11331149          nrx = nxr - nxl + 1
    11341150          nry = nyn - nys + 1
     
    11391155!
    11401156!--          Area along y required by actual child PE
    1141              DO  j = coarse_bound_all(3,k), coarse_bound_all(4,k)
     1157             DO  j = coarse_bound_all(3,k), coarse_bound_all(4,k)  !: j = jcs, jcn of PE# k
    11421158!
    11431159!--             Area along x required by actual child PE
    1144                 DO  i = coarse_bound_all(1,k), coarse_bound_all(2,k)
     1160                DO  i = coarse_bound_all(1,k), coarse_bound_all(2,k)  !: i = icl, icr of PE# k
    11451161
    11461162                   px = i / nrx
     
    12301246    INTEGER(iwp) ::  i          !<
    12311247    INTEGER(iwp) ::  ierr       !<
    1232     INTEGER(iwp) ::  icl        !< left index limit for children's parent-grid arrays
    1233     INTEGER(iwp) ::  icla       !< left index limit for anterpolation
    1234     INTEGER(iwp) ::  icr        !< left index limit for children's parent-grid arrays
    1235     INTEGER(iwp) ::  icra       !< right index limit for anterpolation
     1248    INTEGER(iwp) ::  icl        !< Left index limit for children's parent-grid arrays
     1249    INTEGER(iwp) ::  icla       !< Left index limit for allocation of index-mapping and other auxiliary arrays
     1250    INTEGER(iwp) ::  iclw       !< Left index limit for children's parent-grid work arrays
     1251    INTEGER(iwp) ::  icr        !< Left index limit for children's parent-grid arrays
     1252    INTEGER(iwp) ::  icra       !< Right index limit for allocation of index-mapping and other auxiliary arrays
     1253    INTEGER(iwp) ::  icrw       !< Right index limit for children's parent-grid work arrays
    12361254    INTEGER(iwp) ::  j          !<
    1237     INTEGER(iwp) ::  jcn        !< north index limit for children's parent-grid arrays
    1238     INTEGER(iwp) ::  jcna       !< north index limit for anterpolation
    1239     INTEGER(iwp) ::  jcs        !< sout index limit for children's parent-grid arrays
    1240     INTEGER(iwp) ::  jcsa       !< south index limit for anterpolation
    1241     INTEGER(iwp) ::  n          !< running index for number of chemical species
     1255    INTEGER(iwp) ::  jcn        !< North index limit for children's parent-grid arrays
     1256    INTEGER(iwp) ::  jcna       !< North index limit for allocation of index-mapping and other auxiliary arrays
     1257    INTEGER(iwp) ::  jcnw       !< North index limit for children's parent-grid work arrays
     1258    INTEGER(iwp) ::  jcs        !< South index limit for children's parent-grid arrays
     1259    INTEGER(iwp) ::  jcsa       !< South index limit for allocation of index-mapping and other auxiliary arrays
     1260    INTEGER(iwp) ::  jcsw       !< South index limit for children's parent-grid work arrays
     1261    INTEGER(iwp) ::  n          !< Running index for number of chemical species
    12421262
    12431263    INTEGER(iwp), DIMENSION(5) ::  val        !<
     
    14411461       ENDIF
    14421462!
    1443 !--    Define the SGS-TKE scaling factor based on the grid-spacing ratio. Only
    1444 !--    if both parent and child are in LES mode or in RANS mode.
    1445 !--    Please note, in case parent and child are in RANS mode, TKE weighting
    1446 !--    factor is simply one.
    1447        IF ( (        rans_mode_parent  .AND.         rans_mode )  .OR.         &
    1448             (  .NOT. rans_mode_parent  .AND.  .NOT.  rans_mode  .AND.          &
    1449                .NOT. constant_diffusion ) )  CALL pmci_init_tkefactor
    1450 !
    14511463!--    Two-way coupling for general and vertical nesting.
    14521464!--    Precompute the index arrays and relaxation functions for the
     
    14571469!--    included in the interpolation algorithms.
    14581470       CALL pmci_init_anterp_tophat
    1459 !
    1460 !--    Finally, compute the total area of the top-boundary face of the domain.
    1461 !--    This is needed in the pmc_ensure_nest_mass_conservation     
    1462        area_t = ( nx + 1 ) * (ny + 1 ) * dx * dy
    14631471
    14641472    ENDIF
     
    14761484       INTEGER(iwp), DIMENSION(2)          ::  size_of_array      !<
    14771485                                   
    1478        INTEGER(iwp) :: i        !<   
     1486       INTEGER(iwp) :: i        !<
     1487       INTEGER(iwp) :: iauxl    !<
     1488       INTEGER(iwp) :: iauxr    !<
    14791489       INTEGER(iwp) :: ijaux    !<
    1480        INTEGER(iwp) :: j        !<
     1490       INTEGER(iwp) :: j        !<
     1491       INTEGER(iwp) :: jauxs    !<
     1492       INTEGER(iwp) :: jauxn    !<
    14811493       REAL(wp) ::  loffset     !<
    14821494       REAL(wp) ::  noffset     !<
    14831495       REAL(wp) ::  roffset     !<
    14841496       REAL(wp) ::  soffset     !<
    1485 
    1486 !
    1487 !--    If the fine- and coarse grid nodes do not match:
    1488        loffset = MOD( coord_x(nxl), cg%dx )
    1489        xexl    = cg%dx + loffset
    1490 !
    1491 !--    This is needed in the anterpolation phase
    1492        nhll = CEILING( xexl / cg%dx )
    1493        xcs  = coord_x(nxl) - xexl
    1494        DO  i = 0, cg%nx
    1495           IF ( cg%coord_x(i) > xcs )  THEN
    1496              icl = MAX( -1, i-1 )
    1497              EXIT
    1498           ENDIF
    1499        ENDDO
    1500 !
    1501 !--    If the fine- and coarse grid nodes do not match
    1502        roffset = MOD( coord_x(nxr+1), cg%dx )
    1503        xexr    = cg%dx + roffset
    1504 !
    1505 !--    This is needed in the anterpolation phase
    1506        nhlr = CEILING( xexr / cg%dx )
    1507        xce  = coord_x(nxr+1) + xexr
    1508 !--    One "extra" layer is taken behind the right boundary
    1509 !--    because it may be needed in cases of non-integer grid-spacing ratio
    1510        DO  i = cg%nx, 0 , -1
    1511           IF ( cg%coord_x(i) < xce )  THEN
    1512              icr = MIN( cg%nx+1, i+1 )
    1513              EXIT
    1514           ENDIF
    1515        ENDDO
    1516 !
    1517 !--    If the fine- and coarse grid nodes do not match
    1518        soffset = MOD( coord_y(nys), cg%dy )
    1519        yexs    = cg%dy + soffset
    1520 !
    1521 !--    This is needed in the anterpolation phase
    1522        nhls = CEILING( yexs / cg%dy )
    1523        ycs  = coord_y(nys) - yexs
    1524        DO  j = 0, cg%ny
    1525           IF ( cg%coord_y(j) > ycs )  THEN
    1526              jcs = MAX( -nbgp, j-1 )
    1527              EXIT
    1528           ENDIF
    1529        ENDDO
    1530 !
    1531 !--    If the fine- and coarse grid nodes do not match
    1532        noffset = MOD( coord_y(nyn+1), cg%dy )
    1533        yexn    = cg%dy + noffset
    1534 !
    1535 !--    This is needed in the anterpolation phase
    1536        nhln = CEILING( yexn / cg%dy )
    1537        yce  = coord_y(nyn+1) + yexn
    1538 !--    One "extra" layer is taken behind the north boundary
    1539 !--    because it may be needed in cases of non-integer grid-spacing ratio
    1540        DO  j = cg%ny, 0, -1
    1541           IF ( cg%coord_y(j) < yce )  THEN
    1542              jcn = MIN( cg%ny + nbgp, j+1 )
    1543              EXIT
    1544           ENDIF
    1545        ENDDO
    1546 
    1547        coarse_bound(1) = icl
    1548        coarse_bound(2) = icr
    1549        coarse_bound(3) = jcs
    1550        coarse_bound(4) = jcn
    1551        coarse_bound(5) = myid
     1497       REAL(wp) ::  xexl        !< Parent-grid array exceedance behind the left edge of the child PE subdomain
     1498       REAL(wp) ::  xexr        !< Parent-grid array exceedance behind the right edge of the child PE subdomain
     1499       REAL(wp) ::  yexs        !< Parent-grid array exceedance behind the south edge of the child PE subdomain
     1500       REAL(wp) ::  yexn        !< Parent-grid array exceedance behind the north edge of the child PE subdomain
     1501
     1502!AH!
     1503!AH!--    If the fine- and coarse grid nodes do not match:
     1504!AH       loffset = MOD( coord_x(nxl), cg%dx )
     1505!AH       xexl    = cg%dx + loffset
     1506!AH       xcs  = coord_x(nxl) - xexl
     1507!AH       DO  i = 0, cg%nx
     1508!AH          IF ( cg%coord_x(i) > xcs )  THEN
     1509!AH             icl = MAX( -1, i-1 )
     1510!AH             EXIT
     1511!AH          ENDIF
     1512!AH       ENDDO
     1513!AH!
     1514!AH!--    If the fine- and coarse grid nodes do not match
     1515!AH       roffset = MOD( coord_x(nxr+1), cg%dx )
     1516!AH       xexr    = cg%dx + roffset
     1517!AH       xce  = coord_x(nxr+1)
     1518!AH       IF ( nxr == nx )  THEN
     1519!AH          xce = xce + xexr
     1520!AH       ENDIF
     1521!AH       DO  i = cg%nx, 0 , -1
     1522!AH          IF ( cg%coord_x(i) < xce )  THEN
     1523!AH             icr = MIN( cg%nx+1, i+1 )
     1524!AH             EXIT
     1525!AH          ENDIF
     1526!AH       ENDDO
     1527!AH!
     1528!AH!--    If the fine- and coarse grid nodes do not match
     1529!AH       soffset = MOD( coord_y(nys), cg%dy )
     1530!AH       yexs    = cg%dy + soffset
     1531!AH       ycs  = coord_y(nys) - yexs
     1532!AH       DO  j = 0, cg%ny
     1533!AH          IF ( cg%coord_y(j) > ycs )  THEN
     1534!AH             jcs = MAX( -nbgp, j-1 )
     1535!AH             EXIT
     1536!AH          ENDIF
     1537!AH       ENDDO
     1538!AH!
     1539!AH!--    If the fine- and coarse grid nodes do not match
     1540!AH       noffset = MOD( coord_y(nyn+1), cg%dy )
     1541!AH       yexn    = cg%dy + noffset
     1542!AH       yce  = coord_y(nyn+1)
     1543!AH       IF ( nyn == ny )  THEN
     1544!AH          yce = yce + yexn
     1545!AH       ENDIF
     1546!AH       DO  j = cg%ny, 0, -1
     1547!AH          IF ( cg%coord_y(j) < yce )  THEN
     1548!AH             jcn = MIN( cg%ny + nbgp, j+1 )
     1549!AH             EXIT
     1550!AH          ENDIF
     1551!AH       ENDDO
     1552!AH
     1553!AH       coarse_bound(1) = icl
     1554!AH       coarse_bound(2) = icr
     1555!AH       coarse_bound(3) = jcs
     1556!AH       coarse_bound(4) = jcn
     1557!AH       coarse_bound(5) = myid
    15521558!
    15531559!--    Determine the anterpolation index limits. If at least half of the
     
    15571563!--    anterpolation domain, or not included at all if we are at the outer
    15581564!--    edge of the child domain.
     1565
     1566!
     1567!--    Left
     1568       IF  ( bc_dirichlet_l )  THEN
     1569          loffset = MOD( coord_x(nxl), cg%dx )
     1570          xexl  = 2 * cg%dx + loffset
     1571          iauxl = 0
     1572       ELSE
     1573          xexl  = 0.0_wp
     1574          iauxl = 1
     1575       ENDIF
     1576       xcs     = coord_x(nxl) - xexl
    15591577       DO  i = 0, cg%nx
    1560           IF ( cg%coord_x(i) + 0.5_wp * cg%dx >= coord_x(nxl) )  THEN
    1561              icla = MAX( 0, i )
     1578          IF ( cg%coord_x(i) + 0.5_wp * cg%dx >= xcs )  THEN
     1579             icl = MAX( 0, i )
    15621580             EXIT
    15631581          ENDIF
    15641582       ENDDO
     1583!
     1584!--    Right
     1585       IF  ( bc_dirichlet_r )  THEN
     1586          roffset = MOD( coord_x(nxr+1), cg%dx )
     1587          xexr  = 2 * cg%dx + roffset
     1588          iauxr = 0 
     1589       ELSE
     1590          xexr  = 0.0_wp
     1591          iauxr = 1 
     1592       ENDIF
     1593       xce  = coord_x(nxr+1) + xexr
    15651594       DO  i = cg%nx, 0 , -1
    1566           IF ( cg%coord_x(i) + 0.5_wp * cg%dx <= coord_x(nxr+1) )  THEN
    1567              icra = MIN( cg%nx, i )
     1595          IF ( cg%coord_x(i) + 0.5_wp * cg%dx <= xce )  THEN
     1596             icr = MIN( cg%nx, i )
    15681597             EXIT
    15691598          ENDIF
    15701599       ENDDO
     1600!
     1601!--    South
     1602       IF  ( bc_dirichlet_s )  THEN
     1603          soffset = MOD( coord_y(nys), cg%dy )
     1604          yexs  = 2 * cg%dy + soffset
     1605          jauxs = 0 
     1606       ELSE
     1607          yexs  = 0.0_wp
     1608          jauxs = 1 
     1609       ENDIF
     1610       ycs  = coord_y(nys) - yexs
    15711611       DO  j = 0, cg%ny
    1572           IF ( cg%coord_y(j) + 0.5_wp * cg%dy >= coord_y(nys) )  THEN
    1573              jcsa = MAX( 0, j )
     1612          IF ( cg%coord_y(j) + 0.5_wp * cg%dy >= ycs )  THEN
     1613             jcs = MAX( 0, j )
    15741614             EXIT
    15751615          ENDIF
    15761616       ENDDO
     1617!
     1618!--    North
     1619       IF  ( bc_dirichlet_n )  THEN
     1620          noffset = MOD( coord_y(nyn+1), cg%dy )
     1621          yexn  = 2 * cg%dy + noffset
     1622          jauxn = 0
     1623       ELSE
     1624          yexn  = 0.0_wp
     1625          jauxn = 1
     1626       ENDIF
     1627       yce  = coord_y(nyn+1) + yexn
    15771628       DO  j = cg%ny, 0 , -1
    1578           IF ( cg%coord_y(j) + 0.5_wp * cg%dy <= coord_y(nyn+1) )  THEN
    1579              jcna = MIN( cg%ny, j )
     1629          IF ( cg%coord_y(j) + 0.5_wp * cg%dy <= yce )  THEN
     1630             jcn = MIN( cg%ny, j )
    15801631             EXIT
    15811632          ENDIF
    15821633       ENDDO
    15831634!
    1584 !--    Make sure that the indexing is contiguous
     1635!--    Make sure that the indexing is contiguous (no gaps, no overlaps)
     1636#if defined( __parallel )
    15851637       IF ( nxl == 0 )  THEN
    1586           CALL MPI_SEND( icra, 1, MPI_INTEGER, pright, 717, comm2d, ierr )
     1638          CALL MPI_SEND( icr, 1, MPI_INTEGER, pright, 717, comm2d, ierr )
    15871639       ELSE IF ( nxr == nx )  THEN
    15881640          CALL MPI_RECV( ijaux, 1, MPI_INTEGER, pleft, 717, comm2d, status, ierr )
    1589           icla = ijaux + 1
     1641          icl = ijaux + 1
    15901642       ELSE
    1591           CALL MPI_SEND( icra, 1, MPI_INTEGER, pright, 717, comm2d, ierr )
     1643          CALL MPI_SEND( icr, 1, MPI_INTEGER, pright, 717, comm2d, ierr )
    15921644          CALL MPI_RECV( ijaux, 1, MPI_INTEGER, pleft, 717, comm2d, status, ierr )
    1593           icla = ijaux + 1
     1645          icl = ijaux + 1
    15941646       ENDIF
    15951647       IF ( nys == 0 )  THEN
    1596           CALL MPI_SEND( jcna, 1, MPI_INTEGER, pnorth, 719, comm2d, ierr )
     1648          CALL MPI_SEND( jcn, 1, MPI_INTEGER, pnorth, 719, comm2d, ierr )
    15971649       ELSE IF ( nyn == ny )  THEN
    15981650          CALL MPI_RECV( ijaux, 1, MPI_INTEGER, psouth, 719, comm2d, status, ierr )
    1599           jcsa = ijaux + 1
     1651          jcs = ijaux + 1
    16001652       ELSE
    1601           CALL MPI_SEND( jcna, 1, MPI_INTEGER, pnorth, 719, comm2d, ierr )
     1653          CALL MPI_SEND( jcn, 1, MPI_INTEGER, pnorth, 719, comm2d, ierr )
    16021654          CALL MPI_RECV( ijaux, 1, MPI_INTEGER, psouth, 719, comm2d, status, ierr )
    1603           jcsa = ijaux + 1
     1655          jcs = ijaux + 1
    16041656       ENDIF
    1605 
    1606        write(9,"('Anterpolation bounds: ',4(i3,2x))") icla, icra, jcsa, jcna
    1607        flush(9)
    1608        coarse_bound_anterp(1) = icla
    1609        coarse_bound_anterp(2) = icra
    1610        coarse_bound_anterp(3) = jcsa
    1611        coarse_bound_anterp(4) = jcna
     1657#endif       
     1658
     1659       WRITE(9,"('Pmci_map_fine_to_coarse_grid. parent-grid array bounds: ',4(i3,2x))") icl, icr, jcs, jcn
     1660       FLUSH(9)
     1661
     1662       coarse_bound(1) = icl
     1663       coarse_bound(2) = icr
     1664       coarse_bound(3) = jcs
     1665       coarse_bound(4) = jcn
     1666       coarse_bound(5) = myid
     1667!
     1668!--    The following index bounds are used for allocating index mapping and some other auxiliary arrays
     1669       coarse_bound_aux(1) = icl - iauxl
     1670       coarse_bound_aux(2) = icr + iauxr
     1671       coarse_bound_aux(3) = jcs - jauxs
     1672       coarse_bound_aux(4) = jcn + jauxn
    16121673!
    16131674!--    Note that MPI_Gather receives data from all processes in the rank order
     
    16361697       IMPLICIT NONE
    16371698
    1638        INTEGER(iwp) ::  acsize  !<
    1639        INTEGER(iwp) ::  i       !<
    1640        INTEGER(iwp) ::  j       !<
    1641        INTEGER(iwp) ::  k       !<
    1642        INTEGER(iwp) ::  kc      !<
    1643        INTEGER(iwp) ::  kdzo    !<
    1644        INTEGER(iwp) ::  kdzw    !<       
    1645 
    1646        REAL(wp) ::  dzmin       !<
    1647        REAL(wp) ::  parentdzmax !<
    1648        REAL(wp) ::  xb          !<
    1649        REAL(wp) ::  xcsu        !<
    1650        REAL(wp) ::  xfso        !<
    1651        REAL(wp) ::  xcso        !<
    1652        REAL(wp) ::  xfsu        !<
    1653        REAL(wp) ::  yb          !<
    1654        REAL(wp) ::  ycso        !<
    1655        REAL(wp) ::  ycsv        !<
    1656        REAL(wp) ::  yfso        !<
    1657        REAL(wp) ::  yfsv        !<
    1658        REAL(wp) ::  zcso        !<
    1659        REAL(wp) ::  zcsw        !<
    1660        REAL(wp) ::  zfso        !<
    1661        REAL(wp) ::  zfsw        !<
     1699       INTEGER(iwp) ::  acsize   !< Maximum dimension of anterpolation cell.
     1700       INTEGER(iwp) ::  i        !< Child-grid i-index
     1701       INTEGER(iwp) ::  ierr     !< MPI error code
     1702       INTEGER(iwp) ::  j        !< Child-grid j-index
     1703       INTEGER(iwp) ::  k        !< Child-grid k-index
     1704       INTEGER(iwp) ::  kc       !<
     1705       INTEGER(iwp) ::  kdzo     !<
     1706       INTEGER(iwp) ::  kdzw     !<
     1707       INTEGER(iwp) ::  moff     !< Parent-grid bound offset in j-direction
     1708       INTEGER(iwp) ::  loff     !< Parent-grid bound offset in i-direction
     1709
     1710       REAL(wp) ::  dzmin        !<
     1711       REAL(wp) ::  parentdzmax  !<
     1712       REAL(wp) ::  xb           !<
     1713       REAL(wp) ::  xcsu         !<
     1714       REAL(wp) ::  xfso         !<
     1715       REAL(wp) ::  xcso         !<
     1716       REAL(wp) ::  xfsu         !<
     1717       REAL(wp) ::  yb           !<
     1718       REAL(wp) ::  ycso         !<
     1719       REAL(wp) ::  ycsv         !<
     1720       REAL(wp) ::  yfso         !<
     1721       REAL(wp) ::  yfsv         !<
     1722       REAL(wp) ::  zcso         !<
     1723       REAL(wp) ::  zcsw         !<
     1724       REAL(wp) ::  zfso         !<
     1725       REAL(wp) ::  zfsw         !<
    16621726     
    16631727       
    1664        xb = nxl * dx
    1665        yb = nys * dy
    1666      
    1667        ALLOCATE( icu(nxlg:nxrg) )
    1668        ALLOCATE( ico(nxlg:nxrg) )
    1669        ALLOCATE( jcv(nysg:nyng) )
    1670        ALLOCATE( jco(nysg:nyng) )
    1671        ALLOCATE( kcw(nzb:nzt+1) )
    1672        ALLOCATE( kco(nzb:nzt+1) )
    1673        ALLOCATE( r1xu(nxlg:nxrg) )
    1674        ALLOCATE( r2xu(nxlg:nxrg) )
    1675        ALLOCATE( r1xo(nxlg:nxrg) )
    1676        ALLOCATE( r2xo(nxlg:nxrg) )
    1677        ALLOCATE( r1yv(nysg:nyng) )
    1678        ALLOCATE( r2yv(nysg:nyng) )
    1679        ALLOCATE( r1yo(nysg:nyng) )
    1680        ALLOCATE( r2yo(nysg:nyng) )
    1681        ALLOCATE( r1zw(nzb:nzt+1) )
    1682        ALLOCATE( r2zw(nzb:nzt+1) )
    1683        ALLOCATE( r1zo(nzb:nzt+1) )
    1684        ALLOCATE( r2zo(nzb:nzt+1) )
    1685 !
    1686 !--    Note that the node coordinates xfs... and xcs... are relative to the
    1687 !--    lower-left-bottom corner of the fc-array, not the actual child domain
    1688 !--    corner
    1689        DO  i = nxlg, nxrg
    1690           xfsu    = coord_x(i) - ( lower_left_coord_x + xb - xexl )
    1691           xfso    = coord_x(i) + 0.5_wp * dx - ( lower_left_coord_x + xb - xexl )
    1692           icu(i)  = icl + FLOOR( xfsu / cg%dx )
    1693           ico(i)  = icl + FLOOR( ( xfso - 0.5_wp * cg%dx ) / cg%dx )
    1694           xcsu    = ( icu(i) - icl ) * cg%dx
    1695           xcso    = ( ico(i) - icl ) * cg%dx + 0.5_wp * cg%dx
     1728!AH
     1729!
     1730!--    Allocate child-grid work arrays for interpolation.
     1731       CALL pmci_allocate_finegrid_workarrays
     1732!       
     1733!--    Determine index bounds for the parent-grid work arrays for
     1734!--    interpolation and allocate them.
     1735       CALL pmci_allocate_coarsegrid_workarrays
     1736!       
     1737!--    Define the MPI-datatypes for parent-grid work array
     1738!--    exchange between the PE-subdomains.
     1739       CALL pmci_create_coarsegrid_workarray_exchange_datatypes
     1740!
     1741!--    Determine index bounds for the fine-to-coarse grid index mapping arrays
     1742!--    and interpolation-coefficient arrays and allocate them.       
     1743       CALL pmci_allocate_fine_to_coarse_mapping_arrays
     1744!AH       
     1745!
     1746       xb   = nxl * dx
     1747       IF  ( bc_dirichlet_l )  THEN
     1748          loff = 2
     1749       ELSE
     1750          loff = 0
     1751       ENDIF
     1752!AH       DO  i = nxlg, nxrg
     1753       DO  i = nxl-1, nxr+1
     1754          xfsu    = coord_x(i) - ( lower_left_coord_x + xb )
     1755          xfso    = coord_x(i) + 0.5_wp * dx - ( lower_left_coord_x + xb )
     1756!
     1757!--       icl points to 2 parent-grid cells left form the left nest boundary,
     1758!--       thence icl + loff points to the left nest boundary.
     1759          icu(i)  = icl + loff + FLOOR( xfsu / cg%dx )
     1760          ico(i)  = icl + loff + FLOOR( ( xfso - 0.5_wp * cg%dx ) / cg%dx )
     1761          xcsu    = ( icu(i) - ( icl + loff ) ) * cg%dx
     1762          xcso    = ( ico(i) - ( icl + loff ) + 0.5_wp ) * cg%dx
    16961763          r2xu(i) = ( xfsu - xcsu ) / cg%dx
    16971764          r2xo(i) = ( xfso - xcso ) / cg%dx
     
    16991766          r1xo(i) = 1.0_wp - r2xo(i)
    17001767       ENDDO
    1701 
    1702        DO  j = nysg, nyng
    1703           yfsv    = coord_y(j) - ( lower_left_coord_y + yb - yexs )
    1704           yfso    = coord_y(j) + 0.5_wp * dy - ( lower_left_coord_y + yb - yexs )
    1705           jcv(j)  = jcs + FLOOR( yfsv / cg%dy )
    1706           jco(j)  = jcs + FLOOR( ( yfso -0.5_wp * cg%dy ) / cg%dy )
    1707           ycsv    = ( jcv(j) - jcs ) * cg%dy
    1708           ycso    = ( jco(j) - jcs ) * cg%dy + 0.5_wp * cg%dy
     1768!       
     1769!--    Fill up the values behind nest boundaries by copying from inside
     1770!--    the domain.
     1771       IF  ( bc_dirichlet_l )  THEN
     1772          icu(nxlfc:nxl-1)  = icu(nxlfc+igsr:nxl-1+igsr) - 1
     1773          r1xu(nxlfc:nxl-1) = r1xu(nxlfc+igsr:nxl-1+igsr)
     1774          r2xu(nxlfc:nxl-1) = r2xu(nxlfc+igsr:nxl-1+igsr)
     1775          ico(nxlfc:nxl-1)  = ico(nxlfc+igsr:nxl-1+igsr) - 1
     1776          r1xo(nxlfc:nxl-1) = r1xo(nxlfc+igsr:nxl-1+igsr)
     1777          r2xo(nxlfc:nxl-1) = r2xo(nxlfc+igsr:nxl-1+igsr)
     1778       ENDIF
     1779       
     1780       IF  ( bc_dirichlet_r )  THEN
     1781          icu(nxr+1:nxrfc)  = icu(nxr+1-igsr:nxrfc-igsr) + 1
     1782          r1xu(nxr+1:nxrfc) = r1xu(nxr+1-igsr:nxrfc-igsr)
     1783          r2xu(nxr+1:nxrfc) = r2xu(nxr+1-igsr:nxrfc-igsr)
     1784          ico(nxr+1:nxrfc)  = ico(nxr+1-igsr:nxrfc-igsr) + 1
     1785          r1xo(nxr+1:nxrfc) = r1xo(nxr+1-igsr:nxrfc-igsr)
     1786          r2xo(nxr+1:nxrfc) = r2xo(nxr+1-igsr:nxrfc-igsr)
     1787       ENDIF
     1788!
     1789!--    Print out the indices and coefficients for checking and debugging purposes
     1790       DO  i = nxlfc, nxrfc
     1791          WRITE(9,"('pmci_init_interp_tril: i, icu, r1xu r2xu ', 2(i4,2x),2(e12.5,2x))") &
     1792               i, icu(i), r1xu(i), r2xu(i)
     1793          FLUSH(9)
     1794       ENDDO
     1795       WRITE(9,*)
     1796       DO  i = nxlfc, nxrfc
     1797          WRITE(9,"('pmci_init_interp_tril: i, ico, r1xo r2xo ', 2(i4,2x),2(e12.5,2x))") &
     1798               i, ico(i), r1xo(i), r2xo(i)
     1799          FLUSH(9)
     1800       ENDDO
     1801       WRITE(9,*)
     1802
     1803       yb   = nys * dy
     1804       IF  ( bc_dirichlet_s )  THEN
     1805          moff = 2
     1806       ELSE
     1807          moff = 0
     1808       ENDIF
     1809!AH       DO  j = nysg, nyng
     1810       DO  j = nys-1, nyn+1
     1811          yfsv    = coord_y(j) - ( lower_left_coord_y + yb )
     1812          yfso    = coord_y(j) + 0.5_wp * dy - ( lower_left_coord_y + yb )
     1813!
     1814!--       jcs points to 2 parent-grid cells south form the south nest boundary,
     1815!--       thence jcs + moff points to the south nest boundary.
     1816          jcv(j)  = jcs + moff + FLOOR( yfsv / cg%dy )
     1817          jco(j)  = jcs + moff + FLOOR( ( yfso - 0.5_wp * cg%dy ) / cg%dy )
     1818          ycsv    = ( jcv(j) - ( jcs + moff ) ) * cg%dy
     1819          ycso    = ( jco(j) - ( jcs + moff ) + 0.5_wp ) * cg%dy
    17091820          r2yv(j) = ( yfsv - ycsv ) / cg%dy
    17101821          r2yo(j) = ( yfso - ycso ) / cg%dy
     
    17121823          r1yo(j) = 1.0_wp - r2yo(j)
    17131824       ENDDO
     1825!       
     1826!--    Fill up the values behind nest boundaries by copying from inside
     1827!--    the domain.
     1828       IF  ( bc_dirichlet_s )  THEN
     1829          jcv(nysfc:nys-1)  = jcv(nysfc+jgsr:nys-1+jgsr) - 1
     1830          r1yv(nysfc:nys-1) = r1yv(nysfc+jgsr:nys-1+jgsr)
     1831          r2yv(nysfc:nys-1) = r2yv(nysfc+jgsr:nys-1+jgsr)
     1832          jco(nysfc:nys-1)  = jco(nysfc+jgsr:nys-1+jgsr) - 1
     1833          r1yo(nysfc:nys-1) = r1yo(nysfc+jgsr:nys-1+jgsr)
     1834          r2yo(nysfc:nys-1) = r2yo(nysfc+jgsr:nys-1+jgsr)
     1835       ENDIF
     1836       
     1837       IF  ( bc_dirichlet_n )  THEN
     1838          jcv(nyn+1:nynfc)  = jcv(nyn+1-jgsr:nynfc-jgsr) + 1
     1839          r1yv(nyn+1:nynfc) = r1yv(nyn+1-jgsr:nynfc-jgsr)
     1840          r2yv(nyn+1:nynfc) = r2yv(nyn+1-jgsr:nynfc-jgsr)
     1841          jco(nyn+1:nynfc)  = jco(nyn+1-jgsr:nynfc-jgsr) + 1
     1842          r1yo(nyn+1:nynfc) = r1yo(nyn+1-jgsr:nynfc-jgsr)
     1843          r2yo(nyn+1:nynfc) = r2yo(nyn+1-jgsr:nynfc-jgsr)
     1844       ENDIF
     1845!
     1846!--    Print out the indices and coefficients for checking and debugging purposes
     1847       DO  j = nysfc, nynfc
     1848          WRITE(9,"('pmci_init_interp_tril: j, jcv, r1yv r2yv ', 2(i4,2x),2(e12.5,2x))") &
     1849               j, jcv(j), r1yv(j), r2yv(j)
     1850          FLUSH(9)
     1851       ENDDO
     1852       WRITE(9,*)
     1853       DO  j = nysfc, nynfc
     1854          WRITE(9,"('pmci_init_interp_tril: j, jco, r1yo r2yo ', 2(i4,2x),2(e12.5,2x))") &
     1855               j, jco(j), r1yo(j), r2yo(j)
     1856          FLUSH(9)
     1857       ENDDO
     1858       WRITE(9,*)
    17141859
    17151860       DO  k = nzb, nzt + 1
     
    17361881          r1zo(k) = 1.0_wp - r2zo(k)
    17371882       ENDDO
     1883!
     1884!--    Set the interpolation index- and coefficient-information to the
     1885!--    child-grid cells within the uppermost parent-grid cell. This
     1886!--    information is only needed for the reversibility correction.   
     1887       kco(nzt+2:nzt+kgsr)  = kco(nzt+1) + 1
     1888       r1zo(nzt+2:nzt+kgsr) = r1zo(nzt+2-kgsr:nzt)
     1889       r2zo(nzt+2:nzt+kgsr) = r2zo(nzt+2-kgsr:nzt)
     1890!
     1891!--    kcw, r1zw and r2zw are not needed when k > nzt+1
     1892       kcw(nzt+2:nzt+kgsr)  = 0
     1893       r1zw(nzt+2:nzt+kgsr) = 0.0_wp
     1894       r2zw(nzt+2:nzt+kgsr) = 0.0_wp
     1895!
     1896!--    Print out the indices and coefficients for checking and debugging purposes
     1897       DO  k = nzb, nzt+1
     1898          WRITE(9,"('pmci_init_interp_tril: k, kcw, r1zw r2zw ', 2(i4,2x),2(e12.5,2x))") &
     1899               k, kcw(k), r1zw(k), r2zw(k)
     1900          FLUSH(9)
     1901       ENDDO
     1902       WRITE(9,*)
     1903       DO  k = nzb, nzt + kgsr
     1904          WRITE(9,"('pmci_init_interp_tril: k, kco, r1zo r2zo ', 2(i4,2x),2(e12.5,2x))") &
     1905               k, kco(k), r1zo(k), r2zo(k)
     1906          FLUSH(9)
     1907       ENDDO
     1908       WRITE(9,*)
    17381909!
    17391910!--    Determine the maximum dimension of anterpolation cells and allocate the
     
    17511922            CEILING( parentdzmax / dzmin )
    17521923       ALLOCATE( celltmpd(1:acsize) )
    1753 !       write(9,"('acsize: ',i3,2(e12.5,2x))") acsize, dzmin, parentdzmax
    17541924     
    17551925    END SUBROUTINE pmci_init_interp_tril
    1756 
    1757 
    1758 
     1926   
     1927
     1928
     1929    SUBROUTINE pmci_allocate_finegrid_workarrays
     1930!
     1931!--    Allocate child-grid work-arrays for interpolation
     1932       IMPLICIT NONE
     1933
     1934
     1935       igsr = NINT( cg%dx / dx, iwp )
     1936       jgsr = NINT( cg%dy / dy, iwp )
     1937       kgsr = NINT( cg%dzu(cg%nz+1) / dzu(nzt+1), iwp )
     1938       write(9,"('igsr, jgsr, kgsr: ',3(i3,2x))") igsr, jgsr, kgsr
     1939       flush(9)
     1940!       
     1941!--    Note that i-indexing for workarr_lr runs from 0 to igsr-1.
     1942!--    For u, only 0-element is used and all elements 0:igsr-1
     1943!--    are used for all other variables.
     1944       ALLOCATE( workarr_lr(nzb:nzt+1,nysg:nyng,0:igsr-1) )
     1945!       
     1946!--    Note that j-indexing for workarr_sn runs from 0 to jgsr-1.
     1947!--    For v, only 0-element is used and all elements 0:jgsr-1
     1948!--    are used for all other variables.
     1949       ALLOCATE( workarr_sn(nzb:nzt+1,0:jgsr-1,nxlg:nxrg) )
     1950!
     1951!--    Note that genuine k-indexing is used for workarr_t.
     1952!--    Only nzt-element is used for w and elements nzt+1:nzt+kgsr
     1953!--    are used for all other variables.
     1954       ALLOCATE( workarr_t(nzt:nzt+kgsr,nysg:nyng,nxlg:nxrg) )
     1955
     1956    END SUBROUTINE pmci_allocate_finegrid_workarrays
     1957
     1958
     1959
     1960    SUBROUTINE pmci_allocate_coarsegrid_workarrays
     1961!
     1962!--    Allocate parent-grid work-arrays for interpolation
     1963       IMPLICIT NONE
     1964
     1965!
     1966!--    Determine and store the PE-subdomain dependent index bounds
     1967       IF  ( bc_dirichlet_l )  THEN
     1968          iclw = icl + 1
     1969       ELSE
     1970          iclw = icl - 1
     1971       ENDIF
     1972
     1973       IF  ( bc_dirichlet_r )  THEN
     1974          icrw = icr - 1
     1975       ELSE
     1976          icrw = icr + 1
     1977       ENDIF
     1978
     1979       IF  ( bc_dirichlet_s )  THEN
     1980          jcsw = jcs + 1
     1981       ELSE
     1982          jcsw = jcs - 1
     1983       ENDIF
     1984
     1985       IF  ( bc_dirichlet_n )  THEN
     1986          jcnw = jcn - 1
     1987       ELSE
     1988          jcnw = jcn + 1
     1989       ENDIF
     1990   
     1991       coarse_bound_w(1) = iclw
     1992       coarse_bound_w(2) = icrw
     1993       coarse_bound_w(3) = jcsw
     1994       coarse_bound_w(4) = jcnw
     1995!
     1996!--    Left and right boundaries.
     1997       ALLOCATE( workarrc_lr(0:cg%nz+1,jcsw:jcnw,0:2) )
     1998!
     1999!--    South and north boundaries.
     2000       ALLOCATE( workarrc_sn(0:cg%nz+1,0:2,iclw:icrw) )
     2001!
     2002!--    Top boundary.
     2003       ALLOCATE( workarrc_t(0:2,jcsw:jcnw,iclw:icrw) )
     2004
     2005    END SUBROUTINE pmci_allocate_coarsegrid_workarrays
     2006
     2007
     2008
     2009    SUBROUTINE pmci_create_coarsegrid_workarray_exchange_datatypes
     2010!
     2011!--    Define specific MPI types for workarrc-exhchange.
     2012       IMPLICIT NONE
     2013
     2014#if defined( __parallel )       
     2015!
     2016!--    For the left and right boundaries
     2017       CALL MPI_TYPE_VECTOR( 3, cg%nz+2, (jcnw-jcsw+1)*(cg%nz+2), MPI_REAL,     &
     2018            workarrc_lr_exchange_type, ierr )
     2019       CALL MPI_TYPE_COMMIT( workarrc_lr_exchange_type, ierr )
     2020!
     2021!--    For the south and north boundaries
     2022       CALL MPI_TYPE_VECTOR( 1, 3*(cg%nz+2), 3*(cg%nz+2), MPI_REAL,             &
     2023            workarrc_sn_exchange_type, ierr )
     2024       CALL MPI_TYPE_COMMIT( workarrc_sn_exchange_type, ierr )
     2025!
     2026!--    For the top-boundary x-slices
     2027       CALL MPI_TYPE_VECTOR( icrw-iclw+1, 3, 3*(jcnw-jcsw+1), MPI_REAL,         &
     2028            workarrc_t_exchange_type_x, ierr )
     2029       CALL MPI_TYPE_COMMIT( workarrc_t_exchange_type_x, ierr )
     2030!
     2031!--    For the top-boundary y-slices
     2032       CALL MPI_TYPE_VECTOR( 1, 3*(jcnw-jcsw+1), 3*(jcnw-jcsw+1), MPI_REAL,         &
     2033            workarrc_t_exchange_type_y, ierr )
     2034       CALL MPI_TYPE_COMMIT( workarrc_t_exchange_type_y, ierr )
     2035#endif
     2036       
     2037    END SUBROUTINE pmci_create_coarsegrid_workarray_exchange_datatypes
     2038
     2039
     2040
     2041    SUBROUTINE pmci_allocate_fine_to_coarse_mapping_arrays
     2042!
     2043!--    Define index limits and allocate the fine-to-coarse grid index mapping
     2044!--    arrays and interpolation coefficient arrays.     
     2045       IMPLICIT NONE
     2046
     2047       
     2048       IF  ( bc_dirichlet_l )  THEN
     2049!AH          nxlfc = MIN( nxl-igsr, nxlg )         
     2050          nxlfc = nxl - igsr
     2051       ELSE
     2052!AH          nxlfc = nxlg
     2053          nxlfc = nxl - 1
     2054       ENDIF
     2055       IF  ( bc_dirichlet_r )  THEN
     2056!AH          nxrfc = MAX( nxr+igsr, nxrg )
     2057          nxrfc = nxr + igsr
     2058       ELSE
     2059!AH          nxrfc = nxrg
     2060          nxrfc = nxr + 1         
     2061       ENDIF
     2062
     2063       IF  ( bc_dirichlet_s )  THEN
     2064!AH          nysfc = MIN( nys-jgsr, nysg )
     2065          nysfc = nys - jgsr
     2066       ELSE
     2067!AH          nysfc = nysg
     2068          nysfc = nys - 1
     2069       ENDIF
     2070       IF  ( bc_dirichlet_n )  THEN
     2071!AH          nynfc = MAX( nyn+jgsr, nyng )
     2072          nynfc = nyn + jgsr
     2073       ELSE
     2074!AH          nynfc = nyng         
     2075          nynfc = nyn + 1         
     2076       ENDIF
     2077
     2078       ALLOCATE( icu(nxlfc:nxrfc) )       
     2079       ALLOCATE( ico(nxlfc:nxrfc) )
     2080       ALLOCATE( jcv(nysfc:nynfc) )
     2081       ALLOCATE( jco(nysfc:nynfc) )
     2082       ALLOCATE( kcw(nzb:nzt+kgsr) )
     2083       ALLOCATE( kco(nzb:nzt+kgsr) )
     2084
     2085       ALLOCATE( r1xu(nxlfc:nxrfc) )
     2086       ALLOCATE( r2xu(nxlfc:nxrfc) )
     2087       ALLOCATE( r1xo(nxlfc:nxrfc) )
     2088       ALLOCATE( r2xo(nxlfc:nxrfc) )
     2089       ALLOCATE( r1yv(nysfc:nynfc) )
     2090       ALLOCATE( r2yv(nysfc:nynfc) )
     2091       ALLOCATE( r1yo(nysfc:nynfc) )
     2092       ALLOCATE( r2yo(nysfc:nynfc) )
     2093       ALLOCATE( r1zw(nzb:nzt+kgsr) )
     2094       ALLOCATE( r2zw(nzb:nzt+kgsr) )
     2095       ALLOCATE( r1zo(nzb:nzt+kgsr) )
     2096       ALLOCATE( r2zo(nzb:nzt+kgsr) )
     2097
     2098    END SUBROUTINE pmci_allocate_fine_to_coarse_mapping_arrays
     2099
     2100     
     2101       
    17592102    SUBROUTINE pmci_init_loglaw_correction
    17602103!
     
    30923435       INTEGER(iwp) ::  istart   !<
    30933436       INTEGER(iwp) ::  ir       !<
     3437       INTEGER(iwp) ::  iw       !< Fine-grid index limited to -1 <= iw <= nx+1
    30943438       INTEGER(iwp) ::  j        !< Fine-grid index
    30953439       INTEGER(iwp) ::  jj       !< Coarse-grid index
    30963440       INTEGER(iwp) ::  jstart   !<
    30973441       INTEGER(iwp) ::  jr       !<
     3442       INTEGER(iwp) ::  jw       !< Fine-grid index limited to -1 <= jw <= ny+1
    30983443       INTEGER(iwp) ::  k        !< Fine-grid index
    30993444       INTEGER(iwp) ::  kk       !< Coarse-grid index
    31003445       INTEGER(iwp) ::  kstart   !<
     3446       INTEGER(iwp) ::  kw       !< Fine-grid index limited to kw <= nzt+1
    31013447       REAL(wp)     ::  xi       !<
    31023448       REAL(wp)     ::  eta      !<
     
    31223468       ENDIF
    31233469!
    3124 !--    First determine kcto and kctw that are the coarse-grid upper bounds for
    3125 !--    index k
     3470!--    First determine kcto and kctw which refer to the uppermost
     3471!--    coarse-grid levels below the child top-boundary level.
    31263472       kk = 0
    31273473       DO  WHILE ( cg%zu(kk) <= zu(nzt) )
     
    31353481       ENDDO
    31363482       kctw = kk - 1
    3137 
    3138        ALLOCATE( iflu(icl:icr) )
    3139        ALLOCATE( iflo(icl:icr) )
    3140        ALLOCATE( ifuu(icl:icr) )
    3141        ALLOCATE( ifuo(icl:icr) )
    3142        ALLOCATE( jflv(jcs:jcn) )
    3143        ALLOCATE( jflo(jcs:jcn) )
    3144        ALLOCATE( jfuv(jcs:jcn) )
    3145        ALLOCATE( jfuo(jcs:jcn) )
     3483!AH
     3484       write(9,"('kcto, kctw = ', 2(i3,2x))") kcto, kctw
     3485
     3486!AH
     3487!       ALLOCATE( iflu(icl:icr) )
     3488!       ALLOCATE( iflo(icl:icr) )
     3489!       ALLOCATE( ifuu(icl:icr) )
     3490!       ALLOCATE( ifuo(icl:icr) )
     3491!       ALLOCATE( jflv(jcs:jcn) )
     3492!       ALLOCATE( jflo(jcs:jcn) )
     3493!       ALLOCATE( jfuv(jcs:jcn) )
     3494!       ALLOCATE( jfuo(jcs:jcn) )
     3495!       
     3496!       ALLOCATE( iflu(icl-1:icr+1) )
     3497!       ALLOCATE( iflo(icl-1:icr+1) )
     3498!       ALLOCATE( ifuu(icl-1:icr+1) )
     3499!       ALLOCATE( ifuo(icl-1:icr+1) )
     3500!       ALLOCATE( jflv(jcs-1:jcn+1) )
     3501!       ALLOCATE( jflo(jcs-1:jcn+1) )
     3502!       ALLOCATE( jfuv(jcs-1:jcn+1) )
     3503!       ALLOCATE( jfuo(jcs-1:jcn+1) )
     3504!
     3505       icla = coarse_bound_aux(1)
     3506       icra = coarse_bound_aux(2)
     3507       jcsa = coarse_bound_aux(3)
     3508       jcna = coarse_bound_aux(4)
     3509       ALLOCATE( iflu(icla:icra) )
     3510       ALLOCATE( iflo(icla:icra) )
     3511       ALLOCATE( ifuu(icla:icra) )
     3512       ALLOCATE( ifuo(icla:icra) )
     3513       ALLOCATE( jflv(jcsa:jcna) )
     3514       ALLOCATE( jflo(jcsa:jcna) )
     3515       ALLOCATE( jfuv(jcsa:jcna) )
     3516       ALLOCATE( jfuo(jcsa:jcna) )       
     3517!AH
    31463518       ALLOCATE( kflw(0:cg%nz+1) )
    31473519       ALLOCATE( kflo(0:cg%nz+1) )
    31483520       ALLOCATE( kfuw(0:cg%nz+1) )
    31493521       ALLOCATE( kfuo(0:cg%nz+1) )
    3150 
    3151        ALLOCATE( ijkfc_u(0:cg%nz+1,jcs:jcn,icl:icr) )
    3152        ALLOCATE( ijkfc_v(0:cg%nz+1,jcs:jcn,icl:icr) )
    3153        ALLOCATE( ijkfc_w(0:cg%nz+1,jcs:jcn,icl:icr) )
    3154        ALLOCATE( ijkfc_s(0:cg%nz+1,jcs:jcn,icl:icr) )
     3522!AH
     3523!       ALLOCATE( ijkfc_u(0:cg%nz+1,jcs:jcn,icl:icr) )
     3524!       ALLOCATE( ijkfc_v(0:cg%nz+1,jcs:jcn,icl:icr) )
     3525!       ALLOCATE( ijkfc_w(0:cg%nz+1,jcs:jcn,icl:icr) )
     3526!       ALLOCATE( ijkfc_s(0:cg%nz+1,jcs:jcn,icl:icr) )
     3527!
     3528!       ALLOCATE( ijkfc_u(0:cg%nz+1,jcs-1:jcn+1,icl-1:icr+1) )
     3529!       ALLOCATE( ijkfc_v(0:cg%nz+1,jcs-1:jcn+1,icl-1:icr+1) )
     3530!       ALLOCATE( ijkfc_w(0:cg%nz+1,jcs-1:jcn+1,icl-1:icr+1) )
     3531!       ALLOCATE( ijkfc_s(0:cg%nz+1,jcs-1:jcn+1,icl-1:icr+1) )
     3532!
     3533       ALLOCATE( ijkfc_u(0:cg%nz+1,jcsa:jcna,icla:icra) )
     3534       ALLOCATE( ijkfc_v(0:cg%nz+1,jcsa:jcna,icla:icra) )
     3535       ALLOCATE( ijkfc_w(0:cg%nz+1,jcsa:jcna,icla:icra) )
     3536       ALLOCATE( ijkfc_s(0:cg%nz+1,jcsa:jcna,icla:icra) )
     3537!AH
    31553538
    31563539       ijkfc_u = 0
     
    31633546       tolerance = 0.000001_wp * dx
    31643547       istart = nxlg
    3165        DO  ii = icl, icr-1
     3548!AH       DO  ii = icl, icr
     3549!AH       DO  ii = icl-1, icr+1
     3550          DO  ii = icla, icra
     3551
    31663552!
    31673553!--       In case the child and parent grid lines match in x
     
    31963582             istart = iflu(ii)
    31973583          ENDIF
    3198 !AH
     3584!
     3585!--       Print out the index bounds for checking and debugging purposes
    31993586          write(9,"('pmci_init_anterp_tophat, ii, iflu, ifuu: ', 3(i4,2x))")    &
    32003587               ii, iflu(ii), ifuu(ii)
     
    32023589
    32033590       ENDDO
    3204        iflu(icr) = nxrg
    3205        ifuu(icr) = nxrg
     3591       write(9,*)
    32063592!
    32073593!--    i-indices of others for each ii-index value
    32083594!--    ii=icr is redundant for anterpolation
    32093595       istart = nxlg
    3210        DO  ii = icl, icr-1
     3596!AH       DO  ii = icl, icr
     3597!AH       DO  ii = icl-1, icr+1
     3598       DO  ii = icla, icra
    32113599          i = istart
    32123600          DO  WHILE ( ( coord_x(i) + 0.5_wp * dx < cg%coord_x(ii) )  .AND.     &
     
    32233611          ifuo(ii) = MIN( MAX( i-1, iflo(ii) ), nxrg )
    32243612          istart = iflo(ii)
     3613!
     3614!--       Print out the index bounds for checking and debugging purposes
     3615          write(9,"('pmci_init_anterp_tophat, ii, iflo, ifuo: ', 3(i4,2x))")    &
     3616               ii, iflo(ii), ifuo(ii)
     3617          flush(9)
    32253618       ENDDO
    3226 !AH
    3227        write(9,"('pmci_init_anterp_tophat, ii, iflo, ifuo: ', 3(i4,2x))")    &
    3228             ii, iflo(ii), ifuo(ii)
    3229        flush(9)
    3230          
    3231        iflo(icr) = nxrg
    3232        ifuo(icr) = nxrg
     3619       write(9,*)
    32333620!
    32343621!--    j-indices of v for each jj-index value
     
    32363623       tolerance = 0.000001_wp * dy
    32373624       jstart = nysg
    3238        DO  jj = jcs, jcn-1
     3625!AH       DO  jj = jcs, jcn
     3626!AH       DO  jj = jcs-1, jcn+1
     3627       DO  jj = jcsa, jcna
    32393628!
    32403629!--       In case the child and parent grid lines match in y
     
    32693658             jstart = jflv(jj)
    32703659          ENDIF
    3271 !AH
     3660!
     3661!--       Print out the index bounds for checking and debugging purposes
    32723662          write(9,"('pmci_init_anterp_tophat, jj, jflv, jfuv: ', 3(i4,2x))")    &
    32733663               jj, jflv(jj), jfuv(jj)
    32743664          flush(9)
    3275 
    32763665       ENDDO
    3277        jflv(jcn) = nyng
    3278        jfuv(jcn) = nyng
     3666       write(9,*)
    32793667!
    32803668!--    j-indices of others for each jj-index value
    32813669!--    jj=jcn is redundant for anterpolation
    32823670       jstart = nysg
    3283        DO  jj = jcs, jcn-1
     3671!AH       DO  jj = jcs, jcn
     3672!AH       DO  jj = jcs-1, jcn+1
     3673       DO  jj = jcsa, jcna
    32843674          j = jstart
    32853675          DO  WHILE ( ( coord_y(j) + 0.5_wp * dy < cg%coord_y(jj) )  .AND.     &
     
    32963686          jfuo(jj) = MIN( MAX( j-1, jflo(jj) ), nyng )
    32973687          jstart = jflo(jj)
    3298 !AH
    3299           write(9,"('pmci_init_anterp_tophat, ii, jflo, jfuo: ', 3(i4,2x))")    &
     3688!
     3689!--       Print out the index bounds for checking and debugging purposes
     3690          write(9,"('pmci_init_anterp_tophat, jj, jflo, jfuo: ', 3(i4,2x))")    &
    33003691               jj, jflo(jj), jfuo(jj)
    33013692          flush(9)
    3302 
    33033693       ENDDO
    3304        jflo(jcn) = nyng
    3305        jfuo(jcn) = nyng
     3694       write(9,*)
    33063695!
    33073696!--    k-indices of w for each kk-index value
     
    33473736          ENDIF
    33483737!AH
    3349           write(9,"('pmci_init_anterp_tophat, kk, kflw, kfuw: ', 3(i4,2x))") &
    3350                kk, kflw(kk), kfuw(kk)
     3738          write(9,"('pmci_init_anterp_tophat, kk, kflw, kfuw: ', 4(i4,2x), 2(e12.5,2x))") &
     3739               kk, kflw(kk), kfuw(kk), nzt,  cg%zu(kk), cg%zw(kk)
    33513740          flush(9)
    3352 
    33533741       ENDDO
     3742       write(9,*)
    33543743!
    33553744!--    k-indices of others for each kk-index value
     
    33603749!--    Note that anterpolation index limits are needed also for the top boundary
    33613750!--    ghost cell level because of the reversibility correction in the interpolation.
    3362 !AH       DO  kk = 1, kcto+1
    33633751       DO  kk = 1, cg%nz+1
    33643752          k = kstart
    3365 !AH          DO  WHILE ( ( zu(k) < cg%zw(kk-1) )  .AND.  ( k < nzt ) )
    3366 !--       Note that this is an IMPORTANT correction for the reversibility correction
    33673753          DO  WHILE ( ( zu(k) < cg%zw(kk-1) )  .AND.  ( k <= nzt ) )
    33683754             k = k + 1
    33693755          ENDDO
    33703756          kflo(kk) = MIN( MAX( k, 1 ), nzt + 1 )
    3371 !AH          DO  WHILE ( ( zu(k) <= cg%zw(kk) )  .AND.  ( k < nzt+1 ) )
    3372 !--       Note that this is an IMPORTANT correction for the reversibility correction
    33733757          DO  WHILE ( ( zu(k) <= cg%zw(kk) )  .AND.  ( k <= nzt+1 ) )
    33743758             k = k + 1
     
    33773761          kfuo(kk) = MIN( MAX( k-1, kflo(kk) ), nzt + 1 )
    33783762          kstart = kflo(kk)
    3379 !AH
    3380           write(9,"('init kflo, kfuo: ', 4(i3,2x), e12.5)") kk, kflo(kk), kfuo(kk), nzt,  cg%zw(kk)
     3763       ENDDO
     3764!
     3765!--    Set the k-index bounds separately for the parent-grid cells cg%nz and cg%nz+1.
     3766!--    Index bounds for cg%nz are needed for the reversibility correction.
     3767       kflo(cg%nz)   = nzt+1    ! Needed for the reversibility correction
     3768       kfuo(cg%nz)   = nzt+kgsr ! Needed for the reversibility correction
     3769       kflo(cg%nz+1) = nzt+kgsr ! Obsolete
     3770       kfuo(cg%nz+1) = nzt+kgsr ! Obsolete
     3771
     3772       DO  kk = 1, cg%nz+1
     3773          write(9,"('pmci_init_anterp_tophat, kk, kflo, kfuo: ', 4(i4,2x), 2(e12.5,2x))") &
     3774               kk, kflo(kk), kfuo(kk), nzt,  cg%zu(kk), cg%zw(kk)
    33813775          flush(9)
    33823776       ENDDO
     3777       write(9,*)
     3778!AH
     3779
    33833780!
    33843781!--    Precomputation of number of fine-grid nodes inside parent-grid cells.
    33853782!--    Note that ii, jj, and kk are parent-grid indices.
    3386 !--    This information is needed in anterpolation.
    3387        DO  ii = icl, icr
    3388           DO  jj = jcs, jcn
    3389 !AH             DO kk = 0, kcto+1
     3783!--    This information is needed in anterpolation and in reversibility
     3784!--    correction in interpolation. For the reversibility correction, ijkfc-
     3785!--    information is needed also beyond the indices for wall_flags_0-masking
     3786!--    must be modified here in the boundary-normal direction (iw, jw, kw).
     3787!AH       DO  ii = icl, icr
     3788!AH          DO  jj = jcs, jcn
     3789!AH       DO  ii = icl-1, icr+1
     3790!AH          DO  jj = jcs-1, jcn+1
     3791       DO  ii = icla, icra
     3792          DO  jj = jcsa, jcna
    33903793             DO kk = 0, cg%nz+1
    33913794!
    33923795!--             u-component
    33933796                DO  i = iflu(ii), ifuu(ii)
     3797                   iw = MAX( MIN( i, nx+1 ), -1 )
    33943798                   DO  j = jflo(jj), jfuo(jj)
     3799                      jw = MAX( MIN( j, ny+1 ), -1 )
    33953800                      DO  k = kflo(kk), kfuo(kk)
    3396                          ijkfc_u(kk,jj,ii) = ijkfc_u(kk,jj,ii) + MERGE( 1, 0,  &
    3397                                             BTEST( wall_flags_0(k,j,i), 1 ) )
     3801                         kw = MIN( k, nzt+1 )               
     3802                         ijkfc_u(kk,jj,ii) = ijkfc_u(kk,jj,ii)                  &
     3803                              + MERGE( 1, 0, BTEST( wall_flags_0(kw,jw,iw), 1 ) )
    33983804                      ENDDO
    33993805                   ENDDO
     
    34023808!--             v-component
    34033809                DO  i = iflo(ii), ifuo(ii)
     3810                   iw = MAX( MIN( i, nx+1 ), -1 )
    34043811                   DO  j = jflv(jj), jfuv(jj)
     3812                      jw = MAX( MIN( j, ny+1 ), -1 )
    34053813                      DO  k = kflo(kk), kfuo(kk)
    3406                          ijkfc_v(kk,jj,ii) = ijkfc_v(kk,jj,ii) + MERGE( 1, 0,  &
    3407                                             BTEST( wall_flags_0(k,j,i), 2 ) )
     3814                         kw = MIN( k, nzt+1 )                                       
     3815                         ijkfc_v(kk,jj,ii) = ijkfc_v(kk,jj,ii)                  &
     3816                              + MERGE( 1, 0, BTEST( wall_flags_0(kw,jw,iw), 2 ) )
    34083817                      ENDDO
    34093818                   ENDDO
     
    34123821!--             scalars
    34133822                DO  i = iflo(ii), ifuo(ii)
     3823                   iw = MAX( MIN( i, nx+1 ), -1 )
    34143824                   DO  j = jflo(jj), jfuo(jj)
     3825                      jw = MAX( MIN( j, ny+1 ), -1 )
    34153826                      DO  k = kflo(kk), kfuo(kk)
    3416                          ijkfc_s(kk,jj,ii) = ijkfc_s(kk,jj,ii) + MERGE( 1, 0,  &
    3417                                             BTEST( wall_flags_0(k,j,i), 0 ) )
     3827                         kw = MIN( k, nzt+1 )
     3828                         ijkfc_s(kk,jj,ii) = ijkfc_s(kk,jj,ii)                  &
     3829                              + MERGE( 1, 0, BTEST( wall_flags_0(kw,jw,iw), 0 ) )
    34183830                      ENDDO
    34193831                   ENDDO
    34203832                ENDDO
    3421              ENDDO
    3422 
    3423 !AH             DO kk = 0, kctw+1
    3424              DO kk = 0, cg%nz+1
    34253833!
    34263834!--             w-component
    34273835                DO  i = iflo(ii), ifuo(ii)
     3836                   iw = MAX( MIN( i, nx+1 ), -1 )
    34283837                   DO  j = jflo(jj), jfuo(jj)
     3838                      jw = MAX( MIN( j, ny+1 ), -1 )
    34293839                      DO  k = kflw(kk), kfuw(kk)
    3430                          ijkfc_w(kk,jj,ii) = ijkfc_w(kk,jj,ii) + MERGE( 1, 0,  &
    3431                                             BTEST( wall_flags_0(k,j,i), 3 ) )
     3840                         kw = MIN( k, nzt+1 )
     3841                         ijkfc_w(kk,jj,ii) = ijkfc_w(kk,jj,ii) + MERGE( 1, 0,   &
     3842                              BTEST( wall_flags_0(kw,jw,iw), 3 ) )
    34323843                      ENDDO
    34333844                   ENDDO
    34343845                ENDDO
    3435              ENDDO
    3436        
    3437           ENDDO
    3438        ENDDO
     3846
     3847             ENDDO  ! kk       
     3848          ENDDO  ! jj
     3849       ENDDO  ! ii
    34393850!
    34403851!--    Spatial under-relaxation coefficients
     
    34453856       fray(jcs:jcn) = 1.0_wp
    34463857
    3447        IF ( nesting_mode /= 'vertical' )  THEN
    3448           DO  ii = icl, icr
    3449              IF ( ifuu(ii) < ( nx + 1 ) / 2 )  THEN   
    3450                 xi = ( MAX( 0.0_wp, ( cg%coord_x(ii) -                         &
    3451                      lower_left_coord_x ) ) / anterp_relax_length_l )**4
    3452                 frax(ii) = xi / ( 1.0_wp + xi )
    3453              ELSE
    3454                 xi = ( MAX( 0.0_wp, ( lower_left_coord_x + ( nx + 1 ) * dx -   &
    3455                                       cg%coord_x(ii) ) ) /                     &
    3456                        anterp_relax_length_r )**4
    3457                 frax(ii) = xi / ( 1.0_wp + xi )               
    3458              ENDIF
    3459           ENDDO
    3460 
    3461           DO  jj = jcs, jcn
    3462              IF ( jfuv(jj) < ( ny + 1 ) / 2 )  THEN
    3463                 eta = ( MAX( 0.0_wp, ( cg%coord_y(jj) -                        &
    3464                      lower_left_coord_y ) ) / anterp_relax_length_s )**4
    3465                 fray(jj) = eta / ( 1.0_wp + eta )
    3466              ELSE
    3467                 eta = ( MAX( 0.0_wp, ( lower_left_coord_y + ( ny + 1 ) * dy -  &
    3468                                        cg%coord_y(jj)) ) /                     &
    3469                         anterp_relax_length_n )**4
    3470                 fray(jj) = eta / ( 1.0_wp + eta )
    3471              ENDIF
    3472           ENDDO
    3473        ENDIF
     3858!AH       IF ( nesting_mode /= 'vertical' )  THEN
     3859!AH          DO  ii = icl, icr
     3860!AH             IF ( ifuu(ii) < ( nx + 1 ) / 2 )  THEN   
     3861!AH                xi = ( MAX( 0.0_wp, ( cg%coord_x(ii) -                         &
     3862!AH                     lower_left_coord_x ) ) / anterp_relax_length_l )**4
     3863!AH                frax(ii) = xi / ( 1.0_wp + xi )
     3864!AH             ELSE
     3865!AH                xi = ( MAX( 0.0_wp, ( lower_left_coord_x + ( nx + 1 ) * dx -   &
     3866!AH                                      cg%coord_x(ii) ) ) /                     &
     3867!AH                       anterp_relax_length_r )**4
     3868!AH                frax(ii) = xi / ( 1.0_wp + xi )               
     3869!AH             ENDIF
     3870!AH          ENDDO
     3871!AH
     3872!AH          DO  jj = jcs, jcn
     3873!AH             IF ( jfuv(jj) < ( ny + 1 ) / 2 )  THEN
     3874!AH                eta = ( MAX( 0.0_wp, ( cg%coord_y(jj) -                        &
     3875!AH                     lower_left_coord_y ) ) / anterp_relax_length_s )**4
     3876!AH                fray(jj) = eta / ( 1.0_wp + eta )
     3877!AH             ELSE
     3878!AH                eta = ( MAX( 0.0_wp, ( lower_left_coord_y + ( ny + 1 ) * dy -  &
     3879!AH                                       cg%coord_y(jj)) ) /                     &
     3880!AH                        anterp_relax_length_n )**4
     3881!AH                fray(jj) = eta / ( 1.0_wp + eta )
     3882!AH             ENDIF
     3883!AH          ENDDO
     3884!AH       ENDIF
    34743885     
    34753886       ALLOCATE( fraz(0:kcto) )
    3476        DO  kk = 0, kcto
    3477           zeta = ( ( zu(nzt) - cg%zu(kk) ) / anterp_relax_length_t )**4
    3478           fraz(kk) = zeta / ( 1.0_wp + zeta )
    3479        ENDDO
     3887       fraz(0:kcto) = 1.0_wp
     3888!AH       DO  kk = 0, kcto
     3889!AH          zeta = ( ( zu(nzt) - cg%zu(kk) ) / anterp_relax_length_t )**4
     3890!AH          fraz(kk) = zeta / ( 1.0_wp + zeta )
     3891!AH       ENDDO
    34803892
    34813893    END SUBROUTINE pmci_init_anterp_tophat
    3482 
    3483 
    3484 
    3485     SUBROUTINE pmci_init_tkefactor
    3486 
    3487 !
    3488 !--    Computes the scaling factor for the SGS TKE from coarse grid to be used
    3489 !--    as BC for the fine grid. Based on the Kolmogorov energy spectrum
    3490 !--    for the inertial subrange and assumption of sharp cut-off of the resolved
    3491 !--    energy spectrum. Near the surface, the reduction of TKE is made
    3492 !--    smaller than further away from the surface.
    3493 !--    Please note, in case parent and child model operate in RANS mode,
    3494 !--    TKE is not grid depenedent and weighting factor is one.
    3495 
    3496        IMPLICIT NONE
    3497 
    3498        INTEGER(iwp)        ::  k                     !< index variable along z
    3499        INTEGER(iwp)        ::  k_wall                !< topography-top index along z
    3500        INTEGER(iwp)        ::  kc                    !<
    3501 
    3502        REAL(wp), PARAMETER ::  cfw = 0.2_wp          !<
    3503        REAL(wp), PARAMETER ::  c_tkef = 0.6_wp       !<
    3504        REAL(wp)            ::  fw                    !<
    3505        REAL(wp), PARAMETER ::  fw0 = 0.9_wp          !<
    3506        REAL(wp)            ::  glsf                  !<
    3507        REAL(wp)            ::  glsc                  !<
    3508        REAL(wp)            ::  height                !<
    3509        REAL(wp), PARAMETER ::  p13 = 1.0_wp/3.0_wp   !<
    3510        REAL(wp), PARAMETER ::  p23 = 2.0_wp/3.0_wp   !<       
    3511 
    3512 !
    3513        IF ( .NOT. rans_mode  .AND.  .NOT. rans_mode_parent )  THEN
    3514           IF ( bc_dirichlet_l )  THEN
    3515              ALLOCATE( tkefactor_l(nzb:nzt+1,nysg:nyng) )
    3516              tkefactor_l = 0.0_wp
    3517              i = nxl - 1
    3518              DO  j = nysg, nyng
    3519                 k_wall = get_topography_top_index_ji( j, i, 's' )
    3520 
    3521                 DO  k = k_wall + 1, nzt
    3522                    kc     = kco(k) + 1
    3523                    glsf   = ( dx * dy * dzu(k) )**p13
    3524                    glsc   = ( cg%dx * cg%dy *cg%dzu(kc) )**p13
    3525                    height = zu(k) - zu(k_wall)
    3526                    fw     = EXP( -cfw * height / glsf )
    3527                    tkefactor_l(k,j) = c_tkef * ( fw0 * fw + ( 1.0_wp - fw ) *      &
    3528                                                  ( glsf / glsc )**p23 )
    3529                 ENDDO
    3530                 tkefactor_l(k_wall,j) = c_tkef * fw0
    3531              ENDDO
    3532           ENDIF
    3533 
    3534           IF ( bc_dirichlet_r )  THEN
    3535              ALLOCATE( tkefactor_r(nzb:nzt+1,nysg:nyng) )
    3536              tkefactor_r = 0.0_wp
    3537              i = nxr + 1
    3538              DO  j = nysg, nyng
    3539                 k_wall = get_topography_top_index_ji( j, i, 's' )
    3540 
    3541                 DO  k = k_wall + 1, nzt
    3542                    kc     = kco(k) + 1
    3543                    glsf   = ( dx * dy * dzu(k) )**p13
    3544                    glsc   = ( cg%dx * cg%dy * cg%dzu(kc) )**p13
    3545                    height = zu(k) - zu(k_wall)
    3546                    fw     = EXP( -cfw * height / glsf )
    3547                    tkefactor_r(k,j) = c_tkef * ( fw0 * fw + ( 1.0_wp - fw ) *      &
    3548                                                  ( glsf / glsc )**p23 )
    3549                 ENDDO
    3550                 tkefactor_r(k_wall,j) = c_tkef * fw0
    3551              ENDDO
    3552           ENDIF
    3553 
    3554           IF ( bc_dirichlet_s )  THEN
    3555              ALLOCATE( tkefactor_s(nzb:nzt+1,nxlg:nxrg) )
    3556              tkefactor_s = 0.0_wp
    3557              j = nys - 1
    3558              DO  i = nxlg, nxrg
    3559                 k_wall = get_topography_top_index_ji( j, i, 's' )
    3560                
    3561                 DO  k = k_wall + 1, nzt
    3562    
    3563                    kc     = kco(k) + 1
    3564                    glsf   = ( dx * dy * dzu(k) )**p13
    3565                    glsc   = ( cg%dx * cg%dy * cg%dzu(kc) ) ** p13
    3566                    height = zu(k) - zu(k_wall)
    3567                    fw     = EXP( -cfw*height / glsf )
    3568                    tkefactor_s(k,i) = c_tkef * ( fw0 * fw + ( 1.0_wp - fw ) *      &
    3569                         ( glsf / glsc )**p23 )
    3570                 ENDDO
    3571                 tkefactor_s(k_wall,i) = c_tkef * fw0
    3572              ENDDO
    3573           ENDIF
    3574 
    3575           IF ( bc_dirichlet_n )  THEN
    3576              ALLOCATE( tkefactor_n(nzb:nzt+1,nxlg:nxrg) )
    3577              tkefactor_n = 0.0_wp
    3578              j = nyn + 1
    3579              DO  i = nxlg, nxrg
    3580                 k_wall = get_topography_top_index_ji( j, i, 's' )
    3581 
    3582                 DO  k = k_wall + 1, nzt
    3583 
    3584                    kc     = kco(k) + 1
    3585                    glsf   = ( dx * dy * dzu(k) )**p13
    3586                    glsc   = ( cg%dx * cg%dy * cg%dzu(kc) )**p13
    3587                    height = zu(k) - zu(k_wall)
    3588                    fw     = EXP( -cfw * height / glsf )
    3589                    tkefactor_n(k,i) = c_tkef * ( fw0 * fw + ( 1.0_wp - fw ) *     &
    3590                                                  ( glsf / glsc )**p23 )
    3591                 ENDDO
    3592                 tkefactor_n(k_wall,i) = c_tkef * fw0
    3593              ENDDO
    3594           ENDIF
    3595 
    3596           ALLOCATE( tkefactor_t(nysg:nyng,nxlg:nxrg) )
    3597           k = nzt
    3598 
    3599           DO  i = nxlg, nxrg
    3600              DO  j = nysg, nyng
    3601 !
    3602 !--             Determine vertical index for local topography top
    3603                 k_wall = get_topography_top_index_ji( j, i, 's' )
    3604 
    3605                 kc     = kco(k) + 1
    3606                 glsf   = ( dx * dy * dzu(k) )**p13
    3607                 glsc   = ( cg%dx * cg%dy * cg%dzu(kc) )**p13
    3608                 height = zu(k) - zu(k_wall)
    3609                 fw     = EXP( -cfw * height / glsf )
    3610                 tkefactor_t(j,i) = c_tkef * ( fw0 * fw + ( 1.0_wp - fw ) *        &
    3611                                               ( glsf / glsc )**p23 )
    3612              ENDDO
    3613           ENDDO
    3614 !
    3615 !--    RANS mode
    3616        ELSE
    3617           IF ( bc_dirichlet_l )  THEN
    3618              ALLOCATE( tkefactor_l(nzb:nzt+1,nysg:nyng) )
    3619              tkefactor_l = 1.0_wp
    3620           ENDIF
    3621           IF ( bc_dirichlet_r )  THEN
    3622              ALLOCATE( tkefactor_r(nzb:nzt+1,nysg:nyng) )
    3623              tkefactor_r = 1.0_wp
    3624           ENDIF
    3625           IF ( bc_dirichlet_s )  THEN
    3626              ALLOCATE( tkefactor_s(nzb:nzt+1,nxlg:nxrg) )
    3627              tkefactor_s = 1.0_wp
    3628           ENDIF
    3629           IF ( bc_dirichlet_n )  THEN
    3630              ALLOCATE( tkefactor_n(nzb:nzt+1,nxlg:nxrg) )
    3631              tkefactor_n = 1.0_wp
    3632           ENDIF
    3633 
    3634           ALLOCATE( tkefactor_t(nysg:nyng,nxlg:nxrg) )
    3635           tkefactor_t = 1.0_wp
    3636 
    3637        ENDIF
    3638      
    3639     END SUBROUTINE pmci_init_tkefactor
    36403894
    36413895#endif
     
    36673921#endif
    36683922 END SUBROUTINE pmci_setup_coordinates
    3669  
     3923
    36703924!------------------------------------------------------------------------------!
    36713925! Description:
     
    40294283    INTEGER(iwp) ::  i          !<
    40304284    INTEGER(iwp) ::  icl        !<
     4285    INTEGER(iwp) ::  icla       !<
     4286    INTEGER(iwp) ::  iclw       !<
    40314287    INTEGER(iwp) ::  icr        !<
     4288    INTEGER(iwp) ::  icra       !<
     4289    INTEGER(iwp) ::  icrw       !<
    40324290    INTEGER(iwp) ::  j          !<
    40334291    INTEGER(iwp) ::  jcn        !<
     4292    INTEGER(iwp) ::  jcna       !<
     4293    INTEGER(iwp) ::  jcnw       !<
    40344294    INTEGER(iwp) ::  jcs        !<
     4295    INTEGER(iwp) ::  jcsa       !<
     4296    INTEGER(iwp) ::  jcsw       !<
    40354297    INTEGER(iwp) ::  k          !<
    40364298    INTEGER(iwp) ::  n          !< running index for chemical species
     
    40434305!
    40444306!--    Child domain boundaries in the parent index space
    4045        icl = coarse_bound(1)
    4046        icr = coarse_bound(2)
    4047        jcs = coarse_bound(3)
    4048        jcn = coarse_bound(4)
     4307       icl  = coarse_bound(1)
     4308       icr  = coarse_bound(2)
     4309       jcs  = coarse_bound(3)
     4310       jcn  = coarse_bound(4)
     4311       icla = coarse_bound_aux(1)
     4312       icra = coarse_bound_aux(2)
     4313       jcsa = coarse_bound_aux(3)
     4314       jcna = coarse_bound_aux(4)
     4315       iclw = coarse_bound_w(1)
     4316       icrw = coarse_bound_w(2)
     4317       jcsw = coarse_bound_w(3)
     4318       jcnw = coarse_bound_w(4)
     4319
    40494320!
    40504321!--    Get data from the parent
     
    40524323!
    40534324!--    The interpolation.
    4054        CALL pmci_interp_tril_all ( u,  uc,  icu, jco, kco, r1xu, r2xu, r1yo,   &
     4325       CALL pmci_interp_1sto_all ( u,  uc,  icu, jco, kco, r1xu, r2xu, r1yo,   &
    40554326                                   r2yo, r1zo, r2zo, kcto, iflu, ifuu,         &
    40564327                                   jflo, jfuo, kflo, kfuo, ijkfc_u, 'u' )
    4057        CALL pmci_interp_tril_all ( v,  vc,  ico, jcv, kco, r1xo, r2xo, r1yv,   &
     4328       CALL pmci_interp_1sto_all ( v,  vc,  ico, jcv, kco, r1xo, r2xo, r1yv,   &
    40584329                                   r2yv, r1zo, r2zo, kcto, iflo, ifuo,         &
    40594330                                   jflv, jfuv, kflo, kfuo, ijkfc_v, 'v' )
    4060        CALL pmci_interp_tril_all ( w,  wc,  ico, jco, kcw, r1xo, r2xo, r1yo,   &
     4331       CALL pmci_interp_1sto_all ( w,  wc,  ico, jco, kcw, r1xo, r2xo, r1yo,   &
    40614332                                   r2yo, r1zw, r2zw, kctw, iflo, ifuo,         &
    40624333                                   jflo, jfuo, kflw, kfuw, ijkfc_w, 'w' )
     
    40654336            (  .NOT. rans_mode_parent  .AND.  .NOT.  rans_mode  .AND.           &
    40664337               .NOT. constant_diffusion ) )  THEN
    4067           CALL pmci_interp_tril_all ( e,  ec,  ico, jco, kco, r1xo, r2xo, r1yo, &
     4338          CALL pmci_interp_1sto_all ( e,  ec,  ico, jco, kco, r1xo, r2xo, r1yo, &
    40684339                                      r2yo, r1zo, r2zo, kcto, iflo, ifuo,       &
    40694340                                      jflo, jfuo, kflo, kfuo, ijkfc_s, 'e' )
     
    40714342
    40724343       IF ( rans_mode_parent  .AND.  rans_mode  .AND.  rans_tke_e )  THEN
    4073           CALL pmci_interp_tril_all ( diss,  dissc,  ico, jco, kco, r1xo, r2xo,&
     4344          CALL pmci_interp_1sto_all ( diss,  dissc,  ico, jco, kco, r1xo, r2xo,&
    40744345                                      r1yo, r2yo, r1zo, r2zo, kcto, iflo, ifuo,&
    40754346                                      jflo, jfuo, kflo, kfuo, ijkfc_s, 's' )
     
    40774348
    40784349       IF ( .NOT. neutral )  THEN
    4079           CALL pmci_interp_tril_all ( pt, ptc, ico, jco, kco, r1xo, r2xo,      &
     4350          CALL pmci_interp_1sto_all ( pt, ptc, ico, jco, kco, r1xo, r2xo,      &
    40804351                                      r1yo, r2yo, r1zo, r2zo, kcto, iflo, ifuo,&
    40814352                                      jflo, jfuo, kflo, kfuo, ijkfc_s, 's' )
     
    40844355       IF ( humidity )  THEN
    40854356
    4086           CALL pmci_interp_tril_all ( q, q_c, ico, jco, kco, r1xo, r2xo, r1yo, &
     4357          CALL pmci_interp_1sto_all ( q, q_c, ico, jco, kco, r1xo, r2xo, r1yo, &
    40874358                                      r2yo, r1zo, r2zo, kcto, iflo, ifuo,      &
    40884359                                      jflo, jfuo, kflo, kfuo, ijkfc_s, 's' )
    40894360
    40904361          IF ( bulk_cloud_model  .AND.  microphysics_morrison )  THEN
    4091              CALL pmci_interp_tril_all ( qc, qcc, ico, jco, kco, r1xo, r2xo,   &
     4362             CALL pmci_interp_1sto_all ( qc, qcc, ico, jco, kco, r1xo, r2xo,   &
    40924363                                         r1yo, r2yo, r1zo, r2zo, kcto,         &
    40934364                                         iflo, ifuo, jflo, jfuo, kflo, kfuo,   &
    40944365                                         ijkfc_s, 's' )
    4095              CALL pmci_interp_tril_all ( nc, ncc, ico, jco, kco, r1xo, r2xo,   &
     4366             CALL pmci_interp_1sto_all ( nc, ncc, ico, jco, kco, r1xo, r2xo,   &
    40964367                                         r1yo, r2yo, r1zo, r2zo, kcto,         &
    40974368                                         iflo, ifuo, jflo, jfuo, kflo, kfuo,   &
     
    41004371
    41014372          IF ( bulk_cloud_model  .AND.  microphysics_seifert )  THEN
    4102              CALL pmci_interp_tril_all ( qr, qrc, ico, jco, kco, r1xo, r2xo,   &
     4373             CALL pmci_interp_1sto_all ( qr, qrc, ico, jco, kco, r1xo, r2xo,   &
    41034374                                         r1yo, r2yo, r1zo, r2zo, kcto,         &
    41044375                                         iflo, ifuo, jflo, jfuo, kflo, kfuo,   &
    41054376                                         ijkfc_s, 's' )
    4106              CALL pmci_interp_tril_all ( nr, nrc, ico, jco, kco, r1xo, r2xo,   &
     4377             CALL pmci_interp_1sto_all ( nr, nrc, ico, jco, kco, r1xo, r2xo,   &
    41074378                                         r1yo, r2yo, r1zo, r2zo, kcto,         &
    41084379                                         iflo, ifuo, jflo, jfuo, kflo, kfuo,   &
     
    41134384
    41144385       IF ( passive_scalar )  THEN
    4115           CALL pmci_interp_tril_all ( s, sc, ico, jco, kco, r1xo, r2xo, r1yo,  &
     4386          CALL pmci_interp_1sto_all ( s, sc, ico, jco, kco, r1xo, r2xo, r1yo,  &
    41164387                                      r2yo, r1zo, r2zo, kcto, iflo, ifuo,      &
    41174388                                      jflo, jfuo, kflo, kfuo, ijkfc_s, 's' )
     
    41204391       IF ( air_chemistry  .AND.  nest_chemistry )  THEN
    41214392          DO  n = 1, nspec
    4122              CALL pmci_interp_tril_all ( chem_species(n)%conc,                 &
     4393             CALL pmci_interp_1sto_all ( chem_species(n)%conc,                 &
    41234394                                         chem_spec_c(:,:,:,n),                 &
    41244395                                         ico, jco, kco, r1xo, r2xo, r1yo,      &
     
    41624433
    41634434
    4164     SUBROUTINE pmci_interp_tril_all( f, fc, ic, jc, kc, r1x, r2x, r1y, r2y,    &
     4435    SUBROUTINE pmci_interp_1sto_all( f, fc, ic, jc, kc, r1x, r2x, r1y, r2y,    &
    41654436                                     r1z, r2z, kct, ifl, ifu, jfl, jfu,        &
    41664437                                     kfl, kfu, ijkfc, var )
     
    41734444       CHARACTER(LEN=1), INTENT(IN) :: var  !<
    41744445
    4175        INTEGER(iwp), DIMENSION(nxlg:nxrg), INTENT(IN)           ::  ic    !<
    4176        INTEGER(iwp), DIMENSION(nysg:nyng), INTENT(IN)           ::  jc    !<
    4177        INTEGER(iwp), DIMENSION(nzb:nzt+1), INTENT(IN)           ::  kc    !<
     4446       INTEGER(iwp), DIMENSION(nxlfc:nxrfc), INTENT(IN)         ::  ic    !<
     4447       INTEGER(iwp), DIMENSION(nysfc:nynfc), INTENT(IN)         ::  jc    !<
     4448!AH       INTEGER(iwp), DIMENSION(nzb:nzt+1), INTENT(IN)           ::  kc    !<
     4449       INTEGER(iwp), DIMENSION(nzb:nzt+kgsr), INTENT(IN)        ::  kc    !<
    41784450
    41794451       REAL(wp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg), INTENT(INOUT) :: f !<
    41804452       REAL(wp), DIMENSION(0:cg%nz+1,jcs:jcn,icl:icr), INTENT(IN) :: fc       !<
    4181        REAL(wp), DIMENSION(nxlg:nxrg), INTENT(IN) :: r1x   !<
    4182        REAL(wp), DIMENSION(nxlg:nxrg), INTENT(IN) :: r2x   !<
    4183        REAL(wp), DIMENSION(nysg:nyng), INTENT(IN) :: r1y   !<
    4184        REAL(wp), DIMENSION(nysg:nyng), INTENT(IN) :: r2y   !<
    4185        REAL(wp), DIMENSION(nzb:nzt+1), INTENT(IN) :: r1z   !<
    4186        REAL(wp), DIMENSION(nzb:nzt+1), INTENT(IN) :: r2z   !<
     4453       REAL(wp), DIMENSION(nxlfc:nxrfc), INTENT(IN) :: r1x   !<
     4454       REAL(wp), DIMENSION(nxlfc:nxrfc), INTENT(IN) :: r2x   !<
     4455       REAL(wp), DIMENSION(nysfc:nynfc), INTENT(IN) :: r1y   !<
     4456       REAL(wp), DIMENSION(nysfc:nynfc), INTENT(IN) :: r2y   !<
     4457       REAL(wp), DIMENSION(nzb:nzt+kgsr), INTENT(IN) :: r1z   !<
     4458       REAL(wp), DIMENSION(nzb:nzt+kgsr), INTENT(IN) :: r2z   !<
    41874459
    41884460       INTEGER(iwp) :: kct
    4189        INTEGER(iwp), DIMENSION(icl:icr), INTENT(IN) ::  ifl !< Indicates start index of child cells belonging to certain parent cell - x direction
    4190        INTEGER(iwp), DIMENSION(icl:icr), INTENT(IN) ::  ifu !< Indicates end index of child cells belonging to certain parent cell - x direction
    4191        INTEGER(iwp), DIMENSION(jcs:jcn), INTENT(IN) ::  jfl !< Indicates start index of child cells belonging to certain parent cell - y direction
    4192        INTEGER(iwp), DIMENSION(jcs:jcn), INTENT(IN) ::  jfu !< Indicates start index of child cells belonging to certain parent cell - y direction
    4193        INTEGER(iwp), DIMENSION(0:cg%nz+1), INTENT(IN)   ::  kfl !< Indicates start index of child cells belonging to certain parent cell - z direction
    4194        INTEGER(iwp), DIMENSION(0:cg%nz+1), INTENT(IN)   ::  kfu !< Indicates start index of child cells belonging to certain parent cell - z direction
    4195        INTEGER(iwp), DIMENSION(0:cg%nz+1,jcs:jcn,icl:icr), INTENT(IN) :: ijkfc !< number of child grid points contributing to a parent grid box
     4461!AH       INTEGER(iwp), DIMENSION(icl:icr), INTENT(IN) ::  ifl !< Indicates start index of child cells belonging to certain parent cell - x direction
     4462!AH       INTEGER(iwp), DIMENSION(icl:icr), INTENT(IN) ::  ifu !< Indicates end index of child cells belonging to certain parent cell - x direction
     4463!AH       INTEGER(iwp), DIMENSION(jcs:jcn), INTENT(IN) ::  jfl !< Indicates start index of child cells belonging to certain parent cell - y direction
     4464!AH       INTEGER(iwp), DIMENSION(jcs:jcn), INTENT(IN) ::  jfu !< Indicates start index of child cells belonging to certain parent cell - y direction
     4465       INTEGER(iwp), DIMENSION(icla:icra), INTENT(IN) ::  ifl !< Indicates start index of child cells belonging to certain parent cell - x direction
     4466       INTEGER(iwp), DIMENSION(icla:icra), INTENT(IN) ::  ifu !< Indicates end index of child cells belonging to certain parent cell - x direction
     4467       INTEGER(iwp), DIMENSION(jcsa:jcna), INTENT(IN) ::  jfl !< Indicates start index of child cells belonging to certain parent cell - y direction
     4468       INTEGER(iwp), DIMENSION(jcsa:jcna), INTENT(IN) ::  jfu !< Indicates start index of child cells belonging to certain parent cell - y direction
     4469       INTEGER(iwp), DIMENSION(0:cg%nz+1), INTENT(IN) ::  kfl !< Indicates start index of child cells belonging to certain parent cell - z direction
     4470       INTEGER(iwp), DIMENSION(0:cg%nz+1), INTENT(IN) ::  kfu !< Indicates start index of child cells belonging to certain parent cell - z direction
     4471!AH
     4472!       INTEGER(iwp), DIMENSION(0:cg%nz+1,jcs:jcn,icl:icr), INTENT(IN) :: ijkfc !< number of child grid points contributing to a parent grid box
     4473       INTEGER(iwp), DIMENSION(0:cg%nz+1,jcsa:jcna,icla:icra), INTENT(IN) :: ijkfc !< number of child grid points contributing to a parent grid box
     4474!AH
    41964475
    41974476       INTEGER(iwp) ::  i        !<
    4198        INTEGER(iwp) ::  ib       !<
    4199        INTEGER(iwp) ::  ie       !<
    4200        INTEGER(iwp) ::  ijk      !<
    42014477       INTEGER(iwp) ::  j        !<
    4202        INTEGER(iwp) ::  jb       !<
    4203        INTEGER(iwp) ::  je       !<
    42044478       INTEGER(iwp) ::  k        !<
    4205        INTEGER(iwp) ::  k_wall   !<
    4206        INTEGER(iwp) ::  k1       !<
    4207        INTEGER(iwp) ::  kb       !<
    4208        INTEGER(iwp) ::  kbc      !<
    42094479       INTEGER(iwp) ::  l        !<
     4480       INTEGER(iwp) ::  lb       !<
     4481       INTEGER(iwp) ::  le       !<
    42104482       INTEGER(iwp) ::  m        !<
     4483       INTEGER(iwp) ::  mb       !<
     4484       INTEGER(iwp) ::  me       !<
    42114485       INTEGER(iwp) ::  n        !<
    42124486       INTEGER(iwp) ::  var_flag !<
    42134487
    4214        REAL(wp) ::  cellsum    !<
    4215        REAL(wp) ::  cellsumd   !<
    4216        REAL(wp) ::  fk         !<
    4217        REAL(wp) ::  fkj        !<
    4218        REAL(wp) ::  fkjp       !<
    4219        REAL(wp) ::  fkp        !<
    4220        REAL(wp) ::  fkpj       !<
    4221        REAL(wp) ::  fkpjp      !<
    4222        REAL(wp) ::  logratio   !<
    4223        REAL(wp) ::  logzuc1    !<
    4224        REAL(wp) ::  rcorr      !<
    4225        REAL(wp) ::  rcorr_ijk  !<       
    4226        REAL(wp) ::  zuc1       !<
    4227        REAL(wp) ::  z0_topo    !<  roughness at vertical walls
    4228 
    4229 
    4230        ib = nxl
    4231        ie = nxr
    4232        jb = nys
    4233        je = nyn
    4234        kb = 0
     4488
     4489       lb = icl
     4490       le = icr
     4491       mb = jcs
     4492       me = jcn
     4493
    42354494       IF ( nesting_mode /= 'vertical' )  THEN
    42364495          IF ( bc_dirichlet_l )  THEN
    4237              ib = nxl - 1
     4496             lb = icl + 1
    42384497!
    42394498!--          For u, nxl is a ghost node, but not for the other variables
    42404499             IF ( var == 'u' )  THEN
    4241                 ib = nxl
     4500                lb = icl + 2
    42424501             ENDIF
    42434502          ENDIF
    42444503          IF ( bc_dirichlet_s )  THEN
    4245              jb = nys - 1
     4504             mb = jcs + 1
    42464505!
    42474506!--          For v, nys is a ghost node, but not for the other variables
    42484507             IF ( var == 'v' )  THEN
    4249                 jb = nys
     4508                mb = jcs + 2
    42504509             ENDIF
    42514510          ENDIF
    42524511          IF ( bc_dirichlet_r )  THEN
    4253              ie = nxr + 1
     4512             le = icr - 1
    42544513          ENDIF
    42554514          IF ( bc_dirichlet_n )  THEN
    4256              je = nyn + 1
     4515             me = jcn - 1
    42574516          ENDIF
    42584517       ENDIF
    4259 
     4518!
     4519!--    Is masking needed here, think about it.
    42604520       IF ( var == 'u' )  THEN
    42614521          var_flag = 1
     
    42664526       ELSE
    42674527          var_flag = 0
    4268        ENDIF
    4269 !
    4270 !--    Trilinear interpolation.
    4271        DO  i = ib, ie
    4272           DO  j = jb, je
    4273 !
    4274 !--          Determine the vertical index of the first node above the
    4275 !--          topography top at grid point (j,i) in order to not overwrite
    4276 !--          the bottom BC.
    4277 !             kb = get_topography_top_index_ji( j, i, TRIM ( var ) ) + 1             
    4278              DO  k = kb, nzt + 1
    4279                 l = ic(i)
    4280                 m = jc(j)
    4281                 n = kc(k)
    4282                 fkj      = r1x(i) * fc(n,m,l)     + r2x(i) * fc(n,m,l+1)
    4283                 fkjp     = r1x(i) * fc(n,m+1,l)   + r2x(i) * fc(n,m+1,l+1)
    4284                 fkpj     = r1x(i) * fc(n+1,m,l)   + r2x(i) * fc(n+1,m,l+1)
    4285                 fkpjp    = r1x(i) * fc(n+1,m+1,l) + r2x(i) * fc(n+1,m+1,l+1)
    4286                 fk       = r1y(j) * fkj  + r2y(j) * fkjp
    4287                 fkp      = r1y(j) * fkpj + r2y(j) * fkpjp
    4288                 f(k,j,i) = r1z(k) * fk   + r2z(k) * fkp
     4528       ENDIF       
     4529
     4530       f(:,:,:) = 0.0_wp
     4531
     4532       IF  ( var == 'u' )  THEN
     4533
     4534          DO  l = lb, le
     4535             DO  m = mb, me
     4536                DO n = 0, kct
     4537
     4538                   DO  i = ifl(l), ifl(l+1)-1
     4539                      DO  j = jfl(m), jfu(m)
     4540                         DO  k = kfl(n), kfu(n)
     4541                            f(k,j,i) = fc(n,m,l)
     4542                         ENDDO
     4543                      ENDDO
     4544                   ENDDO
     4545                   
     4546                ENDDO
    42894547             ENDDO
    42904548          ENDDO
    4291        ENDDO
    4292 !
    4293 !--    Correct the interpolated values of u and v in near-wall nodes, i.e. in
    4294 !--    the nodes below the coarse-grid nodes with k=1. The corrction is only
    4295 !--    made over horizontal wall surfaces in this phase. For the nest boundary
    4296 !--    conditions, a corresponding correction is made for all vertical walls,
    4297 !--    too.
    4298        IF ( constant_flux_layer .AND. ( var == 'u' .OR. var == 'v' ) )  THEN
    4299           z0_topo = roughness_length
    4300           DO  i = ib, nxr
    4301              DO  j = jb, nyn
    4302 !
    4303 !--             Determine vertical index of topography top at grid point (j,i)
    4304                 k_wall = get_topography_top_index_ji( j, i, TRIM ( var ) )
    4305 !
    4306 !--             kbc is the first coarse-grid point above the surface
    4307                 kbc = 1
    4308                 DO  WHILE ( cg%zu(kbc) < zu(k_wall) )
    4309                    kbc = kbc + 1
     4549
     4550       ELSE IF  ( var == 'v' )  THEN
     4551
     4552          DO  l = lb, le
     4553             DO  m = mb, me
     4554                DO n = 0, kct
     4555               
     4556                   DO i = ifl(l), ifu(l)
     4557                      DO  j = jfl(m), jfl(m+1)-1
     4558                         DO  k = kfl(n), kfu(n)
     4559                            f(k,j,i) = fc(n,m,l)
     4560                         ENDDO
     4561                      ENDDO
     4562                   ENDDO
     4563
    43104564                ENDDO
    4311                 zuc1 = cg%zu(kbc)
    4312                 k1   = k_wall + 1
    4313                 DO  WHILE ( zu(k1) < zuc1 )
    4314                    k1 = k1 + 1
    4315                 ENDDO
    4316                 logzuc1 = LOG( ( zu(k1) - zu(k_wall) ) / z0_topo )
    4317 
    4318                 k = k_wall + 1
    4319                 DO  WHILE ( zu(k) < zuc1 )
    4320                    logratio = ( LOG( ( zu(k) - zu(k_wall) ) / z0_topo ) ) /    &
    4321                                 logzuc1
    4322                    f(k,j,i) = logratio * f(k1,j,i)
    4323                    k  = k + 1
    4324                 ENDDO
    4325                 f(k_wall,j,i) = 0.0_wp
    43264565             ENDDO
    43274566          ENDDO
    43284567
    4329        ELSEIF ( var == 'w' )  THEN
    4330 
    4331           DO  i = ib, nxr
    4332               DO  j = jb, nyn
    4333 !
    4334 !--              Determine vertical index of topography top at grid point (j,i)
    4335                  k_wall = get_topography_top_index_ji( j, i, 'w' )
    4336 
    4337                  f(k_wall,j,i) = 0.0_wp
    4338               ENDDO
    4339            ENDDO
    4340 
    4341        ENDIF
    4342 !
    4343 !--    Apply the reversibility correction.
    4344        DO  l = icl, icr
    4345           DO  m = jcs, jcn
    4346              DO  n = 0, kct+1
    4347                 ijk = 1
    4348                 cellsum   = 0.0_wp
    4349                 cellsumd  = 0.0_wp
    4350 !
    4351 !--             Note that the index name i must not be used here as a loop
    4352 !--             index name since i is the constant boundary index, hence
    4353 !--             the name ia.
    4354                 DO  i = ifl(l), ifu(l)   
    4355                    DO  j = jfl(m), jfu(m)
    4356                       DO  k = kfl(n), kfu(n)
    4357                          cellsum = cellsum + MERGE( f(k,j,i), 0.0_wp,           &
    4358                               BTEST( wall_flags_0(k,j,i), var_flag ) )
    4359                          celltmpd(ijk) = ABS( fc(n,m,l) - f(k,j,i) )
    4360                          cellsumd      = cellsumd  + MERGE( celltmpd(ijk),      &
    4361                               0.0_wp, BTEST( wall_flags_0(k,j,i), var_flag ) )
    4362                          ijk = ijk + 1
     4568       ELSE IF  ( var == 'w' )  THEN
     4569
     4570          DO  l = lb, le
     4571             DO  m = mb, me
     4572                DO n = 1, kct + 1   ! It is important to go up to kct+1 
     4573
     4574                   DO i = ifl(l), ifu(l)
     4575                      DO  j = jfl(m), jfu(m)
     4576                         f(nzb,j,i) = 0.0_wp   ! Because the n-loop starts from n=1 instead of 0
     4577                         DO  k = kfu(n-1)+1, kfu(n)
     4578                            f(k,j,i) = fc(n,m,l)
     4579                         ENDDO
    43634580                      ENDDO
    43644581                   ENDDO
     4582                   
    43654583                ENDDO
    4366                
    4367                 IF ( ijkfc(n,m,l) /= 0 )  THEN
    4368                    cellsum   = cellsum / REAL( ijkfc(n,m,l), KIND=wp )
    4369                    rcorr     = fc(n,m,l) - cellsum
    4370                    cellsumd  = cellsumd / REAL( ijkfc(n,m,l), KIND=wp )
    4371                 ELSE
    4372                    cellsum   = 0.0_wp                 
    4373                    rcorr     = 0.0_wp
    4374                    cellsumd  = 1.0_wp
    4375                    celltmpd  = 1.0_wp
    4376                 ENDIF
    4377 !
    4378 !--             Distribute the correction term to the child nodes according to
    4379 !--             their relative difference to the parent value such that the
    4380 !--             node with the largest difference gets the largest share of the
    4381 !--             correction. The distribution is skipped if rcorr is negligibly
    4382 !--             small in order to avoid division by zero.
    4383                 IF ( ABS(rcorr) < 0.000001_wp )  THEN                 
    4384                    cellsumd  = 1.0_wp
    4385                    celltmpd  = 1.0_wp
    4386                 ENDIF
    4387 
    4388                 ijk = 1
    4389                 DO  i = ifl(l), ifu(l)
    4390                    DO  j = jfl(m), jfu(m)
    4391                       DO  k = kfl(n), kfu(n)
    4392                          rcorr_ijk = rcorr * celltmpd(ijk) / cellsumd
    4393                          f(k,j,i) = f(k,j,i) + rcorr_ijk
    4394                          ijk = ijk + 1
     4584             ENDDO
     4585          ENDDO
     4586
     4587       ELSE   ! scalars
     4588
     4589          DO  l = lb, le
     4590             DO  m = mb, me
     4591                DO n = 0, kct
     4592                   
     4593                   DO i = ifl(l), ifu(l)
     4594                      DO  j = jfl(m), jfu(m)
     4595                         DO  k = kfl(n), kfu(n)
     4596                            f(k,j,i) = fc(n,m,l)
     4597                         ENDDO
    43954598                      ENDDO
    43964599                   ENDDO
     4600                   
    43974601                ENDDO
    4398              
    4399              ENDDO  ! n
    4400           ENDDO  ! m
    4401        ENDDO  ! l
    4402 
    4403     END SUBROUTINE pmci_interp_tril_all
     4602             ENDDO
     4603          ENDDO
     4604
     4605       ENDIF  ! var
     4606
     4607    END SUBROUTINE pmci_interp_1sto_all
    44044608
    44054609#endif
     
    46744878    IMPLICIT NONE
    46754879
    4676     INTEGER(iwp), INTENT(IN) ::  direction   !<
     4880    INTEGER(iwp), INTENT(IN) ::  direction  !< Transfer direction: parent_to_child or child_to_parent
    46774881
    46784882#if defined( __parallel )
    4679     INTEGER(iwp) ::  icl         !<
    4680     INTEGER(iwp) ::  icr         !<
    4681     INTEGER(iwp) ::  jcs         !<
    4682     INTEGER(iwp) ::  jcn         !<
    4683    
    4684     REAL(wp), DIMENSION(1) ::  dtl         !<
     4883    INTEGER(iwp) ::  icl         !< Parent-grid array index bound, left
     4884    INTEGER(iwp) ::  icr         !< Parent-grid array index bound, right
     4885    INTEGER(iwp) ::  jcn         !< Parent-grid array index bound, north
     4886    INTEGER(iwp) ::  jcs         !< Parent-grid array index bound, south
     4887    INTEGER(iwp) ::  icla        !< Auxiliary-array (index-mapping etc) index bound, left
     4888    INTEGER(iwp) ::  icra        !< Auxiliary-array (index-mapping etc) index bound, right
     4889    INTEGER(iwp) ::  jcna        !< Auxiliary-array (index-mapping etc) index bound, north
     4890    INTEGER(iwp) ::  jcsa        !< Auxiliary-array (index-mapping etc) index bound, south
     4891    INTEGER(iwp) ::  iclw        !< Parent-grid work array index bound, left
     4892    INTEGER(iwp) ::  icrw        !< Parent-grid work array index bound, right
     4893    INTEGER(iwp) ::  jcnw        !< Parent-grid work array index bound, north
     4894    INTEGER(iwp) ::  jcsw        !< Parent-grid work array index bound, south
     4895
     4896    REAL(wp), DIMENSION(1) ::  dtl         !< Time step size
    46854897
    46864898
     
    46894901!
    46904902!--    Child domain boundaries in the parent indice space.
    4691        icl = coarse_bound(1)
    4692        icr = coarse_bound(2)
    4693        jcs = coarse_bound(3)
    4694        jcn = coarse_bound(4)
     4903       icl  = coarse_bound(1)
     4904       icr  = coarse_bound(2)
     4905       jcs  = coarse_bound(3)
     4906       jcn  = coarse_bound(4)
     4907       icla = coarse_bound_aux(1)
     4908       icra = coarse_bound_aux(2)
     4909       jcsa = coarse_bound_aux(3)
     4910       jcna = coarse_bound_aux(4)
     4911       iclw = coarse_bound_w(1)
     4912       icrw = coarse_bound_w(2)
     4913       jcsw = coarse_bound_w(3)
     4914       jcnw = coarse_bound_w(4)
    46954915
    46964916       IF ( direction == parent_to_child )  THEN
     
    47364956!--    horizontal boundaries
    47374957       IF ( nesting_mode /= 'vertical' )  THEN
    4738        
    47394958!
    47404959!--       Left border pe:
    47414960          IF ( bc_dirichlet_l )  THEN
    47424961
    4743              CALL pmci_interp_tril_lr( u,  uc,  icu, jco, kco, r1xu, r2xu,      &
     4962             CALL pmci_interp_1sto_lr( u,  uc,  icu, jco, kco, r1xu, r2xu,      &
    47444963                                       r1yo, r2yo, r1zo, r2zo,                  &
    47454964                                       logc_u_l, logc_ratio_u_l,                &
     
    47484967                                       kfuo, ijkfc_u, 'l', 'u' )
    47494968
    4750              CALL pmci_interp_tril_lr( v,  vc,  ico, jcv, kco, r1xo, r2xo,      &
     4969             CALL pmci_interp_1sto_lr( v,  vc,  ico, jcv, kco, r1xo, r2xo,      &
    47514970                                       r1yv, r2yv, r1zo, r2zo,                  &
    47524971                                       logc_v_l, logc_ratio_v_l,                &
     
    47554974                                       kfuo, ijkfc_v, 'l', 'v' )
    47564975
    4757              CALL pmci_interp_tril_lr( w,  wc,  ico, jco, kcw, r1xo, r2xo,      &
     4976             CALL pmci_interp_1sto_lr( w,  wc,  ico, jco, kcw, r1xo, r2xo,      &
    47584977                                       r1yo, r2yo, r1zw, r2zw,                  &
    47594978                                       logc_w_l, logc_ratio_w_l,                &
     
    47654984                  (  .NOT. rans_mode_parent  .AND.  .NOT.  rans_mode  .AND.    &
    47664985                     .NOT. constant_diffusion ) )  THEN
    4767 !                CALL pmci_interp_tril_lr( e,  ec,  ico, jco, kco, r1xo, r2xo,  &
     4986!                CALL pmci_interp_1sto_lr( e,  ec,  ico, jco, kco, r1xo, r2xo,  &
    47684987!                                          r1yo, r2yo, r1zo, r2zo,              &
    47694988!                                          logc_w_l, logc_ratio_w_l,            &
     
    47804999
    47815000             IF ( rans_mode_parent  .AND.  rans_mode  .AND.  rans_tke_e )  THEN
    4782                 CALL pmci_interp_tril_lr( diss,  dissc,  ico, jco, kco, r1xo,  &
     5001                CALL pmci_interp_1sto_lr( diss,  dissc,  ico, jco, kco, r1xo,  &
    47835002                                          r2xo, r1yo, r2yo, r1zo, r2zo,        &
    47845003                                          logc_w_l, logc_ratio_w_l,            &
     
    47895008
    47905009             IF ( .NOT. neutral )  THEN
    4791                 CALL pmci_interp_tril_lr( pt, ptc, ico, jco, kco, r1xo, r2xo,  &
     5010                CALL pmci_interp_1sto_lr( pt, ptc, ico, jco, kco, r1xo, r2xo,  &
    47925011                                          r1yo, r2yo, r1zo, r2zo,              &
    47935012                                          logc_w_l, logc_ratio_w_l,            &
     
    47995018             IF ( humidity )  THEN
    48005019
    4801                 CALL pmci_interp_tril_lr( q, q_c, ico, jco, kco, r1xo, r2xo,   &
     5020                CALL pmci_interp_1sto_lr( q, q_c, ico, jco, kco, r1xo, r2xo,   &
    48025021                                          r1yo, r2yo, r1zo, r2zo,              &
    48035022                                          logc_w_l, logc_ratio_w_l,            &
     
    48075026
    48085027                IF ( bulk_cloud_model  .AND.  microphysics_morrison )  THEN
    4809                    CALL pmci_interp_tril_lr( qc, qcc, ico, jco, kco, r1xo,     &
     5028                   CALL pmci_interp_1sto_lr( qc, qcc, ico, jco, kco, r1xo,     &
    48105029                                             r2xo, r1yo, r2yo, r1zo, r2zo,     &
    48115030                                             logc_w_l, logc_ratio_w_l,         &
     
    48155034                                             kflo, kfuo, ijkfc_s, 'l', 's' ) 
    48165035
    4817                    CALL pmci_interp_tril_lr( nc, ncc, ico, jco, kco, r1xo,     &
     5036                   CALL pmci_interp_1sto_lr( nc, ncc, ico, jco, kco, r1xo,     &
    48185037                                             r2xo, r1yo, r2yo, r1zo, r2zo,     &
    48195038                                             logc_w_l, logc_ratio_w_l,         &
     
    48255044
    48265045                IF ( bulk_cloud_model  .AND.  microphysics_seifert )  THEN
    4827                    CALL pmci_interp_tril_lr( qr, qrc, ico, jco, kco, r1xo,     &
     5046                   CALL pmci_interp_1sto_lr( qr, qrc, ico, jco, kco, r1xo,     &
    48285047                                             r2xo, r1yo, r2yo, r1zo, r2zo,     &
    48295048                                             logc_w_l, logc_ratio_w_l,         &
     
    48335052                                             kflo, kfuo, ijkfc_s, 'l', 's' )
    48345053
    4835                    CALL pmci_interp_tril_lr( nr, nrc, ico, jco, kco, r1xo,     &
     5054                   CALL pmci_interp_1sto_lr( nr, nrc, ico, jco, kco, r1xo,     &
    48365055                                             r2xo, r1yo, r2yo, r1zo, r2zo,     &
    48375056                                             logc_w_l, logc_ratio_w_l,         &
     
    48455064
    48465065             IF ( passive_scalar )  THEN
    4847                 CALL pmci_interp_tril_lr( s, sc, ico, jco, kco, r1xo, r2xo,    &
     5066                CALL pmci_interp_1sto_lr( s, sc, ico, jco, kco, r1xo, r2xo,    &
    48485067                                          r1yo, r2yo, r1zo, r2zo,              &
    48495068                                          logc_w_l, logc_ratio_w_l,            &
     
    48565075             IF ( air_chemistry  .AND.  nest_chemistry )  THEN
    48575076                DO  n = 1, nspec
    4858                    CALL pmci_interp_tril_lr( chem_species(n)%conc,             &
     5077                   CALL pmci_interp_1sto_lr( chem_species(n)%conc,             &
    48595078                                             chem_spec_c(:,:,:,n),             &
    48605079                                             ico, jco, kco, r1xo, r2xo,        &
     
    48735092          IF ( bc_dirichlet_r )  THEN
    48745093             
    4875              CALL pmci_interp_tril_lr( u,  uc,  icu, jco, kco, r1xu, r2xu,     &
     5094             CALL pmci_interp_1sto_lr( u,  uc,  icu, jco, kco, r1xu, r2xu,     &
    48765095                                       r1yo, r2yo, r1zo, r2zo,                 &
    48775096                                       logc_u_r, logc_ratio_u_r,               &
     
    48805099                                       kfuo, ijkfc_u, 'r', 'u' )
    48815100
    4882              CALL pmci_interp_tril_lr( v,  vc,  ico, jcv, kco, r1xo, r2xo,     &
     5101             CALL pmci_interp_1sto_lr( v,  vc,  ico, jcv, kco, r1xo, r2xo,     &
    48835102                                       r1yv, r2yv, r1zo, r2zo,                 &
    48845103                                       logc_v_r, logc_ratio_v_r,               &
     
    48875106                                       kfuo, ijkfc_v, 'r', 'v' )
    48885107
    4889              CALL pmci_interp_tril_lr( w,  wc,  ico, jco, kcw, r1xo, r2xo,     &
     5108             CALL pmci_interp_1sto_lr( w,  wc,  ico, jco, kcw, r1xo, r2xo,     &
    48905109                                       r1yo, r2yo, r1zw, r2zw,                 &
    48915110                                       logc_w_r, logc_ratio_w_r,               &
     
    48975116                  (  .NOT. rans_mode_parent  .AND.  .NOT.  rans_mode  .AND.    &
    48985117                     .NOT. constant_diffusion ) )  THEN
    4899 !                CALL pmci_interp_tril_lr( e,  ec,  ico, jco, kco, r1xo, r2xo,  &
     5118!                CALL pmci_interp_1sto_lr( e,  ec,  ico, jco, kco, r1xo, r2xo,  &
    49005119!                                          r1yo,r2yo, r1zo, r2zo,               &
    49015120!                                          logc_w_r, logc_ratio_w_r,            &
     
    49115130
    49125131             IF ( rans_mode_parent  .AND.  rans_mode  .AND.  rans_tke_e )  THEN
    4913                 CALL pmci_interp_tril_lr( diss,  dissc,  ico, jco, kco, r1xo,  &
     5132                CALL pmci_interp_1sto_lr( diss,  dissc,  ico, jco, kco, r1xo,  &
    49145133                                          r2xo, r1yo,r2yo, r1zo, r2zo,         &
    49155134                                          logc_w_r, logc_ratio_w_r,            &
     
    49215140
    49225141             IF ( .NOT. neutral )  THEN
    4923                 CALL pmci_interp_tril_lr( pt, ptc, ico, jco, kco, r1xo, r2xo,  &
     5142                CALL pmci_interp_1sto_lr( pt, ptc, ico, jco, kco, r1xo, r2xo,  &
    49245143                                          r1yo, r2yo, r1zo, r2zo,              &
    49255144                                          logc_w_r, logc_ratio_w_r,            &
     
    49305149
    49315150             IF ( humidity )  THEN
    4932                 CALL pmci_interp_tril_lr( q, q_c, ico, jco, kco, r1xo, r2xo,   &
     5151                CALL pmci_interp_1sto_lr( q, q_c, ico, jco, kco, r1xo, r2xo,   &
    49335152                                          r1yo, r2yo, r1zo, r2zo,              &
    49345153                                          logc_w_r, logc_ratio_w_r,            &
     
    49395158                IF ( bulk_cloud_model  .AND.  microphysics_morrison )  THEN
    49405159
    4941                    CALL pmci_interp_tril_lr( qc, qcc, ico, jco, kco, r1xo,     &
     5160                   CALL pmci_interp_1sto_lr( qc, qcc, ico, jco, kco, r1xo,     &
    49425161                                             r2xo, r1yo, r2yo, r1zo, r2zo,     &
    49435162                                             logc_w_r, logc_ratio_w_r,         &
     
    49475166                                             kflo, kfuo, ijkfc_s, 'r', 's' )
    49485167     
    4949                    CALL pmci_interp_tril_lr( nc, ncc, ico, jco, kco, r1xo,     &
     5168                   CALL pmci_interp_1sto_lr( nc, ncc, ico, jco, kco, r1xo,     &
    49505169                                             r2xo, r1yo, r2yo, r1zo, r2zo,     &
    49515170                                             logc_w_r, logc_ratio_w_r,         &
     
    49605179
    49615180     
    4962                    CALL pmci_interp_tril_lr( qr, qrc, ico, jco, kco, r1xo,     &
     5181                   CALL pmci_interp_1sto_lr( qr, qrc, ico, jco, kco, r1xo,     &
    49635182                                             r2xo, r1yo, r2yo, r1zo, r2zo,     &
    49645183                                             logc_w_r, logc_ratio_w_r,         &
     
    49695188                                             'r', 's' )
    49705189
    4971                    CALL pmci_interp_tril_lr( nr, nrc, ico, jco, kco, r1xo,     &
     5190                   CALL pmci_interp_1sto_lr( nr, nrc, ico, jco, kco, r1xo,     &
    49725191                                             r2xo, r1yo, r2yo, r1zo, r2zo,     &
    49735192                                             logc_w_r, logc_ratio_w_r,         &
     
    49825201
    49835202             IF ( passive_scalar )  THEN
    4984                 CALL pmci_interp_tril_lr( s, sc, ico, jco, kco, r1xo, r2xo,    &
     5203                CALL pmci_interp_1sto_lr( s, sc, ico, jco, kco, r1xo, r2xo,    &
    49855204                                          r1yo, r2yo, r1zo, r2zo,              &
    49865205                                          logc_w_r, logc_ratio_w_r,            &
     
    49935212             IF ( air_chemistry  .AND.  nest_chemistry )  THEN
    49945213                DO  n = 1, nspec
    4995                    CALL pmci_interp_tril_lr( chem_species(n)%conc,             &
     5214                   CALL pmci_interp_1sto_lr( chem_species(n)%conc,             &
    49965215                                             chem_spec_c(:,:,:,n),             &
    49975216                                             ico, jco, kco, r1xo, r2xo,        &
     
    50095228          IF ( bc_dirichlet_s )  THEN
    50105229
    5011              CALL pmci_interp_tril_sn( u,  uc,  icu, jco, kco, r1xu, r2xu,     &
     5230             CALL pmci_interp_1sto_sn( v,  vc,  ico, jcv, kco, r1xo, r2xo,     &
     5231                                       r1yv, r2yv, r1zo, r2zo,                 &
     5232                                       logc_v_s, logc_ratio_v_s,               &
     5233                                       logc_kbounds_v_s, nzt_topo_nestbc_s,    &
     5234                                       kcto, iflo, ifuo, jflv, jfuv, kflo,     &
     5235                                       kfuo, ijkfc_v, 's', 'v' )
     5236
     5237             CALL pmci_interp_1sto_sn( w,  wc,  ico, jco, kcw, r1xo, r2xo,     &
     5238                                       r1yo, r2yo, r1zw, r2zw,                 &
     5239                                       logc_w_s, logc_ratio_w_s,               &
     5240                                       logc_kbounds_w_s, nzt_topo_nestbc_s,    &
     5241                                       kctw, iflo, ifuo, jflo, jfuo, kflw,     &
     5242                                       kfuw, ijkfc_w, 's','w' )
     5243
     5244             CALL pmci_interp_1sto_sn( u,  uc,  icu, jco, kco, r1xu, r2xu,     &
    50125245                                       r1yo, r2yo, r1zo, r2zo,                 &
    50135246                                       logc_u_s, logc_ratio_u_s,               &
     
    50165249                                       kfuo, ijkfc_u, 's', 'u' )
    50175250
    5018              CALL pmci_interp_tril_sn( v,  vc,  ico, jcv, kco, r1xo, r2xo,     &
    5019                                        r1yv, r2yv, r1zo, r2zo,                 &
    5020                                        logc_v_s, logc_ratio_v_s,               &
    5021                                        logc_kbounds_v_s, nzt_topo_nestbc_s,    &
    5022                                        kcto, iflo, ifuo, jflv, jfuv, kflo,     &
    5023                                        kfuo, ijkfc_v, 's', 'v' )
    5024 
    5025              CALL pmci_interp_tril_sn( w,  wc,  ico, jco, kcw, r1xo, r2xo,     &
    5026                                        r1yo, r2yo, r1zw, r2zw,                 &
    5027                                        logc_w_s, logc_ratio_w_s,               &
    5028                                        logc_kbounds_w_s, nzt_topo_nestbc_s,    &
    5029                                        kctw, iflo, ifuo, jflo, jfuo, kflw,     &
    5030                                        kfuw, ijkfc_w, 's','w' )
    5031 
    50325251             IF ( (        rans_mode_parent  .AND.         rans_mode )  .OR.   &
    50335252                  (  .NOT. rans_mode_parent  .AND.  .NOT.  rans_mode  .AND.    &
    50345253                     .NOT. constant_diffusion ) )  THEN
    5035 !                CALL pmci_interp_tril_sn( e,  ec,  ico, jco, kco, r1xo, r2xo,  &
     5254!                CALL pmci_interp_1sto_sn( e,  ec,  ico, jco, kco, r1xo, r2xo,  &
    50365255!                                          r1yo, r2yo, r1zo, r2zo,              &
    50375256!                                          logc_w_s, logc_ratio_w_s,            &
     
    50475266
    50485267             IF ( rans_mode_parent  .AND.  rans_mode  .AND.  rans_tke_e )  THEN
    5049                 CALL pmci_interp_tril_sn( diss, dissc,  ico, jco, kco, r1xo,   &
     5268                CALL pmci_interp_1sto_sn( diss, dissc,  ico, jco, kco, r1xo,   &
    50505269                                          r2xo, r1yo, r2yo, r1zo, r2zo,        &
    50515270                                          logc_w_s, logc_ratio_w_s,            &
     
    50565275
    50575276             IF ( .NOT. neutral )  THEN
    5058                 CALL pmci_interp_tril_sn( pt, ptc, ico, jco, kco, r1xo, r2xo,  &
     5277                CALL pmci_interp_1sto_sn( pt, ptc, ico, jco, kco, r1xo, r2xo,  &
    50595278                                          r1yo, r2yo, r1zo, r2zo,              &
    50605279                                          logc_w_s, logc_ratio_w_s,            &
     
    50655284
    50665285             IF ( humidity )  THEN
    5067                 CALL pmci_interp_tril_sn( q, q_c, ico, jco, kco, r1xo, r2xo,   &
     5286                CALL pmci_interp_1sto_sn( q, q_c, ico, jco, kco, r1xo, r2xo,   &
    50685287                                          r1yo,r2yo, r1zo, r2zo,               &
    50695288                                          logc_w_s, logc_ratio_w_s,            &
     
    50745293                IF ( bulk_cloud_model  .AND.  microphysics_morrison )  THEN
    50755294
    5076                    CALL pmci_interp_tril_sn( qc, qcc, ico, jco, kco, r1xo,     &
     5295                   CALL pmci_interp_1sto_sn( qc, qcc, ico, jco, kco, r1xo,     &
    50775296                                             r2xo, r1yo,r2yo, r1zo, r2zo,      &
    50785297                                             logc_w_s, logc_ratio_w_s,         &
     
    50825301                                             kflo, kfuo, ijkfc_s, 's', 's' )
    50835302
    5084                    CALL pmci_interp_tril_sn( nc, ncc, ico, jco, kco, r1xo,     &
     5303                   CALL pmci_interp_1sto_sn( nc, ncc, ico, jco, kco, r1xo,     &
    50855304                                             r2xo, r1yo,r2yo, r1zo, r2zo,      &
    50865305                                             logc_w_s, logc_ratio_w_s,         &
     
    50945313                IF ( bulk_cloud_model  .AND.  microphysics_seifert )  THEN
    50955314
    5096                    CALL pmci_interp_tril_sn( qr, qrc, ico, jco, kco, r1xo,     &
     5315                   CALL pmci_interp_1sto_sn( qr, qrc, ico, jco, kco, r1xo,     &
    50975316                                             r2xo, r1yo,r2yo, r1zo, r2zo,      &
    50985317                                             logc_w_s, logc_ratio_w_s,         &
     
    51025321                                             kflo, kfuo, ijkfc_s, 's', 's' )
    51035322
    5104                    CALL pmci_interp_tril_sn( nr, nrc, ico, jco, kco, r1xo,     &
     5323                   CALL pmci_interp_1sto_sn( nr, nrc, ico, jco, kco, r1xo,     &
    51055324                                             r2xo, r1yo,r2yo, r1zo, r2zo,      &
    51065325                                             logc_w_s, logc_ratio_w_s,         &
     
    51155334
    51165335             IF ( passive_scalar )  THEN
    5117                 CALL pmci_interp_tril_sn( s, sc, ico, jco, kco, r1xo, r2xo,    &
     5336                CALL pmci_interp_1sto_sn( s, sc, ico, jco, kco, r1xo, r2xo,    &
    51185337                                          r1yo,r2yo, r1zo, r2zo,               &
    51195338                                          logc_w_s, logc_ratio_w_s,            &
     
    51265345             IF ( air_chemistry  .AND.  nest_chemistry )  THEN
    51275346                DO  n = 1, nspec
    5128                    CALL pmci_interp_tril_sn( chem_species(n)%conc,             &
     5347                   CALL pmci_interp_1sto_sn( chem_species(n)%conc,             &
    51295348                                             chem_spec_c(:,:,:,n),             &
    51305349                                             ico, jco, kco, r1xo, r2xo,        &
     
    51425361          IF ( bc_dirichlet_n )  THEN
    51435362             
    5144              CALL pmci_interp_tril_sn( u,  uc,  icu, jco, kco, r1xu, r2xu,     &
     5363             CALL pmci_interp_1sto_sn( u,  uc,  icu, jco, kco, r1xu, r2xu,     &
    51455364                                       r1yo, r2yo, r1zo, r2zo,                 &
    51465365                                       logc_u_n, logc_ratio_u_n,               &
     
    51495368                                       kfuo, ijkfc_u, 'n', 'u' )
    51505369
    5151              CALL pmci_interp_tril_sn( v,  vc,  ico, jcv, kco, r1xo, r2xo,     &
     5370             CALL pmci_interp_1sto_sn( v,  vc,  ico, jcv, kco, r1xo, r2xo,     &
    51525371                                       r1yv, r2yv, r1zo, r2zo,                 &
    51535372                                       logc_v_n, logc_ratio_v_n,               &
     
    51565375                                       kfuo, ijkfc_v, 'n', 'v' )
    51575376
    5158              CALL pmci_interp_tril_sn( w,  wc,  ico, jco, kcw, r1xo, r2xo,     &
     5377             CALL pmci_interp_1sto_sn( w,  wc,  ico, jco, kcw, r1xo, r2xo,     &
    51595378                                       r1yo, r2yo, r1zw, r2zw,                 &
    51605379                                       logc_w_n, logc_ratio_w_n,               &
     
    51665385                  (  .NOT. rans_mode_parent  .AND.  .NOT.  rans_mode  .AND.    &
    51675386                     .NOT. constant_diffusion ) )  THEN
    5168 !                CALL pmci_interp_tril_sn( e,  ec,  ico, jco, kco, r1xo, r2xo,  &
     5387!                CALL pmci_interp_1sto_sn( e,  ec,  ico, jco, kco, r1xo, r2xo,  &
    51695388!                                          r1yo, r2yo, r1zo, r2zo,              &
    51705389!                                          logc_w_n, logc_ratio_w_n,            &
     
    51805399
    51815400             IF ( rans_mode_parent  .AND.  rans_mode  .AND.  rans_tke_e )  THEN
    5182                 CALL pmci_interp_tril_sn( diss, dissc,  ico, jco, kco, r1xo,   &
     5401                CALL pmci_interp_1sto_sn( diss, dissc,  ico, jco, kco, r1xo,   &
    51835402                                          r2xo, r1yo, r2yo, r1zo, r2zo,        &
    51845403                                          logc_w_n, logc_ratio_w_n,            &
     
    51905409
    51915410             IF ( .NOT. neutral )  THEN
    5192                 CALL pmci_interp_tril_sn( pt, ptc, ico, jco, kco, r1xo, r2xo,  &
     5411                CALL pmci_interp_1sto_sn( pt, ptc, ico, jco, kco, r1xo, r2xo,  &
    51935412                                          r1yo, r2yo, r1zo, r2zo,              &
    51945413                                          logc_w_n, logc_ratio_w_n,            &
     
    51995418
    52005419             IF ( humidity )  THEN
    5201                 CALL pmci_interp_tril_sn( q, q_c, ico, jco, kco, r1xo, r2xo,   &
     5420                CALL pmci_interp_1sto_sn( q, q_c, ico, jco, kco, r1xo, r2xo,   &
    52025421                                          r1yo, r2yo, r1zo, r2zo,              &
    52035422                                          logc_w_n, logc_ratio_w_n,            &
     
    52085427                IF ( bulk_cloud_model  .AND.  microphysics_morrison )  THEN
    52095428
    5210                    CALL pmci_interp_tril_sn( qc, qcc, ico, jco, kco, r1xo,     &
     5429                   CALL pmci_interp_1sto_sn( qc, qcc, ico, jco, kco, r1xo,     &
    52115430                                             r2xo, r1yo, r2yo, r1zo, r2zo,     &
    52125431                                             logc_w_n, logc_ratio_w_n,         &
     
    52165435                                             kflo, kfuo, ijkfc_s, 'n', 's' )
    52175436
    5218                    CALL pmci_interp_tril_sn( nc, ncc, ico, jco, kco, r1xo,     &
     5437                   CALL pmci_interp_1sto_sn( nc, ncc, ico, jco, kco, r1xo,     &
    52195438                                             r2xo, r1yo, r2yo, r1zo, r2zo,     &
    52205439                                             logc_u_n, logc_ratio_u_n,         &
     
    52285447                IF ( bulk_cloud_model  .AND.  microphysics_seifert )  THEN
    52295448
    5230                    CALL pmci_interp_tril_sn( qr, qrc, ico, jco, kco, r1xo,     &
     5449                   CALL pmci_interp_1sto_sn( qr, qrc, ico, jco, kco, r1xo,     &
    52315450                                             r2xo, r1yo, r2yo, r1zo, r2zo,     &
    52325451                                             logc_w_n, logc_ratio_w_n,         &
     
    52365455                                             kflo, kfuo, ijkfc_s, 'n', 's' )
    52375456
    5238                    CALL pmci_interp_tril_sn( nr, nrc, ico, jco, kco, r1xo,     &
     5457                   CALL pmci_interp_1sto_sn( nr, nrc, ico, jco, kco, r1xo,     &
    52395458                                             r2xo, r1yo, r2yo, r1zo, r2zo,     &
    52405459                                             logc_w_n, logc_ratio_w_n,         &
     
    52495468
    52505469             IF ( passive_scalar )  THEN
    5251                 CALL pmci_interp_tril_sn( s, sc, ico, jco, kco, r1xo, r2xo,    &
     5470                CALL pmci_interp_1sto_sn( s, sc, ico, jco, kco, r1xo, r2xo,    &
    52525471                                          r1yo, r2yo, r1zo, r2zo,              &
    52535472                                          logc_w_n, logc_ratio_w_n,            &
     
    52605479             IF ( air_chemistry  .AND.  nest_chemistry )  THEN
    52615480                DO  n = 1, nspec
    5262                    CALL pmci_interp_tril_sn( chem_species(n)%conc,             &
     5481                   CALL pmci_interp_1sto_sn( chem_species(n)%conc,             &
    52635482                                             chem_spec_c(:,:,:,n),             &
    52645483                                             ico, jco, kco, r1xo, r2xo,        &
     
    52765495!
    52775496!--    All PEs are top-border PEs
    5278        CALL pmci_interp_tril_t( u,  uc,  icu, jco, kco, r1xu, r2xu, r1yo,      &
     5497       CALL pmci_interp_1sto_t( w,  wc,  ico, jco, kcw, r1xo, r2xo, r1yo,      &
     5498                                r2yo, r1zw, r2zw, kctw, iflo, ifuo,            &
     5499                                jflo, jfuo, kflw, kfuw, ijkfc_w, 'w' )
     5500       CALL pmci_interp_1sto_t( u,  uc,  icu, jco, kco, r1xu, r2xu, r1yo,      &
    52795501                                r2yo, r1zo, r2zo, kcto, iflu, ifuu,            &
    52805502                                jflo, jfuo, kflo, kfuo, ijkfc_u, 'u' )
    5281        CALL pmci_interp_tril_t( v,  vc,  ico, jcv, kco, r1xo, r2xo, r1yv,      &
     5503       CALL pmci_interp_1sto_t( v,  vc,  ico, jcv, kco, r1xo, r2xo, r1yv,      &
    52825504                                r2yv, r1zo, r2zo, kcto, iflo, ifuo,            &
    52835505                                jflv, jfuv, kflo, kfuo, ijkfc_v, 'v' )
    5284        CALL pmci_interp_tril_t( w,  wc,  ico, jco, kcw, r1xo, r2xo, r1yo,      &
    5285                                 r2yo, r1zw, r2zw, kctw, iflo, ifuo,            &
    5286                                 jflo, jfuo, kflw, kfuw, ijkfc_w, 'w' )
     5506
    52875507
    52885508       IF ( (        rans_mode_parent  .AND.         rans_mode )  .OR.         &
    52895509            (  .NOT. rans_mode_parent  .AND.  .NOT.  rans_mode  .AND.          &
    52905510               .NOT. constant_diffusion ) )  THEN
    5291 !          CALL pmci_interp_tril_t( e,  ec,  ico, jco, kco, r1xo, r2xo, r1yo,   &
     5511!          CALL pmci_interp_1sto_t( e,  ec,  ico, jco, kco, r1xo, r2xo, r1yo,   &
    52925512!                                   r2yo, r1zo, r2zo, kcto, iflo, ifuo,         &
    52935513!                                   jflo, jfuo, kflo, kfuo, ijkfc_s, 'e' )
     
    52995519
    53005520       IF ( rans_mode_parent  .AND.  rans_mode  .AND.  rans_tke_e )  THEN
    5301           CALL pmci_interp_tril_t( diss, dissc, ico, jco, kco, r1xo, r2xo,     &
     5521          CALL pmci_interp_1sto_t( diss, dissc, ico, jco, kco, r1xo, r2xo,     &
    53025522                                   r1yo, r2yo, r1zo, r2zo, kcto, iflo, ifuo,   &
    53035523                                   jflo, jfuo, kflo, kfuo, ijkfc_s, 's' )
     
    53055525
    53065526       IF ( .NOT. neutral )  THEN
    5307           CALL pmci_interp_tril_t( pt, ptc, ico, jco, kco, r1xo, r2xo,         &
     5527          CALL pmci_interp_1sto_t( pt, ptc, ico, jco, kco, r1xo, r2xo,         &
    53085528                                   r1yo, r2yo, r1zo, r2zo, kcto, iflo, ifuo,   &
    53095529                                   jflo, jfuo, kflo, kfuo, ijkfc_s, 's' )
     
    53125532       IF ( humidity )  THEN
    53135533
    5314           CALL pmci_interp_tril_t( q, q_c, ico, jco, kco, r1xo, r2xo, r1yo,    &
     5534          CALL pmci_interp_1sto_t( q, q_c, ico, jco, kco, r1xo, r2xo, r1yo,    &
    53155535                                   r2yo, r1zo, r2zo, kcto, iflo, ifuo,         &
    53165536                                   jflo, jfuo, kflo, kfuo, ijkfc_s, 's' )
     
    53185538          IF ( bulk_cloud_model  .AND.  microphysics_morrison )  THEN
    53195539
    5320              CALL pmci_interp_tril_t( qc, qcc, ico, jco, kco, r1xo, r2xo, r1yo,&
     5540             CALL pmci_interp_1sto_t( qc, qcc, ico, jco, kco, r1xo, r2xo, r1yo,&
    53215541                                      r2yo, r1zo, r2zo, kcto, iflo, ifuo,      &
    53225542                                      jflo, jfuo, kflo, kfuo, ijkfc_s, 's' )
    53235543
    5324              CALL pmci_interp_tril_t( nc, ncc, ico, jco, kco, r1xo, r2xo, r1yo,&
     5544             CALL pmci_interp_1sto_t( nc, ncc, ico, jco, kco, r1xo, r2xo, r1yo,&
    53255545                                      r2yo, r1zo, r2zo, kcto, iflo, ifuo,      &
    53265546                                      jflo, jfuo, kflo, kfuo, ijkfc_s, 's' )
     
    53315551
    53325552
    5333              CALL pmci_interp_tril_t( qr, qrc, ico, jco, kco, r1xo, r2xo, r1yo,&
     5553             CALL pmci_interp_1sto_t( qr, qrc, ico, jco, kco, r1xo, r2xo, r1yo,&
    53345554                                      r2yo, r1zo, r2zo, kcto, iflo, ifuo,      &
    53355555                                      jflo, jfuo, kflo, kfuo, ijkfc_s, 's' )
    53365556
    5337              CALL pmci_interp_tril_t( nr, nrc, ico, jco, kco, r1xo, r2xo, r1yo,&
     5557             CALL pmci_interp_1sto_t( nr, nrc, ico, jco, kco, r1xo, r2xo, r1yo,&
    53385558                                      r2yo, r1zo, r2zo, kcto, iflo, ifuo,      &
    53395559                                      jflo, jfuo, kflo, kfuo, ijkfc_s, 's' )
     
    53445564
    53455565       IF ( passive_scalar )  THEN
    5346           CALL pmci_interp_tril_t( s, sc, ico, jco, kco, r1xo, r2xo, r1yo,     &
     5566          CALL pmci_interp_1sto_t( s, sc, ico, jco, kco, r1xo, r2xo, r1yo,     &
    53475567                                   r2yo, r1zo, r2zo, kcto, iflo, ifuo,         &
    53485568                                   jflo, jfuo, kflo, kfuo, ijkfc_s, 's' )
     
    53515571       IF ( air_chemistry  .AND.  nest_chemistry )  THEN
    53525572          DO  n = 1, nspec
    5353              CALL pmci_interp_tril_t( chem_species(n)%conc,                    &
     5573             CALL pmci_interp_1sto_t( chem_species(n)%conc,                    &
    53545574                                      chem_spec_c(:,:,:,n),                    &
    53555575                                      ico, jco, kco, r1xo, r2xo,               &
     
    54445664
    54455665
    5446    SUBROUTINE pmci_interp_tril_lr( f, fc, ic, jc, kc, r1x, r2x, r1y, r2y, r1z, &
     5666   SUBROUTINE pmci_interp_1sto_lr( f, fc, ic, jc, kc, r1x, r2x, r1y, r2y, r1z, &
    54475667                                   r2z, logc, logc_ratio, logc_kbounds,        &
    54485668                                   nzt_topo_nestbc,                            &
     
    54645684      REAL(wp), DIMENSION(1:2,0:ncorr-1,nzb:nzt_topo_nestbc,nys:nyn),          &
    54655685                                      INTENT(IN)    ::  logc_ratio   !<
    5466       REAL(wp), DIMENSION(nxlg:nxrg), INTENT(IN)    ::  r1x     !<
    5467       REAL(wp), DIMENSION(nxlg:nxrg), INTENT(IN)    ::  r2x     !<
    5468       REAL(wp), DIMENSION(nysg:nyng), INTENT(IN)    ::  r1y     !<
    5469       REAL(wp), DIMENSION(nysg:nyng), INTENT(IN)    ::  r2y     !<
    5470       REAL(wp), DIMENSION(nzb:nzt+1), INTENT(IN)    ::  r1z     !<
    5471       REAL(wp), DIMENSION(nzb:nzt+1), INTENT(IN)    ::  r2z     !<
     5686!AH      REAL(wp), DIMENSION(nxlg:nxrg), INTENT(IN)    ::  r1x     !<
     5687!AH      REAL(wp), DIMENSION(nxlg:nxrg), INTENT(IN)    ::  r2x     !<
     5688!AH      REAL(wp), DIMENSION(nysg:nyng), INTENT(IN)    ::  r1y     !<
     5689!AH      REAL(wp), DIMENSION(nysg:nyng), INTENT(IN)    ::  r2y     !<
     5690      REAL(wp), DIMENSION(nxlfc:nxrfc), INTENT(IN)  ::  r1x     !<
     5691      REAL(wp), DIMENSION(nxlfc:nxrfc), INTENT(IN)  ::  r2x     !<
     5692      REAL(wp), DIMENSION(nysfc:nynfc), INTENT(IN)  ::  r1y     !<
     5693      REAL(wp), DIMENSION(nysfc:nynfc), INTENT(IN)  ::  r2y     !<
     5694
     5695!AH      REAL(wp), DIMENSION(nzb:nzt+1), INTENT(IN)    ::  r1z     !<
     5696!AH      REAL(wp), DIMENSION(nzb:nzt+1), INTENT(IN)    ::  r2z     !<
     5697      REAL(wp), DIMENSION(nzb:nzt+kgsr), INTENT(IN) ::  r1z     !<
     5698      REAL(wp), DIMENSION(nzb:nzt+kgsr), INTENT(IN) ::  r2z     !<
    54725699     
    5473       INTEGER(iwp), DIMENSION(nxlg:nxrg), INTENT(IN)           ::  ic     !<
    5474       INTEGER(iwp), DIMENSION(nysg:nyng), INTENT(IN)           ::  jc     !<
    5475       INTEGER(iwp), DIMENSION(nzb:nzt+1), INTENT(IN)           ::  kc     !<
     5700
     5701      INTEGER(iwp), DIMENSION(nxlfc:nxrfc), INTENT(IN)         ::  ic     !<
     5702      INTEGER(iwp), DIMENSION(nysfc:nynfc), INTENT(IN)         ::  jc     !<
     5703!AH      INTEGER(iwp), DIMENSION(nzb:nzt+1), INTENT(IN)           ::  kc     !<
     5704      INTEGER(iwp), DIMENSION(nzb:nzt+kgsr), INTENT(IN)        ::  kc     !<
    54765705      INTEGER(iwp), DIMENSION(1:2,nzb:nzt_topo_nestbc,nys:nyn),                &
    54775706                                          INTENT(IN)           :: logc   !<
     
    54795708
    54805709      INTEGER(iwp) :: kct
    5481       INTEGER(iwp), DIMENSION(icl:icr), INTENT(IN) ::  ifl !< Indicates start index of child cells belonging to certain parent cell - x direction
    5482       INTEGER(iwp), DIMENSION(icl:icr), INTENT(IN) ::  ifu !< Indicates end index of child cells belonging to certain parent cell - x direction
    5483       INTEGER(iwp), DIMENSION(jcs:jcn), INTENT(IN) ::  jfl !< Indicates start index of child cells belonging to certain parent cell - y direction
    5484       INTEGER(iwp), DIMENSION(jcs:jcn), INTENT(IN) ::  jfu !< Indicates start index of child cells belonging to certain parent cell - y direction
     5710
     5711!AH
     5712!      INTEGER(iwp), DIMENSION(icl:icr), INTENT(IN) ::  ifl !< Indicates start index of child cells belonging to certain parent cell - x direction
     5713!      INTEGER(iwp), DIMENSION(icl:icr), INTENT(IN) ::  ifu !< Indicates end index of child cells belonging to certain parent cell - x direction
     5714!      INTEGER(iwp), DIMENSION(jcs:jcn), INTENT(IN) ::  jfl !< Indicates start index of child cells belonging to certain parent cell - y direction
     5715!      INTEGER(iwp), DIMENSION(jcs:jcn), INTENT(IN) ::  jfu !< Indicates start index of child cells belonging to certain parent cell - y direction
     5716      INTEGER(iwp), DIMENSION(icla:icra), INTENT(IN) ::  ifl !< Indicates start index of child cells belonging to certain parent cell - x direction
     5717      INTEGER(iwp), DIMENSION(icla:icra), INTENT(IN) ::  ifu !< Indicates end index of child cells belonging to certain parent cell - x direction
     5718      INTEGER(iwp), DIMENSION(jcsa:jcna), INTENT(IN) ::  jfl !< Indicates start index of child cells belonging to certain parent cell - y direction
     5719      INTEGER(iwp), DIMENSION(jcsa:jcna), INTENT(IN) ::  jfu !< Indicates start index of child cells belonging to certain parent cell - y direction
     5720!AH
     5721
    54855722!AH      INTEGER(iwp), DIMENSION(0:kct), INTENT(IN)   ::  kfl !< Indicates start index of child cells belonging to certain parent cell - z direction
    54865723!AH      INTEGER(iwp), DIMENSION(0:kct), INTENT(IN)   ::  kfu !< Indicates start index of child cells belonging to certain parent cell - z direction
     
    54895726
    54905727!AH      INTEGER(iwp), DIMENSION(0:kct,jcs:jcn,icl:icr), INTENT(IN) :: ijkfc !< number of child grid points contributing to a parent grid box
    5491       INTEGER(iwp), DIMENSION(0:cg%nz+1,jcs:jcn,icl:icr), INTENT(IN) :: ijkfc !< number of child grid points contributing to a parent grid box
    5492 
    5493       CHARACTER(LEN=1), INTENT(IN) ::  edge   !<
    5494       CHARACTER(LEN=1), INTENT(IN) ::  var    !<
    5495 
    5496       INTEGER(iwp) ::  i        !<
    5497       INTEGER(iwp) ::  ia       !<
    5498       INTEGER(iwp) ::  ib       !<
    5499       INTEGER(iwp) ::  ibgp     !<
    5500       INTEGER(iwp) ::  ijk      !<
    5501       INTEGER(iwp) ::  iw       !<
    5502       INTEGER(iwp) ::  j        !<
     5728!AH
     5729!      INTEGER(iwp), DIMENSION(0:cg%nz+1,jcs:jcn,icl:icr), INTENT(IN) :: ijkfc !< number of child grid points contributing to a parent grid box
     5730      INTEGER(iwp), DIMENSION(0:cg%nz+1,jcsa:jcna,icla:icra), INTENT(IN) :: ijkfc !< number of child grid points contributing to a parent grid box
     5731!AH
     5732
     5733      CHARACTER(LEN=1), INTENT(IN) ::  edge   !< Edge symbol: 'l', 'r', 's' or 'n'
     5734      CHARACTER(LEN=1), INTENT(IN) ::  var    !< Variable symbol: 'u', 'v', 'w' or 's'
     5735
     5736      INTEGER(iwp) ::  i        !< Lower bound of the running index ia
     5737      INTEGER(iwp) ::  ia       !< i-index running over the parent-grid cell on the boundary
     5738      INTEGER(iwp) ::  iaw      !< Reduced ia-index for workarr_lr
     5739      INTEGER(iwp) ::  iawbc    !< iaw-index pointing to the boundary-value nodes (either 0 or igsr-1)     
     5740      INTEGER(iwp) ::  ibc      !< Fixed i-index pointing to the boundary-value nodes (either i or iend)
     5741!AH      INTEGER(iwp) ::  ibeg     !< i-index pointing to the starting point of workarr_lr in the i-direction
     5742      INTEGER(iwp) ::  iend     !< Upper bound of the running index ia
     5743      INTEGER(iwp) ::  ierr     !< MPI error code
     5744      INTEGER(iwp) ::  ijk      !< Running index for all child-grid cells within the anterpolation cell
     5745      INTEGER(iwp) ::  iw       !< i-index for wall_flags_0
     5746      INTEGER(iwp) ::  j        !< Running index in the y-direction
    55035747      INTEGER(iwp) ::  jco      !<
    55045748      INTEGER(iwp) ::  jcorr    !<
    55055749      INTEGER(iwp) ::  jinc     !<
    5506       INTEGER(iwp) ::  jw       !<
     5750      INTEGER(iwp) ::  jw       !< j-index for wall_flags_0
    55075751      INTEGER(iwp) ::  j1       !<
    5508       INTEGER(iwp) ::  k        !<
    5509       INTEGER(iwp) ::  k_wall   !< vertical index of topography top
     5752      INTEGER(iwp) ::  k        !< Running index in the z-direction
     5753      INTEGER(iwp) ::  k_wall   !< Vertical index of topography top
    55105754      INTEGER(iwp) ::  kco      !<
    55115755      INTEGER(iwp) ::  kcorr    !<
     5756      INTEGER(iwp) ::  kw       !< k-index for wall_flags_0
    55125757      INTEGER(iwp) ::  k1       !<
    5513       INTEGER(iwp) ::  l        !<
    5514       INTEGER(iwp) ::  m        !<
    5515       INTEGER(iwp) ::  n        !<
    5516       INTEGER(iwp) ::  kbc      !<
    5517       INTEGER(iwp) ::  var_flag !<     
    5518 
    5519       REAL(wp) ::  cellsum     !<
    5520       REAL(wP) ::  cellsumd    !<
    5521       REAL(wp) ::  fkj         !<
    5522       REAL(wp) ::  fkjp        !<
    5523       REAL(wp) ::  fkpj        !<
    5524       REAL(wp) ::  fkpjp       !<
    5525       REAL(wp) ::  fk          !<
    5526       REAL(wp) ::  fkp         !<
    5527       REAL(wp) ::  rcorr       !<
    5528       REAL(wp) ::  rcorr_ijk   !<
    5529  
     5758      INTEGER(iwp) ::  l        !< Parent-grid running index in the x-direction
     5759      INTEGER(iwp) ::  lbeg     !< l-index pointing to the starting point of workarrc_lr in the l-direction
     5760      INTEGER(iwp) ::  lp1      !< l+1
     5761      INTEGER(iwp) ::  loff     !< l-offset needed on the right boundary to correctly refer to boundary ghost points
     5762      INTEGER(iwp) ::  lw       !< Reduced l-index for workarrc_lr
     5763      INTEGER(iwp) ::  m        !< Parent-grid running index in the y-direction
     5764      INTEGER(iwp) ::  mnorthv  !< Upshift by one for the upper bound of index m in case of var == 'v'
     5765      INTEGER(iwp) ::  mp1      !< m+1
     5766      INTEGER(iwp) ::  n        !< Parent-grid running index in the z-direction
     5767      INTEGER(iwp) ::  np1      !< n+1
     5768      INTEGER(iwp) ::  ntopw    !< Upshift by one for the upper bound of index n in case of var == 'w'
     5769      INTEGER(iwp) ::  var_flag !< Variable flag for BTEST( wall_flags_0 )
     5770
     5771      REAL(wp) ::  cellsum      !< Sum of child-grid node values over the anterpolation cell
     5772      REAL(wP) ::  cellsumd     !< Sum of differences over the anterpolation cell
     5773      REAL(wp) ::  fkj          !< Intermediate result in trilinear interpolation
     5774      REAL(wp) ::  fkjp         !< Intermediate result in trilinear interpolation
     5775      REAL(wp) ::  fkpj         !< Intermediate result in trilinear interpolation
     5776      REAL(wp) ::  fkpjp        !< Intermediate result in trilinear interpolation
     5777      REAL(wp) ::  fk           !< Intermediate result in trilinear interpolation
     5778      REAL(wp) ::  fkp          !< Intermediate result in trilinear interpolation
     5779      REAL(wp) ::  rcorr        !< Average reversibility correction for the whole anterpolation cell
     5780      REAL(wp) ::  rcorr_ijk    !< Reversibility correction distributed to the individual child-grid nodes
     5781
    55305782!
    55315783!--   Check which edge is to be handled
     
    55345786!--      For u, nxl is a ghost node, but not for the other variables
    55355787         IF ( var == 'u' )  THEN
    5536             i  = nxl
    5537             ib = nxl - 1
     5788            i     = nxl
     5789            iend  = nxl
     5790            ibc   = nxl
     5791            iawbc = 0
     5792            l     = icl + 2
     5793            lw    = 2
     5794            lbeg  = icl
     5795            loff  = 0
    55385796         ELSE
    5539             i  = nxl - 1
    5540             ib = nxl - 2
     5797            i     = nxl - igsr
     5798            iend  = nxl - 1
     5799            ibc   = nxl - 1
     5800            iawbc = igsr-1
     5801            l     = icl + 1
     5802            lw    = 1
     5803            lbeg  = icl
     5804            loff  = 0
    55415805         ENDIF
    55425806      ELSEIF ( edge == 'r' )  THEN
    5543          i  = nxr + 1
    5544          ib = nxr + 2
     5807         IF ( var == 'u' )  THEN
     5808            i     = nxr + 1           
     5809            iend  = nxr + 1
     5810            ibc   = nxr + 1
     5811            iawbc = 0
     5812            l     = icr - 1
     5813            lw    = 1
     5814            lbeg  = icr - 2
     5815            loff  = 0
     5816         ELSE
     5817            i     = nxr + 1
     5818            iend  = nxr + igsr
     5819            ibc   = nxr + 1
     5820            iawbc = 0
     5821            l     = icr - 1
     5822            lw    = 1
     5823            lbeg  = icr - 2
     5824            loff  = 1
     5825         ENDIF
     5826      ENDIF
     5827
     5828      IF  ( var == 'w' )  THEN
     5829         ntopw = 1
     5830      ELSE
     5831         ntopw = 0
     5832      ENDIF
     5833
     5834      IF  ( var == 'v' )  THEN
     5835         mnorthv = 0
     5836      ELSE
     5837         mnorthv = 1
    55455838      ENDIF
    55465839
     
    55545847         var_flag = 0
    55555848      ENDIF
    5556    
    5557       DO  j = nys, nyn+1
    5558 !
    5559 !--      Determine vertical index of topography top at grid point (j,i)
     5849
     5850      IF  ( var == 'u' )  THEN
     5851!AH!
     5852!AH!--      Substitute the necessary parent-grid data to the work array workarrc_lr.
     5853!AH         workarrc_lr = 0.0_wp     
     5854!AH         IF  ( pdims(2) > 1 )  THEN
     5855!AH#if defined( __parallel )
     5856!AH            IF  ( nys == 0 )  THEN
     5857!AH               workarrc_lr(0:cg%nz+1,jcsw:jcnw-1,0:2)                           &
     5858!AH                    = fc(0:cg%nz+1,jcsw:jcnw-1,lbeg:lbeg+2)
     5859!AH            ELSE IF  ( nyn == ny )  THEN
     5860!AH               workarrc_lr(0:cg%nz+1,jcsw+1:jcnw,0:2)                           &
     5861!AH                    = fc(0:cg%nz+1,jcsw+1:jcnw,lbeg:lbeg+2)
     5862!AH            ELSE
     5863!AH               workarrc_lr(0:cg%nz+1,jcsw+1:jcnw-1,0:2)                         &
     5864!AH                    = fc(0:cg%nz+1,jcsw+1:jcnw-1,lbeg:lbeg+2)
     5865!AH            ENDIF
     5866!AH!
     5867!AH!--         South-north exchange if more than one PE subdomain in the y-direction.
     5868!AH!--         Note that in case of 3-D nesting the south (psouth == MPI_PROC_NULL)
     5869!AH!--         and north (pnorth == MPI_PROC_NULL) boundaries are not exchanged
     5870!AH!--         because the nest domain is not cyclic.
     5871!AH!--         From south to north
     5872!AH            CALL MPI_SENDRECV( workarrc_lr(0,jcsw+1,0), 1,                      &
     5873!AH                 workarrc_lr_exchange_type, psouth,  0,                         &
     5874!AH                 workarrc_lr(0,jcnw,0), 1,                                      &
     5875!AH                 workarrc_lr_exchange_type, pnorth,  0,                         &
     5876!AH                 comm2d, status, ierr )
     5877!AH!
     5878!AH!--         From north to south       
     5879!AH            CALL MPI_SENDRECV( workarrc_lr(0,jcnw-1,0), 1,                      &
     5880!AH                 workarrc_lr_exchange_type, pnorth,  1,                         &
     5881!AH                 workarrc_lr(0,jcsw,0), 1,                                      &
     5882!AH                 workarrc_lr_exchange_type, psouth,  1,                         &
     5883!AH                 comm2d, status, ierr )
     5884!AH#endif
     5885!AH         ELSE
     5886!AH            workarrc_lr(0:cg%nz+1,jcsw:jcnw,0:2)                                &
     5887!AH                 = fc(0:cg%nz+1,jcsw:jcnw,lbeg:lbeg+2)           
     5888!AH         ENDIF
     5889
     5890         DO  m = jcsw+1, jcnw-1
     5891            DO n = 0, kct
     5892
     5893               DO  j = jfl(m), jfu(m)
     5894                  DO  k = kfl(n), kfu(n)
     5895                     f(k,j,ibc) = fc(n,m,l)
     5896                  ENDDO
     5897               ENDDO
     5898
     5899            ENDDO
     5900         ENDDO
     5901
     5902      ELSE IF  ( var == 'v' )  THEN
     5903         
     5904         DO  m = jcsw+1, jcnw-1
     5905            DO n = 0, kct
     5906
     5907               DO  j = jfl(m), jfl(m+1)-1
     5908                  DO  k = kfl(n), kfu(n)
     5909                     f(k,j,ibc) = fc(n,m,l)
     5910                  ENDDO
     5911               ENDDO
     5912
     5913            ENDDO
     5914         ENDDO
     5915
     5916      ELSE IF  ( var == 'w' )  THEN
     5917
     5918         DO  m = jcsw+1, jcnw-1
     5919            DO n = 1, kct + 1   ! It is important to go up to kct+1 
     5920
     5921               DO  j = jfl(m), jfu(m)
     5922                  f(nzb,j,ibc) = 0.0_wp   ! Because the n-loop starts from n=1 instead of 0
     5923                  DO  k = kfu(n-1)+1, kfu(n)
     5924                     f(k,j,ibc) = fc(n,m,l)
     5925                  ENDDO
     5926               ENDDO
     5927
     5928            ENDDO
     5929         ENDDO
     5930
     5931      ELSE   ! scalars
     5932         
     5933         DO  m = jcsw+1, jcnw-1
     5934            DO n = 0, kct
     5935               
     5936               DO  j = jfl(m), jfu(m)
     5937                  DO  k = kfl(n), kfu(n)
     5938                     f(k,j,ibc) = fc(n,m,l)
     5939                  ENDDO
     5940               ENDDO
     5941
     5942            ENDDO
     5943         ENDDO
     5944
     5945      ENDIF  ! var
     5946
     5947   END SUBROUTINE pmci_interp_1sto_lr
     5948
     5949
     5950
     5951   SUBROUTINE pmci_interp_1sto_sn( f, fc, ic, jc, kc, r1x, r2x, r1y, r2y, r1z, &
     5952                                   r2z, logc, logc_ratio, logc_kbounds,        &
     5953                                   nzt_topo_nestbc,                            &
     5954                                   kct, ifl, ifu, jfl, jfu, kfl, kfu, ijkfc,   &
     5955                                   edge, var )
     5956
     5957!
     5958!--   Interpolation of ghost-node values used as the child-domain boundary
     5959!--   conditions. This subroutine handles the south and north boundaries.
     5960!--   This subroutine is based on trilinear interpolation.
     5961
     5962      IMPLICIT NONE
     5963
     5964      INTEGER(iwp) ::  nzt_topo_nestbc   !<
     5965
     5966      REAL(wp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg),                      &
     5967                                      INTENT(INOUT) ::  f             !<
     5968      REAL(wp), DIMENSION(0:cg%nz+1,jcs:jcn,icl:icr),                          &
     5969                                      INTENT(IN)    ::  fc            !<
     5970      REAL(wp), DIMENSION(1:2,0:ncorr-1,nzb:nzt_topo_nestbc,nxl:nxr),          &
     5971                                      INTENT(IN)    ::  logc_ratio    !<
     5972      REAL(wp), DIMENSION(nxlfc:nxrfc), INTENT(IN)  ::  r1x           !<
     5973      REAL(wp), DIMENSION(nxlfc:nxrfc), INTENT(IN)  ::  r2x           !<
     5974      REAL(wp), DIMENSION(nysfc:nynfc), INTENT(IN)  ::  r1y           !<
     5975      REAL(wp), DIMENSION(nysfc:nynfc), INTENT(IN)  ::  r2y           !<
     5976!AH      REAL(wp), DIMENSION(nzb:nzt+1), INTENT(IN)    ::  r1z           !<
     5977!AH      REAL(wp), DIMENSION(nzb:nzt+1), INTENT(IN)    ::  r2z           !<
     5978      REAL(wp), DIMENSION(nzb:nzt+kgsr), INTENT(IN) ::  r1z           !<
     5979      REAL(wp), DIMENSION(nzb:nzt+kgsr), INTENT(IN) ::  r2z           !<
     5980
     5981     
     5982      INTEGER(iwp), DIMENSION(nxlfc:nxrfc), INTENT(IN)         ::  ic    !<
     5983      INTEGER(iwp), DIMENSION(nysfc:nynfc), INTENT(IN)         ::  jc    !<
     5984!AH      INTEGER(iwp), DIMENSION(nzb:nzt+1), INTENT(IN)           ::  kc    !<
     5985      INTEGER(iwp), DIMENSION(nzb:nzt+kgsr), INTENT(IN)        ::  kc    !<
     5986      INTEGER(iwp), DIMENSION(1:2,nzb:nzt_topo_nestbc,nxl:nxr),                &
     5987                                          INTENT(IN)           ::  logc  !<
     5988      INTEGER(iwp), DIMENSION(1:2,nxl:nxr), INTENT(IN)         ::  logc_kbounds  !<
     5989
     5990      INTEGER(iwp) :: kct
     5991!AH
     5992!      INTEGER(iwp), DIMENSION(icl:icr), INTENT(IN) ::  ifl !< Indicates start index of child cells belonging to certain parent cell - x direction
     5993!      INTEGER(iwp), DIMENSION(icl:icr), INTENT(IN) ::  ifu !< Indicates end index of child cells belonging to certain parent cell - x direction
     5994!      INTEGER(iwp), DIMENSION(jcs:jcn), INTENT(IN) ::  jfl !< Indicates start index of child cells belonging to certain parent cell - y direction
     5995!      INTEGER(iwp), DIMENSION(jcs:jcn), INTENT(IN) ::  jfu !< Indicates start index of child cells belonging to certain parent cell - y direction
     5996      INTEGER(iwp), DIMENSION(icla:icra), INTENT(IN) ::  ifl !< Indicates start index of child cells belonging to certain parent cell - x direction
     5997      INTEGER(iwp), DIMENSION(icla:icra), INTENT(IN) ::  ifu !< Indicates end index of child cells belonging to certain parent cell - x direction
     5998      INTEGER(iwp), DIMENSION(jcsa:jcna), INTENT(IN) ::  jfl !< Indicates start index of child cells belonging to certain parent cell - y direction
     5999      INTEGER(iwp), DIMENSION(jcsa:jcna), INTENT(IN) ::  jfu !< Indicates start index of child cells belonging to certain parent cell - y direction
     6000!AH
     6001
     6002!AH      INTEGER(iwp), DIMENSION(0:kct), INTENT(IN)   ::  kfl !< Indicates start index of child cells belonging to certain parent cell - z direction
     6003!AH      INTEGER(iwp), DIMENSION(0:kct), INTENT(IN)   ::  kfu !< Indicates start index of child cells belonging to certain parent cell - z direction
     6004      INTEGER(iwp), DIMENSION(0:cg%nz+1), INTENT(IN)   ::  kfl !< Indicates start index of child cells belonging to certain parent cell - z direction
     6005      INTEGER(iwp), DIMENSION(0:cg%nz+1), INTENT(IN)   ::  kfu !< Indicates start index of child cells belonging to certain parent cell - z direction
     6006!AH      INTEGER(iwp), DIMENSION(0:kct,jcs:jcn,icl:icr), INTENT(IN) :: ijkfc !< number of child grid points contributing to a parent grid box
     6007!AH
     6008!      INTEGER(iwp), DIMENSION(0:cg%nz+1,jcs:jcn,icl:icr), INTENT(IN) :: ijkfc !< number of child grid points contributing to a parent grid box
     6009      INTEGER(iwp), DIMENSION(0:cg%nz+1,jcsa:jcna,icla:icra), INTENT(IN) :: ijkfc !< number of child grid points contributing to a parent grid box
     6010!AH
     6011
     6012      CHARACTER(LEN=1), INTENT(IN) ::  edge   !< Edge symbol: 'l', 'r', 's' or 'n'
     6013      CHARACTER(LEN=1), INTENT(IN) ::  var    !< Variable symbol: 'u', 'v', 'w' or 's'
     6014     
     6015      INTEGER(iwp) ::  i        !< Running index in the x-direction
     6016      INTEGER(iwp) ::  iinc     !<
     6017      INTEGER(iwp) ::  icorr    !<
     6018      INTEGER(iwp) ::  ico      !<
     6019      INTEGER(iwp) ::  ierr     !< MPI error code
     6020      INTEGER(iwp) ::  ijk      !< Running index for all child-grid cells within the anterpolation cell
     6021      INTEGER(iwp) ::  iw       !< i-index for wall_flags_0
     6022      INTEGER(iwp) ::  i1       !<
     6023      INTEGER(iwp) ::  j        !< Lower bound of the running index ja
     6024      INTEGER(iwp) ::  ja       !< Index in y-direction running over the parent-grid cell on the boundary
     6025      INTEGER(iwp) ::  jaw      !< Reduced ja-index for workarr_sn
     6026      INTEGER(iwp) ::  jawbc    !< jaw-index pointing to the boundary-value nodes (either 0 or jgsr-1)
     6027!AH      INTEGER(iwp) ::  jbeg     !< j-index pointing to the starting point of workarr_sn in the j-direction
     6028      INTEGER(iwp) ::  jbc      !< Fixed j-index pointing to the boundary-value nodes (either j or jend)
     6029      INTEGER(iwp) ::  jend     !< Upper bound of the running index ja
     6030      INTEGER(iwp) ::  jw       !< j-index for wall_flags_0
     6031      INTEGER(iwp) ::  k        !< Running index in the z-direction
     6032      INTEGER(iwp) ::  k_wall   !< Vertical index of topography top
     6033      INTEGER(iwp) ::  kcorr    !<
     6034      INTEGER(iwp) ::  kco      !<
     6035      INTEGER(iwp) ::  kw       !< k-index for wall_flags_0
     6036      INTEGER(iwp) ::  k1       !<
     6037      INTEGER(iwp) ::  l        !< Parent-grid running index in the x-direction
     6038      INTEGER(iwp) ::  lp1      !< l+1
     6039      INTEGER(iwp) ::  lrightu  !< Upshift by one for the upper bound of index l in case of var == 'u'
     6040      INTEGER(iwp) ::  m        !< Parent-grid running index in the y-direction
     6041      INTEGER(iwp) ::  mbeg     !< m-index pointing to the starting point of workarrc_sn in the m-direction
     6042      INTEGER(iwp) ::  moff     !< m-offset needed on the north boundary to correctly refer to boundary ghost points
     6043      INTEGER(iwp) ::  mp1      !< m+1
     6044      INTEGER(iwp) ::  mw       !< Reduced m-index for workarrc_sn
     6045      INTEGER(iwp) ::  n        !< Parent-grid running index in the z-direction
     6046      INTEGER(iwp) ::  np1      !< n+1
     6047      INTEGER(iwp) ::  ntopw    !< Upshift by one for the upper bound of index n in case of var == 'w'
     6048      INTEGER(iwp) ::  var_flag !< Variable flag for BTEST( wall_flags_0 )
     6049
     6050      REAL(wp) ::  cellsum      !< Sum of child-grid node values over the anterpolation cell
     6051      REAL(wp) ::  cellsumd     !< Sum of differences over the anterpolation cell
     6052      REAL(wp) ::  fk           !< Intermediate result in trilinear interpolation
     6053      REAL(wp) ::  fkj          !< Intermediate result in trilinear interpolation
     6054      REAL(wp) ::  fkjp         !< Intermediate result in trilinear interpolation
     6055      REAL(wp) ::  fkpj         !< Intermediate result in trilinear interpolation
     6056      REAL(wp) ::  fkpjp        !< Intermediate result in trilinear interpolation
     6057      REAL(wp) ::  fkp          !< Intermediate result in trilinear interpolation
     6058      REAL(wp) ::  rcorr        !< Average reversibility correction for the whole anterpolation cell
     6059      REAL(wp) ::  rcorr_ijk    !< Reversibility correction distributed to the individual child-grid nodes
     6060
     6061!
     6062!--   Check which edge is to be handled: south or north
     6063      IF ( edge == 's' )  THEN
     6064!
     6065!--      For v, nys is a ghost node, but not for the other variables
     6066         IF ( var == 'v' )  THEN
     6067            j     = nys
     6068            jend  = nys
     6069            jawbc = 0
     6070            jbc   = nys
     6071            m     = jcs + 2
     6072            mw    = 2
     6073            mbeg  = jcs
     6074            moff  = 0
     6075         ELSE
     6076            j     = nys - jgsr
     6077            jend  = nys - 1
     6078            jawbc = jgsr - 1
     6079            jbc   = nys - 1
     6080            m     = jcs + 1
     6081            mw    = 1
     6082            mbeg  = jcs
     6083            moff  = 0
     6084         ENDIF
     6085      ELSEIF ( edge == 'n' )  THEN
     6086         IF ( var == 'v' )  THEN
     6087            j     = nyn + 1
     6088            jend  = nyn + 1
     6089            jawbc = 0
     6090            jbc   = nyn + 1
     6091            m     = jcn - 1
     6092            mw    = 1
     6093            mbeg  = jcn - 2
     6094            moff  = 0
     6095         ELSE
     6096            j     = nyn + 1
     6097            jend  = nyn + jgsr
     6098            jawbc = 0
     6099            jbc   = nyn + 1
     6100            m     = jcn - 1
     6101            mw    = 1
     6102            mbeg  = jcn - 2
     6103            moff  = 1
     6104         ENDIF
     6105      ENDIF
     6106
     6107      IF  ( var == 'w' )  THEN
     6108         ntopw = 1
     6109      ELSE
     6110         ntopw = 0
     6111      ENDIF
     6112
     6113      IF  ( var == 'u' )  THEN
     6114         lrightu = 0
     6115      ELSE
     6116         lrightu = 1
     6117      ENDIF
     6118
     6119      IF ( var == 'u' )  THEN
     6120         var_flag = 1
     6121      ELSEIF ( var == 'v' )  THEN
     6122         var_flag = 2
     6123      ELSEIF ( var == 'w' )  THEN
     6124         var_flag = 3
     6125      ELSE
     6126         var_flag = 0
     6127      ENDIF
     6128
     6129      IF  ( var == 'v' )  THEN
     6130!AH!
     6131!AH!--      Substitute the necessary parent-grid data to the work array workarrc_sn.
     6132!AH         workarrc_sn = 0.0_wp     
     6133!AH         IF  ( pdims(1) > 1 )  THEN
     6134!AH#if defined( __parallel )
     6135!AH            IF  ( nxl == 0 )  THEN   ! if ( bc_dirichlet_l )
     6136!AH               workarrc_sn(0:cg%nz+1,0:2,iclw:icrw-1)                           &
     6137!AH                    = fc(0:cg%nz+1,mbeg:mbeg+2,iclw:icrw-1)
     6138!AH            ELSE IF  ( nxr == nx )  THEN    ! if ( bc_dirichlet_r )
     6139!AH               workarrc_sn(0:cg%nz+1,0:2,iclw+1:icrw)                           &
     6140!AH                    = fc(0:cg%nz+1,mbeg:mbeg+2,iclw+1:icrw)
     6141!AH            ELSE
     6142!AH               workarrc_sn(0:cg%nz+1,0:2,iclw+1:icrw-1)                         &
     6143!AH                    = fc(0:cg%nz+1,mbeg:mbeg+2,iclw+1:icrw-1)
     6144!AH            ENDIF
     6145!AH!
     6146!AH!--         Left-right exchange if more than one PE subdomain in the x-direction.
     6147!AH!--         Note that in case of 3-D nesting the left (pleft == MPI_PROC_NULL) and
     6148!AH!--         right (pright == MPI_PROC_NULL) boundaries are not exchanged because
     6149!AH!--         the nest domain is not cyclic.
     6150!AH!--         From left to right
     6151!AH            CALL MPI_SENDRECV( workarrc_sn(0,0,iclw+1), 1,                      &
     6152!AH                 workarrc_sn_exchange_type, pleft,   0,                         &
     6153!AH                 workarrc_sn(0,0,icrw), 1,                                      &
     6154!AH                 workarrc_sn_exchange_type, pright,  0,                         &
     6155!AH                 comm2d, status, ierr )
     6156!AH!
     6157!AH!--         From right to left       
     6158!AH            CALL MPI_SENDRECV( workarrc_sn(0,0,icrw-1), 1,                      &
     6159!AH                 workarrc_sn_exchange_type, pright,  1,                         &
     6160!AH                 workarrc_sn(0,0,iclw), 1,                                      &
     6161!AH                 workarrc_sn_exchange_type, pleft,   1,                         &
     6162!AH                 comm2d, status, ierr )
     6163!AH#endif     
     6164!AH         ELSE
     6165!AH            workarrc_sn(0:cg%nz+1,0:2,iclw+1:icrw-1)                            &
     6166!AH                 = fc(0:cg%nz+1,mbeg:mbeg+2,iclw+1:icrw-1)
     6167!AH         ENDIF
     6168
     6169         DO  l = iclw+1, icrw-1
     6170            DO n = 0, kct
     6171
     6172               DO  i = ifl(l), ifu(l)
     6173                  DO  k = kfl(n), kfu(n)
     6174                     f(k,jbc,i) = fc(n,m,l)
     6175                  ENDDO
     6176               ENDDO
     6177
     6178            ENDDO
     6179         ENDDO
     6180
     6181      ELSE IF  ( var == 'u' )  THEN
     6182         
     6183         DO  l = iclw+1, icrw-1
     6184            DO n = 0, kct
     6185               
     6186               DO  i = ifl(l), ifl(l+1)-1
     6187                  DO  k = kfl(n), kfu(n)
     6188                     f(k,jbc,i) = fc(n,m,l)
     6189                  ENDDO
     6190               ENDDO
     6191
     6192            ENDDO
     6193         ENDDO
     6194
     6195      ELSE IF  ( var == 'w' )  THEN
     6196
     6197         DO  l = iclw+1, icrw-1
     6198            DO n = 1, kct + 1   ! It is important to go up to kct+1 
     6199               
     6200               DO  i = ifl(l), ifu(l)
     6201                  f(nzb,jbc,i) = 0.0_wp   ! Because the n-loop starts from n=1 instead of 0
     6202                  DO  k = kfu(n-1)+1, kfu(n)
     6203                     f(k,jbc,i) = fc(n,m,l)
     6204                  ENDDO
     6205               ENDDO
     6206
     6207            ENDDO
     6208         ENDDO
     6209
     6210      ELSE   ! scalars
     6211         
     6212         DO  l = iclw+1, icrw-1
     6213            DO n = 0, kct
     6214               
     6215               DO  i = ifl(l), ifu(l)
     6216                  DO  k = kfl(n), kfu(n)
     6217                     f(k,jbc,i) = fc(n,m,l)
     6218                  ENDDO
     6219               ENDDO
     6220
     6221            ENDDO
     6222         ENDDO
     6223
     6224      ENDIF  ! var
     6225
     6226   END SUBROUTINE pmci_interp_1sto_sn
     6227
     6228
     6229
     6230   SUBROUTINE pmci_interp_1sto_t( f, fc, ic, jc, kc, r1x, r2x, r1y, r2y,       &
     6231                                  r1z, r2z, kct, ifl, ifu, jfl, jfu, kfl, kfu, &
     6232                                  ijkfc, var )
     6233
     6234!
     6235!--   Interpolation of ghost-node values used as the child-domain boundary
     6236!--   conditions. This subroutine handles the top boundary.
     6237!--   This subroutine is based on trilinear interpolation.
     6238
     6239      IMPLICIT NONE
     6240
     6241      REAL(wp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg),                      &
     6242                                      INTENT(INOUT) ::  f     !< Child-grid array
     6243      REAL(wp), DIMENSION(0:cg%nz+1,jcs:jcn,icl:icr),                          &
     6244                                      INTENT(IN)    ::  fc    !< Parent-grid array
     6245      REAL(wp), DIMENSION(nxlfc:nxrfc), INTENT(IN)  ::  r1x   !<
     6246      REAL(wp), DIMENSION(nxlfc:nxrfc), INTENT(IN)  ::  r2x   !<
     6247      REAL(wp), DIMENSION(nysfc:nynfc), INTENT(IN)  ::  r1y   !<
     6248      REAL(wp), DIMENSION(nysfc:nynfc), INTENT(IN)  ::  r2y   !<
     6249!AH      REAL(wp), DIMENSION(nzb:nzt+1), INTENT(IN)    ::  r1z   !<
     6250!AH      REAL(wp), DIMENSION(nzb:nzt+1), INTENT(IN)    ::  r2z   !<
     6251      REAL(wp), DIMENSION(nzb:nzt+kgsr), INTENT(IN) ::  r1z   !<
     6252      REAL(wp), DIMENSION(nzb:nzt+kgsr), INTENT(IN) ::  r2z   !<
     6253
     6254     
     6255      INTEGER(iwp), DIMENSION(nxlfc:nxrfc), INTENT(IN)  ::  ic    !<
     6256      INTEGER(iwp), DIMENSION(nysfc:nynfc), INTENT(IN)  ::  jc    !<
     6257!AH      INTEGER(iwp), DIMENSION(nzb:nzt+1), INTENT(IN)    ::  kc    !<
     6258      INTEGER(iwp), DIMENSION(nzb:nzt+kgsr), INTENT(IN) ::  kc    !<
     6259
     6260      INTEGER(iwp) :: kct
     6261!AH
     6262!      INTEGER(iwp), DIMENSION(icl:icr), INTENT(IN) ::  ifl !< Indicates start index of child cells belonging to certain parent cell - x direction
     6263!      INTEGER(iwp), DIMENSION(icl:icr), INTENT(IN) ::  ifu !< Indicates end index of child cells belonging to certain parent cell - x direction
     6264!      INTEGER(iwp), DIMENSION(jcs:jcn), INTENT(IN) ::  jfl !< Indicates start index of child cells belonging to certain parent cell - y direction
     6265!      INTEGER(iwp), DIMENSION(jcs:jcn), INTENT(IN) ::  jfu !< Indicates start index of child cells belonging to certain parent cell - y direction
     6266      INTEGER(iwp), DIMENSION(icla:icra), INTENT(IN) ::  ifl !< Indicates start index of child cells belonging to certain parent cell - x direction
     6267      INTEGER(iwp), DIMENSION(icla:icra), INTENT(IN) ::  ifu !< Indicates end index of child cells belonging to certain parent cell - x direction
     6268      INTEGER(iwp), DIMENSION(jcsa:jcna), INTENT(IN) ::  jfl !< Indicates start index of child cells belonging to certain parent cell - y direction
     6269      INTEGER(iwp), DIMENSION(jcsa:jcna), INTENT(IN) ::  jfu !< Indicates start index of child cells belonging to certain parent cell - y direction
     6270!AH      INTEGER(iwp), DIMENSION(0:kct), INTENT(IN)   ::  kfl !< Indicates start index of child cells belonging to certain parent cell - z direction
     6271!AH      INTEGER(iwp), DIMENSION(0:kct), INTENT(IN)   ::  kfu !< Indicates start index of child cells belonging to certain parent cell - z direction
     6272      INTEGER(iwp), DIMENSION(0:cg%nz+1), INTENT(IN)   ::  kfl !< Indicates start index of child cells belonging to certain parent cell - z direction
     6273      INTEGER(iwp), DIMENSION(0:cg%nz+1), INTENT(IN)   ::  kfu !< Indicates start index of child cells belonging to certain parent cell - z direction
     6274!AH      INTEGER(iwp), DIMENSION(0:kct,jcs:jcn,icl:icr), INTENT(IN) :: ijkfc !< number of child grid points contributing to a parent grid box
     6275!AH
     6276!      INTEGER(iwp), DIMENSION(0:cg%nz+1,jcs:jcn,icl:icr), INTENT(IN) :: ijkfc !< number of child grid points contributing to a parent grid box
     6277      INTEGER(iwp), DIMENSION(0:cg%nz+1,jcsa:jcna,icla:icra), INTENT(IN) :: ijkfc !< number of child grid points contributing to a parent grid box
     6278!AH
     6279
     6280      CHARACTER(LEN=1), INTENT(IN) :: var   !<
     6281
     6282      INTEGER(iwp) ::  i    !<
     6283      INTEGER(iwp) ::  ib   !<
     6284      INTEGER(iwp) ::  iclc !< Lower i-index limit for copying fc-data to workarrc_t
     6285      INTEGER(iwp) ::  icrc !< Upper i-index limit for copying fc-data to workarrc_t
     6286      INTEGER(iwp) ::  ie   !<
     6287      INTEGER(iwp) ::  ierr !< MPI error code
     6288      INTEGER(iwp) ::  ijk  !<
     6289      INTEGER(iwp) ::  iw   !<
     6290      INTEGER(iwp) ::  j    !<
     6291      INTEGER(iwp) ::  jb   !<
     6292      INTEGER(iwp) ::  jcsc !< Lower j-index limit for copying fc-data to workarrc_t
     6293      INTEGER(iwp) ::  jcnc !< Upper j-index limit for copying fc-data to workarrc_t
     6294      INTEGER(iwp) ::  je   !<
     6295      INTEGER(iwp) ::  jw   !<     
     6296      INTEGER(iwp) ::  k    !< Vertical child-grid index fixed to the boundary-value level
     6297      INTEGER(iwp) ::  ka   !< Running vertical child-grid index
     6298      INTEGER(iwp) ::  kw   !<
     6299      INTEGER(iwp) ::  l    !< Parent-grid index in x-direction
     6300      INTEGER(iwp) ::  lp1  !< l+1
     6301      INTEGER(iwp) ::  m    !< Parent-grid index in y-direction
     6302      INTEGER(iwp) ::  mp1  !< m+1
     6303      INTEGER(iwp) ::  n    !< Parent-grid work array index in z-direction
     6304      INTEGER(iwp) ::  np1  !< n+1
     6305      INTEGER(iwp) ::  noff !< n-offset needed on the top boundary to correctly refer to boundary ghost points 
     6306      INTEGER(iwp) ::  nw   !< n-index for workarrc_t
     6307      INTEGER(iwp) ::  var_flag  !<
     6308     
     6309      REAL(wp) ::  cellsum     !<
     6310      REAL(wp) ::  cellsumd    !<
     6311      REAL(wp) ::  fac
     6312      REAL(wp) ::  fk          !<
     6313      REAL(wp) ::  fkj         !<
     6314      REAL(wp) ::  fkjp        !<
     6315      REAL(wp) ::  fkpj        !<
     6316      REAL(wp) ::  fkpjp       !<
     6317      REAL(wp) ::  fkp         !<
     6318      REAL(wp) ::  rcorr       !<
     6319      REAL(wp) ::  rcorr_ijk   !<
     6320
     6321
     6322      IF ( var == 'w' )  THEN
     6323         k    = nzt
     6324         noff = 0
     6325      ELSE
     6326         k    = nzt + 1
     6327         noff = 1
     6328      ENDIF
     6329
     6330      IF ( var == 'u' )  THEN
     6331         var_flag = 1
     6332      ELSEIF ( var == 'v' )  THEN
     6333         var_flag = 2     
     6334      ELSEIF ( var == 'w' )  THEN
     6335         var_flag = 3
     6336      ELSE
     6337         var_flag = 0
     6338      ENDIF
     6339      n  = kc(k) + noff
     6340      nw = 1
     6341
     6342      IF  ( var == 'w' )  THEN
     6343!AH!
     6344!AH!--      Substitute the necessary parent-grid data to the work array.
     6345!AH!--      Note that the dimension of workarrc_t is (0:2,jcsw:jcnw,iclw:icrw),
     6346!AH!--      And the jc?w and ic?w-index bounds depend on the location of the PE-
     6347!AH!--      subdomain relative to the side boundaries.
     6348!AH         iclc = iclw + 1
     6349!AH         icrc = icrw - 1     
     6350!AH         jcsc = jcsw + 1
     6351!AH         jcnc = jcnw - 1
     6352!AH         IF  ( bc_dirichlet_l )  THEN
     6353!AH            iclc = iclw
     6354!AH         ENDIF
     6355!AH         IF  ( bc_dirichlet_r )  THEN
     6356!AH            icrc = icrw
     6357!AH         ENDIF
     6358!AH         IF  ( bc_dirichlet_s )  THEN
     6359!AH            jcsc = jcsw
     6360!AH         ENDIF
     6361!AH         IF  ( bc_dirichlet_n )  THEN
     6362!AH            jcnc = jcnw
     6363!AH         ENDIF
     6364!AH         workarrc_t = 0.0_wp
     6365!AH         workarrc_t(0:2,jcsc:jcnc,iclc:icrc)                                    &
     6366!AH              = fc(kc(k):kc(k)+2,jcsc:jcnc,iclc:icrc)
     6367!AH!
     6368!AH!--      Left-right exchange if more than one PE subdomain in the x-direction.
     6369!AH!--      Note that in case of 3-D nesting the left and right boundaries are
     6370!AH!--      not exchanged because the nest domain is not cyclic.
     6371!AH#if defined( __parallel )
     6372!AH         IF  ( pdims(1) > 1 )  THEN
     6373!AH!
     6374!AH!--         From left to right
     6375!AH            CALL MPI_SENDRECV( workarrc_t(0,jcsw,iclw+1), 1,                    &
     6376!AH                 workarrc_t_exchange_type_y, pleft,  0,                         &
     6377!AH                 workarrc_t(0,jcsw,icrw), 1,                                    &
     6378!AH                 workarrc_t_exchange_type_y, pright, 0,                         &
     6379!AH                 comm2d, status, ierr )
     6380!AH!
     6381!AH!--         From right to left       
     6382!AH            CALL MPI_SENDRECV( workarrc_t(0,jcsw,icrw-1), 1,                    &
     6383!AH                 workarrc_t_exchange_type_y, pright, 1,                         &
     6384!AH                 workarrc_t(0,jcsw,iclw), 1,                                    &
     6385!AH                 workarrc_t_exchange_type_y, pleft,  1,                         &
     6386!AH                 comm2d, status, ierr )
     6387!AH         ENDIF
     6388!AH!
     6389!AH!--      South-north exchange if more than one PE subdomain in the y-direction.
     6390!AH!--      Note that in case of 3-D nesting the south and north boundaries are
     6391!AH!--      not exchanged because the nest domain is not cyclic.
     6392!AH         IF  ( pdims(2) > 1 )  THEN
     6393!AH!
     6394!AH!--         From south to north         
     6395!AH            CALL MPI_SENDRECV( workarrc_t(0,jcsw+1,iclw), 1,                    &
     6396!AH                 workarrc_t_exchange_type_x, psouth, 2,                         &
     6397!AH                 workarrc_t(0,jcnw,iclw), 1,                                    &
     6398!AH                 workarrc_t_exchange_type_x, pnorth, 2,                         &
     6399!AH                 comm2d, status, ierr )
     6400!AH!
     6401!AH!--         From north to south       
     6402!AH            CALL MPI_SENDRECV( workarrc_t(0,jcnw-1,iclw), 1,                    &
     6403!AH                 workarrc_t_exchange_type_x, pnorth, 3,                         &
     6404!AH                 workarrc_t(0,jcsw,iclw), 1,                                    &
     6405!AH                 workarrc_t_exchange_type_x, psouth, 3,                         &
     6406!AH                 comm2d, status, ierr )
     6407!AH         ENDIF
     6408!AH#endif     
     6409!AH
     6410
     6411         DO  l = iclw+1, icrw-1
     6412            DO  m = jcsw+1, jcnw-1
     6413
     6414               DO  i = ifl(l), ifu(l)
     6415                  DO  j = jfl(m), jfu(m)
     6416                     f(k,j,i) = fc(n,m,l)
     6417                  ENDDO
     6418               ENDDO
     6419
     6420            ENDDO
     6421         ENDDO
     6422
     6423      ELSE IF  ( var == 'u' )  THEN
     6424         
     6425         DO  l = iclw+1, icrw-1
     6426            DO  m = jcsw+1, jcnw-1
     6427               
     6428               DO  i = ifl(l), ifl(l+1)-1
     6429                  DO  j = jfl(m), jfu(m)
     6430                     f(k,j,i) = fc(n,m,l)
     6431                  ENDDO
     6432               ENDDO
     6433
     6434            ENDDO
     6435         ENDDO
     6436
     6437      ELSE IF  ( var == 'v' )  THEN
     6438
     6439         DO  l = iclw+1, icrw-1
     6440            DO  m = jcsw+1, jcnw-1
     6441
     6442               DO  i = ifl(l), ifu(l)
     6443                  DO  j = jfl(m), jfl(m+1)-1
     6444                     f(k,j,i) = fc(n,m,l)
     6445                  ENDDO
     6446               ENDDO
     6447
     6448            ENDDO
     6449         ENDDO
     6450
     6451      ELSE   ! scalars
     6452         
     6453         DO  l = iclw+1, icrw-1
     6454            DO  m = jcsw+1, jcnw-1
     6455
     6456               DO  i = ifl(l), ifu(l)
     6457                  DO  j = jfl(m), jfu(m)
     6458                     f(k,j,i) = fc(n,m,l)
     6459                  ENDDO
     6460               ENDDO
     6461
     6462            ENDDO
     6463         ENDDO
     6464
     6465      ENDIF  ! var
     6466
     6467   END SUBROUTINE pmci_interp_1sto_t
     6468
     6469
     6470
     6471   SUBROUTINE pmci_interp_tril_lr( f, fc, ic, jc, kc, r1x, r2x, r1y, r2y, r1z, &
     6472                                   r2z, logc, logc_ratio, logc_kbounds,        &
     6473                                   nzt_topo_nestbc,                            &
     6474                                   kct, ifl, ifu, jfl, jfu, kfl, kfu, ijkfc,   &
     6475                                   edge, var )
     6476!
     6477!--   Interpolation of ghost-node values used as the child-domain boundary
     6478!--   conditions. This subroutine handles the left and right boundaries. It is
     6479!--   based on trilinear interpolation.
     6480
     6481      IMPLICIT NONE
     6482
     6483      INTEGER(iwp) ::  nzt_topo_nestbc   !<
     6484
     6485      REAL(wp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg),                      &
     6486                                      INTENT(INOUT) ::  f       !<
     6487      REAL(wp), DIMENSION(0:cg%nz+1,jcs:jcn,icl:icr),                          &
     6488                                      INTENT(IN)    ::  fc      !<
     6489      REAL(wp), DIMENSION(1:2,0:ncorr-1,nzb:nzt_topo_nestbc,nys:nyn),          &
     6490                                      INTENT(IN)    ::  logc_ratio   !<
     6491!AH      REAL(wp), DIMENSION(nxlg:nxrg), INTENT(IN)    ::  r1x     !<
     6492!AH      REAL(wp), DIMENSION(nxlg:nxrg), INTENT(IN)    ::  r2x     !<
     6493!AH      REAL(wp), DIMENSION(nysg:nyng), INTENT(IN)    ::  r1y     !<
     6494!AH      REAL(wp), DIMENSION(nysg:nyng), INTENT(IN)    ::  r2y     !<
     6495      REAL(wp), DIMENSION(nxlfc:nxrfc), INTENT(IN)  ::  r1x     !<
     6496      REAL(wp), DIMENSION(nxlfc:nxrfc), INTENT(IN)  ::  r2x     !<
     6497      REAL(wp), DIMENSION(nysfc:nynfc), INTENT(IN)  ::  r1y     !<
     6498      REAL(wp), DIMENSION(nysfc:nynfc), INTENT(IN)  ::  r2y     !<
     6499
     6500!AH      REAL(wp), DIMENSION(nzb:nzt+1), INTENT(IN)    ::  r1z     !<
     6501!AH      REAL(wp), DIMENSION(nzb:nzt+1), INTENT(IN)    ::  r2z     !<
     6502      REAL(wp), DIMENSION(nzb:nzt+kgsr), INTENT(IN) ::  r1z     !<
     6503      REAL(wp), DIMENSION(nzb:nzt+kgsr), INTENT(IN) ::  r2z     !<
     6504     
     6505
     6506      INTEGER(iwp), DIMENSION(nxlfc:nxrfc), INTENT(IN)         ::  ic     !<
     6507      INTEGER(iwp), DIMENSION(nysfc:nynfc), INTENT(IN)         ::  jc     !<
     6508!AH      INTEGER(iwp), DIMENSION(nzb:nzt+1), INTENT(IN)           ::  kc     !<
     6509      INTEGER(iwp), DIMENSION(nzb:nzt+kgsr), INTENT(IN)        ::  kc     !<
     6510      INTEGER(iwp), DIMENSION(1:2,nzb:nzt_topo_nestbc,nys:nyn),                &
     6511                                          INTENT(IN)           :: logc   !<
     6512      INTEGER(iwp), DIMENSION(1:2,nys:nyn), INTENT(IN)         :: logc_kbounds !<
     6513
     6514      INTEGER(iwp) :: kct
     6515
     6516!AH
     6517!      INTEGER(iwp), DIMENSION(icl:icr), INTENT(IN) ::  ifl !< Indicates start index of child cells belonging to certain parent cell - x direction
     6518!      INTEGER(iwp), DIMENSION(icl:icr), INTENT(IN) ::  ifu !< Indicates end index of child cells belonging to certain parent cell - x direction
     6519!      INTEGER(iwp), DIMENSION(jcs:jcn), INTENT(IN) ::  jfl !< Indicates start index of child cells belonging to certain parent cell - y direction
     6520!      INTEGER(iwp), DIMENSION(jcs:jcn), INTENT(IN) ::  jfu !< Indicates start index of child cells belonging to certain parent cell - y direction
     6521      INTEGER(iwp), DIMENSION(icla:icra), INTENT(IN) ::  ifl !< Indicates start index of child cells belonging to certain parent cell - x direction
     6522      INTEGER(iwp), DIMENSION(icla:icra), INTENT(IN) ::  ifu !< Indicates end index of child cells belonging to certain parent cell - x direction
     6523      INTEGER(iwp), DIMENSION(jcsa:jcna), INTENT(IN) ::  jfl !< Indicates start index of child cells belonging to certain parent cell - y direction
     6524      INTEGER(iwp), DIMENSION(jcsa:jcna), INTENT(IN) ::  jfu !< Indicates start index of child cells belonging to certain parent cell - y direction
     6525!AH
     6526
     6527!AH      INTEGER(iwp), DIMENSION(0:kct), INTENT(IN)   ::  kfl !< Indicates start index of child cells belonging to certain parent cell - z direction
     6528!AH      INTEGER(iwp), DIMENSION(0:kct), INTENT(IN)   ::  kfu !< Indicates start index of child cells belonging to certain parent cell - z direction
     6529      INTEGER(iwp), DIMENSION(0:cg%nz+1), INTENT(IN)   ::  kfl !< Indicates start index of child cells belonging to certain parent cell - z direction
     6530      INTEGER(iwp), DIMENSION(0:cg%nz+1), INTENT(IN)   ::  kfu !< Indicates start index of child cells belonging to certain parent cell - z direction
     6531
     6532!AH      INTEGER(iwp), DIMENSION(0:kct,jcs:jcn,icl:icr), INTENT(IN) :: ijkfc !< number of child grid points contributing to a parent grid box
     6533!AH
     6534!      INTEGER(iwp), DIMENSION(0:cg%nz+1,jcs:jcn,icl:icr), INTENT(IN) :: ijkfc !< number of child grid points contributing to a parent grid box
     6535      INTEGER(iwp), DIMENSION(0:cg%nz+1,jcsa:jcna,icla:icra), INTENT(IN) :: ijkfc !< number of child grid points contributing to a parent grid box
     6536!AH
     6537
     6538      CHARACTER(LEN=1), INTENT(IN) ::  edge   !< Edge symbol: 'l', 'r', 's' or 'n'
     6539      CHARACTER(LEN=1), INTENT(IN) ::  var    !< Variable symbol: 'u', 'v', 'w' or 's'
     6540
     6541      INTEGER(iwp) ::  i        !< Lower bound of the running index ia
     6542      INTEGER(iwp) ::  ia       !< i-index running over the parent-grid cell on the boundary
     6543      INTEGER(iwp) ::  iaw      !< Reduced ia-index for workarr_lr
     6544      INTEGER(iwp) ::  iawbc    !< iaw-index pointing to the boundary-value nodes (either 0 or igsr-1)     
     6545      INTEGER(iwp) ::  ibc      !< Fixed i-index pointing to the boundary-value nodes (either i or iend)
     6546!AH      INTEGER(iwp) ::  ibeg     !< i-index pointing to the starting point of workarr_lr in the i-direction
     6547      INTEGER(iwp) ::  iend     !< Upper bound of the running index ia
     6548      INTEGER(iwp) ::  ierr     !< MPI error code
     6549      INTEGER(iwp) ::  ijk      !< Running index for all child-grid cells within the anterpolation cell
     6550      INTEGER(iwp) ::  iw       !< i-index for wall_flags_0
     6551      INTEGER(iwp) ::  j        !< Running index in the y-direction
     6552      INTEGER(iwp) ::  jco      !<
     6553      INTEGER(iwp) ::  jcorr    !<
     6554      INTEGER(iwp) ::  jinc     !<
     6555      INTEGER(iwp) ::  jw       !< j-index for wall_flags_0
     6556      INTEGER(iwp) ::  j1       !<
     6557      INTEGER(iwp) ::  k        !< Running index in the z-direction
     6558      INTEGER(iwp) ::  k_wall   !< Vertical index of topography top
     6559      INTEGER(iwp) ::  kco      !<
     6560      INTEGER(iwp) ::  kcorr    !<
     6561      INTEGER(iwp) ::  kw       !< k-index for wall_flags_0
     6562      INTEGER(iwp) ::  k1       !<
     6563      INTEGER(iwp) ::  l        !< Parent-grid running index in the x-direction
     6564      INTEGER(iwp) ::  lbeg     !< l-index pointing to the starting point of workarrc_lr in the l-direction
     6565      INTEGER(iwp) ::  lp1      !< l+1
     6566      INTEGER(iwp) ::  loff     !< l-offset needed on the right boundary to correctly refer to boundary ghost points
     6567      INTEGER(iwp) ::  lw       !< Reduced l-index for workarrc_lr
     6568      INTEGER(iwp) ::  m        !< Parent-grid running index in the y-direction
     6569      INTEGER(iwp) ::  mnorthv  !< Upshift by one for the upper bound of index m in case of var == 'v'
     6570      INTEGER(iwp) ::  mp1      !< m+1
     6571      INTEGER(iwp) ::  n        !< Parent-grid running index in the z-direction
     6572      INTEGER(iwp) ::  np1      !< n+1
     6573      INTEGER(iwp) ::  ntopw    !< Upshift by one for the upper bound of index n in case of var == 'w'
     6574      INTEGER(iwp) ::  var_flag !< Variable flag for BTEST( wall_flags_0 )
     6575
     6576      REAL(wp) ::  cellsum      !< Sum of child-grid node values over the anterpolation cell
     6577      REAL(wP) ::  cellsumd     !< Sum of differences over the anterpolation cell
     6578      REAL(wp) ::  fkj          !< Intermediate result in trilinear interpolation
     6579      REAL(wp) ::  fkjp         !< Intermediate result in trilinear interpolation
     6580      REAL(wp) ::  fkpj         !< Intermediate result in trilinear interpolation
     6581      REAL(wp) ::  fkpjp        !< Intermediate result in trilinear interpolation
     6582      REAL(wp) ::  fk           !< Intermediate result in trilinear interpolation
     6583      REAL(wp) ::  fkp          !< Intermediate result in trilinear interpolation
     6584      REAL(wp) ::  rcorr        !< Average reversibility correction for the whole anterpolation cell
     6585      REAL(wp) ::  rcorr_ijk    !< Reversibility correction distributed to the individual child-grid nodes
     6586 
     6587!
     6588!--   Check which edge is to be handled
     6589      IF ( edge == 'l' )  THEN
     6590!
     6591!--      For u, nxl is a ghost node, but not for the other variables
     6592         IF ( var == 'u' )  THEN
     6593            i     = nxl
     6594            iend  = nxl
     6595            ibc   = nxl
     6596            iawbc = 0
     6597            lbeg  = icl
     6598            loff  = 0
     6599         ELSE
     6600            i     = nxl - igsr
     6601            iend  = nxl - 1
     6602            ibc   = nxl - 1
     6603            iawbc = igsr-1
     6604            lbeg  = icl
     6605            loff  = 0
     6606         ENDIF
     6607      ELSEIF ( edge == 'r' )  THEN
     6608         IF ( var == 'u' )  THEN
     6609            i     = nxr + 1           
     6610            iend  = nxr + 1
     6611            ibc   = nxr + 1
     6612            iawbc = 0
     6613            lbeg  = icr - 2
     6614            loff  = 0
     6615         ELSE
     6616            i     = nxr + 1
     6617            iend  = nxr + igsr
     6618            ibc   = nxr + 1
     6619            iawbc = 0
     6620            lbeg  = icr - 2
     6621            loff  = 1
     6622         ENDIF
     6623
     6624      ENDIF
     6625
     6626      IF  ( var == 'w' )  THEN
     6627         ntopw = 1
     6628      ELSE
     6629         ntopw = 0
     6630      ENDIF
     6631
     6632      IF  ( var == 'v' )  THEN
     6633         mnorthv = 0
     6634      ELSE
     6635         mnorthv = 1
     6636      ENDIF
     6637
     6638      IF ( var == 'u' )  THEN
     6639         var_flag = 1
     6640      ELSEIF ( var == 'v' )  THEN
     6641         var_flag = 2
     6642      ELSEIF ( var == 'w' )  THEN
     6643         var_flag = 3
     6644      ELSE
     6645         var_flag = 0
     6646      ENDIF
     6647
     6648!AH
     6649!
     6650!--   Substitute the necessary parent-grid data to the work array workarrc_lr.
     6651      workarrc_lr = 0.0_wp     
     6652      IF  ( pdims(2) > 1 )  THEN
     6653#if defined( __parallel )
     6654         IF  ( nys == 0 )  THEN
     6655            workarrc_lr(0:cg%nz+1,jcsw:jcnw-1,0:2)                              &
     6656                 = fc(0:cg%nz+1,jcsw:jcnw-1,lbeg:lbeg+2)
     6657         ELSE IF  ( nyn == ny )  THEN
     6658            workarrc_lr(0:cg%nz+1,jcsw+1:jcnw,0:2)                              &
     6659                 = fc(0:cg%nz+1,jcsw+1:jcnw,lbeg:lbeg+2)
     6660         ELSE
     6661            workarrc_lr(0:cg%nz+1,jcsw+1:jcnw-1,0:2)                            &
     6662                 = fc(0:cg%nz+1,jcsw+1:jcnw-1,lbeg:lbeg+2)
     6663         ENDIF
     6664!
     6665!--      South-north exchange if more than one PE subdomain in the y-direction.
     6666!--      Note that in case of 3-D nesting the south (psouth == MPI_PROC_NULL)
     6667!--      and north (pnorth == MPI_PROC_NULL) boundaries are not exchanged
     6668!--      because the nest domain is not cyclic.
     6669!--      From south to north
     6670         CALL MPI_SENDRECV( workarrc_lr(0,jcsw+1,0), 1,                         &
     6671              workarrc_lr_exchange_type, psouth,  0,                            &
     6672              workarrc_lr(0,jcnw,0), 1,                                         &
     6673              workarrc_lr_exchange_type, pnorth,  0,                            &
     6674              comm2d, status, ierr )
     6675!
     6676!--      From north to south       
     6677         CALL MPI_SENDRECV( workarrc_lr(0,jcnw-1,0), 1,                         &
     6678              workarrc_lr_exchange_type, pnorth,  1,                            &
     6679              workarrc_lr(0,jcsw,0), 1,                                         &
     6680              workarrc_lr_exchange_type, psouth,  1,                            &
     6681              comm2d, status, ierr )
     6682#endif
     6683      ELSE
     6684         workarrc_lr(0:cg%nz+1,jcsw:jcnw,0:2)                                   &
     6685              = fc(0:cg%nz+1,jcsw:jcnw,lbeg:lbeg+2)           
     6686      ENDIF
     6687!
     6688!AH
     6689      workarr_lr = 0.0_wp
     6690     
     6691      DO  ia = i, iend
     6692         iaw = ia - i
     6693         DO  j = nys-1, nyn+1
     6694!AH         DO  j = nys, nyn
     6695!
     6696!--         Determine vertical index of topography top at grid point (j,i)
    55606697!AH         k_wall = get_topography_top_index_ji( j, i, TRIM( var ) )
    5561 
    5562          DO  k = nzb, nzt+1 !k_wall, nzt+1
    5563             l = ic(i)
    5564             m = jc(j)
    5565             n = kc(k)
    5566             fkj      = r1x(i) * fc(n,m,l)     + r2x(i) * fc(n,m,l+1)
    5567             fkjp     = r1x(i) * fc(n,m+1,l)   + r2x(i) * fc(n,m+1,l+1)
    5568             fkpj     = r1x(i) * fc(n+1,m,l)   + r2x(i) * fc(n+1,m,l+1)
    5569             fkpjp    = r1x(i) * fc(n+1,m+1,l) + r2x(i) * fc(n+1,m+1,l+1)
    5570             fk       = r1y(j) * fkj  + r2y(j) * fkjp
    5571             fkp      = r1y(j) * fkpj + r2y(j) * fkpjp
    5572             f(k,j,i) = r1z(k) * fk   + r2z(k) * fkp
     6698            DO  k = nzb, nzt+1 !k_wall, nzt+1
     6699!AH               l   = ic(ia) - ic(i)
     6700               l   = ic(ia) - lbeg
     6701               lp1 = MIN( l + 1, 2 )  ! If l+1 > 2 (l=ic(nxr+1)-lbeg), r1x = 1 and r2x = 0
     6702               m   = jc(j)
     6703               mp1 = MIN( m + 1, jcnw )  ! If m+1 > jcn (m=jc(nyn+1)), r1y = 1 and r2y = 0
     6704               n   = kc(k)
     6705               np1 = n + 1           
     6706
     6707!AH
     6708!               fkj      = r1x(i) * fc(n,m,l)     + r2x(i) * fc(n,m,l+1)
     6709!               fkjp     = r1x(i) * fc(n,m+1,l)   + r2x(i) * fc(n,m+1,l+1)
     6710!               fkpj     = r1x(i) * fc(n+1,m,l)   + r2x(i) * fc(n+1,m,l+1)
     6711!               fkpjp    = r1x(i) * fc(n+1,m+1,l) + r2x(i) * fc(n+1,m+1,l+1)
     6712!AH
     6713               
     6714               fkj      = r1x(ia) * workarrc_lr(n,m,l)     + r2x(ia) * workarrc_lr(n,m,lp1)
     6715               fkjp     = r1x(ia) * workarrc_lr(n,mp1,l)   + r2x(ia) * workarrc_lr(n,mp1,lp1)
     6716               fkpj     = r1x(ia) * workarrc_lr(np1,m,l)   + r2x(ia) * workarrc_lr(np1,m,lp1)
     6717               fkpjp    = r1x(ia) * workarrc_lr(np1,mp1,l) + r2x(ia) * workarrc_lr(np1,mp1,lp1)
     6718               
     6719               fk       = r1y(j) * fkj  + r2y(j) * fkjp
     6720               fkp      = r1y(j) * fkpj + r2y(j) * fkpjp
     6721
     6722!AH
     6723!               f(k,j,i) = r1z(k) * fk + r2z(k) * fkp               
     6724               workarr_lr(k,j,iaw) = r1z(k) * fk + r2z(k) * fkp
     6725               
     6726!               if  ( ( edge == 'l' ) .and. ( ia  == ibc ) ) then
     6727!                  write(9,"('pmci_interp_tril_lr: ',a2,2x,11(i4,2x),7(e12.5,2x))") var, k, j, ia, ibc, iaw, n, m, l, np1, mp1, lp1, &
     6728!                       workarr_lr(k,j,iaw), r1x(ia), r2x(ia), workarrc_lr(n,m,l), workarrc_lr(n,mp1,l), workarrc_lr(np1,m,l), workarrc_lr(np1,mp1,l)
     6729!                  flush(9)
     6730!               endif
     6731
     6732!AH
     6733               
     6734            ENDDO
    55736735         ENDDO
    55746736      ENDDO
     
    56516813      ENDIF  ! ( topography /= 'flat' )
    56526814!
    5653 !--   Apply the reversibility correction to the boundary-normal velocity-
    5654 !--   component u and the scalars. It must not be applied to the boundary-
    5655 !--   tangential velocity components v and w because their 2-D anterpolation
    5656 !--   cells do not cover all the child-grid nodes on the boundary.
    5657       IF ( .NOT. ( ( var == 'v' ) .OR. ( var == 'w' ) ) )  THEN
    5658          l = ic(i)
    5659          DO  m = jcs, jcn
    5660             DO  n = 0, kct+1
    5661                ijk = 1
    5662                cellsum   = 0.0_wp
    5663                cellsumd  = 0.0_wp
    5664 !
    5665 !--            Note that the index name i must not be used here as a loop
    5666 !--            index name since i is the constant boundary index, hence
    5667 !--            the name ia.
    5668                DO  ia = ifl(l), ifu(l)   
    5669                   DO  j = jfl(m), jfu(m)
    5670                      DO  k = kfl(n), kfu(n)
    5671                         cellsum = cellsum + MERGE( f(k,j,ia), 0.0_wp,           &
    5672                              BTEST( wall_flags_0(k,j,ia), var_flag ) )
    5673                         celltmpd(ijk) = ABS( fc(n,m,l) - f(k,j,ia) )
    5674                         cellsumd      = cellsumd  + MERGE( celltmpd(ijk),       &
    5675                              0.0_wp, BTEST( wall_flags_0(k,j,ia), var_flag ) )
    5676                         ijk = ijk + 1
    5677                      ENDDO
     6815!--   Apply the reversibility correction.
     6816
     6817!      if  ( var == 'u' )  then
     6818
     6819      l  = ic(ibc) + loff
     6820      lw = 1
     6821!      write(9,"('pmci_interp_tril_lr: edge, var, l, i, iend, ifl(l), ifu(l) = ',2(a2,2x),5(i4,2x))") &
     6822!           edge, var, l, i, iend, ifl(l), ifu(l)
     6823!      flush(9)
     6824!AH      DO  m = jcsw+1, jcnw-1       
     6825      DO  m = jcsw + 1, jcnw - mnorthv   ! mnorthv = 0 for v and 1 for all others
     6826         DO  n = 0, kct + ntopw            ! ntopw = 1 for w and 0 for all others
     6827            ijk = 1
     6828            cellsum   = 0.0_wp
     6829            cellsumd  = 0.0_wp
     6830!
     6831!--         Note that the index name i must not be used here as a loop
     6832!--         index name since i is the constant boundary index, hence
     6833!--         the name ia.
     6834            DO  ia = ifl(l), ifu(l)
     6835               iaw = ia - i
     6836               iw  = MAX( MIN( ia, nx+1 ), -1 )
     6837               DO  j = jfl(m), jfu(m)
     6838                  jw = MAX( MIN( j, ny+1 ), -1 )
     6839                  DO  k = kfl(n), kfu(n)
     6840                     kw = MIN( k, nzt+1 )
     6841!AH
     6842!                     cellsum = cellsum + MERGE( f(k,j,ia), 0.0_wp,              &
     6843!                          BTEST( wall_flags_0(kw,jw,iw), var_flag ) )
     6844                     cellsum = cellsum + MERGE( workarr_lr(k,j,iaw), 0.0_wp,     &
     6845                          BTEST( wall_flags_0(kw,jw,iw), var_flag ) )
     6846!AH
     6847                     
     6848!AH                     celltmpd(ijk) = ABS( fc(n,m,l) - f(k,j,ia) )
     6849!AH                     celltmpd(ijk) = ABS( workarrc_lr(n,m,lw) - f(k,j,ia) )
     6850                     celltmpd(ijk) = ABS( workarrc_lr(n,m,lw) - workarr_lr(k,j,iaw) )
     6851                     cellsumd      = cellsumd  + MERGE( celltmpd(ijk),          &
     6852                          0.0_wp, BTEST( wall_flags_0(kw,jw,iw), var_flag ) )
     6853
     6854!                     write(9,"('lr1: ',a1,2x,8(i4,2x),5(e12.5,2x))") var, n, m, l, k, j, ia, iaw, ijk,  &
     6855!                          workarrc_lr(n,m,lw), workarr_lr(k,j,iaw), cellsum, celltmpd(ijk), cellsumd
     6856!                     flush(9)
     6857
     6858                     ijk = ijk + 1
    56786859                  ENDDO
    56796860               ENDDO
    5680 
    5681                IF ( ijkfc(n,m,l) /= 0 )  THEN
    5682                   cellsum   = cellsum / REAL( ijkfc(n,m,l), KIND=wp )
    5683                   rcorr     = fc(n,m,l) - cellsum
    5684                   cellsumd  = cellsumd / REAL( ijkfc(n,m,l), KIND=wp )
    5685                ELSE
    5686                   cellsum   = 0.0_wp                 
    5687                   rcorr     = 0.0_wp
    5688                   cellsumd  = 1.0_wp
    5689                   celltmpd  = 1.0_wp
    5690                ENDIF
     6861            ENDDO
     6862
     6863            IF ( ijkfc(n,m,l) /= 0 )  THEN
     6864               cellsum   = cellsum / REAL( ijkfc(n,m,l), KIND=wp )
     6865!               rcorr     = fc(n,m,l) - cellsum
     6866               rcorr     = workarrc_lr(n,m,lw) - cellsum
     6867               cellsumd  = cellsumd / REAL( ijkfc(n,m,l), KIND=wp )
     6868            ELSE
     6869               cellsum   = 0.0_wp                 
     6870               rcorr     = 0.0_wp
     6871               cellsumd  = 1.0_wp
     6872               celltmpd  = 1.0_wp
     6873            ENDIF
    56916874!
    5692 !--            Distribute the correction term to the child nodes according to
    5693 !--            their relative difference to the parent value such that the
    5694 !--            node with the largest difference gets the largest share of the
    5695 !--            correction. The distribution is skipped if rcorr is negligibly
    5696 !--            small in order to avoid division by zero.
    5697                IF ( ABS(rcorr) < 0.000001_wp )  THEN                 
    5698                   cellsumd  = 1.0_wp
    5699                   celltmpd  = 1.0_wp
    5700                ENDIF
    5701 
    5702                ijk = 1
    5703                DO  ia = ifl(l), ifu(l)
    5704                   DO  j = jfl(m), jfu(m)
    5705                      DO  k = kfl(n), kfu(n)
    5706                         rcorr_ijk = rcorr * celltmpd(ijk) / cellsumd
    5707                         f(k,j,ia) = f(k,j,ia) + rcorr_ijk
    5708                         ijk = ijk + 1
    5709                      ENDDO
     6875!--         Distribute the correction term to the child nodes according to
     6876!--         their relative difference to the parent value such that the
     6877!--         node with the largest difference gets the largest share of the
     6878!--         correction. The distribution is skipped if rcorr is negligibly
     6879!--         small in order to avoid division by zero.
     6880            IF ( ABS(rcorr) < 0.000001_wp )  THEN                 
     6881               cellsumd  = 1.0_wp
     6882               celltmpd  = 1.0_wp
     6883            ENDIF
     6884
     6885            ijk = 1
     6886            DO  ia = ifl(l), ifu(l)
     6887!AH               iaw = ia - ifl(l)
     6888               iaw = ia - i
     6889               DO  j = jfl(m), jfu(m)
     6890                  DO  k = kfl(n), kfu(n)
     6891                     rcorr_ijk = rcorr * celltmpd(ijk) / cellsumd
     6892!AH                     f(k,j,ia) = f(k,j,ia) + rcorr_ijk
     6893                     workarr_lr(k,j,iaw) = workarr_lr(k,j,iaw) + rcorr_ijk
     6894
     6895!                     write(9,"('lr2: ',a1,2x,9(i4,2x),4(e12.5,2x))") var, n, m, l, k, j, ia, iaw, ijk, ijkfc(n,m,l), &
     6896!                          rcorr, rcorr_ijk, workarr_lr(k,j,iaw), workarrc_lr(n,m,lw)
     6897!                     flush(9)
     6898
     6899                     ijk = ijk + 1
    57106900                  ENDDO
    57116901               ENDDO
     6902            ENDDO
     6903!
     6904!--         Velocity components tangential to the boundary need special
     6905!--         treatment because their anterpolation cells are flat in their
     6906!--         direction and hence do not cover all the child-grid boundary nodes.
     6907!--         These components are next linearly interpolated to those child-grid
     6908!--         boundary nodes which are not covered by the anterpolation cells.
     6909            IF  ( ( var == 'w' ) .AND. ( n > 0 ) )  THEN
     6910               DO  k = kfu(n-1)+1, kfl(n)-1
     6911                  IF  ( k <= nzt )  THEN
     6912                     DO  j = jfl(m), jfu(m)
     6913                        IF  ( ( j >= nys ) .AND. ( j <= nyn+1 ) )  THEN
     6914!AH                             
     6915!                           f(k,j,ia) = r1z(k) * f(kfu(n-1),j,ia)                &
     6916!                                   + r2z(k) * f(kfl(n),j,ia)
     6917                           workarr_lr(k,j,iawbc) =                              &
     6918                                  r1z(k) * workarr_lr(kfu(n-1),j,iawbc)         &
     6919                                + r2z(k) * workarr_lr(kfl(n),j,iawbc)
     6920
     6921!                           write(9,"('lr3: ',a1,2x,7(i4,2x),3(e12.5,2x))") var, n, m, l, k, j, iawbc, ibc, &
     6922!                                workarr_lr(k-1,j,iawbc), workarr_lr(k,j,iawbc), workarr_lr(k+1,j,iawbc)
     6923!                           flush(9)
     6924
     6925!AH                             
     6926                        ENDIF
     6927                     ENDDO
     6928                  ENDIF
     6929               ENDDO
     6930            ENDIF
     6931
     6932            IF  ( ( var == 'v' ) .AND. ( m > jcsw ) )  THEN
     6933               DO  j = jfu(m-1)+1, jfl(m)-1
     6934                  IF  ( ( j >= nys ) .AND. ( j <= nyn+1 ) )  THEN
     6935                     DO  k = kfl(n), kfu(n)
     6936                        IF  ( k <= nzt+1 )  THEN                             
     6937!AH                             
     6938!                           f(k,j,ia) = r1y(j) * f(k,jfu(m-1),ia)                &
     6939!                                   + r2y(j) * f(k,jfl(m),ia)
     6940                           workarr_lr(k,j,iawbc) =                              &
     6941                                  r1y(j) * workarr_lr(k,jfu(m-1),iawbc)         &
     6942                                + r2y(j) * workarr_lr(k,jfl(m),iawbc)
     6943
     6944!                           write(9,"('lr4: ',a1,2x,7(i4,2x),3(e12.5,2x))") var, n, m, l, k, j, iawbc, ibc, &
     6945!                                workarr_lr(k,j-1,iawbc), workarr_lr(k,j,iawbc), workarr_lr(k,j+1,iawbc)
     6946!                           flush(9)
     6947
     6948!AH                             
     6949                        ENDIF
     6950                     ENDDO
     6951                  ENDIF
     6952               ENDDO
     6953            ENDIF
    57126954               
    5713             ENDDO  ! n
    5714          ENDDO  ! m
    5715          
    5716       ENDIF  ! var not v or w
    5717 !
    5718 !--   Store the boundary values also into the other redundant ghost node layers.
    5719 !--   Note that in case of only one ghost node layer, e.g. for the PW
    5720 !--   scheme, the following loops will not be entered.
    5721       IF ( edge == 'l' )  THEN
    5722          DO  ibgp = -nbgp, ib
    5723             f(0:nzt+1,nysg:nyng,ibgp) = f(0:nzt+1,nysg:nyng,i)
    5724          ENDDO
    5725       ELSEIF ( edge == 'r' )  THEN
    5726          DO  ibgp = ib, nx+nbgp
    5727             f(0:nzt+1,nysg:nyng,ibgp) = f(0:nzt+1,nysg:nyng,i)
    5728          ENDDO
    5729       ENDIF
     6955         ENDDO  ! n
     6956      ENDDO  ! m
     6957
     6958!      endif  ! var
     6959
     6960!
     6961!--   Finally substitute the boundary values.
     6962      f(nzb:nzt+1,nys:nyn,ibc) = workarr_lr(nzb:nzt+1,nys:nyn,iawbc)
     6963
     6964!      do  k = 0, 2
     6965!         do  j = nys, nyn
     6966!            if  ( edge == 'l' )  then
     6967!               write(9,"('lr5: ',2(a2,2x),4(i4,2x),4(e12.5,2x))") edge, var, k, j, ibc, iawbc,  &
     6968!                    workarr_lr(k,j,iawbc), f(k,j,ibc), f(k,j,ibc+1), f(k,j,ibc+2)
     6969!            else if  ( edge == 'r' )  then
     6970!               write(9,"('lr5: ',2(a2,2x),4(i4,2x),4(e12.5,2x))") edge, var, k, j, ibc, iawbc,  &
     6971!                    f(k,j,ibc-2), f(k,j,ibc-1), f(k,j,ibc), workarr_lr(k,j,iawbc)
     6972!            endif
     6973!         enddo
     6974!      enddo
     6975!      flush(9)
    57306976
    57316977   END SUBROUTINE pmci_interp_tril_lr
     
    57547000      REAL(wp), DIMENSION(1:2,0:ncorr-1,nzb:nzt_topo_nestbc,nxl:nxr),          &
    57557001                                      INTENT(IN)    ::  logc_ratio    !<
    5756       REAL(wp), DIMENSION(nxlg:nxrg), INTENT(IN)    ::  r1x           !<
    5757       REAL(wp), DIMENSION(nxlg:nxrg), INTENT(IN)    ::  r2x           !<
    5758       REAL(wp), DIMENSION(nysg:nyng), INTENT(IN)    ::  r1y           !<
    5759       REAL(wp), DIMENSION(nysg:nyng), INTENT(IN)    ::  r2y           !<
    5760       REAL(wp), DIMENSION(nzb:nzt+1), INTENT(IN)    ::  r1z           !<
    5761       REAL(wp), DIMENSION(nzb:nzt+1), INTENT(IN)    ::  r2z           !<
     7002      REAL(wp), DIMENSION(nxlfc:nxrfc), INTENT(IN)  ::  r1x           !<
     7003      REAL(wp), DIMENSION(nxlfc:nxrfc), INTENT(IN)  ::  r2x           !<
     7004      REAL(wp), DIMENSION(nysfc:nynfc), INTENT(IN)  ::  r1y           !<
     7005      REAL(wp), DIMENSION(nysfc:nynfc), INTENT(IN)  ::  r2y           !<
     7006!AH      REAL(wp), DIMENSION(nzb:nzt+1), INTENT(IN)    ::  r1z           !<
     7007!AH      REAL(wp), DIMENSION(nzb:nzt+1), INTENT(IN)    ::  r2z           !<
     7008      REAL(wp), DIMENSION(nzb:nzt+kgsr), INTENT(IN) ::  r1z           !<
     7009      REAL(wp), DIMENSION(nzb:nzt+kgsr), INTENT(IN) ::  r2z           !<
     7010
    57627011     
    5763       INTEGER(iwp), DIMENSION(nxlg:nxrg), INTENT(IN)           ::  ic    !<
    5764       INTEGER(iwp), DIMENSION(nysg:nyng), INTENT(IN)           ::  jc    !<
    5765       INTEGER(iwp), DIMENSION(nzb:nzt+1), INTENT(IN)           ::  kc    !<
     7012      INTEGER(iwp), DIMENSION(nxlfc:nxrfc), INTENT(IN)         ::  ic    !<
     7013      INTEGER(iwp), DIMENSION(nysfc:nynfc), INTENT(IN)         ::  jc    !<
     7014!AH      INTEGER(iwp), DIMENSION(nzb:nzt+1), INTENT(IN)           ::  kc    !<
     7015      INTEGER(iwp), DIMENSION(nzb:nzt+kgsr), INTENT(IN)        ::  kc    !<
    57667016      INTEGER(iwp), DIMENSION(1:2,nzb:nzt_topo_nestbc,nxl:nxr),                &
    57677017                                          INTENT(IN)           ::  logc  !<
     
    57697019
    57707020      INTEGER(iwp) :: kct
    5771       INTEGER(iwp), DIMENSION(icl:icr), INTENT(IN) ::  ifl !< Indicates start index of child cells belonging to certain parent cell - x direction
    5772       INTEGER(iwp), DIMENSION(icl:icr), INTENT(IN) ::  ifu !< Indicates end index of child cells belonging to certain parent cell - x direction
    5773       INTEGER(iwp), DIMENSION(jcs:jcn), INTENT(IN) ::  jfl !< Indicates start index of child cells belonging to certain parent cell - y direction
    5774       INTEGER(iwp), DIMENSION(jcs:jcn), INTENT(IN) ::  jfu !< Indicates start index of child cells belonging to certain parent cell - y direction
     7021!AH
     7022!      INTEGER(iwp), DIMENSION(icl:icr), INTENT(IN) ::  ifl !< Indicates start index of child cells belonging to certain parent cell - x direction
     7023!      INTEGER(iwp), DIMENSION(icl:icr), INTENT(IN) ::  ifu !< Indicates end index of child cells belonging to certain parent cell - x direction
     7024!      INTEGER(iwp), DIMENSION(jcs:jcn), INTENT(IN) ::  jfl !< Indicates start index of child cells belonging to certain parent cell - y direction
     7025!      INTEGER(iwp), DIMENSION(jcs:jcn), INTENT(IN) ::  jfu !< Indicates start index of child cells belonging to certain parent cell - y direction
     7026      INTEGER(iwp), DIMENSION(icla:icra), INTENT(IN) ::  ifl !< Indicates start index of child cells belonging to certain parent cell - x direction
     7027      INTEGER(iwp), DIMENSION(icla:icra), INTENT(IN) ::  ifu !< Indicates end index of child cells belonging to certain parent cell - x direction
     7028      INTEGER(iwp), DIMENSION(jcsa:jcna), INTENT(IN) ::  jfl !< Indicates start index of child cells belonging to certain parent cell - y direction
     7029      INTEGER(iwp), DIMENSION(jcsa:jcna), INTENT(IN) ::  jfu !< Indicates start index of child cells belonging to certain parent cell - y direction
     7030!AH
     7031
    57757032!AH      INTEGER(iwp), DIMENSION(0:kct), INTENT(IN)   ::  kfl !< Indicates start index of child cells belonging to certain parent cell - z direction
    57767033!AH      INTEGER(iwp), DIMENSION(0:kct), INTENT(IN)   ::  kfu !< Indicates start index of child cells belonging to certain parent cell - z direction
     
    57787035      INTEGER(iwp), DIMENSION(0:cg%nz+1), INTENT(IN)   ::  kfu !< Indicates start index of child cells belonging to certain parent cell - z direction
    57797036!AH      INTEGER(iwp), DIMENSION(0:kct,jcs:jcn,icl:icr), INTENT(IN) :: ijkfc !< number of child grid points contributing to a parent grid box
    5780       INTEGER(iwp), DIMENSION(0:cg%nz+1,jcs:jcn,icl:icr), INTENT(IN) :: ijkfc !< number of child grid points contributing to a parent grid box
    5781 
    5782       CHARACTER(LEN=1), INTENT(IN) ::  edge   !<
    5783       CHARACTER(LEN=1), INTENT(IN) ::  var    !<
     7037!AH
     7038!      INTEGER(iwp), DIMENSION(0:cg%nz+1,jcs:jcn,icl:icr), INTENT(IN) :: ijkfc !< number of child grid points contributing to a parent grid box
     7039      INTEGER(iwp), DIMENSION(0:cg%nz+1,jcsa:jcna,icla:icra), INTENT(IN) :: ijkfc !< number of child grid points contributing to a parent grid box
     7040!AH
     7041
     7042      CHARACTER(LEN=1), INTENT(IN) ::  edge   !< Edge symbol: 'l', 'r', 's' or 'n'
     7043      CHARACTER(LEN=1), INTENT(IN) ::  var    !< Variable symbol: 'u', 'v', 'w' or 's'
    57847044     
    5785       INTEGER(iwp) ::  i       !<
    5786       INTEGER(iwp) ::  iinc    !<
    5787       INTEGER(iwp) ::  icorr   !<
    5788       INTEGER(iwp) ::  ico     !<
    5789       INTEGER(iwp) ::  ijk     !<
    5790       INTEGER(iwp) ::  i1      !<
    5791       INTEGER(iwp) ::  j       !<
    5792       INTEGER(iwp) ::  ja      !<
    5793       INTEGER(iwp) ::  jb      !<
    5794       INTEGER(iwp) ::  jbgp    !<
    5795       INTEGER(iwp) ::  k       !<
    5796       INTEGER(iwp) ::  k_wall  !< vertical index of topography top
    5797       INTEGER(iwp) ::  kcorr   !<
    5798       INTEGER(iwp) ::  kco     !<
    5799       INTEGER(iwp) ::  k1      !<
    5800       INTEGER(iwp) ::  l       !<
    5801       INTEGER(iwp) ::  m       !<
    5802       INTEGER(iwp) ::  n       !<
    5803       INTEGER(iwp) ::  var_flag !<
    5804 
    5805       REAL(wp) ::  cellsum     !<
    5806       REAL(wp) ::  cellsumd    !<
    5807       REAL(wp) ::  fk          !<
    5808       REAL(wp) ::  fkj         !<
    5809       REAL(wp) ::  fkjp        !<
    5810       REAL(wp) ::  fkpj        !<
    5811       REAL(wp) ::  fkpjp       !<
    5812       REAL(wp) ::  fkp         !<
    5813       REAL(wp) ::  rcorr       !<
    5814       REAL(wp) ::  rcorr_ijk   !<
    5815      
     7045      INTEGER(iwp) ::  i        !< Running index in the x-direction
     7046      INTEGER(iwp) ::  iinc     !<
     7047      INTEGER(iwp) ::  icorr    !<
     7048      INTEGER(iwp) ::  ico      !<
     7049      INTEGER(iwp) ::  ierr     !< MPI error code
     7050      INTEGER(iwp) ::  ijk      !< Running index for all child-grid cells within the anterpolation cell
     7051      INTEGER(iwp) ::  iw       !< i-index for wall_flags_0
     7052      INTEGER(iwp) ::  i1       !<
     7053      INTEGER(iwp) ::  j        !< Lower bound of the running index ja
     7054      INTEGER(iwp) ::  ja       !< Index in y-direction running over the parent-grid cell on the boundary
     7055      INTEGER(iwp) ::  jaw      !< Reduced ja-index for workarr_sn
     7056      INTEGER(iwp) ::  jawbc    !< jaw-index pointing to the boundary-value nodes (either 0 or jgsr-1)
     7057!AH      INTEGER(iwp) ::  jbeg     !< j-index pointing to the starting point of workarr_sn in the j-direction
     7058      INTEGER(iwp) ::  jbc      !< Fixed j-index pointing to the boundary-value nodes (either j or jend)
     7059      INTEGER(iwp) ::  jend     !< Upper bound of the running index ja
     7060      INTEGER(iwp) ::  jw       !< j-index for wall_flags_0
     7061      INTEGER(iwp) ::  k        !< Running index in the z-direction
     7062      INTEGER(iwp) ::  k_wall   !< Vertical index of topography top
     7063      INTEGER(iwp) ::  kcorr    !<
     7064      INTEGER(iwp) ::  kco      !<
     7065      INTEGER(iwp) ::  kw       !< k-index for wall_flags_0
     7066      INTEGER(iwp) ::  k1       !<
     7067      INTEGER(iwp) ::  l        !< Parent-grid running index in the x-direction
     7068      INTEGER(iwp) ::  lp1      !< l+1
     7069      INTEGER(iwp) ::  lrightu  !< Upshift by one for the upper bound of index l in case of var == 'u'
     7070      INTEGER(iwp) ::  m        !< Parent-grid running index in the y-direction
     7071      INTEGER(iwp) ::  mbeg     !< m-index pointing to the starting point of workarrc_sn in the m-direction
     7072      INTEGER(iwp) ::  moff     !< m-offset needed on the north boundary to correctly refer to boundary ghost points
     7073      INTEGER(iwp) ::  mp1      !< m+1
     7074      INTEGER(iwp) ::  mw       !< Reduced m-index for workarrc_sn
     7075      INTEGER(iwp) ::  n        !< Parent-grid running index in the z-direction
     7076      INTEGER(iwp) ::  np1      !< n+1
     7077      INTEGER(iwp) ::  ntopw    !< Upshift by one for the upper bound of index n in case of var == 'w'
     7078      INTEGER(iwp) ::  var_flag !< Variable flag for BTEST( wall_flags_0 )
     7079
     7080      REAL(wp) ::  cellsum      !< Sum of child-grid node values over the anterpolation cell
     7081      REAL(wp) ::  cellsumd     !< Sum of differences over the anterpolation cell
     7082      REAL(wp) ::  fk           !< Intermediate result in trilinear interpolation
     7083      REAL(wp) ::  fkj          !< Intermediate result in trilinear interpolation
     7084      REAL(wp) ::  fkjp         !< Intermediate result in trilinear interpolation
     7085      REAL(wp) ::  fkpj         !< Intermediate result in trilinear interpolation
     7086      REAL(wp) ::  fkpjp        !< Intermediate result in trilinear interpolation
     7087      REAL(wp) ::  fkp          !< Intermediate result in trilinear interpolation
     7088      REAL(wp) ::  rcorr        !< Average reversibility correction for the whole anterpolation cell
     7089      REAL(wp) ::  rcorr_ijk    !< Reversibility correction distributed to the individual child-grid nodes
     7090
    58167091!
    58177092!--   Check which edge is to be handled: south or north
     
    58207095!--      For v, nys is a ghost node, but not for the other variables
    58217096         IF ( var == 'v' )  THEN
    5822             j  = nys
    5823             jb = nys - 1
     7097            j     = nys
     7098            jend  = nys
     7099            jawbc = 0
     7100            jbc   = nys       
     7101            mbeg  = jcs
     7102            moff  = 0
    58247103         ELSE
    5825             j  = nys - 1
    5826             jb = nys - 2
     7104            j     = nys - jgsr
     7105            jend  = nys - 1
     7106            jawbc = jgsr - 1
     7107            jbc   = nys - 1
     7108            mbeg  = jcs
     7109            moff  = 0
    58277110         ENDIF
    58287111      ELSEIF ( edge == 'n' )  THEN
    5829          j  = nyn + 1
    5830          jb = nyn + 2
     7112         IF ( var == 'v' )  THEN
     7113            j     = nyn + 1
     7114            jend  = nyn + 1
     7115            jawbc = 0
     7116            jbc   = nyn + 1
     7117            mbeg  = jcn - 2
     7118            moff  = 0
     7119         ELSE
     7120            j     = nyn + 1
     7121            jend  = nyn + jgsr
     7122            jawbc = 0
     7123            jbc   = nyn + 1
     7124            mbeg  = jcn - 2
     7125            moff  = 1
     7126         ENDIF
     7127      ENDIF
     7128
     7129      IF  ( var == 'w' )  THEN
     7130         ntopw = 1
     7131      ELSE
     7132         ntopw = 0
     7133      ENDIF
     7134
     7135      IF  ( var == 'u' )  THEN
     7136         lrightu = 0
     7137      ELSE
     7138         lrightu = 1
    58317139      ENDIF
    58327140
     
    58407148         var_flag = 0
    58417149      ENDIF
    5842 
    5843       DO  i = nxl, nxr+1
    5844 !
    5845 !--      Determine vertical index of topography top at grid point (j,i)
    5846 !AH         k_wall = get_topography_top_index_ji( j, i, TRIM( var ) )
    5847 
    5848          DO  k = nzb, nzt+1 !AH k_wall, nzt+1
    5849             l = ic(i)
    5850             m = jc(j)
    5851             n = kc(k)             
    5852             fkj      = r1x(i) * fc(n,m,l)     + r2x(i) * fc(n,m,l+1)
    5853             fkjp     = r1x(i) * fc(n,m+1,l)   + r2x(i) * fc(n,m+1,l+1)
    5854             fkpj     = r1x(i) * fc(n+1,m,l)   + r2x(i) * fc(n+1,m,l+1)
    5855             fkpjp    = r1x(i) * fc(n+1,m+1,l) + r2x(i) * fc(n+1,m+1,l+1)
    5856             fk       = r1y(j) * fkj  + r2y(j) * fkjp
    5857             fkp      = r1y(j) * fkpj + r2y(j) * fkpjp
    5858             f(k,j,i) = r1z(k) * fk   + r2z(k) * fkp
     7150!AH
     7151!
     7152!--   Substitute the necessary parent-grid data to the work array workarrc_sn.
     7153      workarrc_sn = 0.0_wp     
     7154      IF  ( pdims(1) > 1 )  THEN
     7155#if defined( __parallel )
     7156         IF  ( nxl == 0 )  THEN   ! if ( bc_dirichlet_l )
     7157            workarrc_sn(0:cg%nz+1,0:2,iclw:icrw-1)                              &
     7158                 = fc(0:cg%nz+1,mbeg:mbeg+2,iclw:icrw-1)
     7159         ELSE IF  ( nxr == nx )  THEN    ! if ( bc_dirichlet_r )
     7160            workarrc_sn(0:cg%nz+1,0:2,iclw+1:icrw)                              &
     7161                 = fc(0:cg%nz+1,mbeg:mbeg+2,iclw+1:icrw)
     7162         ELSE
     7163            workarrc_sn(0:cg%nz+1,0:2,iclw+1:icrw-1)                            &
     7164                 = fc(0:cg%nz+1,mbeg:mbeg+2,iclw+1:icrw-1)
     7165         ENDIF
     7166!
     7167!--      Left-right exchange if more than one PE subdomain in the x-direction.
     7168!--      Note that in case of 3-D nesting the left (pleft == MPI_PROC_NULL) and
     7169!--      right (pright == MPI_PROC_NULL) boundaries are not exchanged because
     7170!--      the nest domain is not cyclic.
     7171!--      From left to right
     7172         CALL MPI_SENDRECV( workarrc_sn(0,0,iclw+1), 1,                         &
     7173              workarrc_sn_exchange_type, pleft,   0,                            &
     7174              workarrc_sn(0,0,icrw), 1,                                         &
     7175              workarrc_sn_exchange_type, pright,  0,                            &
     7176              comm2d, status, ierr )
     7177!
     7178!--      From right to left       
     7179         CALL MPI_SENDRECV( workarrc_sn(0,0,icrw-1), 1,                         &
     7180              workarrc_sn_exchange_type, pright,  1,                            &
     7181              workarrc_sn(0,0,iclw), 1,                                         &
     7182              workarrc_sn_exchange_type, pleft,   1,                            &
     7183              comm2d, status, ierr )
     7184#endif     
     7185      ELSE
     7186         workarrc_sn(0:cg%nz+1,0:2,iclw+1:icrw-1)                               &
     7187                 = fc(0:cg%nz+1,mbeg:mbeg+2,iclw+1:icrw-1)
     7188      ENDIF
     7189!
     7190!AH
     7191
     7192      workarr_sn = 0.0_wp
     7193     
     7194      DO  i = nxl-1, nxr+1
     7195!AH      DO  i = nxl, nxr
     7196         DO  ja = j, jend
     7197            jaw = ja - j
     7198            DO  k = nzb, nzt+1
     7199               l   = ic(i)
     7200               lp1 = MIN( l + 1, icrw )  ! If l+1 > icr (l=ic(nxr+1)), r1x = 1 and r2x = 0
     7201!AH               m   = jc(ja) - jc(j)
     7202               m   = jc(ja) - mbeg
     7203               mp1 = MIN( m + 1, 2 )  ! If m+1 > 2 (m=jc(nyn+1)-mbeg), r1y = 1 and r2y = 0
     7204               n   = kc(k)
     7205               np1 = n + 1
     7206!AH
     7207!               fkj      = r1x(i) * fc(n,m,l)     + r2x(i) * fc(n,m,l+1)
     7208!               fkjp     = r1x(i) * fc(n,m+1,l)   + r2x(i) * fc(n,m+1,l+1)
     7209!               fkpj     = r1x(i) * fc(n+1,m,l)   + r2x(i) * fc(n+1,m,l+1)
     7210!               fkpjp    = r1x(i) * fc(n+1,m+1,l) + r2x(i) * fc(n+1,m+1,l+1)
     7211!AH
     7212               fkj      = r1x(i) * workarrc_sn(n,m,l)     + r2x(i) * workarrc_sn(n,m,lp1)
     7213               fkjp     = r1x(i) * workarrc_sn(n,mp1,l)   + r2x(i) * workarrc_sn(n,mp1,lp1)
     7214               fkpj     = r1x(i) * workarrc_sn(np1,m,l)   + r2x(i) * workarrc_sn(np1,m,lp1)
     7215               fkpjp    = r1x(i) * workarrc_sn(np1,mp1,l) + r2x(i) * workarrc_sn(np1,mp1,lp1)
     7216
     7217               fk       = r1y(ja) * fkj  + r2y(ja) * fkjp
     7218               fkp      = r1y(ja) * fkpj + r2y(ja) * fkpjp
     7219!AH
     7220!               f(k,j,i) = r1z(k) * fk   + r2z(k) * fkp
     7221               workarr_sn(k,jaw,i) = r1z(k) * fk   + r2z(k) * fkp
     7222
     7223!               if  ( ( edge == 's' ) .and. ( ja  == jbc ) ) then
     7224!                  write(9,"('pmci_interp_tril_sn: ',a2,2x,11(i4,2x),1(e12.5,2x))") var, k, ja, i, jbc, jaw, n, m, l, np1, mp1, lp1, &
     7225!                       workarr_sn(k,jaw,i)
     7226!                  flush(9)
     7227!               endif
     7228
     7229!AH               
     7230            ENDDO
    58597231         ENDDO
    5860       ENDDO
     7232      ENDDO     
    58617233!
    58627234!--   Generalized log-law-correction algorithm.
     
    59387310      ENDIF  ! ( topography /= 'flat' )
    59397311!
    5940 !--   Apply the reversibility correction to the boundary-normal velocity-
    5941 !--   component v and the scalars. It must not be applied to the boundary-
    5942 !--   tangential velocity components u and w because their 2-D anterpolation
    5943 !--   cells do not cover all the child-grid nodes on the boundary.
    5944       IF ( .NOT. ( ( var == 'u' ) .OR. ( var == 'w' ) ) )  THEN
    5945          m = jc(j)
    5946          DO  l = icl, icr
    5947             DO  n = 0, kct+1
     7312!--   Apply the reversibility correction.
     7313     
     7314!      if  ( var == 'u' )  then
     7315
     7316      m  = jc(jbc) + moff
     7317      mw = 1
     7318!      write(9,"('pmci_interp_tril_sn: edge, var, m, j, jend, jfl(m), jfu(m) = ',2(a2,2x),5(i4,2x))") &
     7319!           edge, var, m, j, jend, jfl(m), jfu(m)
     7320!      flush(9)
     7321!AH      DO  l = iclw+1, icrw-1
     7322      DO  l = iclw + 1, icrw - lrightu   ! lrightu = 0 for u and 1 for all others
     7323         DO  n = 0, kct + ntopw            ! ntopw = 1 for w and 0 for all others
     7324            ijk = 1
     7325            cellsum   = 0.0_wp
     7326            cellsumd  = 0.0_wp
     7327            DO  i = ifl(l), ifu(l)
     7328               iw = MAX( MIN( i, nx+1 ), -1 )
     7329               DO  ja = jfl(m), jfu(m)
     7330                  jaw = ja - j
     7331                  jw  = MAX( MIN( ja, ny+1 ), -1 )
     7332                  DO  k = kfl(n), kfu(n)
     7333                     kw = MIN( k, nzt+1 )
     7334!AH                     cellsum = cellsum + MERGE( f(k,ja,i), 0.0_wp,              &
     7335!AH                          BTEST( wall_flags_0(kw,jw,iw), var_flag ) )
     7336                     cellsum = cellsum + MERGE( workarr_sn(k,jaw,i), 0.0_wp,       &
     7337                          BTEST( wall_flags_0(kw,jw,iw), var_flag ) )                   
     7338!AH                     celltmpd(ijk) = ABS( fc(n,m,l) - f(k,ja,i) )
     7339!AH                     celltmpd(ijk) = ABS( workarrc_sn(n,mw,l) - f(k,ja,i) )
     7340                     celltmpd(ijk) = ABS( workarrc_sn(n,mw,l) - workarr_sn(k,jaw,i) )
     7341                     cellsumd      = cellsumd  + MERGE( celltmpd(ijk),          &
     7342                          0.0_wp, BTEST( wall_flags_0(kw,jw,iw), var_flag ) )
     7343
     7344!                     write(9,"('sn1: ',a1,2x,8(i4,2x),5(e12.5,2x))") var, n, m, l, k, ja, i, jaw, ijk,  &
     7345!                          workarrc_sn(n,mw,l), workarr_sn(k,jaw,i), cellsum, celltmpd(ijk), cellsumd
     7346!                     flush(9)
     7347
     7348                     ijk = ijk + 1
     7349                  ENDDO
     7350               ENDDO
     7351            ENDDO
     7352
     7353            IF ( ijkfc(n,m,l) /= 0 )  THEN
     7354               cellsum   = cellsum / REAL( ijkfc(n,m,l), KIND=wp )
     7355!AH               rcorr     = fc(n,m,l) - cellsum
     7356               rcorr     = workarrc_sn(n,mw,l) - cellsum
     7357               cellsumd  = cellsumd / REAL( ijkfc(n,m,l), KIND=wp )
     7358            ELSE
     7359               cellsum   = 0.0_wp                 
     7360               rcorr     = 0.0_wp
     7361               cellsumd  = 1.0_wp
     7362               celltmpd  = 1.0_wp
     7363            ENDIF
     7364!
     7365!--         Distribute the correction term to the child nodes according to
     7366!--         their relative difference to the parent value such that the
     7367!--         node with the largest difference gets the largest share of the
     7368!--         correction. The distribution is skipped if rcorr is negligibly
     7369!--         small in order to avoid division by zero.
     7370            IF ( ABS(rcorr) < 0.000001_wp )  THEN                 
     7371               cellsumd  = 1.0_wp
     7372               celltmpd  = 1.0_wp
     7373            ENDIF
     7374           
     7375            ijk = 1           
     7376            DO  i = ifl(l), ifu(l)
     7377               DO  ja = jfl(m), jfu(m)
     7378!AH                  jaw = ja - jfl(m)
     7379                  jaw = ja - j
     7380                  DO  k = kfl(n), kfu(n)
     7381                     rcorr_ijk = rcorr * celltmpd(ijk) / cellsumd
     7382!AH                     f(k,ja,i) = f(k,ja,i) + rcorr_ijk
     7383                     workarr_sn(k,jaw,i) = workarr_sn(k,jaw,i) + rcorr_ijk
     7384
     7385!                     write(9,"('sn2: ',a1,2x,9(i4,2x),4(e12.5,2x))") var, n, m, l, k, ja, i, jaw, ijk, ijkfc(n,m,l), &
     7386!                          rcorr, rcorr_ijk, workarr_sn(k,jaw,i), workarrc_sn(n,mw,l)
     7387!                     flush(9)
     7388
     7389                     ijk = ijk + 1
     7390                  ENDDO
     7391               ENDDO
     7392            ENDDO
     7393!
     7394!--         Velocity components tangential to the boundary need special
     7395!--         treatment because their anterpolation cells are flat in their
     7396!--         direction and hence do not cover all the child-grid boundary nodes.
     7397!--         These components are next linearly interpolated to those child-grid
     7398!--         boundary nodes which are not covered by the anterpolation cells.     
     7399            IF  ( ( var == 'w' ) .AND. ( n > 0 ) )  THEN
     7400               DO  k = kfu(n-1)+1, kfl(n)-1
     7401                  IF  ( k <= nzt )  THEN
     7402                     DO  i = ifl(l), ifu(l)
     7403                        IF  ( ( i >= nxl ) .AND. ( i <= nxr+1 ) )  THEN
     7404!AH                         f(k,ja,i) = r1z(k) * f(kfu(n-1),ja,i)                &
     7405!AH                               + r2z(k) * f(kfl(n),ja,i)
     7406                           workarr_sn(k,jawbc,i) =                              &
     7407                                r1z(k) * workarr_sn(kfu(n-1),jawbc,i) +         &
     7408                                r2z(k) * workarr_sn(kfl(n),jawbc,i)
     7409   
     7410!                           write(9,"('sn3: ',a1,2x,7(i4,2x),3(e12.5,2x))") var, n, m, l, k, jawbc, i, jbc,  &
     7411!                                workarr_sn(k-1,jawbc,i), workarr_sn(k,jawbc,i), workarr_sn(k+1,jawbc,i)
     7412!                           flush(9)
     7413
     7414                        ENDIF
     7415                     ENDDO
     7416                  ENDIF
     7417               ENDDO
     7418            ENDIF
     7419               
     7420            IF  ( ( var == 'u' ) .AND. ( l > iclw ) )  THEN
     7421               DO  i = ifu(l-1)+1, ifl(l)-1
     7422                  IF  ( ( i >= nxl ) .AND. ( i <= nxr+1 ) )  THEN
     7423                     DO  k = kfl(n), kfu(n)
     7424                        IF  ( k <= nzt+1 )  THEN
     7425!AH                         f(k,ja,i) = r1x(i) * f(k,ja,ifu(l-1))                &
     7426!AH                               + r2x(i) * f(k,ja,ifl(l))
     7427                           workarr_sn(k,jawbc,i) =                              &
     7428                                r1x(i) * workarr_sn(k,jawbc,ifu(l-1)) +         &
     7429                                r2x(i) * workarr_sn(k,jawbc,ifl(l))
     7430                           
     7431!                           write(9,"('sn4: ',a1,2x,7(i4,2x),3(e12.5,2x))") var, n, m, l, k, jawbc, i, jbc, &
     7432!                                workarr_sn(k,jawbc,i-1), workarr_sn(k,jawbc,i), workarr_sn(k,jawbc,i+1)
     7433!                           flush(9)
     7434
     7435                        ENDIF
     7436                     ENDDO
     7437                  ENDIF
     7438               ENDDO
     7439            ENDIF
     7440               
     7441         ENDDO  ! n
     7442      ENDDO  ! l
     7443
     7444!      endif  ! var
     7445
     7446!
     7447!--   Finally substitute the boundary values.
     7448      f(nzb:nzt+1,jbc,nxl:nxr) = workarr_sn(nzb:nzt+1,jawbc,nxl:nxr)
     7449
     7450!      do  k = 0, 2
     7451!         do  i = nxl, nxr
     7452!            if  ( edge == 's' )  then
     7453!               write(9,"('sn5: ',2(a2,2x),4(i4,2x),4(e12.5,2x))") edge, var, k, i, jbc, jawbc,  &
     7454!                    workarr_sn(k,jawbc,i), f(k,jbc,i), f(k,jbc+1,i), f(k,jbc+2,i)
     7455!            else if  ( edge == 'n' )  then
     7456!               write(9,"('sn5: ',2(a2,2x),4(i4,2x),4(e12.5,2x))") edge, var, k, i, jbc, jawbc,  &
     7457!                    f(k,jbc-2,i), f(k,jbc-1,i), f(k,jbc,i), workarr_sn(k,jawbc,i)
     7458!            endif
     7459!         enddo
     7460!      enddo
     7461!      flush(9)
     7462
     7463   END SUBROUTINE pmci_interp_tril_sn
     7464
     7465 
     7466
     7467   SUBROUTINE pmci_interp_tril_t( f, fc, ic, jc, kc, r1x, r2x, r1y, r2y,       &
     7468                                  r1z, r2z, kct, ifl, ifu, jfl, jfu, kfl, kfu, &
     7469                                  ijkfc, var )
     7470
     7471!
     7472!--   Interpolation of ghost-node values used as the child-domain boundary
     7473!--   conditions. This subroutine handles the top boundary.
     7474!--   This subroutine is based on trilinear interpolation.
     7475
     7476      IMPLICIT NONE
     7477
     7478      REAL(wp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg),                      &
     7479                                      INTENT(INOUT) ::  f     !< Child-grid array
     7480      REAL(wp), DIMENSION(0:cg%nz+1,jcs:jcn,icl:icr),                          &
     7481                                      INTENT(IN)    ::  fc    !< Parent-grid array
     7482      REAL(wp), DIMENSION(nxlfc:nxrfc), INTENT(IN)  ::  r1x   !<
     7483      REAL(wp), DIMENSION(nxlfc:nxrfc), INTENT(IN)  ::  r2x   !<
     7484      REAL(wp), DIMENSION(nysfc:nynfc), INTENT(IN)  ::  r1y   !<
     7485      REAL(wp), DIMENSION(nysfc:nynfc), INTENT(IN)  ::  r2y   !<
     7486!AH      REAL(wp), DIMENSION(nzb:nzt+1), INTENT(IN)    ::  r1z   !<
     7487!AH      REAL(wp), DIMENSION(nzb:nzt+1), INTENT(IN)    ::  r2z   !<
     7488      REAL(wp), DIMENSION(nzb:nzt+kgsr), INTENT(IN) ::  r1z   !<
     7489      REAL(wp), DIMENSION(nzb:nzt+kgsr), INTENT(IN) ::  r2z   !<
     7490
     7491     
     7492      INTEGER(iwp), DIMENSION(nxlfc:nxrfc), INTENT(IN)  ::  ic    !<
     7493      INTEGER(iwp), DIMENSION(nysfc:nynfc), INTENT(IN)  ::  jc    !<
     7494!AH      INTEGER(iwp), DIMENSION(nzb:nzt+1), INTENT(IN)    ::  kc    !<
     7495      INTEGER(iwp), DIMENSION(nzb:nzt+kgsr), INTENT(IN) ::  kc    !<
     7496
     7497      INTEGER(iwp) :: kct
     7498!AH
     7499!      INTEGER(iwp), DIMENSION(icl:icr), INTENT(IN) ::  ifl !< Indicates start index of child cells belonging to certain parent cell - x direction
     7500!      INTEGER(iwp), DIMENSION(icl:icr), INTENT(IN) ::  ifu !< Indicates end index of child cells belonging to certain parent cell - x direction
     7501!      INTEGER(iwp), DIMENSION(jcs:jcn), INTENT(IN) ::  jfl !< Indicates start index of child cells belonging to certain parent cell - y direction
     7502!      INTEGER(iwp), DIMENSION(jcs:jcn), INTENT(IN) ::  jfu !< Indicates start index of child cells belonging to certain parent cell - y direction
     7503      INTEGER(iwp), DIMENSION(icla:icra), INTENT(IN) ::  ifl !< Indicates start index of child cells belonging to certain parent cell - x direction
     7504      INTEGER(iwp), DIMENSION(icla:icra), INTENT(IN) ::  ifu !< Indicates end index of child cells belonging to certain parent cell - x direction
     7505      INTEGER(iwp), DIMENSION(jcsa:jcna), INTENT(IN) ::  jfl !< Indicates start index of child cells belonging to certain parent cell - y direction
     7506      INTEGER(iwp), DIMENSION(jcsa:jcna), INTENT(IN) ::  jfu !< Indicates start index of child cells belonging to certain parent cell - y direction
     7507!AH      INTEGER(iwp), DIMENSION(0:kct), INTENT(IN)   ::  kfl !< Indicates start index of child cells belonging to certain parent cell - z direction
     7508!AH      INTEGER(iwp), DIMENSION(0:kct), INTENT(IN)   ::  kfu !< Indicates start index of child cells belonging to certain parent cell - z direction
     7509      INTEGER(iwp), DIMENSION(0:cg%nz+1), INTENT(IN)   ::  kfl !< Indicates start index of child cells belonging to certain parent cell - z direction
     7510      INTEGER(iwp), DIMENSION(0:cg%nz+1), INTENT(IN)   ::  kfu !< Indicates start index of child cells belonging to certain parent cell - z direction
     7511!AH      INTEGER(iwp), DIMENSION(0:kct,jcs:jcn,icl:icr), INTENT(IN) :: ijkfc !< number of child grid points contributing to a parent grid box
     7512!AH
     7513!      INTEGER(iwp), DIMENSION(0:cg%nz+1,jcs:jcn,icl:icr), INTENT(IN) :: ijkfc !< number of child grid points contributing to a parent grid box
     7514      INTEGER(iwp), DIMENSION(0:cg%nz+1,jcsa:jcna,icla:icra), INTENT(IN) :: ijkfc !< number of child grid points contributing to a parent grid box
     7515!AH
     7516
     7517      CHARACTER(LEN=1), INTENT(IN) :: var   !<
     7518
     7519      INTEGER(iwp) ::  i    !<
     7520      INTEGER(iwp) ::  ib   !<
     7521      INTEGER(iwp) ::  iclc !< Lower i-index limit for copying fc-data to workarrc_t
     7522      INTEGER(iwp) ::  icrc !< Upper i-index limit for copying fc-data to workarrc_t
     7523      INTEGER(iwp) ::  ie   !<
     7524      INTEGER(iwp) ::  ierr !< MPI error code
     7525      INTEGER(iwp) ::  ijk  !<
     7526      INTEGER(iwp) ::  iw   !<
     7527      INTEGER(iwp) ::  j    !<
     7528      INTEGER(iwp) ::  jb   !<
     7529      INTEGER(iwp) ::  jcsc !< Lower j-index limit for copying fc-data to workarrc_t
     7530      INTEGER(iwp) ::  jcnc !< Upper j-index limit for copying fc-data to workarrc_t
     7531      INTEGER(iwp) ::  je   !<
     7532      INTEGER(iwp) ::  jw   !<     
     7533      INTEGER(iwp) ::  k    !< Vertical child-grid index fixed to the boundary-value level
     7534      INTEGER(iwp) ::  ka   !< Running vertical child-grid index
     7535      INTEGER(iwp) ::  kw   !<
     7536      INTEGER(iwp) ::  l    !< Parent-grid index in x-direction
     7537      INTEGER(iwp) ::  lp1  !< l+1
     7538      INTEGER(iwp) ::  m    !< Parent-grid index in y-direction
     7539      INTEGER(iwp) ::  mp1  !< m+1
     7540      INTEGER(iwp) ::  n    !< Parent-grid work array index in z-direction
     7541      INTEGER(iwp) ::  np1  !< n+1
     7542      INTEGER(iwp) ::  noff !< n-offset needed on the top boundary to correctly refer to boundary ghost points 
     7543      INTEGER(iwp) ::  nw   !< n-index for workarrc_t
     7544      INTEGER(iwp) ::  var_flag  !<
     7545     
     7546      REAL(wp) ::  cellsum     !<
     7547      REAL(wp) ::  cellsumd    !<
     7548      REAL(wp) ::  fk          !<
     7549      REAL(wp) ::  fkj         !<
     7550      REAL(wp) ::  fkjp        !<
     7551      REAL(wp) ::  fkpj        !<
     7552      REAL(wp) ::  fkpjp       !<
     7553      REAL(wp) ::  fkp         !<
     7554      REAL(wp) ::  rcorr       !<
     7555      REAL(wp) ::  rcorr_ijk   !<
     7556
     7557      integer(iwp) :: kend
     7558
     7559
     7560      IF ( var == 'w' )  THEN
     7561         k    = nzt
     7562         noff = 0
     7563         kend = nzt
     7564      ELSE
     7565         k    = nzt + 1
     7566         noff = 1
     7567         kend = nzt+kgsr
     7568      ENDIF
     7569!
     7570!--   These exceedings by one are needed only to avoid stripes
     7571!--   and spots in visualization. They have no effect on the
     7572!--   actual solution.     
     7573!
     7574!AH   These loop bounds lead to overflows with the current reduced icl, icr, jcs, jcn
     7575!AH      ib = nxl-1
     7576!AH      ie = nxr+1
     7577!AH      jb = nys-1
     7578!AH      je = nyn+1
     7579      ib = nxl
     7580      ie = nxr
     7581      jb = nys
     7582      je = nyn
     7583
     7584      IF ( var == 'u' )  THEN
     7585         var_flag = 1
     7586         ie       = nxr + 1 ! Needed for finishing interpolation for u
     7587      ELSEIF ( var == 'v' )  THEN
     7588         var_flag = 2     
     7589         je       = nyn + 1 ! Needed for finishing interpolation for v
     7590      ELSEIF ( var == 'w' )  THEN
     7591         var_flag = 3
     7592      ELSE
     7593         var_flag = 0
     7594      ENDIF
     7595         
     7596!AH      DO  i = ib, ie
     7597!AH         DO  j = jb, je
     7598!AH            l = ic(i)
     7599!AH            m = jc(j)
     7600!AH            n = kc(k)           
     7601!AH            fkj      = r1x(i) * fc(n,m,l)     + r2x(i) * fc(n,m,l+1)
     7602!AH            fkjp     = r1x(i) * fc(n,m+1,l)   + r2x(i) * fc(n,m+1,l+1)
     7603!AH            fkpj     = r1x(i) * fc(n+1,m,l)   + r2x(i) * fc(n+1,m,l+1)
     7604!AH            fkpjp    = r1x(i) * fc(n+1,m+1,l) + r2x(i) * fc(n+1,m+1,l+1)
     7605!AH            fk       = r1y(j) * fkj  + r2y(j) * fkjp
     7606!AH            fkp      = r1y(j) * fkpj + r2y(j) * fkpjp
     7607!AH            f(k,j,i) = r1z(k) * fk   + r2z(k) * fkp
     7608!AH         ENDDO
     7609!AH      ENDDO
     7610
     7611!      write(9,"('workarrc_t kbounds: ',a2,2x,5(i3,2x))") var, k, kend, kc(k), kc(kend), cg%nz+1
     7612!      flush(9)
     7613!AH
     7614!
     7615!--   Substitute the necessary parent-grid data to the work array.
     7616!--   Note that the dimension of workarrc_t is (0:2,jcsw:jcnw,iclw:icrw),
     7617!--   And the jc?w and ic?w-index bounds depend on the location of the PE-
     7618!--   subdomain relative to the side boundaries.
     7619      iclc = iclw + 1
     7620      icrc = icrw - 1     
     7621      jcsc = jcsw + 1
     7622      jcnc = jcnw - 1
     7623      IF  ( bc_dirichlet_l )  THEN
     7624         iclc = iclw
     7625      ENDIF
     7626      IF  ( bc_dirichlet_r )  THEN
     7627         icrc = icrw
     7628      ENDIF
     7629      IF  ( bc_dirichlet_s )  THEN
     7630         jcsc = jcsw
     7631      ENDIF
     7632      IF  ( bc_dirichlet_n )  THEN
     7633         jcnc = jcnw
     7634      ENDIF
     7635      workarrc_t = 0.0_wp
     7636      workarrc_t(0:2,jcsc:jcnc,iclc:icrc)                                       &
     7637           = fc(kc(k):kc(k)+2,jcsc:jcnc,iclc:icrc)
     7638!
     7639!--   Left-right exchange if more than one PE subdomain in the x-direction.
     7640!--   Note that in case of 3-D nesting the left and right boundaries are
     7641!--   not exchanged because the nest domain is not cyclic.
     7642#if defined( __parallel )
     7643      IF  ( pdims(1) > 1 )  THEN
     7644!
     7645!--      From left to right
     7646         CALL MPI_SENDRECV( workarrc_t(0,jcsw,iclw+1), 1,                       &
     7647              workarrc_t_exchange_type_y, pleft,  0,                            &
     7648              workarrc_t(0,jcsw,icrw), 1,                                       &
     7649              workarrc_t_exchange_type_y, pright, 0,                            &
     7650              comm2d, status, ierr )
     7651!
     7652!--      From right to left       
     7653         CALL MPI_SENDRECV( workarrc_t(0,jcsw,icrw-1), 1,                       &
     7654              workarrc_t_exchange_type_y, pright, 1,                            &
     7655              workarrc_t(0,jcsw,iclw), 1,                                       &
     7656              workarrc_t_exchange_type_y, pleft,  1,                            &
     7657              comm2d, status, ierr )
     7658      ENDIF
     7659!
     7660!--   South-north exchange if more than one PE subdomain in the y-direction.
     7661!--   Note that in case of 3-D nesting the south and north boundaries are
     7662!--   not exchanged because the nest domain is not cyclic.
     7663      IF  ( pdims(2) > 1 )  THEN
     7664!
     7665!--      From south to north         
     7666         CALL MPI_SENDRECV( workarrc_t(0,jcsw+1,iclw), 1,                       &
     7667              workarrc_t_exchange_type_x, psouth, 2,                            &
     7668              workarrc_t(0,jcnw,iclw), 1,                                       &
     7669              workarrc_t_exchange_type_x, pnorth, 2,                            &
     7670              comm2d, status, ierr )
     7671!
     7672!--      From north to south       
     7673         CALL MPI_SENDRECV( workarrc_t(0,jcnw-1,iclw), 1,                       &
     7674              workarrc_t_exchange_type_x, pnorth, 3,                            &
     7675              workarrc_t(0,jcsw,iclw), 1,                                       &
     7676              workarrc_t_exchange_type_x, psouth, 3,                            &
     7677              comm2d, status, ierr )
     7678      ENDIF
     7679#endif     
     7680!
     7681!AH
     7682
     7683      workarr_t = 0.0_wp
     7684
     7685      DO  i = ib, ie
     7686         DO  j = jb, je
     7687            DO ka = k, kend
     7688               l    = ic(i)
     7689               lp1  = MIN( l + 1, icrw ) ! If l+1 > icr (l=ic(nxr+1)), r1x = 1 and r2x = 0
     7690               m    = jc(j)
     7691               mp1  = MIN( m + 1, jcnw ) ! If m+1 > jcn (m=jc(nyn+1)), r1y = 1 and r2y = 0
     7692!AH
     7693!               n    = kc(ka)           
     7694               n   = kc(ka) - kc(k)
     7695               np1 = n + 1
     7696!AH
     7697!               fkj       = r1x(i)  * fc(n,m,l)     + r2x(i) * fc(n,m,l+1)
     7698!               fkjp      = r1x(i)  * fc(n,m+1,l)   + r2x(i) * fc(n,m+1,l+1)
     7699!               fkpj      = r1x(i)  * fc(n+1,m,l)   + r2x(i) * fc(n+1,m,l+1)
     7700!               fkpjp     = r1x(i)  * fc(n+1,m+1,l) + r2x(i) * fc(n+1,m+1,l+1)
     7701!AH
     7702               fkj       = r1x(i)  * workarrc_t(n,m,l)     + r2x(i) * workarrc_t(n,m,lp1)
     7703               fkjp      = r1x(i)  * workarrc_t(n,mp1,l)   + r2x(i) * workarrc_t(n,mp1,lp1)
     7704               fkpj      = r1x(i)  * workarrc_t(np1,m,l)   + r2x(i) * workarrc_t(np1,m,lp1)
     7705               fkpjp     = r1x(i)  * workarrc_t(np1,mp1,l) + r2x(i) * workarrc_t(np1,mp1,lp1)
     7706!AH
     7707               fk        = r1y(j)  * fkj  + r2y(j) * fkjp
     7708               fkp       = r1y(j)  * fkpj + r2y(j) * fkpjp
     7709               workarr_t(ka,j,i) = r1z(ka) * fk + r2z(ka) * fkp
     7710         
     7711            ENDDO
     7712         ENDDO
     7713      ENDDO
     7714
     7715!AH!
     7716!AH!--   Just fill up the redundant second ghost-node layer for w.
     7717!AH      IF ( var == 'w' )  THEN
     7718!AH         f(nzt+1,:,:) = f(nzt,:,:)
     7719!AH      ENDIF
     7720!
     7721!--      Apply the reversibility correction.
     7722         n  = kc(k) + noff 
     7723         nw = 0
     7724!AH         DO  l = icl-1, icr+1
     7725         DO  l = iclw, icrw
     7726!AH            DO  m = jcs-1, jcn+1
     7727            DO  m = jcsw, jcnw
    59487728               ijk = 1
    5949                cellsum   = 0.0_wp 
     7729               cellsum   = 0.0_wp
    59507730               cellsumd  = 0.0_wp
    59517731               DO  i = ifl(l), ifu(l)
    5952                   DO  ja = jfl(m), jfu(m)
    5953                      DO  k = kfl(n), kfu(n)
    5954                         cellsum = cellsum + MERGE( f(k,ja,i), 0.0_wp,           &
    5955                              BTEST( wall_flags_0(k,ja,i), var_flag ) )                       
    5956                         celltmpd(ijk) = ABS( fc(n,m,l) - f(k,ja,i) )
    5957                         cellsumd      = cellsumd  + MERGE( celltmpd(ijk),       &
    5958                              0.0_wp, BTEST( wall_flags_0(k,ja,i), var_flag ) )
    5959                         ijk = ijk + 1
     7732                  iw = MAX( MIN( i, nx+1 ), -1 )
     7733                  IF  ( ( i >= nxl ) .AND. ( i <= nxr+1 ) )  THEN
     7734                     DO  j = jfl(m), jfu(m)
     7735                        jw = MAX( MIN( j, ny+1 ), -1 )
     7736                        IF  ( ( j >= nys ) .AND. ( j <= nyn+1 ) )  THEN
     7737                           DO  ka = kfl(n), kfu(n)
     7738                              kw = MIN( ka, nzt+1 )
     7739!AH                            cellsum = cellsum + MERGE( f(ka,j,i), 0.0_wp,           &
     7740                              cellsum = cellsum + MERGE( workarr_t(ka,j,i), 0.0_wp,   &
     7741                                   BTEST( wall_flags_0(kw,jw,iw), var_flag ) )
     7742!                              cellsum = cellsum + workarr_t(ka,j,i)
     7743!AH                            celltmpd(ijk) = ABS( fc(n,m,l) - f(ka,j,i) )
     7744!AH
     7745!                              celltmpd(ijk) = ABS( fc(n,m,l) - workarr_t(ka,j,i) )
     7746                              celltmpd(ijk) = ABS( workarrc_t(nw,m,l) - workarr_t(ka,j,i) )
     7747!AH
     7748                              cellsumd      = cellsumd  + MERGE( celltmpd(ijk),       &
     7749                                   0.0_wp, BTEST( wall_flags_0(kw,jw,iw), var_flag ) )
     7750                              ijk = ijk + 1
     7751                           ENDDO
     7752                        ENDIF
    59607753                     ENDDO
    5961                   ENDDO
     7754                  ENDIF
    59627755               ENDDO
    59637756
    59647757               IF ( ijkfc(n,m,l) /= 0 )  THEN
    59657758                  cellsum   = cellsum / REAL( ijkfc(n,m,l), KIND=wp )
    5966                   rcorr     = fc(n,m,l) - cellsum
     7759!AH
     7760!                  rcorr     = fc(n,m,l) - cellsum
     7761                  rcorr     = workarrc_t(nw,m,l) - cellsum
     7762!AH                 
    59677763                  cellsumd  = cellsumd / REAL( ijkfc(n,m,l), KIND=wp )
    59687764               ELSE
    5969                   cellsum   = 0.0_wp                 
     7765                  cellsum   = 0.0_wp
    59707766                  rcorr     = 0.0_wp
    59717767                  cellsumd  = 1.0_wp
     
    59837779               ENDIF
    59847780           
    5985                ijk = 1           
    5986                DO  i = ifl(l), ifu(l)
    5987                   DO  ja = jfl(m), jfu(m)
    5988                      DO  k = kfl(n), kfu(n)
    5989                         rcorr_ijk = rcorr * celltmpd(ijk) / cellsumd
    5990                         f(k,ja,i) = f(k,ja,i) + rcorr_ijk
    5991                         ijk = ijk + 1
    5992                      ENDDO
    5993                   ENDDO
    5994                ENDDO
    5995                
    5996             ENDDO  ! n
    5997          ENDDO  ! l
    5998 
    5999       ENDIF  ! var not u or w
    6000 !
    6001 !--   Store the boundary values also into the other redundant ghost node layers.
    6002 !--   Note that in case of only one ghost node layer, e.g. for the PW
    6003 !--   scheme, the following loops will not be entered.
    6004       IF ( edge == 's' )  THEN
    6005          DO  jbgp = -nbgp, jb
    6006             f(0:nzt+1,jbgp,nxlg:nxrg) = f(0:nzt+1,j,nxlg:nxrg)
    6007          ENDDO
    6008       ELSEIF ( edge == 'n' )  THEN
    6009          DO  jbgp = jb, ny+nbgp
    6010             f(0:nzt+1,jbgp,nxlg:nxrg) = f(0:nzt+1,j,nxlg:nxrg)
    6011          ENDDO
    6012       ENDIF
    6013 
    6014    END SUBROUTINE pmci_interp_tril_sn
    6015 
    6016  
    6017 
    6018    SUBROUTINE pmci_interp_tril_t( f, fc, ic, jc, kc, r1x, r2x, r1y, r2y,       &
    6019                                   r1z, r2z, kct, ifl, ifu, jfl, jfu, kfl, kfu, &
    6020                                   ijkfc, var )
    6021 
    6022 !
    6023 !--   Interpolation of ghost-node values used as the child-domain boundary
    6024 !--   conditions. This subroutine handles the top boundary.
    6025 !--   This subroutine is based on trilinear interpolation.
    6026 
    6027       IMPLICIT NONE
    6028 
    6029       REAL(wp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg),                      &
    6030                                       INTENT(INOUT) ::  f     !<
    6031       REAL(wp), DIMENSION(0:cg%nz+1,jcs:jcn,icl:icr),                          &
    6032                                       INTENT(IN)    ::  fc    !<
    6033       REAL(wp), DIMENSION(nxlg:nxrg), INTENT(IN)    ::  r1x   !<
    6034       REAL(wp), DIMENSION(nxlg:nxrg), INTENT(IN)    ::  r2x   !<
    6035       REAL(wp), DIMENSION(nysg:nyng), INTENT(IN)    ::  r1y   !<
    6036       REAL(wp), DIMENSION(nysg:nyng), INTENT(IN)    ::  r2y   !<
    6037       REAL(wp), DIMENSION(nzb:nzt+1), INTENT(IN)    ::  r1z   !<
    6038       REAL(wp), DIMENSION(nzb:nzt+1), INTENT(IN)    ::  r2z   !<
    6039      
    6040       INTEGER(iwp), DIMENSION(nxlg:nxrg), INTENT(IN) ::  ic    !<
    6041       INTEGER(iwp), DIMENSION(nysg:nyng), INTENT(IN) ::  jc    !<
    6042       INTEGER(iwp), DIMENSION(nzb:nzt+1), INTENT(IN) ::  kc    !<
    6043      
    6044       INTEGER(iwp) :: kct
    6045       INTEGER(iwp), DIMENSION(icl:icr), INTENT(IN) ::  ifl !< Indicates start index of child cells belonging to certain parent cell - x direction
    6046       INTEGER(iwp), DIMENSION(icl:icr), INTENT(IN) ::  ifu !< Indicates end index of child cells belonging to certain parent cell - x direction
    6047       INTEGER(iwp), DIMENSION(jcs:jcn), INTENT(IN) ::  jfl !< Indicates start index of child cells belonging to certain parent cell - y direction
    6048       INTEGER(iwp), DIMENSION(jcs:jcn), INTENT(IN) ::  jfu !< Indicates start index of child cells belonging to certain parent cell - y direction
    6049 !AH      INTEGER(iwp), DIMENSION(0:kct), INTENT(IN)   ::  kfl !< Indicates start index of child cells belonging to certain parent cell - z direction
    6050 !AH      INTEGER(iwp), DIMENSION(0:kct), INTENT(IN)   ::  kfu !< Indicates start index of child cells belonging to certain parent cell - z direction
    6051       INTEGER(iwp), DIMENSION(0:cg%nz+1), INTENT(IN)   ::  kfl !< Indicates start index of child cells belonging to certain parent cell - z direction
    6052       INTEGER(iwp), DIMENSION(0:cg%nz+1), INTENT(IN)   ::  kfu !< Indicates start index of child cells belonging to certain parent cell - z direction
    6053 !AH      INTEGER(iwp), DIMENSION(0:kct,jcs:jcn,icl:icr), INTENT(IN) :: ijkfc !< number of child grid points contributing to a parent grid box
    6054       INTEGER(iwp), DIMENSION(0:cg%nz+1,jcs:jcn,icl:icr), INTENT(IN) :: ijkfc !< number of child grid points contributing to a parent grid box
    6055 
    6056       CHARACTER(LEN=1), INTENT(IN) :: var   !<
    6057 
    6058       INTEGER(iwp) ::  i   !<
    6059       INTEGER(iwp) ::  ib  !<
    6060       INTEGER(iwp) ::  ie  !<
    6061       INTEGER(iwp) ::  ijk !<
    6062       INTEGER(iwp) ::  j   !<
    6063       INTEGER(iwp) ::  jb  !<
    6064       INTEGER(iwp) ::  je  !<     
    6065       INTEGER(iwp) ::  k   !<
    6066       INTEGER(iwp) ::  ka  !<
    6067       INTEGER(iwp) ::  l   !<
    6068       INTEGER(iwp) ::  m   !<
    6069       INTEGER(iwp) ::  n   !<
    6070       INTEGER(iwp) ::  var_flag  !<
    6071      
    6072       REAL(wp) ::  cellsum     !<
    6073       REAL(wp) ::  cellsumd    !<
    6074       REAL(wp) ::  fk          !<
    6075       REAL(wp) ::  fkj         !<
    6076       REAL(wp) ::  fkjp        !<
    6077       REAL(wp) ::  fkpj        !<
    6078       REAL(wp) ::  fkpjp       !<
    6079       REAL(wp) ::  fkp         !<
    6080       REAL(wp) ::  rcorr       !<
    6081       REAL(wp) ::  rcorr_ijk   !<
    6082 
    6083 
    6084       IF ( var == 'w' )  THEN
    6085          k  = nzt
    6086       ELSE
    6087          k  = nzt + 1
    6088       ENDIF
    6089 !
    6090 !--   These exceedings by one are needed only to avoid stripes
    6091 !--   and spots in visualization. They have no effect on the
    6092 !--   actual solution.     
    6093       ib = nxl-1
    6094       ie = nxr+1
    6095       jb = nys-1
    6096       je = nyn+1
    6097 
    6098       IF ( var == 'u' )  THEN
    6099          var_flag = 1
    6100       ELSEIF ( var == 'v' )  THEN
    6101          var_flag = 2
    6102       ELSEIF ( var == 'w' )  THEN
    6103          var_flag = 3
    6104       ELSE
    6105          var_flag = 0
    6106       ENDIF
    6107          
    6108       DO  i = ib, ie
    6109          DO  j = jb, je
    6110             l = ic(i)
    6111             m = jc(j)
    6112             n = kc(k)           
    6113             fkj      = r1x(i) * fc(n,m,l)     + r2x(i) * fc(n,m,l+1)
    6114             fkjp     = r1x(i) * fc(n,m+1,l)   + r2x(i) * fc(n,m+1,l+1)
    6115             fkpj     = r1x(i) * fc(n+1,m,l)   + r2x(i) * fc(n+1,m,l+1)
    6116             fkpjp    = r1x(i) * fc(n+1,m+1,l) + r2x(i) * fc(n+1,m+1,l+1)
    6117             fk       = r1y(j) * fkj  + r2y(j) * fkjp
    6118             fkp      = r1y(j) * fkpj + r2y(j) * fkpjp
    6119             f(k,j,i) = r1z(k) * fk   + r2z(k) * fkp
    6120          ENDDO
    6121       ENDDO
    6122 !
    6123 !--   Apply the reversibility correction to the boundary-normal velocity-
    6124 !--   component w and scalars. It must not be applied to the boundary-
    6125 !--   tangential velocity components u and v because their 2-D anterpolation
    6126 !--   cells do not cover all the child-grid nodes on the boundary.
    6127       IF ( .NOT. ( ( var == 'u' ) .OR. ( var == 'v' ) ) )  THEN 
    6128          IF ( var == 'w' )  THEN
    6129             n = kc(k)
    6130          ELSE
    6131             n = kc(k) + 1
    6132          ENDIF
    6133 
    6134          DO  l = icl, icr
    6135             DO  m = jcs, jcn
    6136                ijk = 1
    6137                cellsum   = 0.0_wp
    6138                cellsumd  = 0.0_wp
    6139                DO  i = ifl(l), ifu(l)
    6140                   DO  j = jfl(m), jfu(m)
    6141                      DO  ka = kfl(n), kfu(n)
    6142                         cellsum = cellsum + MERGE( f(ka,j,i), 0.0_wp,           &
    6143                              BTEST( wall_flags_0(ka,j,i), var_flag ) )
    6144                         celltmpd(ijk) = ABS( fc(n,m,l) - f(ka,j,i) )
    6145                         cellsumd      = cellsumd  + MERGE( celltmpd(ijk),       &
    6146                              0.0_wp, BTEST( wall_flags_0(ka,j,i), var_flag ) )                     
    6147                         ijk = ijk + 1
    6148                      ENDDO
    6149                   ENDDO
    6150                ENDDO
    6151 
    6152                IF ( ijkfc(n,m,l) /= 0 )  THEN
    6153                   cellsum   = cellsum / REAL( ijkfc(n,m,l), KIND=wp )
    6154                   rcorr     = fc(n,m,l) - cellsum
    6155                   cellsumd  = cellsumd / REAL( ijkfc(n,m,l), KIND=wp )
    6156                ELSE
    6157                   cellsum   = 0.0_wp
    6158                   rcorr     = 0.0_wp
    6159                   cellsumd  = 1.0_wp
    6160                   celltmpd  = 1.0_wp
    6161                ENDIF
    6162 
    6163                IF ( ABS(rcorr) < 0.000001_wp )  THEN                 
    6164                   cellsumd  = 1.0_wp
    6165                   celltmpd  = 1.0_wp
    6166                ENDIF
    6167 
    61687781               ijk = 1
    61697782               DO  i = ifl(l), ifu(l)
    6170                   DO  j = jfl(m), jfu(m)
    6171                      DO  ka = kfl(n), kfu(n)
    6172                         rcorr_ijk = rcorr * celltmpd(ijk) / cellsumd
    6173                         f(ka,j,i) = f(ka,j,i) + rcorr_ijk
    6174                         ijk = ijk + 1
     7783                  IF  ( ( i >= nxl ) .AND. ( i <= nxr+1 ) )  THEN
     7784                     DO  j = jfl(m), jfu(m)
     7785                        IF  ( ( j >= nys ) .AND. ( j <= nyn+1 ) )  THEN
     7786                           DO  ka = kfl(n), kfu(n)
     7787                              rcorr_ijk = rcorr * celltmpd(ijk) / cellsumd
     7788!AH                            f(ka,j,i) = f(ka,j,i) + rcorr_ijk
     7789                              workarr_t(ka,j,i) = workarr_t(ka,j,i) + rcorr_ijk
     7790
     7791!                                 if  ( i == 128 .and. var == 'u' )  then
     7792!                                    write(9,"('t2: ', 8(i4,2x),3(e12.5,2x))") nw, m, l, ka, j, i, ifl(l), ifu(l), &
     7793!                                         rcorr, rcorr_ijk, workarr_t(ka,j,i)
     7794!                                    flush(9)
     7795!                                 endif
     7796
     7797                              ijk = ijk + 1
     7798                           ENDDO
     7799                        ENDIF
    61757800                     ENDDO
     7801                  ENDIF
     7802               ENDDO
     7803!
     7804!--            Velocity components tangential to the boundary need special
     7805!--            "finishing" because their anterpolation cells are flat in their
     7806!--            direction and hence do not cover all the child-grid boundary nodes.
     7807!--            These components are next linearly interpolated to those child-grid
     7808!--            boundary nodes which are not covered by the anterpolation cells.
     7809               IF  ( ( var == 'v' ) .AND. ( m > jcs ) )  THEN
     7810                  DO  j = jfu(m-1)+1, jfl(m)-1
     7811                     IF  ( ( j >= nys ) .AND. ( j <= nyn+1 ) )  THEN
     7812                        DO  i = ifl(l), ifu(l)
     7813                           IF  ( ( i >= nxl ) .AND. ( i <= nxr+1 ) )  THEN
     7814                              DO  ka = kfl(n), kfu(n)        ! This loop should be removed and fixed k-value be used instead
     7815!AH                              f(ka,j,i) = r1y(j) * f(ka,jfu(m-1),i)             &
     7816!AH                                   + r2y(j) * f(ka,jfl(m),i)
     7817                                 workarr_t(ka,j,i) = r1y(j) * workarr_t(ka,jfu(m-1),i) &
     7818                                      + r2y(j) * workarr_t(ka,jfl(m),i)
     7819                              ENDDO
     7820                           ENDIF
     7821                        ENDDO
     7822                     ENDIF
    61767823                  ENDDO
    6177                ENDDO
     7824               ENDIF
     7825               
     7826               IF  ( ( var == 'u' ) .AND. ( l > icl ) )  THEN
     7827                  DO  i = ifu(l-1)+1, ifl(l)-1
     7828                     IF  ( ( i >= nxl ) .AND. ( i <= nxr+1 ) )  THEN
     7829                        DO  j = jfl(m), jfu(m)
     7830                           IF  ( ( j >= nys ) .AND. ( j <= nyn+1 ) )  THEN
     7831                              DO  ka = kfl(n), kfu(n)        ! This loop should be removed and fixed k-value be used instead
     7832!AH                              f(ka,j,i) = r1x(i) * f(ka,j,ifu(l-1)) +           &
     7833!AH                                   r2x(i) * f(ka,j,ifl(l))
     7834                                 workarr_t(ka,j,i) = r1x(i) * workarr_t(ka,j,ifu(l-1)) &
     7835                                      + r2x(i) * workarr_t(ka,j,ifl(l))
     7836
     7837!                                 if  ( i == 127 )  then
     7838!                                    write(9,"('t4: ', 8(i4,2x),3(e12.5,2x))") nw, m, l, ka, j, ifu(l-1), i, ifl(l), &
     7839!                                         workarr_t(ka,j,ifu(l-1)), workarr_t(ka,j,i), workarr_t(ka,j,ifl(l))
     7840!                                    flush(9)
     7841!                                 endif
     7842
     7843                              ENDDO
     7844                           ENDIF
     7845                        ENDDO
     7846                     ENDIF
     7847                  ENDDO
     7848               ENDIF
    61787849               
    61797850            ENDDO  ! m
    61807851         ENDDO  ! l
    6181