mod_ghostcells_update.t

Go to the documentation of this file.

!> update ghost cells of all blocks including physical boundaries 
module mod_ghostcells_update
 
  implicit none
 
  ! The number of interleaving sending buffers for ghost cells
  integer, parameter :: npwbuf=2
 
  integer :: ixm^l, ixcog^l, ixcom^l, ixcogs^l
 
  ! index ranges to send (S) to sibling blocks, receive (R) from sibling blocks
  integer, dimension(-1:1) :: ixs_srl_^l, ixr_srl_^l
 
  ! index ranges of staggered variables to send (S) to sibling blocks, receive (R) from sibling blocks
  integer, dimension(^ND,-1:1) :: ixs_srl_stg_^l, ixr_srl_stg_^l
 
  ! index ranges to send (S) restricted (r) ghost cells to coarser blocks 
  integer, dimension(-1:1) :: ixs_r_^l
 
  ! index ranges of staggered variables to send (S) restricted (r) ghost cells to coarser blocks 
  integer, dimension(^ND,-1:1) :: ixs_r_stg_^l
 
  ! index ranges to receive restriced ghost cells from finer blocks 
  integer, dimension(0:3) :: ixr_r_^l
 
  ! index ranges of staggered variables to receive restriced ghost cells from finer blocks 
  integer, dimension(^ND,0:3)  :: ixr_r_stg_^l
 
  ! send prolongated (p) ghost cells to finer blocks, receive prolongated from coarser blocks
  integer, dimension(0:3) :: ixs_p_^l, ixr_p_^l
 
  ! send prolongated (p) staggered ghost cells to finer blocks, receive prolongated from coarser blocks
  integer, dimension(^ND,0:3)  :: ixs_p_stg_^l, ixr_p_stg_^l
 
  ! number of MPI receive-send pairs, srl: same refinement level; r: restrict; p: prolong
  integer :: nrecv_bc_srl, nsend_bc_srl, nrecv_bc_r, nsend_bc_r, nrecv_bc_p, nsend_bc_p
 
  ! record index position of buffer arrays
  integer :: ibuf_send_srl, ibuf_recv_srl, ibuf_send_r, ibuf_recv_r, ibuf_send_p, ibuf_recv_p
 
  ! count of times of send and receive
  integer :: isend_srl, irecv_srl, isend_r, irecv_r, isend_p, irecv_p
 
  ! count of times of send and receive for cell center ghost cells
  integer :: isend_c, irecv_c
 
  ! tag of MPI send and recv
  integer, private :: itag
 
  ! total sizes = cell-center normal flux + stagger-grid flux of send and receive
  integer, dimension(-1:1^D&) :: sizes_srl_send_total, sizes_srl_recv_total
 
  ! sizes of buffer arrays for center-grid variable for siblings and restrict
  integer, dimension(:), allocatable :: recvrequest_c_sr, sendrequest_c_sr
  integer, dimension(:,:), allocatable :: recvstatus_c_sr, sendstatus_c_sr
 
  ! sizes of buffer arrays for center-grid variable for prolongation
  integer, dimension(:), allocatable :: recvrequest_c_p, sendrequest_c_p
  integer, dimension(:,:), allocatable :: recvstatus_c_p, sendstatus_c_p
 
  ! sizes of buffer arrays for stagger-grid variable
  integer, dimension(^ND,-1:1^D&) :: sizes_srl_send_stg, sizes_srl_recv_stg
 
  integer, dimension(:), allocatable :: recvrequest_srl, sendrequest_srl
  integer, dimension(:,:), allocatable :: recvstatus_srl, sendstatus_srl
 
  ! buffer arrays for send and receive of siblings, allocate in build_connectivity
  double precision, dimension(:), allocatable :: recvbuffer_srl, sendbuffer_srl
 
  integer, dimension(:), allocatable :: recvrequest_r, sendrequest_r
  integer, dimension(:,:), allocatable :: recvstatus_r, sendstatus_r
 
  ! buffer arrays for send and receive in restriction
  double precision, dimension(:), allocatable :: recvbuffer_r, sendbuffer_r
 
  integer, dimension(:), allocatable :: recvrequest_p, sendrequest_p
  integer, dimension(:,:), allocatable :: recvstatus_p, sendstatus_p
 
  ! buffer arrays for send and receive in prolongation
  double precision, dimension(:), allocatable :: recvbuffer_p, sendbuffer_p
 
  ! sizes to allocate buffer arrays for send and receive for restriction
  integer, dimension(-1:1^D&)     :: sizes_r_send_total
  integer, dimension(0:3^D&)      :: sizes_r_recv_total
  integer, dimension(^ND,-1:1^D&) :: sizes_r_send_stg
  integer, dimension(^ND,0:3^D&)  :: sizes_r_recv_stg
 
  ! sizes to allocate buffer arrays for send and receive for restriction
  integer, dimension(0:3^D&)      :: sizes_p_send_total, sizes_p_recv_total
  integer, dimension(^ND,0:3^D&)  :: sizes_p_send_stg, sizes_p_recv_stg
 
  ! There are two variants, _f indicates that all flux variables are filled,
  ! whereas _p means that part of the variables is filled 
  ! Furthermore _r_ stands for restrict, _p_ for prolongation.
  integer, dimension(-1:1^D&), target :: type_send_srl_f, type_recv_srl_f
  integer, dimension(-1:1^D&), target :: type_send_r_f
  integer, dimension( 0:3^D&), target :: type_recv_r_f, type_send_p_f, type_recv_p_f
  integer, dimension(-1:1^D&), target :: type_send_srl_p1, type_recv_srl_p1
  integer, dimension(-1:1^D&), target :: type_send_r_p1
  integer, dimension( 0:3^D&), target :: type_recv_r_p1, type_send_p_p1, type_recv_p_p1
  integer, dimension(-1:1^D&), target :: type_send_srl_p2, type_recv_srl_p2
  integer, dimension(-1:1^D&), target :: type_send_r_p2
  integer, dimension( 0:3^D&), target :: type_recv_r_p2, type_send_p_p2, type_recv_p_p2
  integer, dimension(  :^D&), pointer :: type_send_srl, type_recv_srl, type_send_r
  integer, dimension(  :^D&), pointer :: type_recv_r, type_send_p, type_recv_p
 
  ! A switch of update physical boundary or not
  logical, public :: bcphys=.true.
  ! Special buffer for pole copy
  type wbuffer
    double precision, dimension(:^D&,:), allocatable :: w
  end type wbuffer
 
  abstract interface
    subroutine update_eos_bc_sub(ixI^L, ixO^L, w, x)
      use mod_global_parameters
      integer, intent(in)             :: ixI^L, ixO^L
      double precision, intent(inout) :: w(ixI^S, nw)
      double precision, intent(in)    :: x(ixI^S, 1:ndim)
    end subroutine update_eos_bc_sub
  end interface
 
  procedure(update_eos_bc_sub), pointer     :: update_eos_4_bc      => null()
 
