comm_particles_global Subroutine

public subroutine comm_particles_global()

Uses

  • proc~~comm_particles_global~~UsesGraph proc~comm_particles_global comm_particles_global module~mod_global_parameters mod_global_parameters proc~comm_particles_global->module~mod_global_parameters 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

Arguments

None

Calls

proc~~comm_particles_global~~CallsGraph proc~comm_particles_global comm_particles_global mpi_waitall mpi_waitall proc~comm_particles_global->mpi_waitall proc~find_particle_ipe find_particle_ipe proc~comm_particles_global->proc~find_particle_ipe proc~mpi_irecv_wrapper mpi_irecv_wrapper proc~comm_particles_global->proc~mpi_irecv_wrapper proc~mpi_isend_wrapper mpi_isend_wrapper proc~comm_particles_global->proc~mpi_isend_wrapper proc~mpi_recv_wrapper mpi_recv_wrapper proc~comm_particles_global->proc~mpi_recv_wrapper proc~mpi_send_wrapper mpi_send_wrapper proc~comm_particles_global->proc~mpi_send_wrapper proc~mpistop mpistop proc~comm_particles_global->proc~mpistop proc~pull_particle_from_particles_on_mype pull_particle_from_particles_on_mype proc~comm_particles_global->proc~pull_particle_from_particles_on_mype proc~push_particle_into_particles_on_mype push_particle_into_particles_on_mype proc~comm_particles_global->proc~push_particle_into_particles_on_mype proc~get_igslice get_igslice proc~find_particle_ipe->proc~get_igslice proc~particle_in_domain particle_in_domain proc~find_particle_ipe->proc~particle_in_domain mpi_irecv mpi_irecv proc~mpi_irecv_wrapper->mpi_irecv mpi_isend mpi_isend proc~mpi_isend_wrapper->mpi_isend mpi_recv mpi_recv proc~mpi_recv_wrapper->mpi_recv mpi_send mpi_send proc~mpi_send_wrapper->mpi_send mpi_abort mpi_abort proc~mpistop->mpi_abort proc~get_igslice->proc~mpistop

Called by

proc~~comm_particles_global~~CalledByGraph proc~comm_particles_global comm_particles_global proc~handle_particles handle_particles proc~handle_particles->proc~comm_particles_global proc~read_particles_snapshot read_particles_snapshot proc~read_particles_snapshot->proc~comm_particles_global proc~advance advance proc~advance->proc~handle_particles proc~main main proc~main->proc~handle_particles proc~main->proc~read_particles_snapshot proc~timeintegration timeintegration proc~main->proc~timeintegration proc~timeintegration->proc~advance program~agile agile program~agile->proc~main

Source Code

  subroutine comm_particles_global()

    ! does not destroy particles like comm_particles

    use mod_global_parameters

    integer                         :: ipart, iipart, igrid_particle,&
        ipe_particle, ipe, iipe
    integer                         :: index
    integer                         :: tag_send, tag_receive, send_buff,&
        rcv_buff
    integer                         :: status(MPI_STATUS_SIZE)
    integer, dimension(0:npe-1)     :: send_n_particles_to_ipe
    integer, dimension(0:npe-1)     :: receive_n_particles_from_ipe
