Отправка и получение операций между коммуникаторами в MPI

Question

После моего предыдущего вопроса: Unable to implement MPI_Intercomm_create

Проблема MPI_INTERCOMM_CREATE была решена. Но когда я пытаюсь реализовать основные операции отправки отправки между процессом 0 цвета 0 (глобальный ранг = 0) и процессом 0 цвета 1 (т. Е. Глобально ранг = 2), код просто зависает после печати принятого буфера. код:

program hello 
include 'mpif.h' 
implicit none 
integer tag,ierr,rank,numtasks,color,new_comm,inter1,inter2 
integer sendbuf,recvbuf,tag,stat(MPI_STATUS_SIZE) 

tag = 22 
sendbuf = 222 

call MPI_Init(ierr) 
call MPI_COMM_RANK(MPI_COMM_WORLD,rank,ierr) 
call MPI_COMM_SIZE(MPI_COMM_WORLD,numtasks,ierr) 

if (rank < 2) then 
color = 0 
else 
color = 1 
end if 

call MPI_COMM_SPLIT(MPI_COMM_WORLD,color,rank,new_comm,ierr) 

if (color .eq. 0) then 
if (rank == 0) print*,' 0 here' 
call MPI_INTERCOMM_CREATE(new_comm,0,MPI_Comm_world,2,tag,inter1,ierr) 
call mpi_send(sendbuf,1,MPI_INT,2,tag,inter1,ierr) 

!local_comm,local leader,peer_comm,remote leader,tag,new,ierr 

else if(color .eq. 1) then 
if(rank ==2) print*,' 2 here' 
call MPI_INTERCOMM_CREATE(new_comm,2,MPI_COMM_WORLD,0,tag,inter2,ierr) 
call mpi_recv(recvbuf,1,MPI_INT,0,tag,inter2,stat,ierr) 
print*,recvbuf 
end if 
end 

Answer 1

Связь с внутренней связью не очень хорошо понятна большинством пользователей, и примеры не столько в качестве примеров для других операций MPI. Вы можете найти хорошее объяснение, следуя this link.

Теперь, есть две вещи, чтобы помнить:

1) Связь в интер коммуникатор всегда идут от одной группы к другой группе. При отправке рангом назначения является его местный рейтинг в удаленном групповом коммуникаторе. При получении ранг отправителя является его локальным рангом в удаленном групповом коммуникаторе.

2) Связь между точками (MPI_send и MPI_recv) находится между одним отправителем и одним приемником. В вашем случае все цвета 0 отправляют и все в цвете 1 принимает, однако, если я понял вашу проблему, вы хотите, чтобы процесс 0 цвета 0 отправил что-то в процесс 0 цвета 1.

Передающий код должен быть что-то вроде этого:

call MPI_COMM_RANK(inter1,irank,ierr) 
if(irank==0)then 
    call mpi_send(sendbuf,1,MPI_INT,0,tag,inter1,ierr) 
end if 

Принимающий код должен выглядеть следующим образом:

call MPI_COMM_RANK(inter2,irank,ierr) 
if(irank==0)then 
    call mpi_recv(recvbuf,1,MPI_INT,0,tag,inter2,stat,ierr) 
    print*,'rec buff = ', recvbuf 
end if 

В примере кода, есть новая переменная irank, которую я использую для запроса ранг каждого процесса в коммуникаторе; это ранг процесса в его локальном коммуникаторе. Таким образом, у вас будет два процесса ранга 0, по одному для каждой группы и т. Д.

Важно подчеркнуть, что другие комментаторы вашего поста говорят: при создании программы в этих современных дней, использовать современные люди конструирует как use mpi вместо include 'mpif.h' см комментарий от Владимира F. Другой посоветуете из вашего предыдущего вопроса было лет использования разряд 0 как дистанционный лидер в обоих случаях. Если я совмещаю эти 2 идеи, ваша программа может выглядеть следующим образом:

program hello 
use mpi !instead of include 'mpif.h' 
implicit none 

    integer :: tag,ierr,rank,numtasks,color,new_comm,inter1,inter2 
    integer :: sendbuf,recvbuf,stat(MPI_STATUS_SIZE) 
    integer :: irank 
    ! 
    tag = 22 
    sendbuf = 222 
    ! 
    call MPI_Init(ierr) 
    call MPI_COMM_RANK(MPI_COMM_WORLD,rank,ierr) 
    call MPI_COMM_SIZE(MPI_COMM_WORLD,numtasks,ierr) 
    ! 
    if (rank < 2) then 
     color = 0 
    else 
     color = 1 
    end if 
    ! 
    call MPI_COMM_SPLIT(MPI_COMM_WORLD,color,rank,new_comm,ierr) 
    ! 
    if (color .eq. 0) then 
     call MPI_INTERCOMM_CREATE(new_comm,0,MPI_Comm_world,2,tag,inter1,ierr) 
    ! 
    call MPI_COMM_RANK(inter1,irank,ierr) 
    if(irank==0)then 
     call mpi_send(sendbuf,1,MPI_INT,0,tag,inter1,ierr) 
    end if 
    ! 
    else if(color .eq. 1) then 
     call MPI_INTERCOMM_CREATE(new_comm,0,MPI_COMM_WORLD,0,tag,inter2,ierr) 
     call MPI_COMM_RANK(inter2,irank,ierr) 
     if(irank==0)then 
      call mpi_recv(recvbuf,1,MPI_INT,0,tag,inter2,stat,ierr) 
      if(ierr/=MPI_SUCCESS)print*,'Error in rec ' 
      print*,'rec buff = ', recvbuf 
     end if 
    end if 
    ! 
    call MPI_finalize(ierr) 
end program h