contains
 
  subroutine init_bc()
    use mod_global_parameters
    use mod_physics, only: physics_type
    use mod_comm_lib, only: mpistop
 
    integer :: nghostcellsCo, interpolation_order
    integer :: nx^D, nxCo^D, ixG^L, i^D, idir
 
    ! Initialise all bc datatype handles to null so get_bc_comm_type can free the previous committed type
    ! before rebuilding. Without this, every create_bc_mpi_datatype leaks its MPI subarray types; the RT
    ! sweep rebuilds them each solve -> unbounded virtual-memory growth -> OOM/SIGKILL on long runs.
    type_send_srl_f=mpi_datatype_null; type_recv_srl_f=mpi_datatype_null
    type_send_r_f  =mpi_datatype_null; type_recv_r_f  =mpi_datatype_null
    type_send_p_f  =mpi_datatype_null; type_recv_p_f  =mpi_datatype_null
    type_send_srl_p1=mpi_datatype_null; type_recv_srl_p1=mpi_datatype_null
    type_send_r_p1 =mpi_datatype_null; type_recv_r_p1 =mpi_datatype_null
    type_send_p_p1 =mpi_datatype_null; type_recv_p_p1 =mpi_datatype_null
    type_send_srl_p2=mpi_datatype_null; type_recv_srl_p2=mpi_datatype_null
    type_send_r_p2 =mpi_datatype_null; type_recv_r_p2 =mpi_datatype_null
    type_send_p_p2 =mpi_datatype_null; type_recv_p_p2 =mpi_datatype_null
 
    ixg^l=ixg^ll;
    ixm^l=ixg^l^lsubnghostcells;
    ixcogmin^d=1;
    ixcogmax^d=(ixghi^d-2*nghostcells)/2+2*nghostcells;
    ixcogsmin^d=0;
    ixcogsmax^d=ixcogmax^d;
 
    ixcom^l=ixcog^l^lsubnghostcells;
 
    nx^d=ixmmax^d-ixmmin^d+1;
    nxco^d=nx^d/2;
 
    if(ghost_copy) then
       interpolation_order=1
    else
       interpolation_order=2
    end if
    nghostcellsco=int((nghostcells+1)/2)
    
    if (nghostcellsco+interpolation_order-1>nghostcells) then
       call mpistop("interpolation order for prolongation in getbc too high")
    end if
 
    ! i=-1 means subregion prepared for the neighbor at its minimum side 
    ! i= 1 means subregion prepared for the neighbor at its maximum side 
    {
    ixs_srl_min^d(-1)=ixmmin^d
    ixs_srl_min^d( 0)=ixmmin^d
    ixs_srl_min^d( 1)=ixmmax^d+1-nghostcells
    ixs_srl_max^d(-1)=ixmmin^d-1+nghostcells
    ixs_srl_max^d( 0)=ixmmax^d
    ixs_srl_max^d( 1)=ixmmax^d
     
    ixr_srl_min^d(-1)=1
    ixr_srl_min^d( 0)=ixmmin^d
    ixr_srl_min^d( 1)=ixmmax^d+1
    ixr_srl_max^d(-1)=nghostcells
    ixr_srl_max^d( 0)=ixmmax^d
    ixr_srl_max^d( 1)=ixgmax^d
    
    ixs_r_min^d(-1)=ixcommin^d
    ixs_r_min^d( 0)=ixcommin^d
    ixs_r_min^d( 1)=ixcommax^d+1-nghostcells
    ixs_r_max^d(-1)=ixcommin^d-1+nghostcells
    ixs_r_max^d( 0)=ixcommax^d
    ixs_r_max^d( 1)=ixcommax^d
    
    ixr_r_min^d(0)=1
    ixr_r_min^d(1)=ixmmin^d
    ixr_r_min^d(2)=ixmmin^d+nxco^d
    ixr_r_min^d(3)=ixmmax^d+1
    ixr_r_max^d(0)=nghostcells
    ixr_r_max^d(1)=ixmmin^d-1+nxco^d
    ixr_r_max^d(2)=ixmmax^d
    ixr_r_max^d(3)=ixgmax^d
 
    ixs_p_min^d(0)=ixmmin^d-(interpolation_order-1)
    ixs_p_min^d(1)=ixmmin^d-(interpolation_order-1)
    ixs_p_min^d(2)=ixmmin^d+nxco^d-nghostcellsco-(interpolation_order-1)
    ixs_p_min^d(3)=ixmmax^d+1-nghostcellsco-(interpolation_order-1)
    ixs_p_max^d(0)=ixmmin^d-1+nghostcellsco+(interpolation_order-1)
    ixs_p_max^d(1)=ixmmin^d-1+nxco^d+nghostcellsco+(interpolation_order-1)
    ixs_p_max^d(2)=ixmmax^d+(interpolation_order-1)
    ixs_p_max^d(3)=ixmmax^d+(interpolation_order-1)
 
    ixr_p_min^d(0)=ixcommin^d-nghostcellsco-(interpolation_order-1)
    ixr_p_min^d(1)=ixcommin^d-(interpolation_order-1)
    ixr_p_min^d(2)=ixcommin^d-nghostcellsco-(interpolation_order-1)
    ixr_p_min^d(3)=ixcommax^d+1-(interpolation_order-1)
    ixr_p_max^d(0)=nghostcells+(interpolation_order-1)
    ixr_p_max^d(1)=ixcommax^d+nghostcellsco+(interpolation_order-1)
    ixr_p_max^d(2)=ixcommax^d+(interpolation_order-1)
    ixr_p_max^d(3)=ixcommax^d+nghostcellsco+(interpolation_order-1)
 
    \}
 
    if (stagger_grid) then
      allocate(pole_buf%ws(ixgs^t,nws))
      ! Staggered (face-allocated) variables
      do idir=1,ndim
      { ixs_srl_stg_min^d(idir,-1)=ixmmin^d-kr(idir,^d)
        ixs_srl_stg_max^d(idir,-1)=ixmmin^d-1+nghostcells
        ixs_srl_stg_min^d(idir,0) =ixmmin^d-kr(idir,^d)
        ixs_srl_stg_max^d(idir,0) =ixmmax^d
        ixs_srl_stg_min^d(idir,1) =ixmmax^d-nghostcells+1-kr(idir,^d)
        ixs_srl_stg_max^d(idir,1) =ixmmax^d
        
        ixr_srl_stg_min^d(idir,-1)=1-kr(idir,^d)
        ixr_srl_stg_max^d(idir,-1)=nghostcells
        ixr_srl_stg_min^d(idir,0) =ixmmin^d-kr(idir,^d)
        ixr_srl_stg_max^d(idir,0) =ixmmax^d
        ixr_srl_stg_min^d(idir,1) =ixmmax^d+1-kr(idir,^d)
        ixr_srl_stg_max^d(idir,1) =ixgmax^d
 
        ixs_r_stg_min^d(idir,-1)=ixcommin^d-kr(idir,^d)
        ixs_r_stg_max^d(idir,-1)=ixcommin^d-1+nghostcells
        ixs_r_stg_min^d(idir,0) =ixcommin^d-kr(idir,^d)
        ixs_r_stg_max^d(idir,0) =ixcommax^d
        ixs_r_stg_min^d(idir,1) =ixcommax^d+1-nghostcells-kr(idir,^d)
        ixs_r_stg_max^d(idir,1) =ixcommax^d
 
        ixr_r_stg_min^d(idir,0)=1-kr(idir,^d)
        ixr_r_stg_max^d(idir,0)=nghostcells
        ixr_r_stg_min^d(idir,1)=ixmmin^d-kr(idir,^d)
        ixr_r_stg_max^d(idir,1)=ixmmin^d-1+nxco^d
        ixr_r_stg_min^d(idir,2)=ixmmin^d+nxco^d-kr(idir,^d)
        ixr_r_stg_max^d(idir,2)=ixmmax^d
        ixr_r_stg_min^d(idir,3)=ixmmax^d+1-kr(idir,^d)
        ixr_r_stg_max^d(idir,3)=ixgmax^d
        \}
       {if (idir==^d) then
          ! Parallel components
          {
          ixs_p_stg_min^d(idir,0)=ixmmin^d-1 ! -1 to make redundant 
          ixs_p_stg_max^d(idir,0)=ixmmin^d-1+nghostcellsco
          ixs_p_stg_min^d(idir,1)=ixmmin^d-1 ! -1 to make redundant 
          ixs_p_stg_max^d(idir,1)=ixmmin^d-1+nxco^d+nghostcellsco
          ixs_p_stg_min^d(idir,2)=ixmmax^d-nxco^d-nghostcellsco
          ixs_p_stg_max^d(idir,2)=ixmmax^d
          ixs_p_stg_min^d(idir,3)=ixmmax^d-nghostcellsco
          ixs_p_stg_max^d(idir,3)=ixmmax^d
 
          ixr_p_stg_min^d(idir,0)=ixcommin^d-1-nghostcellsco
          ixr_p_stg_max^d(idir,0)=ixcommin^d-1
          ixr_p_stg_min^d(idir,1)=ixcommin^d-1 ! -1 to make redundant 
          ixr_p_stg_max^d(idir,1)=ixcommax^d+nghostcellsco
          ixr_p_stg_min^d(idir,2)=ixcommin^d-1-nghostcellsco
          ixr_p_stg_max^d(idir,2)=ixcommax^d
          ixr_p_stg_min^d(idir,3)=ixcommax^d+1-1 ! -1 to make redundant 
          ixr_p_stg_max^d(idir,3)=ixcommax^d+nghostcellsco
          \}
        else
          {
          ! Perpendicular component
          ixs_p_stg_min^d(idir,0)=ixmmin^d
          ixs_p_stg_max^d(idir,0)=ixmmin^d-1+nghostcellsco+(interpolation_order-1)
          ixs_p_stg_min^d(idir,1)=ixmmin^d
          ixs_p_stg_max^d(idir,1)=ixmmin^d-1+nxco^d+nghostcellsco+(interpolation_order-1)
          ixs_p_stg_min^d(idir,2)=ixmmax^d+1-nxco^d-nghostcellsco-(interpolation_order-1)
          ixs_p_stg_max^d(idir,2)=ixmmax^d
          ixs_p_stg_min^d(idir,3)=ixmmax^d+1-nghostcellsco-(interpolation_order-1)
          ixs_p_stg_max^d(idir,3)=ixmmax^d
 
          ixr_p_stg_min^d(idir,0)=ixcommin^d-nghostcellsco-(interpolation_order-1)
          ixr_p_stg_max^d(idir,0)=ixcommin^d-1
          ixr_p_stg_min^d(idir,1)=ixcommin^d
          ixr_p_stg_max^d(idir,1)=ixcommax^d+nghostcellsco+(interpolation_order-1)
          ixr_p_stg_min^d(idir,2)=ixcommin^d-nghostcellsco-(interpolation_order-1)
          ixr_p_stg_max^d(idir,2)=ixcommax^d
          ixr_p_stg_min^d(idir,3)=ixcommax^d+1
          ixr_p_stg_max^d(idir,3)=ixcommax^d+nghostcellsco+(interpolation_order-1)
          \}
        end if
        }
      end do
      ! calculate sizes for buffer arrays for siblings
      {do i^db=-1,1\}
         ! Staggered (face-allocated) variables
         do idir=1,ndim
           sizes_srl_send_stg(idir,i^d)={(ixs_srl_stg_max^d(idir,i^d)-ixs_srl_stg_min^d(idir,i^d)+1)|*}
           sizes_srl_recv_stg(idir,i^d)={(ixr_srl_stg_max^d(idir,i^d)-ixr_srl_stg_min^d(idir,i^d)+1)|*}
           sizes_r_send_stg(idir,i^d)={(ixs_r_stg_max^d(idir,i^d)-ixs_r_stg_min^d(idir,i^d)+1)|*}
         end do
         sizes_srl_send_total(i^d)=sum(sizes_srl_send_stg(:,i^d))
         sizes_srl_recv_total(i^d)=sum(sizes_srl_recv_stg(:,i^d))
         sizes_r_send_total(i^d)=sum(sizes_r_send_stg(:,i^d))
      {end do\}
 
      {do i^db=0,3\}
         ! Staggered (face-allocated) variables
           do idir=1,ndim
             sizes_r_recv_stg(idir,i^d)={(ixr_r_stg_max^d(idir,i^d)-ixr_r_stg_min^d(idir,i^d)+1)|*}
             sizes_p_send_stg(idir,i^d)={(ixs_p_stg_max^d(idir,i^d)-ixs_p_stg_min^d(idir,i^d)+1)|*}
             sizes_p_recv_stg(idir,i^d)={(ixr_p_stg_max^d(idir,i^d)-ixr_p_stg_min^d(idir,i^d)+1)|*}
           end do
           sizes_r_recv_total(i^d)=sum(sizes_r_recv_stg(:,i^d))
           sizes_p_send_total(i^d)=sum(sizes_p_send_stg(:,i^d))
           sizes_p_recv_total(i^d)=sum(sizes_p_recv_stg(:,i^d))
      {end do\}
    end if
 
  end subroutine init_bc
 
  subroutine create_bc_mpi_datatype(nwstart,nwbc,nwfull)
    use mod_global_parameters
 
    integer, intent(in) :: nwstart, nwbc
    !> stride of the target state (its last-dim size); defaults to global nw. See get_bc_comm_type.
    integer, intent(in), optional :: nwfull
    integer :: i^D, ic^D, inc^D
    integer :: errh_w, errh_s
 
    ! get_bc_comm_type frees the previous committed type before rebuilding (else the RT sweep, which
    ! rebuilds these every solve, leaks MPI subarray types -> unbounded virtual memory -> OOM). Some
    ! degenerate restrict/prolong handles reject MPI_TYPE_FREE on this MPI, so make the free best-effort:
    ! set the error handler to return for the rebuild, so a failed free is ignored (that one type leaks,
    ! minor) while all valid frees succeed; a successful create always overwrites the handle. Restore after.
    call mpi_comm_get_errhandler(mpi_comm_world, errh_w, ierrmpi)
    call mpi_comm_get_errhandler(mpi_comm_self,  errh_s, ierrmpi)
    call mpi_comm_set_errhandler(mpi_comm_world, mpi_errors_return, ierrmpi)
    call mpi_comm_set_errhandler(mpi_comm_self,  mpi_errors_return, ierrmpi)
 
   {do i^db=-1,1\}
      if(i^d==0|.and.) cycle
      call get_bc_comm_type(type_send_srl(i^d),ixs_srl_^l(i^d),ixg^ll,nwstart,nwbc,nwfull)
      call get_bc_comm_type(type_recv_srl(i^d),ixr_srl_^l(i^d),ixg^ll,nwstart,nwbc,nwfull)
      call get_bc_comm_type(type_send_r(i^d),   ixs_r_^l(i^d),ixcog^l,nwstart,nwbc,nwfull)
      {do ic^db=1+int((1-i^db)/2),2-int((1+i^db)/2)
         inc^db=2*i^db+ic^db\}
         call get_bc_comm_type(type_recv_r(inc^d),ixr_r_^l(inc^d), ixg^ll,nwstart,nwbc,nwfull)
         call get_bc_comm_type(type_send_p(inc^d),ixs_p_^l(inc^d), ixg^ll,nwstart,nwbc,nwfull)
         call get_bc_comm_type(type_recv_p(inc^d),ixr_p_^l(inc^d),ixcog^l,nwstart,nwbc,nwfull)
      {end do\}
   {end do\}
 
    call mpi_comm_set_errhandler(mpi_comm_world, errh_w, ierrmpi)   ! restore fatal handlers
    call mpi_comm_set_errhandler(mpi_comm_self,  errh_s, ierrmpi)
 
  end subroutine create_bc_mpi_datatype
 
  subroutine get_bc_comm_type(comm_type,ix^L,ixG^L,nwstart,nwbc,nwfull)
    use mod_global_parameters
 
    integer, intent(inout) :: comm_type
    integer, intent(in) :: ix^L, ixG^L, nwstart, nwbc
    !> total number of w-variables in the target state's last dimension (its stride). Defaults to the
    !> global nw (the hydro state). Pass the actual nw of a separate state (e.g. the RT intensity state,
    !> nw=nisw) so the MPI subarray stride matches that array's layout.
    integer, intent(in), optional :: nwfull
 
    integer, dimension(ndim+1) :: fullsize, subsize, start
 
    ^d&fullsize(^d)=ixgmax^d;
    fullsize(ndim+1)=nw
    if(present(nwfull)) fullsize(ndim+1)=nwfull
    ^d&subsize(^d)=ixmax^d-ixmin^d+1;
    subsize(ndim+1)=nwbc
    ^d&start(^d)=ixmin^d-1;
    start(ndim+1)=nwstart-1
    
    if(comm_type/=mpi_datatype_null) call mpi_type_free(comm_type,ierrmpi)   ! free the previous type (no leak)
    call mpi_type_create_subarray(ndim+1,fullsize,subsize,start,mpi_order_fortran, &
                                  mpi_double_precision,comm_type,ierrmpi)
    call mpi_type_commit(comm_type,ierrmpi)
 
  end subroutine get_bc_comm_type
 
  !> do update ghost cells of all blocks including physical boundaries
  subroutine getbc(time,qdt,psb,nwstart,nwbc)
    use mod_global_parameters
    use mod_physics
    use mod_usr_methods, only: usr_prepare_boundary
    use mod_coarsen, only: coarsen_grid
    use mod_boundary_conditions, only: getintbc, bc_phys
    use mod_comm_lib, only: mpistop
 
    double precision, intent(in)      :: time, qdt
    type(state), target               :: psb(max_blocks)
    integer, intent(in)               :: nwstart ! Fill from nwstart
    integer, intent(in)               :: nwbc    ! Number of variables to fill
 
    double precision :: time_bcin
    integer :: nwhead, nwtail
    integer :: iigrid, igrid, isizes, i^D
    integer :: isend_buf(npwbuf), ipwbuf, nghostcellsco
    integer :: flushed_send_c, flushed_send_srl, flushed_send_r, flushed_send_p
    ! index pointer for buffer arrays as a start for a segment
    integer :: ibuf_start, ibuf_next
    ! shapes of reshape
    integer, dimension(1) :: shapes
    type(wbuffer) :: pwbuf(npwbuf)
 
    time_bcin=mpi_wtime()
 
    nwhead=nwstart
    nwtail=nwstart+nwbc-1
 
    ! fill internal physical boundary
    if (internalboundary) then 
       call getintbc(time,qdt,ixg^ll)
    end if
 
    ! prepare coarse values to send to coarser neighbors
    !$OMP PARALLEL DO SCHEDULE(dynamic) PRIVATE(igrid)
    do iigrid=1,igridstail; igrid=igrids(iigrid);
      if(any(neighbor_type(:^d&,igrid)==neighbor_coarse)) then
        call coarsen_grid(psb(igrid),ixg^ll,ixm^l,psc(igrid),ixcog^l,ixcom^l)
      end if
    end do
    !$OMP END PARALLEL DO
 
    ! default : no singular axis
    irecv_c=0
    isend_c=0
    flushed_send_c=0
    flushed_send_srl=0
    flushed_send_r=0
    flushed_send_p=0
    isend_buf=0
    ipwbuf=1
 
    if(stagger_grid) then
      ibuf_recv_srl=1
      ibuf_recv_r=1
      ibuf_recv_p=1
      ibuf_send_srl=1
      ibuf_send_r=1
      ibuf_send_p=1
      irecv_srl=0
      irecv_r=0
      irecv_p=0
      isend_srl=0
      isend_r=0
      isend_p=0
    end if
 
    !$OMP PARALLEL SECTIONS PRIVATE(iigrid,igrid,i^D)
    !$OMP SECTION
    ! MPI receive ghost-cell values from sibling blocks and finer neighbors in different processors
    do iigrid=1,igridstail; igrid=igrids(iigrid);
      {do i^db=-1,1\}
         if (skip_direction([ i^d ])) cycle
         select case (neighbor_type(i^d,igrid))
         case (neighbor_sibling)
            call bc_recv_srl(igrid,i^d)
         case (neighbor_fine)
            call bc_recv_restrict(igrid,i^d)
         end select
      {end do\}
    end do
 
    ! MPI send ghost-cell values to sibling blocks and coarser neighbors in different processors
    do iigrid=1,igridstail; igrid=igrids(iigrid);
      {do i^db=-1,1\}
         if(skip_direction([ i^d ])) cycle
         select case (neighbor_type(i^d,igrid))
         case (neighbor_sibling)
            call bc_send_srl(igrid,i^d)
         case (neighbor_coarse)
            call bc_send_restrict(igrid,i^d)
         end select
      {end do\}
    end do
 
    call waitall_limited(irecv_c,recvrequest_c_sr,recvstatus_c_sr)
    call waitall_pending(isend_c,flushed_send_c,sendrequest_c_sr,sendstatus_c_sr)
    if(stagger_grid) then
      call waitall_limited(nrecv_bc_srl,recvrequest_srl,recvstatus_srl)
      call waitall_pending(nsend_bc_srl,flushed_send_srl,sendrequest_srl,sendstatus_srl)
      call waitall_limited(nrecv_bc_r,recvrequest_r,recvstatus_r)
      call waitall_pending(nsend_bc_r,flushed_send_r,sendrequest_r,sendstatus_r)
    end if
 
    do ipwbuf=1,npwbuf
       if (isend_buf(ipwbuf)/=0) deallocate(pwbuf(ipwbuf)%w)
    end do
    !$OMP SECTION
    ! fill ghost-cell values of sibling blocks and coarser neighbors in the same processor
    do iigrid=1,igridstail; igrid=igrids(iigrid);
      {do i^db=-1,1\}
        if(skip_direction([ i^d ])) cycle
         select case (neighbor_type(i^d,igrid))
         case(neighbor_sibling)
           call bc_fill_srl(igrid,i^d)
         case(neighbor_coarse)
           call bc_fill_restrict(igrid,i^d)
         end select
      {end do\}
    end do
    !$OMP END PARALLEL SECTIONS
 
    if(stagger_grid) then
      ! unpack the received data from sibling blocks and finer neighbors to fill ghost-cell staggered values
      ibuf_recv_srl=1
      ibuf_recv_r=1
      do iigrid=1,igridstail; igrid=igrids(iigrid);
       {do i^db=-1,1\}
          if (skip_direction([ i^d ])) cycle
          select case (neighbor_type(i^d,igrid))
          case (neighbor_sibling)
             call bc_fill_srl_stg(igrid,i^d)
          case (neighbor_fine)
             call bc_fill_restrict_stg(igrid,i^d)
          end select
       {end do\}
      end do
    end if
 
    irecv_c=0
    isend_c=0
    flushed_send_c=0
    flushed_send_p=0
    isend_buf=0
    ipwbuf=1
 
    !$OMP PARALLEL SECTIONS PRIVATE(iigrid,igrid,i^D)
    !$OMP SECTION
    ! MPI receive ghost-cell values from coarser neighbors in different processors
    do iigrid=1,igridstail; igrid=igrids(iigrid);
      {do i^db=-1,1\}
         if (skip_direction([ i^d ])) cycle
         if (neighbor_type(i^d,igrid)==neighbor_coarse) call bc_recv_prolong(igrid,i^d)
      {end do\}
    end do
    ! MPI send ghost-cell values to finer neighbors in different processors
    do iigrid=1,igridstail; igrid=igrids(iigrid);
      {do i^db=-1,1\}
         if (skip_direction([ i^d ])) cycle
         if (neighbor_type(i^d,igrid)==neighbor_fine) call bc_send_prolong(igrid,i^d)
      {end do\}
    end do
 
    call waitall_limited(irecv_c,recvrequest_c_p,recvstatus_c_p)
    call waitall_pending(isend_c,flushed_send_c,sendrequest_c_p,sendstatus_c_p)
 
    if(stagger_grid) then
      call waitall_limited(nrecv_bc_p,recvrequest_p,recvstatus_p)
      call waitall_pending(nsend_bc_p,flushed_send_p,sendrequest_p,sendstatus_p)
    end if
 
    do ipwbuf=1,npwbuf
       if (isend_buf(ipwbuf)/=0) deallocate(pwbuf(ipwbuf)%w)
    end do
 
    !$OMP SECTION
    ! fill coarse ghost-cell values of finer neighbors in the same processor
    do iigrid=1,igridstail; igrid=igrids(iigrid);
      {do i^db=-1,1\}
         if (skip_direction([ i^d ])) cycle
         if (neighbor_type(i^d,igrid)==neighbor_fine) call bc_fill_prolong(igrid,i^d)
      {end do\}
    end do
    !$OMP END PARALLEL SECTIONS
 
    if(stagger_grid) then
      ! fill coarser representative ghost cells after receipt
      ibuf_recv_p=1
      do iigrid=1,igridstail; igrid=igrids(iigrid);
        {do i^db=-1,1\}
           if (skip_direction([ i^d ])) cycle
           if(neighbor_type(i^d,igrid)==neighbor_coarse) call bc_fill_prolong_stg(igrid,i^d)
        {end do\}
      end do
    end if
    ! do prolongation on the ghost-cell values based on the received coarse values from coarser neighbors
    !$OMP PARALLEL DO SCHEDULE(dynamic) PRIVATE(igrid)
    do iigrid=1,igridstail; igrid=igrids(iigrid);
      call gc_prolong(igrid)
    end do
    !$OMP END PARALLEL DO
 
    ! fill physical boundary ghost cells after internal ghost-cell values exchange
    if(bcphys) then
      if(associated(usr_prepare_boundary)) then
        call usr_prepare_boundary(time, qdt)
      endif
      !$OMP PARALLEL DO SCHEDULE(dynamic) PRIVATE(igrid)
      do iigrid=1,igridstail; igrid=igrids(iigrid);
        if(.not.phyboundblock(igrid)) cycle
        call fill_boundary_after_gc(igrid)
      end do
      !$OMP END PARALLEL DO
    end if
 
     ! modify normal component of magnetic field to fix divB=0 
    if(bcphys.and.associated(phys_boundary_adjust)) then
      !$OMP PARALLEL DO SCHEDULE(dynamic) PRIVATE(igrid)
      do iigrid=1,igridstail; igrid=igrids(iigrid);
        if(.not.phyboundblock(igrid)) cycle
        call phys_boundary_adjust(igrid,psb)
      end do
      !$OMP END PARALLEL DO
    end if
 
    time_bc=time_bc+(mpi_wtime()-time_bcin)
 
    contains
 
      subroutine waitall_limited(nrequest,requests,statuses)
        integer, intent(in) :: nrequest
        integer, intent(inout) :: requests(:)
        integer, intent(inout) :: statuses(:,:)
 
        if (ghostcell_comm_batched) then
          call waitall_range(1,nrequest,requests,statuses)
        else
          call mpi_waitall(nrequest,requests,statuses,ierrmpi)
        end if
      end subroutine waitall_limited
 
      subroutine waitall_range(ifirst,ilast,requests,statuses)
        integer, intent(in) :: ifirst, ilast
        integer, intent(inout) :: requests(:)
        integer, intent(inout) :: statuses(:,:)
 
        integer :: irequest,nwait
 
        do irequest=ifirst,ilast,ghostcell_comm_batch_size
          nwait=min(ghostcell_comm_batch_size,ilast-irequest+1)
          call mpi_waitall(nwait,requests(irequest:irequest+nwait-1),&
                           statuses(:,irequest:irequest+nwait-1),ierrmpi)
        end do
      end subroutine waitall_range
 
      subroutine waitall_pending(nrequest,nwaited,requests,statuses)
        integer, intent(in) :: nrequest
        integer, intent(inout) :: nwaited
        integer, intent(inout) :: requests(:)
        integer, intent(inout) :: statuses(:,:)
 
        if (nrequest>nwaited) then
          if (ghostcell_comm_batched) then
            call waitall_range(nwaited+1,nrequest,requests,statuses)
          else
            call mpi_waitall(nrequest-nwaited,requests(nwaited+1:nrequest),&
                             statuses(:,nwaited+1:nrequest),ierrmpi)
          end if
          nwaited=nrequest
        end if
      end subroutine waitall_pending
 
      subroutine wait_send_batch(nrequest,nwaited,requests,statuses)
        integer, intent(in) :: nrequest
        integer, intent(inout) :: nwaited
        integer, intent(inout) :: requests(:)
        integer, intent(inout) :: statuses(:,:)
 
        if (ghostcell_comm_batched .and. &
            nrequest-nwaited >= ghostcell_comm_batch_size) then
          call waitall_range(nwaited+1,nrequest,requests,statuses)
          nwaited=nrequest
        end if
      end subroutine wait_send_batch
 
      logical function skip_direction(dir)
        integer, intent(in) :: dir(^ND)
 
        if (all(dir == 0)) then
           skip_direction = .true.
        else
           skip_direction = .false.
        end if
      end function skip_direction
 
      !> Physical boundary conditions
      subroutine fill_boundary_after_gc(igrid)
 
        integer, intent(in) :: igrid
 
        integer :: idims,iside,i^D,k^L,ixB^L,ixO^L
        logical :: has_eos_bc
 
        !> Query the hook once: gfortran resolves the symbol as a procedure after the
        !> first call statement and then rejects associated() on it later in the scope.
        has_eos_bc = associated(update_eos_4_bc)
        block=>psb(igrid)
        ^d&dxlevel(^d)=rnode(rpdx^d_,igrid);
        do idims=1,ndim
          ! to avoid using as yet unknown corner info in more than 1D, we
          ! fill only interior mesh ranges of the ghost cell ranges at first,
          ! and progressively enlarge the ranges to include corners later
          kmin1=0; kmax1=0;
          {^iftwod
           kmin2=merge(1, 0,  idims .lt. 2 .and. neighbor_type(0,-1,igrid)==1)
           kmax2=merge(1, 0,  idims .lt. 2 .and. neighbor_type(0, 1,igrid)==1)}
          {^ifthreed
           kmin2=merge(1, 0, idims .lt. 2 .and. neighbor_type(0,-1,0,igrid)==1)
           kmax2=merge(1, 0, idims .lt. 2 .and. neighbor_type(0, 1,0,igrid)==1)
           kmin3=merge(1, 0, idims .lt. 3 .and. neighbor_type(0,0,-1,igrid)==1)
           kmax3=merge(1, 0, idims .lt. 3 .and. neighbor_type(0,0, 1,igrid)==1)}
          ixbmin^d=ixglo^d+kmin^d*nghostcells;
          ixbmax^d=ixghi^d-kmax^d*nghostcells;
          do iside=1,2
            i^d=kr(^d,idims)*(2*iside-3);
            if (aperiodb(idims)) then 
              if (neighbor_type(i^d,igrid) /= neighbor_boundary .and. &
                 .not. psb(igrid)%is_physical_boundary(2*idims-2+iside)) cycle
            else 
              if (neighbor_type(i^d,igrid) /= neighbor_boundary) cycle
            end if
            !> Refresh the EoS-derived ghost fields before extrapolation; the hook
            !> is set (in amrvac.t) only when the EoS needs it, e.g. LTE.
            !> ixM (interior) is deliberate: bc_phys extrapolates outward from interior
            !> values, so it is the interior that must be current here. Ghost cells are
            !> covered afterwards, for every block, at the end of getbc.
            if (has_eos_bc) &
               call update_eos_4_bc(ixg^ll,ixm^ll,psb(igrid)%w,psb(igrid)%x)
            call bc_phys(iside,idims,time,qdt,psb(igrid),ixg^ll,ixb^l)
            !> ...and derive them again on the cells bc_phys just wrote. The call above
            !> refreshes the interior so bc_phys can extrapolate outward from current values;
            !> it does not touch the ghosts bc_phys produces. Those are never reached by the
            !> exchange either (physical boundaries have no neighbour to receive from), so
            !> without this they keep whatever the block held before. ixO is the same ghost
            !> strip bc_phys derives internally from ixB -- nghostcells deep, this side only.
            if (has_eos_bc) then
              select case (idims)
              {case (^d)
                if (iside==2) then
                  ixomin^dd=ixbmax^d+1-nghostcells^d%ixOmin^dd=ixbmin^dd;
                  ixomax^dd=ixbmax^dd;
                else
                  ixomin^dd=ixbmin^dd;
                  ixomax^dd=ixbmin^d-1+nghostcells^d%ixOmax^dd=ixbmax^dd;
                end if \}
              end select
              call update_eos_4_bc(ixg^ll,ixo^l,psb(igrid)%w,psb(igrid)%x)
            end if
          end do
        end do
 
      end subroutine fill_boundary_after_gc
 
      !> MPI receive from sibling at same refinement level
      subroutine bc_recv_srl(igrid,i^D)
        integer, intent(in) :: igrid,i^D
 
        integer :: ipe_neighbor
 
        ipe_neighbor=neighbor(2,i^d,igrid)
        if (ipe_neighbor/=mype) then
           irecv_c=irecv_c+1
           itag=(3**^nd+4**^nd)*(igrid-1)+{(i^d+1)*3**(^d-1)+}
           call mpi_irecv(psb(igrid)%w,1,type_recv_srl(i^d), &
                          ipe_neighbor,itag,icomm,recvrequest_c_sr(irecv_c),ierrmpi)
           if(stagger_grid) then
             irecv_srl=irecv_srl+1
             call mpi_irecv(recvbuffer_srl(ibuf_recv_srl),sizes_srl_recv_total(i^d),mpi_double_precision, &
                            ipe_neighbor,itag,icomm,recvrequest_srl(irecv_srl),ierrmpi)
             ibuf_recv_srl=ibuf_recv_srl+sizes_srl_recv_total(i^d)
           end if
        end if
 
      end subroutine bc_recv_srl
 
      !> MPI receive from fine neighbor
      subroutine bc_recv_restrict(igrid,i^D)
        integer, intent(in) :: igrid,i^D
 
        integer :: ic^D,inc^D,ipe_neighbor
 
        {do ic^db=1+int((1-i^db)/2),2-int((1+i^db)/2)
           inc^db=2*i^db+ic^db\}
           ipe_neighbor=neighbor_child(2,inc^d,igrid)
           if (ipe_neighbor/=mype) then
              irecv_c=irecv_c+1
              itag=(3**^nd+4**^nd)*(igrid-1)+3**^nd+{inc^d*4**(^d-1)+}
              call mpi_irecv(psb(igrid)%w,1,type_recv_r(inc^d), &
                             ipe_neighbor,itag,icomm,recvrequest_c_sr(irecv_c),ierrmpi)
              if(stagger_grid) then
                irecv_r=irecv_r+1
                call mpi_irecv(recvbuffer_r(ibuf_recv_r),sizes_r_recv_total(inc^d), &
                               mpi_double_precision,ipe_neighbor,itag, &
                               icomm,recvrequest_r(irecv_r),ierrmpi)
                ibuf_recv_r=ibuf_recv_r+sizes_r_recv_total(inc^d)
              end if
           end if
        {end do\}
 
      end subroutine bc_recv_restrict
 
      !> MPI send to sibling at same refinement level
      subroutine bc_send_srl(igrid,i^D)
        integer, intent(in) :: igrid,i^D
 
        integer :: n_i^D,ipole,idir,ineighbor,ipe_neighbor,ixS^L
 
        ipe_neighbor=neighbor(2,i^d,igrid)
        if(ipe_neighbor/=mype) then
          ineighbor=neighbor(1,i^d,igrid)
          ipole=neighbor_pole(i^d,igrid)
          if(ipole==0) then
            n_i^d=-i^d;
            isend_c=isend_c+1
            itag=(3**^nd+4**^nd)*(ineighbor-1)+{(n_i^d+1)*3**(^d-1)+}
            call mpi_isend(psb(igrid)%w,1,type_send_srl(i^d), &
                           ipe_neighbor,itag,icomm,sendrequest_c_sr(isend_c),ierrmpi)
            call wait_send_batch(isend_c,flushed_send_c,sendrequest_c_sr,sendstatus_c_sr)
            if(stagger_grid) then
              ibuf_start=ibuf_send_srl
              do idir=1,ndim
                ixs^l=ixs_srl_stg_^l(idir,i^d);
                ibuf_next=ibuf_start+sizes_srl_send_stg(idir,i^d)
                shapes=(/sizes_srl_send_stg(idir,i^d)/)
                sendbuffer_srl(ibuf_start:ibuf_next-1)=&
                  reshape(psb(igrid)%ws(ixs^s,idir),shapes)
                ibuf_start=ibuf_next
              end do
              isend_srl=isend_srl+1
              call mpi_isend(sendbuffer_srl(ibuf_send_srl),sizes_srl_send_total(i^d),&
                mpi_double_precision, ipe_neighbor,itag,icomm,sendrequest_srl(isend_srl),ierrmpi)
              call wait_send_batch(isend_srl,flushed_send_srl,sendrequest_srl,sendstatus_srl)
              ibuf_send_srl=ibuf_next
            end if
          else
            ixs^l=ixs_srl_^l(i^d);
            select case (ipole)
            {case (^d)
               n_i^d=i^d^d%n_i^dd=-i^dd;\}
            end select
            if (isend_buf(ipwbuf)/=0) then
               call mpi_wait(sendrequest_c_sr(isend_buf(ipwbuf)), &
                             sendstatus_c_sr(:,isend_buf(ipwbuf)),ierrmpi)
               deallocate(pwbuf(ipwbuf)%w)
            end if
            allocate(pwbuf(ipwbuf)%w(ixs^s,nwhead:nwtail))
            call pole_buffer(pwbuf(ipwbuf)%w,ixs^l,ixs^l,psb(igrid)%w,ixg^ll,ixs^l,ipole)
            isend_c=isend_c+1
            isend_buf(ipwbuf)=isend_c
            itag=(3**^nd+4**^nd)*(ineighbor-1)+{(n_i^d+1)*3**(^d-1)+}
            isizes={(ixsmax^d-ixsmin^d+1)*}*nwbc
            call mpi_isend(pwbuf(ipwbuf)%w,isizes,mpi_double_precision, &
                           ipe_neighbor,itag,icomm,sendrequest_c_sr(isend_c),ierrmpi)
            call wait_send_batch(isend_c,flushed_send_c,sendrequest_c_sr,sendstatus_c_sr)
            ipwbuf=1+modulo(ipwbuf,npwbuf)
            if(stagger_grid) then
              ibuf_start=ibuf_send_srl
              do idir=1,ndim
                ixs^l=ixs_srl_stg_^l(idir,i^d);
                ibuf_next=ibuf_start+sizes_srl_send_stg(idir,i^d)
                shapes=(/sizes_srl_send_stg(idir,i^d)/)
                sendbuffer_srl(ibuf_start:ibuf_next-1)=&
                  reshape(psb(igrid)%ws(ixs^s,idir),shapes)
                ibuf_start=ibuf_next
              end do
              isend_srl=isend_srl+1
              call mpi_isend(sendbuffer_srl(ibuf_send_srl),sizes_srl_send_total(i^d),&
                mpi_double_precision, ipe_neighbor,itag,icomm,sendrequest_srl(isend_srl),ierrmpi)
              call wait_send_batch(isend_srl,flushed_send_srl,sendrequest_srl,sendstatus_srl)
              ibuf_send_srl=ibuf_next
            end if
          end if
        end if
 
      end subroutine bc_send_srl
 
      !> MPI send to coarser neighbor's ghost cells
      subroutine bc_send_restrict(igrid,i^D)
        integer, intent(in) :: igrid,i^D
 
        integer :: ic^D,n_inc^D,ipole,idir,ineighbor,ipe_neighbor,ixS^L
 
        ipe_neighbor=neighbor(2,i^d,igrid)
        if(ipe_neighbor/=mype) then
          ic^d=1+modulo(node(pig^d_,igrid)-1,2);
          if({.not.(i^d==0.or.i^d==2*ic^d-3)|.or.}) return
          ineighbor=neighbor(1,i^d,igrid)
          ipole=neighbor_pole(i^d,igrid)
          if(ipole==0) then
            n_inc^d=-2*i^d+ic^d;
            isend_c=isend_c+1
            itag=(3**^nd+4**^nd)*(ineighbor-1)+3**^nd+{n_inc^d*4**(^d-1)+}
            call mpi_isend(psc(igrid)%w,1,type_send_r(i^d), &
                           ipe_neighbor,itag,icomm,sendrequest_c_sr(isend_c),ierrmpi)
            call wait_send_batch(isend_c,flushed_send_c,sendrequest_c_sr,sendstatus_c_sr)
            if(stagger_grid) then 
              ibuf_start=ibuf_send_r
              do idir=1,ndim
                ixs^l=ixs_r_stg_^l(idir,i^d);
                ibuf_next=ibuf_start+sizes_r_send_stg(idir,i^d)
                shapes=(/sizes_r_send_stg(idir,i^d)/)
                sendbuffer_r(ibuf_start:ibuf_next-1)=&
                  reshape(psc(igrid)%ws(ixs^s,idir),shapes)
                ibuf_start=ibuf_next
              end do
              isend_r=isend_r+1
              call mpi_isend(sendbuffer_r(ibuf_send_r),sizes_r_send_total(i^d),&
                             mpi_double_precision,ipe_neighbor,itag, &
                             icomm,sendrequest_r(isend_r),ierrmpi)
              call wait_send_batch(isend_r,flushed_send_r,sendrequest_r,sendstatus_r)
              ibuf_send_r=ibuf_next
            end if
          else
            ixs^l=ixs_r_^l(i^d);
            select case (ipole)
            {case (^d)
               n_inc^d=2*i^d+(3-ic^d)^d%n_inc^dd=-2*i^dd+ic^dd;\}
            end select
            if(isend_buf(ipwbuf)/=0) then
              call mpi_wait(sendrequest_c_sr(isend_buf(ipwbuf)), &
                            sendstatus_c_sr(:,isend_buf(ipwbuf)),ierrmpi)
              deallocate(pwbuf(ipwbuf)%w)
            end if
            allocate(pwbuf(ipwbuf)%w(ixs^s,nwhead:nwtail))
            call pole_buffer(pwbuf(ipwbuf)%w,ixs^l,ixs^l,psc(igrid)%w,ixcog^l,ixs^l,ipole)
            isend_c=isend_c+1
            isend_buf(ipwbuf)=isend_c
            itag=(3**^nd+4**^nd)*(ineighbor-1)+3**^nd+{n_inc^d*4**(^d-1)+}
            isizes={(ixsmax^d-ixsmin^d+1)*}*nwbc
            call mpi_isend(pwbuf(ipwbuf)%w,isizes,mpi_double_precision, &
                           ipe_neighbor,itag,icomm,sendrequest_c_sr(isend_c),ierrmpi)
            call wait_send_batch(isend_c,flushed_send_c,sendrequest_c_sr,sendstatus_c_sr)
            ipwbuf=1+modulo(ipwbuf,npwbuf)
            if(stagger_grid) then 
              ibuf_start=ibuf_send_r
              do idir=1,ndim
                ixs^l=ixs_r_stg_^l(idir,i^d);
                ibuf_next=ibuf_start+sizes_r_send_stg(idir,i^d)
                shapes=(/sizes_r_send_stg(idir,i^d)/)
                sendbuffer_r(ibuf_start:ibuf_next-1)=&
                  reshape(psc(igrid)%ws(ixs^s,idir),shapes)
                ibuf_start=ibuf_next
              end do
              isend_r=isend_r+1
              call mpi_isend(sendbuffer_r(ibuf_send_r),sizes_r_send_total(i^d),&
                             mpi_double_precision,ipe_neighbor,itag, &
                             icomm,sendrequest_r(isend_r),ierrmpi)
              call wait_send_batch(isend_r,flushed_send_r,sendrequest_r,sendstatus_r)
              ibuf_send_r=ibuf_next
            end if
          end if
        end if
 
      end subroutine bc_send_restrict
 
      !> fill same-level neighbor's ghost cells in the same processor
      subroutine bc_fill_srl(igrid,i^D)
        integer, intent(in) :: igrid,i^D
 
        integer :: ineighbor,ipe_neighbor,ipole,ixS^L,ixR^L,n_i^D,idir
 
        ipe_neighbor=neighbor(2,i^d,igrid)
        if(ipe_neighbor==mype) then
          ineighbor=neighbor(1,i^d,igrid)
          ipole=neighbor_pole(i^d,igrid)
          if(ipole==0) then
            n_i^d=-i^d;
            ixs^l=ixs_srl_^l(i^d);
            ixr^l=ixr_srl_^l(n_i^d);
            psb(ineighbor)%w(ixr^s,nwhead:nwtail)=&
                psb(igrid)%w(ixs^s,nwhead:nwtail)
            if(stagger_grid) then
              do idir=1,ndim
                ixs^l=ixs_srl_stg_^l(idir,i^d);
                ixr^l=ixr_srl_stg_^l(idir,n_i^d);
                psb(ineighbor)%ws(ixr^s,idir)=psb(igrid)%ws(ixs^s,idir)
              end do
            end if
          else
            ixs^l=ixs_srl_^l(i^d);
            select case (ipole)
            {case (^d)
              n_i^d=i^d^d%n_i^dd=-i^dd;\}
            end select
            ixr^l=ixr_srl_^l(n_i^d);
            call pole_copy(psb(ineighbor)%w,ixg^ll,ixr^l,psb(igrid)%w,ixg^ll,ixs^l,ipole)
            if(stagger_grid) then
              do idir=1,ndim
                ixs^l=ixs_srl_stg_^l(idir,i^d);
                ixr^l=ixr_srl_stg_^l(idir,n_i^d);
                call pole_copy_stg(psb(ineighbor)%ws,ixgs^ll,ixr^l,psb(igrid)%ws,ixgs^ll,ixs^l,idir,ipole)
              end do
            end if
          end if
        end if
 
      end subroutine bc_fill_srl
 
      !> fill coarser neighbor's ghost cells in the same processor
      subroutine bc_fill_restrict(igrid,i^D)
        integer, intent(in) :: igrid,i^D
 
        integer :: ic^D,n_inc^D,ixS^L,ixR^L,ipe_neighbor,ineighbor,ipole,idir
 
        ipe_neighbor=neighbor(2,i^d,igrid)
        if(ipe_neighbor==mype) then
          ic^d=1+modulo(node(pig^d_,igrid)-1,2);
          if({.not.(i^d==0.or.i^d==2*ic^d-3)|.or.}) return
          ineighbor=neighbor(1,i^d,igrid)
          ipole=neighbor_pole(i^d,igrid)
          if(ipole==0) then
            n_inc^d=-2*i^d+ic^d;
            ixs^l=ixs_r_^l(i^d);
            ixr^l=ixr_r_^l(n_inc^d);
            psb(ineighbor)%w(ixr^s,nwhead:nwtail)=&
                psc(igrid)%w(ixs^s,nwhead:nwtail)
            if(stagger_grid) then
              do idir=1,ndim
                 ixs^l=ixs_r_stg_^l(idir,i^d);
                 ixr^l=ixr_r_stg_^l(idir,n_inc^d);
                 psb(ineighbor)%ws(ixr^s,idir)=psc(igrid)%ws(ixs^s,idir)
              end do
            end if
          else
            ixs^l=ixs_r_^l(i^d);
            select case (ipole)
            {case (^d)
              n_inc^d=2*i^d+(3-ic^d)^d%n_inc^dd=-2*i^dd+ic^dd;\}
            end select
            ixr^l=ixr_r_^l(n_inc^d);
            call pole_copy(psb(ineighbor)%w,ixg^ll,ixr^l,psc(igrid)%w,ixcog^l,ixs^l,ipole)
            if(stagger_grid) then
              do idir=1,ndim
                ixs^l=ixs_r_stg_^l(idir,i^d);
                ixr^l=ixr_r_stg_^l(idir,n_inc^d);
                !! Fill ghost cells
                call pole_copy_stg(psb(ineighbor)%ws,ixgs^ll,ixr^l,psc(igrid)%ws,ixcogs^l,ixs^l,idir,ipole)
              end do
            end if
          end if
        end if
 
      end subroutine bc_fill_restrict
 
      !> fill siblings ghost cells with received data
      subroutine bc_fill_srl_stg(igrid,i^D)
        integer, intent(in) :: igrid,i^D
 
        integer :: ixS^L,ixR^L,n_i^D,idir,ineighbor,ipe_neighbor,ipole
 
        ipe_neighbor=neighbor(2,i^d,igrid)
        if(ipe_neighbor/=mype) then
          ineighbor=neighbor(1,i^d,igrid)
          ipole=neighbor_pole(i^d,igrid)
 
        !! Now the special treatment of the pole is done here, at the receive step
          if (ipole==0) then
            ixr^l=ixr_srl_^l(i^d);
            !! Unpack the buffer and fill the ghost cells
            n_i^d=-i^d;
            do idir=1,ndim
              ixs^l=ixs_srl_stg_^l(idir,n_i^d);
              ixr^l=ixr_srl_stg_^l(idir,i^d);
              ibuf_next=ibuf_recv_srl+sizes_srl_recv_stg(idir,i^d)
              psb(igrid)%ws(ixr^s,idir)=reshape(source=recvbuffer_srl(ibuf_recv_srl:ibuf_next-1),&
                shape=shape(psb(igrid)%ws(ixs^s,idir)))       
              ibuf_recv_srl=ibuf_next
            end do
          else ! There is a pole
            select case (ipole)
            {case (^d)
               n_i^d=i^d^d%n_i^dd=-i^dd;\}
            end select
            pole_buf%ws=zero
            do idir=1,ndim
             ixr^l=ixr_srl_stg_^l(idir,i^d);
             ixs^l=ixs_srl_stg_^l(idir,n_i^d);
             ibuf_next=ibuf_recv_srl+sizes_srl_recv_stg(idir,i^d)
             pole_buf%ws(ixs^s,idir)=reshape(source=recvbuffer_srl(ibuf_recv_srl:ibuf_next-1),&
               shape=shape(psb(igrid)%ws(ixs^s,idir)))
             ibuf_recv_srl=ibuf_next
             call pole_copy_stg(psb(igrid)%ws,ixgs^ll,ixr^l,pole_buf%ws,ixgs^ll,ixs^l,idir,ipole)
            end do
          end if
        end if
 
      end subroutine bc_fill_srl_stg
 
      !> fill restricted ghost cells after receipt
      subroutine bc_fill_restrict_stg(igrid,i^D)
        integer, intent(in) :: igrid,i^D
 
        integer :: ipole,ic^D,inc^D,ineighbor,ipe_neighbor,ixS^L,ixR^L,n_i^D,idir
 
        ipole=neighbor_pole(i^d,igrid)
        if (ipole==0) then
          ! Loop over the children ic^D to and their neighbors inc^D
          {do ic^db=1+int((1-i^db)/2),2-int((1+i^db)/2)
             inc^db=2*i^db+ic^db\}
             ipe_neighbor=neighbor_child(2,inc^d,igrid)
             if(ipe_neighbor/=mype) then
               ineighbor=neighbor_child(1,inc^d,igrid)
               n_i^d=-i^d;
               !! Unpack the buffer and fill the ghost cells
               do idir=1,ndim
                 ixr^l=ixr_r_stg_^l(idir,inc^d);
                 ibuf_next=ibuf_recv_r+sizes_r_recv_stg(idir,inc^d)
                 psb(igrid)%ws(ixr^s,idir)=reshape(source=recvbuffer_r(ibuf_recv_r:ibuf_next-1),&
                       shape=shape(psb(igrid)%ws(ixr^s,idir)))
                 ibuf_recv_r=ibuf_next
               end do
             end if
          {end do\}
        else !! There is a pole
          {do ic^db=1+int((1-i^db)/2),2-int((1+i^db)/2)
             inc^db=2*i^db+ic^db\}
             ipe_neighbor=neighbor_child(2,inc^d,igrid)
             if(ipe_neighbor/=mype) then
               ineighbor=neighbor_child(1,inc^d,igrid)
               select case(ipole)
              {case (^d)
                 n_i^d=i^d^d%n_i^dd=-i^dd;\}
               end select
               ixr^l=ixr_r_^l(inc^d);
               !! Unpack the buffer and fill an auxiliary array
               pole_buf%ws=zero
               do idir=1,ndim
                 ixs^l=ixs_r_stg_^l(idir,n_i^d);
                 ixr^l=ixr_r_stg_^l(idir,inc^d);
                 ibuf_next=ibuf_recv_r+sizes_r_recv_stg(idir,inc^d)
                 pole_buf%ws(ixr^s,idir)=reshape(source=recvbuffer_r(ibuf_recv_r:ibuf_next-1),&
                   shape=shape(psb(igrid)%ws(ixr^s,idir)))
                 call pole_copy_stg(psb(igrid)%ws,ixgs^ll,ixr^l,pole_buf%ws,ixgs^ll,ixr^l,idir,ipole)
                 ibuf_recv_r=ibuf_next
               end do
             end if
          {end do\}
        end if
 
      end subroutine bc_fill_restrict_stg
 
      !> Receive from coarse neighbor
      subroutine bc_recv_prolong(igrid,i^D)
        integer, intent(in) :: igrid,i^D
 
        integer :: ic^D,ipe_neighbor,inc^D
 
        ic^d=1+modulo(node(pig^d_,igrid)-1,2);
        if ({.not.(i^d==0.or.i^d==2*ic^d-3)|.or.}) return
 
        ipe_neighbor=neighbor(2,i^d,igrid)
        if (ipe_neighbor/=mype) then
           irecv_c=irecv_c+1
           inc^d=ic^d+i^d;
           itag=(3**^nd+4**^nd)*(igrid-1)+3**^nd+{inc^d*4**(^d-1)+}
           call mpi_irecv(psc(igrid)%w,1,type_recv_p(inc^d), &
                          ipe_neighbor,itag,icomm,recvrequest_c_p(irecv_c),ierrmpi)  
           if(stagger_grid) then
             irecv_p=irecv_p+1
             call mpi_irecv(recvbuffer_p(ibuf_recv_p),sizes_p_recv_total(inc^d),& 
                            mpi_double_precision,ipe_neighbor,itag,&
                            icomm,recvrequest_p(irecv_p),ierrmpi)
             ibuf_recv_p=ibuf_recv_p+sizes_p_recv_total(inc^d)
           end if
        end if
 
      end subroutine bc_recv_prolong
 
      !> Send to finer neighbor
      subroutine bc_send_prolong(igrid,i^D)
        integer, intent(in) :: igrid,i^D
 
        integer :: ic^D,inc^D,n_i^D,n_inc^D,ineighbor,ipe_neighbor,ixS^L,ipole,idir
 
        ipole=neighbor_pole(i^d,igrid)
 
        {do ic^db=1+int((1-i^db)/2),2-int((1+i^db)/2)
           inc^db=2*i^db+ic^db\}
           ipe_neighbor=neighbor_child(2,inc^d,igrid)
           if(ipe_neighbor/=mype) then
             ineighbor=neighbor_child(1,inc^d,igrid)
             if(ipole==0) then
               n_i^d=-i^d;
               n_inc^d=ic^d+n_i^d;
               isend_c=isend_c+1
               itag=(3**^nd+4**^nd)*(ineighbor-1)+3**^nd+{n_inc^d*4**(^d-1)+}
               call mpi_isend(psb(igrid)%w,1,type_send_p(inc^d), &
                              ipe_neighbor,itag,icomm,sendrequest_c_p(isend_c),ierrmpi)
               call wait_send_batch(isend_c,flushed_send_c,sendrequest_c_p,sendstatus_c_p)
               if(stagger_grid) then 
                 ibuf_start=ibuf_send_p
                 do idir=1,ndim
                   ixs^l=ixs_p_stg_^l(idir,inc^d);
                   ibuf_next=ibuf_start+sizes_p_send_stg(idir,inc^d)
                   shapes=(/sizes_p_send_stg(idir,inc^d)/)
                   sendbuffer_p(ibuf_start:ibuf_next-1)=&
                     reshape(psb(igrid)%ws(ixs^s,idir),shapes)   
                   ibuf_start=ibuf_next
                 end do
                 isend_p=isend_p+1
                 call mpi_isend(sendbuffer_p(ibuf_send_p),sizes_p_send_total(inc^d),&
                                mpi_double_precision,ipe_neighbor,itag, &
                                icomm,sendrequest_p(isend_p),ierrmpi)
                 call wait_send_batch(isend_p,flushed_send_p,sendrequest_p,sendstatus_p)
                 ibuf_send_p=ibuf_next
               end if
             else
               ixs^l=ixs_p_^l(inc^d);
               select case (ipole)
               {case (^d)
                 n_inc^d=inc^d^d%n_inc^dd=ic^dd-i^dd;\}
               end select
               if(isend_buf(ipwbuf)/=0) then
                 call mpi_wait(sendrequest_c_p(isend_buf(ipwbuf)), &
                               sendstatus_c_p(:,isend_buf(ipwbuf)),ierrmpi)
                 deallocate(pwbuf(ipwbuf)%w)
               end if
               allocate(pwbuf(ipwbuf)%w(ixs^s,nwhead:nwtail))
               call pole_buffer(pwbuf(ipwbuf)%w,ixs^l,ixs^l,psb(igrid)%w,ixg^ll,ixs^l,ipole)
               isend_c=isend_c+1
               isend_buf(ipwbuf)=isend_c
               itag=(3**^nd+4**^nd)*(ineighbor-1)+3**^nd+{n_inc^d*4**(^d-1)+}
               isizes={(ixsmax^d-ixsmin^d+1)*}*nwbc
               call mpi_isend(pwbuf(ipwbuf)%w,isizes,mpi_double_precision, &
                              ipe_neighbor,itag,icomm,sendrequest_c_p(isend_c),ierrmpi)
               call wait_send_batch(isend_c,flushed_send_c,sendrequest_c_p,sendstatus_c_p)
               ipwbuf=1+modulo(ipwbuf,npwbuf)
               if(stagger_grid) then 
                 ibuf_start=ibuf_send_p
                 do idir=1,ndim
                   ixs^l=ixs_p_stg_^l(idir,inc^d);
                   ibuf_next=ibuf_start+sizes_p_send_stg(idir,inc^d)
                   shapes=(/sizes_p_send_stg(idir,inc^d)/)
                   sendbuffer_p(ibuf_start:ibuf_next-1)=&
                     reshape(psb(igrid)%ws(ixs^s,idir),shapes)   
                   ibuf_start=ibuf_next
                 end do
                 isend_p=isend_p+1
                 call mpi_isend(sendbuffer_p(ibuf_send_p),sizes_p_send_total(inc^d),&
                                mpi_double_precision,ipe_neighbor,itag, &
                                icomm,sendrequest_p(isend_p),ierrmpi)
                 call wait_send_batch(isend_p,flushed_send_p,sendrequest_p,sendstatus_p)
                 ibuf_send_p=ibuf_next
               end if
             end if
           end if
        {end do\}
 
      end subroutine bc_send_prolong
 
      !> Send to finer neighbor
      subroutine bc_fill_prolong(igrid,i^D)
        integer, intent(in) :: igrid,i^D
 
        integer :: ipe_neighbor,ineighbor,ixS^L,ixR^L,ic^D,inc^D,n_i^D,n_inc^D,ipole,idir
 
        ipole=neighbor_pole(i^d,igrid)
 
        if(ipole==0) then
          {do ic^db=1+int((1-i^db)/2),2-int((1+i^db)/2)
             inc^db=2*i^db+ic^db\}
             ipe_neighbor=neighbor_child(2,inc^d,igrid)
             if(ipe_neighbor==mype) then
               ixs^l=ixs_p_^l(inc^d);
               ineighbor=neighbor_child(1,inc^d,igrid)
               n_i^d=-i^d;
               n_inc^d=ic^d+n_i^d;
               ixr^l=ixr_p_^l(n_inc^d);
               psc(ineighbor)%w(ixr^s,nwhead:nwtail) &
                  =psb(igrid)%w(ixs^s,nwhead:nwtail)
               if(stagger_grid) then
                 do idir=1,ndim
                   ixs^l=ixs_p_stg_^l(idir,inc^d);
                   ixr^l=ixr_p_stg_^l(idir,n_inc^d);
                   psc(ineighbor)%ws(ixr^s,idir)=psb(igrid)%ws(ixs^s,idir)
                 end do
               end if
             end if
          {end do\}
        else
          {do ic^db=1+int((1-i^db)/2),2-int((1+i^db)/2)
             inc^db=2*i^db+ic^db\}
             ipe_neighbor=neighbor_child(2,inc^d,igrid)
             if(ipe_neighbor==mype) then
               ixs^l=ixs_p_^l(inc^d);
               ineighbor=neighbor_child(1,inc^d,igrid)
               select case (ipole)
               {case (^d)
                  n_inc^d=inc^d^d%n_inc^dd=ic^dd-i^dd;\}
               end select
               ixr^l=ixr_p_^l(n_inc^d);
               call pole_copy(psc(ineighbor)%w,ixcog^l,ixr^l,psb(igrid)%w,ixg^ll,ixs^l,ipole)
               if(stagger_grid) then
                 do idir=1,ndim
                   ixs^l=ixs_p_stg_^l(idir,inc^d);
                   ixr^l=ixr_p_stg_^l(idir,n_inc^d);
                   call pole_copy_stg(psc(ineighbor)%ws,ixcogs^l,ixr^l,psb(igrid)%ws,ixgs^ll,ixs^l,idir,ipole)
                 end do
               end if
             end if
          {end do\}
        end if
      end subroutine bc_fill_prolong
 
      subroutine gc_prolong(igrid)
        integer, intent(in) :: igrid
 
        integer :: i^D,idims,iside
        logical,dimension(-1:1^D&) :: NeedProlong
 
        needprolong=.false.
        {do i^db=-1,1\}
           if (skip_direction([ i^d ])) cycle
           if (neighbor_type(i^d,igrid)==neighbor_coarse) then
             call bc_prolong(igrid,i^d)
             needprolong(i^d)=.true.
           end if
        {end do\}
        if(stagger_grid) then
          ! Ghost cell prolongation for staggered variables
          ! must be done in a specific order.
          ! First the first neighbours, which have 2 indices=0 in 3D
          ! or one index=0 in 2D
          block=>psb(igrid)
          do idims=1,ndim
            i^d=0;
            select case(idims)
           {case(^d)
              do i^d=-1,1,2
                if (needprolong(i^dd)) call bc_prolong_stg(igrid,i^dd,needprolong)
              end do
            \}
            end select
          end do
          ! Then the second neighbours which have 1 index=0 in 3D
          ! (Only in 3D)
          {^ifthreed
          i1=0;
          do i2=-1,1,2
            do i3=-1,1,2
              if (needprolong(i^d)) call bc_prolong_stg(igrid,i^d,needprolong)
            end do
          end do
          i2=0;
          do i3=-1,1,2
            do i1=-1,1,2
              if (needprolong(i^d)) call bc_prolong_stg(igrid,i^d,needprolong)
            end do
          end do
          i3=0;
          do i1=-1,1,2
            do i2=-1,1,2
              if (needprolong(i^d)) call bc_prolong_stg(igrid,i^d,needprolong)
            end do
          end do
          }
          ! Finally, the corners, that have no index=0
         {do i^d=-1,1,2\}
            if (needprolong(i^d)) call bc_prolong_stg(igrid,i^d,needprolong)
         {end do\}
        end if
      end subroutine gc_prolong
 
      !> fill coarser representative with data from coarser neighbors
      subroutine bc_fill_prolong_stg(igrid,i^D)
        integer, intent(in) :: igrid,i^D
 
        integer :: ipe_neighbor,ineighbor,ipole,ixR^L,ic^D,inc^D,n_inc^D,idir
 
        ic^d=1+modulo(node(pig^d_,igrid)-1,2);
        if ({.not.(i^d==0.or.i^d==2*ic^d-3)|.or.}) return
 
        ipe_neighbor=neighbor(2,i^d,igrid)
        if(ipe_neighbor/=mype) then
          ineighbor=neighbor(1,i^d,igrid)
          ipole=neighbor_pole(i^d,igrid)
 
          if (ipole==0) then   !! There is no pole 
            inc^d=ic^d+i^d;
            ixr^l=ixr_p_^l(inc^d);
            do idir=1,ndim
              ixr^l=ixr_p_stg_^l(idir,inc^d);
              ibuf_next=ibuf_recv_p+sizes_p_recv_stg(idir,inc^d)
              psc(igrid)%ws(ixr^s,idir)=reshape(source=recvbuffer_p(ibuf_recv_p:ibuf_next-1),&
                    shape=shape(psc(igrid)%ws(ixr^s,idir)))
              ibuf_recv_p=ibuf_next
            end do
          else !! There is a pole
            inc^d=ic^d+i^d;
            select case (ipole)
            {case (^d)
               n_inc^d=2*i^d+(3-ic^d)^d%n_inc^dd=-2*i^dd+ic^dd;\}
            end select
            !! Unpack the buffer and fill an auxiliary array
            pole_buf%ws=zero
            do idir=1,ndim
              ixr^l=ixr_p_stg_^l(idir,inc^d);
              ibuf_next=ibuf_recv_p+sizes_p_recv_stg(idir,inc^d)
              pole_buf%ws(ixr^s,idir)=reshape(source=recvbuffer_p(ibuf_recv_p:ibuf_next-1),&
                shape=shape(psc(igrid)%ws(ixr^s,idir)))
              call pole_copy_stg(psc(igrid)%ws,ixcogs^l,ixr^l,pole_buf%ws,ixgs^ll,ixr^l,idir,ipole)
              ibuf_recv_p=ibuf_next
            end do
          end if
        end if
 
      end subroutine bc_fill_prolong_stg
 
      !> do prolongation for fine blocks after receipt data from coarse neighbors
      subroutine bc_prolong(igrid,i^D)
        use mod_physics, only: phys_to_primitive, phys_to_conserved, &
             phys_to_prolong, phys_from_prolong
 
        double precision :: dxFi^D, dxCo^D, xFimin^D, xComin^D, invdxCo^D
        integer :: i^D,igrid
        integer :: ixFi^L,ixCo^L,ii^D, idims,iside,ixB^L
 
        ixfi^l=ixr_srl_^l(i^d);
        dxfi^d=rnode(rpdx^d_,igrid);
        dxco^d=two*dxfi^d;
        invdxco^d=1.d0/dxco^d;
 
        ! compute the enlarged grid lower left corner coordinates
        ! these are true coordinates for an equidistant grid, 
        ! but we can temporarily also use them for getting indices 
        ! in stretched grids
        xfimin^d=rnode(rpxmin^d_,igrid)-dble(nghostcells)*dxfi^d;
        xcomin^d=rnode(rpxmin^d_,igrid)-dble(nghostcells)*dxco^d;
 
        if(phyboundblock(igrid).and.bcphys) then
          block=>psc(igrid)
          do idims=1,ndim
            ixcomin^d=int((xfimin^d+(dble(ixfimin^d)-half)*dxfi^d-xcomin^d)*invdxco^d)+1-1;
            ixcomax^d=int((xfimin^d+(dble(ixfimax^d)-half)*dxfi^d-xcomin^d)*invdxco^d)+1+1;
            {^ifthreed
            ! avoid using undetermined ghost cells at physical boundary edges
            if(idims == 1) then
              if(neighbor_type(-1,0,0,igrid)==neighbor_boundary .or. &
                 neighbor_type(1,0,0,igrid)==neighbor_boundary) then
                if(neighbor_type(0,-1,0,igrid)==neighbor_boundary) ixcomin2=ixcommin2
                if(neighbor_type(0,0,-1,igrid)==neighbor_boundary) ixcomin3=ixcommin3
                if(neighbor_type(0,1,0,igrid)==neighbor_boundary) ixcomax2=ixcommax2
                if(neighbor_type(0,0,1,igrid)==neighbor_boundary) ixcomax3=ixcommax3
              end if
            else if(idims == 2) then
              if(neighbor_type(0,-1,0,igrid)==neighbor_boundary .or. &
                 neighbor_type(0,1,0,igrid)==neighbor_boundary) then
                if(neighbor_type(0,0,-1,igrid)==neighbor_boundary) ixcomin3=ixcommin3
                if(neighbor_type(0,0,1,igrid)==neighbor_boundary) ixcomax3=ixcommax3
              end if
            end if
            }
            do iside=1,2
              ii^d=kr(^d,idims)*(2*iside-3);
              if(neighbor_type(ii^d,igrid)/=neighbor_boundary) cycle
              if(( {(iside==1.and.idims==^d.and.ixcomin^d<ixcogmin^d+nghostcells)|.or.} ) &
               .or.( {(iside==2.and.idims==^d.and.ixcomax^d>ixcogmax^d-nghostcells)|.or. })) then
                {ixbmin^d=merge(ixcogmin^d,ixcomin^d,idims==^d);}
                {ixbmax^d=merge(ixcogmax^d,ixcomax^d,idims==^d);}
                call bc_phys(iside,idims,time,0.d0,psc(igrid),ixcog^l,ixb^l)
              end if
            end do
          end do
        end if
 
        if(prolongprimitive) then
          block=>psc(igrid)
          ixcomin^d=int((xfimin^d+(dble(ixfimin^d)-half)*dxfi^d-xcomin^d)*invdxco^d)+1-1;
          ixcomax^d=int((xfimin^d+(dble(ixfimax^d)-half)*dxfi^d-xcomin^d)*invdxco^d)+1+1;
          call phys_to_primitive(ixcog^l,ixco^l,psc(igrid)%w,psc(igrid)%x)
        end if
 
        if(ghost_copy) then
          call interpolation_copy(igrid,ixfi^l,dxfi^d,xfimin^d,dxco^d,invdxco^d,xcomin^d)
        else
          call interpolation_linear(igrid,ixfi^l,dxfi^d,xfimin^d,dxco^d,invdxco^d,xcomin^d)
        end if
 
        if(prolongprimitive) then
          block=>psc(igrid)
          call phys_to_conserved(ixcog^l,ixco^l,psc(igrid)%w,psc(igrid)%x)
        end if
 
      end subroutine bc_prolong
 
      subroutine bc_prolong_stg(igrid,i^D,NeedProlong)
        use mod_amr_fct
        double precision           :: dxFi^D,dxCo^D,xFimin^D,xComin^D,invdxCo^D
        integer                    :: igrid,i^D
        integer                    :: ixFi^L,ixCo^L
        logical,dimension(-1:1^D&) :: NeedProlong
        logical                    :: fine_^Lin
        ! Check what is already at the desired level
        fine_^lin=.false.;
        {
        if(i^d>-1) fine_min^din=(.not.needprolong(i^dd-kr(^d,^dd)).and.neighbor_type(i^dd-kr(^d,^dd),igrid)/=1)
        if(i^d<1)  fine_max^din=(.not.needprolong(i^dd+kr(^d,^dd)).and.neighbor_type(i^dd+kr(^d,^dd),igrid)/=1)
        \}
 
        ixfi^l=ixr_srl_^l(i^d);
 
        dxfi^d=rnode(rpdx^d_,igrid);
        dxco^d=two*dxfi^d;
        invdxco^d=1.d0/dxco^d;
 
        xfimin^d=rnode(rpxmin^d_,igrid)-dble(nghostcells)*dxfi^d;
        xcomin^d=rnode(rpxmin^d_,igrid)-dble(nghostcells)*dxco^d;
 
        ! moved the physical boundary filling here, to only fill the
        ! part needed
 
        ixcomin^d=int((xfimin^d+(dble(ixfimin^d)-half)*dxfi^d-xcomin^d)*invdxco^d)+1-1;
        ixcomax^d=int((xfimin^d+(dble(ixfimax^d)-half)*dxfi^d-xcomin^d)*invdxco^d)+1+1;
 
        if(prolongprimitive) call phys_to_primitive(ixg^ll,ixfi^l,psb(igrid)%w,psb(igrid)%x)
 
        call prolong_2nd_stg(psc(igrid),psb(igrid),ixco^l,ixfi^l,dxco^d,xcomin^d,dxfi^d,xfimin^d,.true.,fine_^lin)
 
        if(prolongprimitive) call phys_to_conserved(ixg^ll,ixfi^l,psb(igrid)%w,psb(igrid)%x)
 
        ! The current region has already been refined, so it does not need to be prolonged again
        needprolong(i^d)=.false. 
 
      end subroutine bc_prolong_stg
 
      subroutine interpolation_linear(igrid,ixFi^L,dxFi^D,xFimin^D, &
                                      dxCo^D,invdxCo^D,xComin^D)
        use mod_physics, only: phys_to_conserved
        integer, intent(in) :: igrid, ixFi^L
        double precision, intent(in) :: dxFi^D, xFimin^D,dxCo^D, invdxCo^D, xComin^D
 
        double precision :: xCo^D, xFi^D, eta^D
        double precision :: slopeL, slopeR, slopeC, signC, signR
        double precision :: slope(1:nw,ndim)
        !!double precision :: local_invdxCo^D
        double precision :: signedfactorhalf^D
        integer :: ixCo^D, jxCo^D, hxCo^D, ixFi^D, ix^D, iw, idims, nwmin,nwmax
        !integer :: ixshift^D, icase
 
        !icase=mod(nghostcells,2)
 
        if(prolongprimitive) then
          nwmin=1
          nwmax=nw
        else
          nwmin=nwhead
          nwmax=nwtail
        end if
 
        {do ixfi^db = ixfi^lim^db
           ! cell-centered coordinates of fine grid point
           ! here we temporarily use an equidistant grid
           xfi^db=xfimin^db+(dble(ixfi^db)-half)*dxfi^db
 
           ! indices of coarse cell which contains the fine cell
           ! since we computed lower left corner earlier 
           ! in equidistant fashion: also ok for stretched case
           ixco^db=int((xfi^db-xcomin^db)*invdxco^db)+1
 
           ! cell-centered coordinates of coarse grid point
           ! here we temporarily use an equidistant grid
           xco^db=xcomin^db+(dble(ixco^db)-half)*dxco^db \}
 
           !if(.not.slab) then
           !   ^D&local_invdxCo^D=1.d0/psc(igrid)%dx({ixCo^DD},^D)\
           !endif
 
           if(slab_uniform) then
             ! actual cell-centered coordinates of fine grid point
             !!^D&xFi^D=block%x({ixFi^DD},^D)\
             ! actual cell-centered coordinates of coarse grid point
             !!^D&xCo^D=psc(igrid)%x({ixCo^DD},^D)\
             ! normalized distance between fine/coarse cell center
             ! in coarse cell: ranges from -0.5 to 0.5 in each direction
             ! (origin is coarse cell center)
             ! this is essentially +1/4 or -1/4 on cartesian mesh
             eta^d=(xfi^d-xco^d)*invdxco^d;
           else
             !select case(icase)
             ! case(0)
             !{! here we assume an even number of ghostcells!!!
             !ixshift^D=2*(mod(ixFi^D,2)-1)+1
             !if(ixshift^D>0.0d0)then
             !   ! oneven fine grid points
             !   eta^D=-0.5d0*(one-block%dvolume(ixFi^DD) &
             !     /sum(block%dvolume(ixFi^D:ixFi^D+1^D%ixFi^DD))) 
             !else
             !   ! even fine grid points
             !   eta^D=+0.5d0*(one-block%dvolume(ixFi^DD) &
             !     /sum(block%dvolume(ixFi^D-1:ixFi^D^D%ixFi^DD))) 
             !endif\}
             ! case(1)
             !{! here we assume an odd number of ghostcells!!!
             !ixshift^D=2*(mod(ixFi^D,2)-1)+1
             !if(ixshift^D>0.0d0)then
             !   ! oneven fine grid points
             !   eta^D=+0.5d0*(one-block%dvolume(ixFi^DD) &
             !     /sum(block%dvolume(ixFi^D-1:ixFi^D^D%ixFi^DD))) 
             !else
             !   ! even fine grid points
             !   eta^D=-0.5d0*(one-block%dvolume(ixFi^DD) &
             !     /sum(block%dvolume(ixFi^D:ixFi^D+1^D%ixFi^DD))) 
             !endif\}
             ! case default
             !  call mpistop("no such case")
             !end select
             ! the different cases for even/uneven number of ghost cells 
             ! are automatically handled using the relative index to ixMlo
             ! as well as the pseudo-coordinates xFi and xCo 
             ! these latter differ from actual cell centers when stretching is used
             ix^d=2*int((ixfi^d+ixmlo^d)/2)-ixmlo^d;
             {if(xfi^d>xco^d) then
                signedfactorhalf^d=0.5d0
              else
                signedfactorhalf^d=-0.5d0
              end if
              eta^d=signedfactorhalf^d*(one-psb(igrid)%dvolume(ixfi^dd) &
                   /sum(psb(igrid)%dvolume(ix^d:ix^d+1^d%ixFi^dd))) \}
             !{eta^D=(xFi^D-xCo^D)*invdxCo^D &
             !      *two*(one-block%dvolume(ixFi^DD) &
             !      /sum(block%dvolume(ix^D:ix^D+1^D%ixFi^DD))) \}
           end if
 
           do idims=1,ndim
              hxco^d=ixco^d-kr(^d,idims)\
              jxco^d=ixco^d+kr(^d,idims)\
 
              do iw=nwmin,nwmax
                 slopel=psc(igrid)%w(ixco^d,iw)-psc(igrid)%w(hxco^d,iw)
                 sloper=psc(igrid)%w(jxco^d,iw)-psc(igrid)%w(ixco^d,iw)
                 slopec=half*(sloper+slopel)
 
                 ! get limited slope
                 signr=sign(one,sloper)
                 signc=sign(one,slopec)
                 !select case(prolong_limiter)
                 !case(1)
                 !  ! unlimit
                 !  slope(iw,idims)=slopeC
                 !case(2)
                 !  ! minmod
                 !  slope(iw,idims)=signR*max(zero,min(dabs(slopeR), &
                 !                                    signR*slopeL))
                 !case(3)
                 !  ! woodward
                 !  slope(iw,idims)=two*signR*max(zero,min(dabs(slopeR), &
                 !                     signR*slopeL,signR*half*slopeC))
                 !case(4)
                 !  ! koren
                 !  slope(iw,idims)=signR*max(zero,min(two*signR*slopeL, &
                 !   (dabs(slopeR)+two*slopeL*signR)*third,two*dabs(slopeR)))
                 !case default
                   slope(iw,idims)=signc*max(zero,min(dabs(slopec), &
                                     signc*slopel,signc*sloper))
                 !end select
              end do
           end do
 
           ! Interpolate from coarse cell using limited slopes
           psb(igrid)%w(ixfi^d,nwmin:nwmax)=psc(igrid)%w(ixco^d,nwmin:nwmax)+&
             {(slope(nwmin:nwmax,^d)*eta^d)+}
 
        {end do\}
 
        if(prolongprimitive) then
          block=>psb(igrid)
          call phys_to_conserved(ixg^ll,ixfi^l,psb(igrid)%w,psb(igrid)%x)
        end if
 
      end subroutine interpolation_linear
 
      subroutine interpolation_copy(igrid, ixFi^L,dxFi^D,xFimin^D, &
                                    dxCo^D,invdxCo^D,xComin^D)
        use mod_physics, only: phys_to_conserved
        integer, intent(in) :: igrid, ixFi^L
        double precision, intent(in) :: dxFi^D, xFimin^D,dxCo^D, invdxCo^D, xComin^D
 
        double precision :: xFi^D
        integer :: ixCo^D, ixFi^D, nwmin,nwmax
 
        if(prolongprimitive) then
          nwmin=1
          nwmax=nw
        else
          nwmin=nwhead
          nwmax=nwtail
        end if
 
        {do ixfi^db = ixfi^lim^db
           ! cell-centered coordinates of fine grid point
           xfi^db=xfimin^db+(dble(ixfi^db)-half)*dxfi^db
        
           ! indices of coarse cell which contains the fine cell
           ! note: this also works for stretched grids
           ixco^db=int((xfi^db-xcomin^db)*invdxco^db)+1\}
        
           ! Copy from coarse cell
           psb(igrid)%w(ixfi^d,nwmin:nwmax)=psc(igrid)%w(ixco^d,nwmin:nwmax)
        
        {end do\}
        
        if(prolongprimitive) call phys_to_conserved(ixg^ll,ixfi^l,psb(igrid)%w,psb(igrid)%x)
      
      end subroutine interpolation_copy
 
      subroutine pole_copy(wrecv,ixIR^L,ixR^L,wsend,ixIS^L,ixS^L,ipole)
      
        integer, intent(in) :: ixIR^L,ixR^L,ixIS^L,ixS^L,ipole
        double precision :: wrecv(ixIR^S,1:nw), wsend(ixIS^S,1:nw)
 
        integer :: iw, iside, iB
 
        select case (ipole)
        {case (^d)
           iside=int((i^d+3)/2)
           ib=2*(^d-1)+iside
           do iw=nwhead,nwtail
             select case (typeboundary(iw,ib))
             case (bc_symm)
               wrecv(ixr^s,iw) = wsend(ixsmax^d:ixsmin^d:-1^d%ixS^s,iw)
             case (bc_asymm)
               wrecv(ixr^s,iw) =-wsend(ixsmax^d:ixsmin^d:-1^d%ixS^s,iw)
             case default
               call mpistop("Pole boundary condition should be symm or asymm")
             end select
           end do \}
        end select
      
      end subroutine pole_copy
 
      subroutine pole_copy_stg(wrecv,ixIR^L,ixR^L,wsend,ixIS^L,ixS^L,idirs,ipole)
      
        integer, intent(in) :: ixIR^L,ixR^L,ixIS^L,ixS^L,idirs,ipole
 
        double precision :: wrecv(ixIR^S,1:nws), wsend(ixIS^S,1:nws)
        integer :: iB, iside
 
        select case (ipole)
        {case (^d)
           iside=int((i^d+3)/2)
           ib=2*(^d-1)+iside
           select case (typeboundary(iw_mag(idirs),ib))
           case (bc_symm)
             wrecv(ixr^s,idirs) = wsend(ixsmax^d:ixsmin^d:-1^d%ixS^s,idirs)
           case (bc_asymm)
             wrecv(ixr^s,idirs) =-wsend(ixsmax^d:ixsmin^d:-1^d%ixS^s,idirs)
           case default
             call mpistop("Pole boundary condition should be symm or asymm")
           end select
         \}
        end select
 
      end subroutine pole_copy_stg
 
      subroutine pole_buffer(wrecv,ixIR^L,ixR^L,wsend,ixIS^L,ixS^L,ipole)
      
        integer, intent(in) :: ixIR^L,ixR^L,ixIS^L,ixS^L,ipole
        double precision :: wrecv(ixIR^S,nwhead:nwtail), wsend(ixIS^S,1:nw)
 
        integer :: iw, iside, iB
 
        select case (ipole)
        {case (^d)
           iside=int((i^d+3)/2)
           ib=2*(^d-1)+iside
           do iw=nwhead,nwtail
             select case (typeboundary(iw,ib))
             case (bc_symm)
               wrecv(ixr^s,iw) = wsend(ixsmax^d:ixsmin^d:-1^d%ixS^s,iw)
             case (bc_asymm)
               wrecv(ixr^s,iw) =-wsend(ixsmax^d:ixsmin^d:-1^d%ixS^s,iw)
             case default
               call mpistop("Pole boundary condition should be symm or asymm")
             end select
           end do \}
        end select
      
      end subroutine pole_buffer
 
  end subroutine getbc
 
end module mod_ghostcells_update