Фортерантные производные типы с mpi, проблема выравнивания?

Question

меня проблемы со следующим базовым кодом:

program foo 

    use mpi 

    implicit none 

    type bartype 
    real(8) :: x 
    integer :: i 
    end type bartype 

    integer :: mpi_bar_type 

    integer ::       & 
     count=2,       & 
     blocklengths(2)=(/1,1/),   & 
     types(2)=(/mpi_double_precision, & 
        mpi_integer/) 
    integer(kind=mpi_address_kind) :: displs(2) 
    type(bartype) :: bar, bararray(4) 
    integer :: rank, ierr, i, test(4), addr0 


    call mpi_init(ierr) 
    call mpi_comm_rank(mpi_comm_world, rank, ierr) 

    call mpi_get_address(bar, addr0) 
    call mpi_get_address(bar%x, displs(1)) 
    call mpi_get_address(bar%i, displs(2)) 
    do i=1,2 
    displs(i)=displs(i)-addr0 
    enddo 

    call mpi_type_create_struct(2,blocklengths,displs,types,mpi_bar_type,ierr) 
    call mpi_type_commit(mpi_bar_type,ierr) 

    bararray(:)%x=rank 
    bararray(:)%i=rank 
    test(:)=rank 
    call mpi_bcast(test, 4, mpi_integer, 0, mpi_comm_world,ierr) 
    call mpi_bcast(bararray, 4, mpi_bar_type, 0, mpi_comm_world,ierr) 

    call mpi_finalize(ierr) 

end program foo 

я получаю Segfault на производный тип Bcast (с intelMPI и OpenMPI), в отладчике (DDT), он сказал, что это может быть Расстановка проблема ...

Я уже видел this нить, где эта проблема, кажется, то же самое, но я не получил до сих пор нет решения ...

спасибо за помощь!

Answer 1

Просто попробуйте это:

program foo 
    implicit none 
    include 'mpif.h' 

    type bartype 
    real(8) :: x 
    integer :: i 
    end type bartype 

    integer :: mpi_bar_type 

    integer ::       & 
     count=4,       & 
     blocklengths(4)=(/1,1,1,1/),  & 
     types(4)=(/MPI_LB,mpi_double_precision, & 
        mpi_integer,MPI_UB/) 
    integer(kind=mpi_address_kind) :: displs(4) 
    type(bartype) :: bararray(4) 
    integer :: rank, ierr, i, test(4) 


    call mpi_init(ierr) 
    call mpi_comm_rank(mpi_comm_world, rank, ierr) 

    call mpi_get_address(bararray(1), displs(1)) 
    call mpi_get_address(bararray(1)%x, displs(2)) 
    call mpi_get_address(bararray(1)%i, displs(3)) 
    call mpi_get_address(bararray(2), displs(4)) 

    do i=4,1,-1 
    displs(i)=displs(i)-displs(1) 
    enddo 

    call mpi_type_create_struct(4,blocklengths,displs,types,mpi_bar_type,ierr) 
    call mpi_type_commit(mpi_bar_type,ierr) 

    bararray(:)%x=rank 
    bararray(:)%i=rank 
    test(:)=rank 
    print *, "before", bararray 

    call mpi_bcast(test, 4, mpi_integer, 0, mpi_comm_world,ierr) 
    call mpi_bcast(bararray, 4, mpi_bar_type, 0, mpi_comm_world,ierr) 

    print *, "after", bararray 

    call mpi_finalize(ierr) 

end program foo 

Обратите внимание на использование MPI_LB и MPI_UB в качестве дополнительных фиктивных членов структуры. Это делается для обеспечения правильности размеров экстентов. Я не совсем уверен, что это рекомендуемый способ сделать это в соответствии со стандартом, но он всегда работал на меня. Для того, что я знаю, в стандарте говорится добавить bind(C) и sequence к определению вашего типа, но даже если я не уверен, что верхняя граница типа будет работать, так как у вас будет проблема выравнивания, которую я подозреваю.

---

EDIT: после различных замечаний о MPI_LB и MPI_UB, которые действительно устаревшими, и тщательное повторное чтение стандарта, я предполагаю, что следующие работы и должны быть совместимыми.

program foo 
    implicit none 
    include 'mpif.h' 

    type bartype 
    real(8) :: x 
    integer :: i 
    end type bartype 

    integer :: tmp_type, bar_type 

    integer ::       & 
     count=4,       & 
     blocklengths(2)=(/1,1/),   & 
     types(2)=(/mpi_double_precision, & 
        mpi_integer/) 
    integer(kind=mpi_address_kind) :: displs(2), lb, extent 
    type(bartype) :: bararray(4) 
    integer :: rank, ierr, i, test(4) 


    call mpi_init(ierr) 
    call mpi_comm_rank(mpi_comm_world, rank, ierr) 

    call mpi_get_address(bararray(1)%x, displs(1)) 
    call mpi_get_address(bararray(1)%i, displs(2)) 
    call mpi_get_address(bararray(1), lb) 
    call mpi_get_address(bararray(2), extent) 

    do i=1,2 
    displs(i)=displs(i)-lb 
    enddo 
    extent=extent-lb 
    lb=0 

    call mpi_type_create_struct(2,blocklengths,displs,types,tmp_type,ierr) 
    call mpi_type_commit(tmp_type,ierr) 
    call mpi_type_create_resized(tmp_type,lb,extent,bar_type,ierr) 
    call mpi_type_free(tmp_type,ierr) 
    call mpi_type_commit(bar_type,ierr) 

    bararray(:)%x=rank 
    bararray(:)%i=rank 
    test(:)=rank 
    print *, "before", bararray 

    call mpi_bcast(test, 4, mpi_integer, 0, mpi_comm_world,ierr) 
    call mpi_bcast(bararray, 4, bar_type, 0, mpi_comm_world,ierr) 

    print *, "after", bararray 

    call mpi_type_free(bar_type,ierr) 
    call mpi_finalize(ierr) 

end program foo