exchange_migrated_blocks Subroutine

private subroutine exchange_migrated_blocks()

Uses

  • proc~~exchange_migrated_blocks~~UsesGraph proc~exchange_migrated_blocks exchange_migrated_blocks module~mod_comm_lib mod_comm_lib proc~exchange_migrated_blocks->module~mod_comm_lib module~mod_global_parameters mod_global_parameters proc~exchange_migrated_blocks->module~mod_global_parameters module~mod_msg_layout mod_msg_layout proc~exchange_migrated_blocks->module~mod_msg_layout module~mod_basic_types mod_basic_types module~mod_global_parameters->module~mod_basic_types module~mod_connectivity mod_connectivity module~mod_global_parameters->module~mod_connectivity module~mod_constants mod_constants module~mod_global_parameters->module~mod_constants module~mod_physicaldata mod_physicaldata module~mod_global_parameters->module~mod_physicaldata module~mod_variables mod_variables module~mod_global_parameters->module~mod_variables mpi mpi module~mod_global_parameters->mpi module~mod_variables->module~mod_basic_types

Exchange and apply the migrating blocks, one message per neighbouring rank, with the buffers sized by what actually moves.

The walk in load_balance has already allocated every arriving block with alloc_node and recorded a descriptor for each departure and arrival. Here those are laid out as one contiguous run per peer, ordered by the shared key, packed by a single kernel and sent as a single message each.

Arguments

None

Calls

proc~~exchange_migrated_blocks~~CallsGraph proc~exchange_migrated_blocks exchange_migrated_blocks mpi_get_count mpi_get_count proc~exchange_migrated_blocks->mpi_get_count mpi_waitall mpi_waitall proc~exchange_migrated_blocks->mpi_waitall proc~layout_runs layout_runs proc~exchange_migrated_blocks->proc~layout_runs proc~mpi_irecv_wrapper mpi_irecv_wrapper proc~exchange_migrated_blocks->proc~mpi_irecv_wrapper proc~mpi_isend_wrapper mpi_isend_wrapper proc~exchange_migrated_blocks->proc~mpi_isend_wrapper proc~mpistop mpistop proc~exchange_migrated_blocks->proc~mpistop proc~rank_keys rank_keys proc~layout_runs->proc~rank_keys mpi_irecv mpi_irecv proc~mpi_irecv_wrapper->mpi_irecv mpi_isend mpi_isend proc~mpi_isend_wrapper->mpi_isend mpi_abort mpi_abort proc~mpistop->mpi_abort

Called by

proc~~exchange_migrated_blocks~~CalledByGraph proc~exchange_migrated_blocks exchange_migrated_blocks proc~load_balance load_balance proc~load_balance->proc~exchange_migrated_blocks proc~amr_coarsen_refine amr_coarsen_refine proc~amr_coarsen_refine->proc~load_balance proc~resettree resettree proc~resettree->proc~amr_coarsen_refine proc~resettree_convert resettree_convert proc~resettree_convert->proc~amr_coarsen_refine proc~settree settree proc~settree->proc~amr_coarsen_refine proc~main main proc~main->proc~resettree_convert proc~main->proc~settree proc~timeintegration timeintegration proc~main->proc~timeintegration proc~timeintegration->proc~resettree program~agile agile program~agile->proc~main

Source Code

  subroutine exchange_migrated_blocks
    use mod_global_parameters
    use mod_msg_layout, only: layout_runs
    use mod_comm_lib, only: mpistop

    integer :: k, nchunk, nbuf, nneed
    integer :: igrid, ibuf, iw, ix1, ix2, ix3
    integer, allocatable :: chunksize(:)

    ! Only 1:nwgc travels. The analytic extras past it - for ffhd the frozen
    ! field - were already rebuilt by fill_nwextra_device inside the
    ! alloc_node that lb_recv calls for every arriving block, so putting them
    ! on the wire would only overwrite identical values.
    nchunk = block_nx1*block_nx2*block_nx3*nwgc

    ! Every chunk is one block interior, so they are all the same size.
    allocate(chunksize(max(n_lb_snd,n_lb_rcv,1)))
    chunksize = nchunk
    call layout_runs(n_lb_snd, lb_snd_dest, lb_snd_key, chunksize, lb_snd_ibuf,&
       n_lb_send_pe, lb_send_pe, lb_send_pe_off, lb_send_pe_len)
    call layout_runs(n_lb_rcv, lb_rcv_src, lb_rcv_key, chunksize, lb_rcv_ibuf,&
       n_lb_recv_pe, lb_recv_pe, lb_recv_pe_off, lb_recv_pe_len)
    deallocate(chunksize)

    ! Grow the buffers to fit, never shrink: load_balance runs on every regrid,
    ! so resizing down would thrash the device heap for nothing.  The device
    ! copy is torn down and recreated around the reallocation rather than
    ! updated afterwards - see the note on the declarations.
    nneed = max(n_lb_snd, n_lb_rcv)
    if (nneed > max_buff) then
      if (allocated(snd_buff_lb)) then
        
        deallocate(snd_buff_lb, rcv_buff_lb)
      end if
      max_buff = nneed
      allocate(snd_buff_lb(max_buff*nchunk), rcv_buff_lb(max_buff*nchunk))
      
    end if
    if (n_lb_snd == 0 .and. n_lb_rcv == 0) return

    if (n_lb_snd > 0) then
      
    end if
    if (n_lb_rcv > 0) then
      
    end if

    ! One Irecv per peer, straight into that peer's run. A peer sends exactly
    ! one message, so (communicator, source) already disambiguates and the tag
    ! carries nothing.
    itag = 0
    if (n_lb_recv_pe > 0) then
