Разбить двумерный массив по столбцам и использовать все

Question

У меня есть Fortran MPI-код, в котором функция интенсивного вычисления вызывается для каждого элемента 2D-массива. Я пытаюсь разделить задачи между рядами. Например, если есть 30 столбцов и 10 рангов, то каждый ранг получает 3 столбца. Следующий код делает это разделение и собирает результаты, используя allgather. Но окончательный массив не имеет значений из всех рангов.

        program allgather
    include 'mpif.h'
    !create a 2 x 30 myarray
    integer :: x=2,y=30
    integer :: numprocs,myid
    integer :: i,j,k,myelements,mycolumns,jb,je
    integer*4,dimension(:),allocatable :: displacement,recvcnt
    real :: checksum
    real,dimension(:,:),allocatable :: myarr,combinedarr
    call MPI_INIT(IERR)
    call MPI_COMM_SIZE(MPI_COMM_WORLD,NUMPROCS,IERR)
    call MPI_COMM_RANK(MPI_COMM_WORLD,MYID,IERR)
    mycolumns = y/numprocs
    myelements = x * mycolumns
    allocate(displacement(numprocs),recvcnt(numprocs))
    jb = 1 + ( myid * mycolumns ) 
    je = ( myid + 1 ) * mycolumns
    allocate(myarr(x,mycolumns))
    allocate(combinedarr(x,y))
    myarr(:,:) =0
    do j=jb,je
      do i=1,x
       myarr(i,j) = 1
      enddo
    enddo
    !myarr(:,:)=1 
    if(mod(y,numprocs) > 0) then
     if(myid==numprocs-1) then
       jb=(myid + 1) * mycolumns + 1
       do j=jb,y 
        do i=1,x
          myarr(i,j) = 1
        enddo
      enddo 
     endif
    endif
    combinedarr(:,:) =0
    recvcnt(:)=myelements
    do k=1,numprocs
    displacement(k) = (k-1) *myelements
    enddo
    call MPI_ALLGATHERV(myarr,myelements,MPI_REAL,combinedarr,recvcnt,displacement,MPI_REAL,MPI_COMM_WORLD,IERR)
    if(mod(y,numprocs) > 0) then
     recvcnt(:) = 0
     recvcnt(numprocs) = (x*y) - myelements * (numprocs)
     displacement(numprocs) = displacement(numprocs) + myelements
     call MPI_ALLGATHERV(myarr,recvcnt(numprocs),MPI_REAL,combinedarr,recvcnt,displacement,MPI_REAL,MPI_COMM_WORLD,IERR)
    endif
    if (myid==0) then 
    checksum=0
     write(6,*) "mycolumns:",mycolumns,"myelements:",myelements 
    do j=1,y
      do i=1,x
       checksum = checksum + combinedarr(i,j)
      enddo
     enddo
       write(6,*) checksum 
    endif
    end

Answer 1

Прежде всего, вы используете MPI_ALLGATHERV() как только MPI_ALLGATHER() и не получает никакой выгоды от его способности отправлять различное количество элементов из / в каждый процесс. Но это не ошибка в вашей программе. Ошибка заключается в том, как он заполняет myarr, Вы выделяете это как myarr(x,mycolumns) но при заполнении из колонки jb в столбец jeвы проходите через конец массива во всех процессах, кроме ранга 0 поскольку jb а также je больше чем mycolumns там. таким образом myarr содержит только в ранге 0 и нули во всех других рядах. Итак, да, конечный массив не имеет ожидаемых значений, но это потому, что вы заполнили их неправильно, а не из-за способа использования подпрограмм MPI.

Запись после конца выделяемого массива уничтожает скрытые структуры, которые используются для управления распределением кучи, и обычно приводит к сбою программы. В вашем случае вам просто повезло - я запускаю ваш код с Open MPI, и он каждый раз вылетает с дампами ядра.

И вы также пропускаете звонок MPI_FINALIZE() в конце вашего кода.

Подсказка: используйте интерфейс Fortran 90, если доступен - замените include 'mpif.h' с use mpi

Answer 2

Вот окончательная версия кода. Я реализовал исправления, предложенные "Христо Илиевым", а также исправил ту часть, где # или ранги не делят поровну # столбцов. Здесь последний ранг вычисляет оставшиеся столбцы.

    program allgather
    include 'mpif.h'
    !create a 2 x 30 myarray
    integer :: x=4,y=6
    integer :: numprocs,myid
    integer :: i,j,k,myelements,mycolumns,jb,je,jbb
    integer*4,dimension(:),allocatable :: displacement,recvcnt
    real :: checksum
    real,dimension(:,:),allocatable :: myarr,combinedarr
    call MPI_INIT(IERR)
    call MPI_COMM_SIZE(MPI_COMM_WORLD,NUMPROCS,IERR)
    call MPI_COMM_RANK(MPI_COMM_WORLD,MYID,IERR)
    mycolumns = y/numprocs
    myelements = x * mycolumns
    allocate(displacement(numprocs),recvcnt(numprocs))
    jb = 1 + ( myid * mycolumns ) 
    je = ( myid + 1 ) * mycolumns
    allocate(myarr(x,y))
    allocate(combinedarr(x,y))
    myarr(:,:) =0
    do j=jb,je
      do i=1,x
       myarr(i,j) = (j-1) * x + i
      enddo
    enddo
    if(mod(y,numprocs) > 0) then
     if(myid==numprocs-1) then
       jbb=(myid + 1) * mycolumns + 1
       do j=jbb,y 
        do i=1,x
           myarr(i,j) = (j-1) * x + i
        enddo
      enddo 
     endif
    endif
    combinedarr(:,:) =0
    recvcnt(:)=myelements
    do k=1,numprocs
    displacement(k) = (k-1) *myelements
    enddo
    call MPI_ALLGATHERV(myarr(1,jb),myelements,MPI_REAL,combinedarr,recvcnt,displacement,MPI_REAL,MPI_COMM_WORLD,IERR)
    if(mod(y,numprocs) > 0) then
     recvcnt(:) = 0
     recvcnt(numprocs) = (x*y) - myelements * (numprocs)
     displacement(numprocs) = displacement(numprocs) + myelements
     call MPI_ALLGATHERV(myarr(1,jbb),recvcnt(numprocs),MPI_REAL,combinedarr,recvcnt,displacement,MPI_REAL,MPI_COMM_WORLD,IERR)
    endif
    if (myid==0) then 
    checksum=0
     write(6,*) "mycolumns:",mycolumns,"myelements:",myelements 
    do j=1,y
      do i=1,x
       checksum = checksum + combinedarr(i,j)
      enddo
     enddo
       write(6,*) checksum 
    endif
    end