exchange_coarsened_blocks Subroutine

private subroutine exchange_coarsened_blocks()

Uses

  • proc~~exchange_coarsened_blocks~~UsesGraph proc~exchange_coarsened_blocks exchange_coarsened_blocks module~mod_comm_lib mod_comm_lib proc~exchange_coarsened_blocks->module~mod_comm_lib module~mod_global_parameters mod_global_parameters proc~exchange_coarsened_blocks->module~mod_global_parameters module~mod_msg_layout mod_msg_layout proc~exchange_coarsened_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 non-local half of a coarsening step, one message per neighbouring rank.

coarsen_grid_siblings has already written each off-rank child into its own coarse representative psc(igridFi) - which is bgc(1)%w(...,igridFi), so it is on the device - and recorded a descriptor for it. Here those descriptors 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_coarsened_blocks~~CallsGraph proc~exchange_coarsened_blocks exchange_coarsened_blocks mpi_get_count mpi_get_count proc~exchange_coarsened_blocks->mpi_get_count mpi_waitall mpi_waitall proc~exchange_coarsened_blocks->mpi_waitall proc~layout_runs layout_runs proc~exchange_coarsened_blocks->proc~layout_runs proc~mpi_irecv_wrapper mpi_irecv_wrapper proc~exchange_coarsened_blocks->proc~mpi_irecv_wrapper proc~mpi_isend_wrapper mpi_isend_wrapper proc~exchange_coarsened_blocks->proc~mpi_isend_wrapper proc~mpistop mpistop proc~exchange_coarsened_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_coarsened_blocks~~CalledByGraph proc~exchange_coarsened_blocks exchange_coarsened_blocks proc~amr_coarsen_refine amr_coarsen_refine proc~amr_coarsen_refine->proc~exchange_coarsened_blocks 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_coarsened_blocks
    use mod_global_parameters
    use mod_msg_layout, only: layout_runs
    use mod_comm_lib, only: mpistop

    integer :: k, nxCo1, nxCo2, nxCo3, nchunk, nbuf
    integer :: ixCoMmin1, ixCoMmin2, ixCoMmin3
    integer :: igrid, ibuf, ic1, ic2, ic3, iw, ix1, ix2, ix3
    integer, allocatable :: chunksize(:)

    nxCo1 = block_nx1/2; nxCo2 = block_nx2/2; nxCo3 = block_nx3/2
    ! only 1:nwgc is coarsened and only 1:nwgc is applied - the analytic extras
    ! past it are re-derived by alloc_node - so nwgc, not nw, is what travels
    nchunk = nxCo1*nxCo2*nxCo3*nwgc
    ! psc is indexed from 1 in every direction, like bgc(1)%w
    ixCoMmin1 = 1+nghostcells
    ixCoMmin2 = 1+nghostcells
    ixCoMmin3 = 1+nghostcells

    ! Every chunk is one coarsened child, so they are all the same size.
    allocate(chunksize(max(n_cf_snd,n_cf_rcv,1)))
    chunksize = nchunk
    call layout_runs(n_cf_snd, cf_snd_dest, cf_snd_key, chunksize, cf_snd_ibuf,&
       n_cf_send_pe, cf_send_pe, cf_send_pe_off, cf_send_pe_len)
    call layout_runs(n_cf_rcv, cf_rcv_src, cf_rcv_key, chunksize, cf_rcv_ibuf,&
       n_cf_recv_pe, cf_recv_pe, cf_recv_pe_off, cf_recv_pe_len)
    deallocate(chunksize)

    if (n_cf_snd > 0) then
      
    end if
    if (n_cf_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_cf_recv_pe > 0) then
#ifndef NOGPUDIRECT
      
#endif
      do k = 1, n_cf_recv_pe
        call mpi_irecv_wrapper(rcv_buff_cf(cf_recv_pe_off(k)),&
           cf_recv_pe_len(k),MPI_DOUBLE_PRECISION,cf_recv_pe(k),itag,icomm,&
           recvrequest(k),ierrmpi)
      end do
#ifndef NOGPUDIRECT
      
#endif
    end if

    ! Pack every outgoing chunk in one kernel.  bgc(1)%w carries the grid index
    ! last, so the block can be selected by a device-side index.
    if (n_cf_snd > 0) then
       
      do k = 1, n_cf_snd
         igrid = cf_snd_igrid(k)
         ibuf  = cf_snd_ibuf(k)
         
         do iw = 1, nwgc
            do ix3 = 1, nxCo3
               do ix2 = 1, nxCo2
                  do ix1 = 1, nxCo1
                     snd_buff_cf(ibuf + (ix1-1) + nxCo1*(ix2-1) &
                          + nxCo1*nxCo2*(ix3-1) &
                          + nxCo1*nxCo2*nxCo3*(iw-1)) = &
                          bgc(1)%w(ixCoMmin1-1+ix1, ixCoMmin2-1+ix2,&
                                   ixCoMmin3-1+ix3, iw, igrid)
                  end do
               end do
            end do
         end do
      end do
    end if

    if (n_cf_send_pe > 0) then
#ifdef NOGPUDIRECT
      
#else
      
#endif
      do k = 1, n_cf_send_pe
        call mpi_isend_wrapper(snd_buff_cf(cf_send_pe_off(k)),&
           cf_send_pe_len(k),MPI_DOUBLE_PRECISION,cf_send_pe(k),itag,icomm,&
           sendrequest(k),ierrmpi)
      end do
#ifndef NOGPUDIRECT
      
#endif
    end if

    if (n_cf_recv_pe > 0) then
      call MPI_WAITALL(n_cf_recv_pe,recvrequest,recvstatus,ierrmpi)
      ! With one aggregated message per peer a disagreement about which chunks
      ! 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_cf_recv_pe
        call MPI_GET_COUNT(recvstatus(:,k),MPI_DOUBLE_PRECISION,nbuf,ierrmpi)
        if (nbuf /= cf_recv_pe_len(k)) call mpistop( &
           "exchange_coarsened_blocks: message length disagrees with the layout")
      end do
#ifdef NOGPUDIRECT
      
#endif
    end if

    ! Apply every incoming chunk in one kernel.
    if (n_cf_rcv > 0) then
       
      do k = 1, n_cf_rcv
         igrid = cf_rcv_igrid(k)
         ibuf  = cf_rcv_ibuf(k)
         ic1   = cf_rcv_ic(1,k)
         ic2   = cf_rcv_ic(2,k)
         ic3   = cf_rcv_ic(3,k)
         
         do iw = 1, nwgc  ! analytic extras past nwgc are set in alloc_node
            do ix3 = 1, nxCo3
               do ix2 = 1, nxCo2
                  do ix1 = 1, nxCo1
                     bg(1)%w( &
                          ixMlo1-1+(ic1-1)*nxCo1 + ix1, &
                          ixMlo2-1+(ic2-1)*nxCo2 + ix2, &
                          ixMlo3-1+(ic3-1)*nxCo3 + ix3, &
                          iw, igrid) &
                          = rcv_buff_cf(ibuf + (ix1-1) + nxCo1*(ix2-1) &
                            + nxCo1*nxCo2*(ix3-1) &
                            + nxCo1*nxCo2*nxCo3*(iw-1))
                  end do
               end do
            end do
         end do
      end do
    end if

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

  end subroutine exchange_coarsened_blocks