#ifndef NOGPUDIRECT
      
#endif
      do k = 1, n_lb_recv_pe
        call mpi_irecv_wrapper(rcv_buff_lb(lb_recv_pe_off(k)),&
           lb_recv_pe_len(k),MPI_DOUBLE_PRECISION,lb_recv_pe(k),itag,icomm,&
           recvrequest(k),ierrmpi)
      end do
#ifndef NOGPUDIRECT
      
#endif
    end if

    ! Pack every departing block in one kernel. bg(1)%w carries the grid index
    ! last, so the block can be selected by a device-side index.
    if (n_lb_snd > 0) then
       
      do k = 1, n_lb_snd
         igrid = lb_snd_igrid(k)
         ibuf  = lb_snd_ibuf(k)
         
         do iw = 1, nwgc
            do ix3 = 1, block_nx3
               do ix2 = 1, block_nx2
                  do ix1 = 1, block_nx1
                     snd_buff_lb(ibuf + (ix1-1) + block_nx1*(ix2-1) &
                          + block_nx1*block_nx2*(ix3-1) &
                          + block_nx1*block_nx2*block_nx3*(iw-1)) = &
                          bg(1)%w(ixMlo1-1+ix1, ixMlo2-1+ix2, ixMlo3-1+ix3,&
                                  iw, igrid)
                  end do
               end do
            end do
         end do
      end do
    end if

    if (n_lb_send_pe > 0) then
#ifdef NOGPUDIRECT
      
#else
      
#endif
      do k = 1, n_lb_send_pe
        call mpi_isend_wrapper(snd_buff_lb(lb_send_pe_off(k)),&
           lb_send_pe_len(k),MPI_DOUBLE_PRECISION,lb_send_pe(k),itag,icomm,&
           sendrequest(k),ierrmpi)
      end do
#ifndef NOGPUDIRECT
      
#endif
    end if

    if (n_lb_recv_pe > 0) then
      call MPI_WAITALL(n_lb_recv_pe,recvrequest,recvstatus,ierrmpi)
      ! With one aggregated message per peer a disagreement about which blocks
      ! the run holds is no longer an MPI mismatch, so check the arrival
      ! lengths. A difference in order cannot arise: both ranks sort the same
      ! run by the same key.
      do k = 1, n_lb_recv_pe
        call MPI_GET_COUNT(recvstatus(:,k),MPI_DOUBLE_PRECISION,nbuf,ierrmpi)
        if (nbuf /= lb_recv_pe_len(k)) call mpistop( &
           "exchange_migrated_blocks: message length disagrees with the layout")
      end do
#ifdef NOGPUDIRECT
      
#endif
    end if

    ! Apply every arriving block in one kernel.
    if (n_lb_rcv > 0) then
       
      do k = 1, n_lb_rcv
         igrid = lb_rcv_igrid(k)
         ibuf  = lb_rcv_ibuf(k)
         
         do iw = 1, nwgc
            do ix3 = 1, block_nx3
               do ix2 = 1, block_nx2
                  do ix1 = 1, block_nx1
                     bg(1)%w(ixMlo1-1+ix1, ixMlo2-1+ix2, ixMlo3-1+ix3,&
                             iw, igrid) &
                          = rcv_buff_lb(ibuf + (ix1-1) + block_nx1*(ix2-1) &
                            + block_nx1*block_nx2*(ix3-1) &
                            + block_nx1*block_nx2*block_nx3*(iw-1))
                  end do
               end do
            end do
         end do
      end do
    end if

    if (n_lb_send_pe > 0) then
      call MPI_WAITALL(n_lb_send_pe,sendrequest,sendstatus,ierrmpi)
    end if

  end subroutine exchange_migrated_blocks