Большой сбор 2d массивов с MPI Fortran - PullRequest
1 голос
/ 29 марта 2020

Хотите собрать большой двумерный массив в MPI для процесса root

В этом коде нет проблем, когда я использую небольшие массивы, но когда я использую количество строк 360 * 75. Это дает сбой. Используйте 6 процессов. Таким образом, у каждого ведомого есть кусок 60 * 75

program test
    implicit none
    include 'mpif.h' 
    INTEGER :: ierr, size, rank, i, j, k, l, num_angles,slice
    DOUBLE PRECISION :: theta1, theta2, PI
    DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: R
    integer :: doublesize
    integer (kind=MPI_Address_kind) :: start, extent
    integer :: blocktype, resizedtype

    CALL MPI_INIT(ierr)
    CALL MPI_COMM_RANK(MPI_COMM_WORLD,rank,ierr)
    CALL MPI_COMM_SIZE(MPI_COMM_WORLD,size,ierr)

    if (rank == 0) then
        if (allocated(R)) deallocate(R)
        allocate(R(1:360*75,1:10))
    else
       if (allocated(R)) deallocate(R)
       allocate(R(1:60*75,1:10))
    end if
    R = rank

    call MPI_Type_create_subarray(2, [360*75,10], [60*75,10], [0,0],     &
                             MPI_ORDER_FORTRAN, MPI_DOUBLE_PRECISION, &
                             blocktype, ierr)
   start = 0
   call MPI_Type_size(MPI_DOUBLE_PRECISION, doublesize, ierr)
   extent = doublesize * 60*75

   call MPI_Type_create_resized(blocktype, start, extent, resizedtype, ierr)
   call MPI_Type_commit(resizedtype, ierr)

   CALL MPI_GATHER(R, 60*75*10, MPI_DOUBLE_PRECISION, R, 1, resizedtype, 0, MPI_COMM_WORLD, ierr)

   CALL MPI_FINALIZE(ierr)


end program

Вывод на маленьких массивах выглядит как

0 0 0 0
0 0 0 0
1 1 1 1
1 1 1 1
2 2 2 2 
2 2 2 2 

.... 

Может ли быть проблема с выделением памяти в процессе root?

РЕДАКТИРОВАТЬ

изменить код в соответствии с комментарием. Все еще есть ошибка

    CALL MPI_Type_contiguous(60*75*10, MPI_DOUBLE_PRECISION, new_type,ierr)
    call MPI_TYPE_COMMIT(new_type,ierr)
    if (rank == 0) then
        CALL MPI_GATHER(MPI_IN_PLACE, 60*75*10, new_type, R, 1, new_type, 0, MPI_COMM_WORLD, ierr)
    else
        CALL MPI_GATHER(R, 60*75*10, new_type, R, 1, new_type, 0, MPI_COMM_WORLD, ierr)
    end if
    CALL MPI_FINALIZE(ierr)
Добро пожаловать на сайт PullRequest, где вы можете задавать вопросы и получать ответы от других членов сообщества.
...