!    type(particle_t), dimension(nparticles_per_cpu_hi)  :: send_particles
!    type(particle_t), dimension(nparticles_per_cpu_hi)  :: receive_particles
!    double precision, dimension(npayload,nparticles_per_cpu_hi)  :: send_payload
!    double precision, dimension(npayload,nparticles_per_cpu_hi)  :: receive_payload
    type(particle_t), allocatable, dimension(:)  :: send_particles
    type(particle_t), allocatable, dimension(:)  :: receive_particles
    double precision, allocatable, dimension(:,:)  :: send_payload
    double precision, allocatable, dimension(:,:)  :: receive_payload
    integer, allocatable, dimension(:,:)      :: &
       particle_index_to_be_sent_to_ipe
    logical                                   :: BC_applied
    integer, allocatable, dimension(:)        :: sndrqst, rcvrqst
    integer                                   :: isnd, ircv
    !-----------------------------------------------------------------------------
    send_n_particles_to_ipe(:)      = 0
    receive_n_particles_from_ipe(:) = 0

    allocate( particle_index_to_be_sent_to_ipe(nparticles_per_cpu_hi,&
       0:npe-1) )
    allocate( sndrqst(1:npe-1), rcvrqst(1:npe-1) )
    sndrqst = MPI_REQUEST_NULL; rcvrqst = MPI_REQUEST_NULL;

    ! check if and where to send each particle, relocate all of them (in case grid has changed)
    do iipart=1,nparticles_on_mype;ipart=particles_on_mype(iipart);

       call find_particle_ipe(particle(ipart)%self%x,igrid_particle,&
          ipe_particle)

       particle(ipart)%igrid = igrid_particle
       particle(ipart)%ipe = ipe_particle

       ! if we have more than one core, is it on another cpu?
       if (particle(ipart)%ipe .ne. mype) then
          send_n_particles_to_ipe(ipe_particle) = &
             send_n_particles_to_ipe(ipe_particle) + 1
          if (send_n_particles_to_ipe(ipe_particle) .gt. &
             nparticles_per_cpu_hi) call &
             mpistop('G: too many particles increase nparticles_per_cpu_hi')
          particle_index_to_be_sent_to_ipe(send_n_particles_to_ipe(&
             ipe_particle),ipe_particle) = ipart
       end if ! ipe_particle

    end do ! ipart

    ! get out when only one core:
    if (npe == 1) then
      deallocate(sndrqst, rcvrqst)
      deallocate(particle_index_to_be_sent_to_ipe)
      return
    end if

    ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    ! communicate amount of particles to be sent/received
    ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    ! opedit: I think this was the main bottleneck.
    ! 31.12.2017: made it nonblocking (easy, least invasive)
    ! If this continues to be problematic, better to
    ! send particles with block in coarsen/refine/loadbalance. (best).

    isnd = 0; ircv = 0;
    do ipe=0,npe-1; if (ipe .eq. mype) cycle;

       tag_send = mype * npe + ipe;  tag_receive = ipe * npe + mype;
       isnd = isnd + 1;  ircv = ircv + 1;
       call mpi_isend_wrapper(send_n_particles_to_ipe(ipe),1,MPI_INTEGER, ipe,tag_send,&
          icomm,sndrqst(isnd),ierrmpi)
       call mpi_irecv_wrapper(receive_n_particles_from_ipe(ipe),1,MPI_INTEGER, ipe,&
          tag_receive,icomm,rcvrqst(ircv),ierrmpi)
    end do

    call MPI_WAITALL(isnd,sndrqst,MPI_STATUSES_IGNORE,ierrmpi)
    call MPI_WAITALL(ircv,rcvrqst,MPI_STATUSES_IGNORE,ierrmpi)
    deallocate(sndrqst, rcvrqst)


    ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    ! send and receive the data of the particles
    ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

    do ipe=0,npe-1
      if (ipe .eq. mype) cycle;
      tag_send    = mype * npe + ipe
      tag_receive = ipe * npe + mype

      ! should i send some particles to ipe?
      if (send_n_particles_to_ipe(ipe) .gt. 0) then

        ! create the send buffer
        allocate(send_particles(1:send_n_particles_to_ipe(ipe)))
        allocate(send_payload(1:npayload,1:send_n_particles_to_ipe(ipe)))
        do ipart = 1, send_n_particles_to_ipe(ipe)
          send_particles(ipart) = particle(particle_index_to_be_sent_to_ipe(&
             ipart,ipe))%self
          send_payload(1:npayload,ipart) = &
             particle(particle_index_to_be_sent_to_ipe(ipart,&
             ipe))%payload(1:npayload)
        end do ! ipart

        call mpi_send_wrapper(send_particles,send_n_particles_to_ipe(ipe),&
           type_particle,ipe,tag_send,icomm,ierrmpi)
        call mpi_send_wrapper(send_payload,npayload*send_n_particles_to_ipe(ipe),&
           MPI_DOUBLE_PRECISION,ipe,tag_send,icomm,ierrmpi)
        do ipart = 1, send_n_particles_to_ipe(ipe)
          deallocate(particle(particle_index_to_be_sent_to_ipe(ipart,&
             ipe))%self)
          deallocate(particle(particle_index_to_be_sent_to_ipe(ipart,&
             ipe))%payload)
          call pull_particle_from_particles_on_mype(&
             particle_index_to_be_sent_to_ipe(ipart,ipe))
        end do ! ipart
        deallocate(send_particles)
        deallocate(send_payload)

      end if ! send .gt. 0

      ! should i receive some particles from ipe?
      if (receive_n_particles_from_ipe(ipe) .gt. 0) then
        allocate(receive_particles(1:receive_n_particles_from_ipe(ipe)))
        allocate(receive_payload(1:npayload,&
           1:receive_n_particles_from_ipe(ipe)))

        call mpi_recv_wrapper(receive_particles,receive_n_particles_from_ipe(ipe),&
           type_particle,ipe,tag_receive,icomm,status,ierrmpi)
        call mpi_recv_wrapper(receive_payload,npayload*receive_n_particles_from_ipe(&
           ipe),MPI_DOUBLE_PRECISION,ipe,tag_receive,icomm,status,ierrmpi)
        do ipart = 1, receive_n_particles_from_ipe(ipe)

          index = receive_particles(ipart)%index
          !if (.not. allocated(particle(index)%self)) &
          allocate(particle(index)%self)
          particle(index)%self = receive_particles(ipart)
          !if (.not. allocated(particle(index)%payload)) &
          allocate(particle(index)%payload(npayload))
          particle(index)%payload(1:npayload) = receive_payload(1:npayload,&
             ipart)
          call push_particle_into_particles_on_mype(index)

          ! since we don't send the igrid, need to re-locate it
          call find_particle_ipe(particle(index)%self%x,igrid_particle,&
             ipe_particle)
          particle(index)%igrid = igrid_particle
          particle(index)%ipe = ipe_particle

        end do ! ipart
        deallocate(receive_particles)
        deallocate(receive_payload)

      end if ! receive .gt. 0
    end do ! ipe
    deallocate(particle_index_to_be_sent_to_ipe)

  end subroutine comm_particles_global