我现在想使用allgather来重建3D数组。声称有16个杯子，Y-Z平面的数据被分成4 * 4个部分。 此外，为方便起见，还创建了一种新类型（newtype）。 错误是否与此新类型相关，谢谢！
!==================================================================================================================================
!****** [ Program main ] ********************************************************************************************************
!==================================================================================================================================
program main
Use mpi
implicit none
integer i, j, k, count, realsize
integer, parameter :: nx = 8, ny = 8, nz = 8
Integer :: interval
real(4), dimension(nx,ny,nz):: u_xyz
Real(4),dimension(:,:,:), allocatable :: Temp0
! === MPI Related ===
Integer, Parameter :: master = 0
Integer :: ierr, num_procs, myid, p_row, p_col, newtype, resizedtype
integer, save :: MPI_COMM_CART
integer, dimension(2) :: dims, coord
Integer, Dimension(2) :: R_coord, C_coord, MPGD
Integer, Dimension(3) :: sizes, subsizes, starts
integer,dimension(:),allocatable :: displacement
integer(kind=mpi_address_kind) :: lb, extent
logical, dimension(2) :: periodic
!--------------=======--------------
! Initialize MPI
!
call MPI_Init ( ierr )
!
! Get the number of processes.
!
call MPI_Comm_size ( MPI_COMM_WORLD, num_procs, ierr )
!
! Get the individual process ID.
!
call MPI_Comm_rank ( MPI_COMM_WORLD, myid, ierr )
!--------------=======--------------
! Y-Z PLANE SPLIT
!--------------=======--------------
p_row = 4; p_col = 4
If(p_row*p_col .NE. num_procs) Print *, 'Wrong CPU Numbers'
!--------------=======--------------
dims(1) = p_row
dims(2) = p_col
periodic(1) = .false.
periodic(2) = .false.
call MPI_CART_CREATE(MPI_COMM_WORLD,2,dims,periodic, &
.false., & ! do not reorder rank
MPI_COMM_CART, ierr)
call MPI_CART_COORDS(MPI_COMM_CART,myid,2,coord,ierr)
!--------------=======--------------
!----------YZ Plane Locations-----
!--------------=======--------------
Interval = Ceiling(dble(ny)/dble(p_row))
If (coord(1) .NE. p_row-1 ) then
R_coord(1) = 1 + (coord(1))*Interval
R_coord(2) = R_coord(1) + Interval - 1
Else
R_coord(1) = 1 + coord(1)*Interval
R_coord(2) = ny
End If
Interval = Ceiling(dble(nz)/dble(p_col))
If (coord(2) .NE. p_col-1 ) then
C_coord(1) = 1 + (coord(2))*Interval
C_coord(2) = C_coord(1) + Interval - 1
Else
C_coord(1) = 1 + (coord(2))*Interval
C_coord(2) = nz
End If
!--------------=======--------------
!----------Obtain displacement-----
!--------------=======--------------
! COUNT = 0
! DO K=1,nz
! DO J=1,ny
! DO I=1,nx
! If(i==1.and.j== R_coord(1).and.k==C_coord(1)) print *, myid, R_coord(1), C_coord(1), COUNT
! COUNT = COUNT + 1
! ENDDO
! ENDDO
! ENDDO
allocate(Temp0(nx,R_coord(1):R_coord(2),C_coord(1):C_coord(2)))!
allocate(displacement(num_procs))
Do k=C_coord(1),C_coord(2)
Do j=R_coord(1),R_coord(2)
Do i=1,nx
u_xyz(i,j,k)= i+j+k
End Do; End Do
End Do
Do i=0,num_procs-1
displacement(i)= (i/4)*(16) + mod(i,4)*128
! if(myid==0) print *, i, displacement(i)
Enddo
!--------------=======--------------
! --- Create the same block type ---
!--------------=======--------------
sizes(1) = nx
sizes(2) = ny
sizes(3) = nz
subsizes(1) = nx
subsizes(2) = R_coord(2)-R_coord(1)+1
subsizes(3) = C_coord(2)-C_coord(1)+1
starts(1) = 0 ! 0-based index
starts(2) = 0
starts(3) = 0
call MPI_TYPE_CREATE_SUBARRAY(3, sizes, subsizes, starts, &
MPI_ORDER_FORTRAN, MPI_REAL, newtype, ierr)
call MPI_Type_size(MPI_REAL, realsize, ierr)
extent = 1*realsize
lb = 0
call MPI_Type_create_resized(newtype, lb, extent, resizedtype, ierr)
call MPI_Type_commit(resizedtype, ierr)
Call MPI_Allgather(Temp0(1,R_coord(1),C_coord(1)),resizedtype, &
1, u_xyz, resizedtype, displacement, &
1, MPI_COMM_WORLD)
call MPI_TYPE_FREE(newtype,ierr)
777 Format(15e25.16e3)
Call MPI_Barrier(MPI_COMM_WORLD, ierr)
Call MPI_Finalize ( ierr )
stop
end program main
代码有一些错误消息如下：
[desktop:18885] *** An error occurred in MPI_Allgather
[desktop:18885] *** reported by process [139648622723073,139646566662149]
[desktop:18885] *** on communicator MPI_COMM_SELF
[desktop:18885] *** MPI_ERR_TYPE: invalid datatype
[desktop:18885] *** MPI_ERRORS_ARE_FATAL (processes in this communicator will now abort,
[desktop:18885] *** and potentially your MPI job)
-------------------------------------------------------
Primary job terminated normally, but 1 process returned
a non-zero exit code.. Per user-direction, the job has been aborted.
-------------------------------------------------------
--------------------------------------------------------------------------
mpirun detected that one or more processes exited with non-zero status, thus causing
the job to be terminated. The first process to do so was:
Process name: [[31373,1],0]
Exit code: 3
--------------------------------------------------------------------------
[desktop:18878] 7 more processes have sent help message help-mpi-errors.txt / mpi_errors_are_fatal
[desktop:18878] Set MCA parameter "orte_base_help_aggregate" to 0 to see all help / error messages
答案 0 :(得分：0)
正确的代码。感谢上面的评论。在定义类型时应小心，例如。
recvcounts 整数数组（长度为组大小），包含从每个进程接收的元素数
displs 整数数组（长度为组大小）。条目i指定放置传入的位移（相对于recvbuf） 来自进程i recvtype的数据
!==================================================================================================================================
!****** [ Program main ] ********************************************************************************************************
!==================================================================================================================================
program main
Use mpi
implicit none
integer i, j, k,ii
integer count, realsize
integer, parameter :: nx = 8, ny = 8, nz = 8
Integer :: interval
real(4), dimension(nx*ny*nz):: u_xyz
Real(4),dimension(:,:,:), allocatable :: Temp0
! === MPI Related ===
Integer, Parameter :: master = 0
Integer :: ierr, num_procs, myid, p_row, p_col, newtype, resizedsd, resizedrv
integer, save :: MPI_COMM_CART
integer, dimension(2) :: dims, coord
Integer, Dimension(2) :: R_coord, C_coord, MPGD
Integer, Dimension(3) :: sizes, subsizes, starts
integer,dimension(:),allocatable :: displacement, recvcnt
integer(kind=mpi_address_kind) :: lb, extent
logical, dimension(2) :: periodic
!--------------=======--------------
! Initialize MPI
!
call MPI_Init ( ierr )
!
! Get the number of processes.
!
call MPI_Comm_size ( MPI_COMM_WORLD, num_procs, ierr )
!
! Get the individual process ID.
!
call MPI_Comm_rank ( MPI_COMM_WORLD, myid, ierr )
!--------------=======--------------
! Y-Z PLANE SPLIT
!--------------=======--------------
p_row = 4; p_col = 4
If(p_row*p_col .NE. num_procs) Print *, 'Wrong CPU Numbers'
!--------------=======--------------
dims(1) = p_row
dims(2) = p_col
periodic(1) = .false.
periodic(2) = .false.
call MPI_CART_CREATE(MPI_COMM_WORLD,2,dims,periodic, &
.false., & ! do not reorder rank
MPI_COMM_CART, ierr)
call MPI_CART_COORDS(MPI_COMM_CART,myid,2,coord,ierr)
!--------------=======--------------
!----------YZ Plane Locations-----
!--------------=======--------------
Interval = Ceiling(dble(ny)/dble(p_row))
If (coord(1) .NE. p_row-1 ) then
R_coord(1) = 1 + (coord(1))*Interval
R_coord(2) = R_coord(1) + Interval - 1
Else
R_coord(1) = 1 + coord(1)*Interval
R_coord(2) = ny
End If
Interval = Ceiling(dble(nz)/dble(p_col))
If (coord(2) .NE. p_col-1 ) then
C_coord(1) = 1 + (coord(2))*Interval
C_coord(2) = C_coord(1) + Interval - 1
Else
C_coord(1) = 1 + (coord(2))*Interval
C_coord(2) = nz
End If
!--------------=======--------------
!----------Obtain displacement-----
!--------------=======--------------
! COUNT = 0
! DO K=1,nz
! DO J=1,ny
! DO I=1,nx
! If(i==1.and.j== R_coord(1).and.k==C_coord(1)) print *, myid, R_coord(1), C_coord(1), COUNT
! COUNT = COUNT + 1
! ENDDO
! ENDDO
! ENDDO
allocate(Temp0(1:nx,R_coord(1):R_coord(2),C_coord(1):C_coord(2)))!
allocate(displacement(num_procs),recvcnt(num_procs))
Do k=C_coord(1),C_coord(2)
Do j=R_coord(1),R_coord(2)
Do i=1,nx
Temp0(i,j,k)= i+j*10+k*100
End Do; End Do
End Do
Do i=1,num_procs
ii = i-1
displacement(i)= (ii/4)*(16) + mod(ii,4)*128
! if(myid==0) print *, i, displacement(i)
Enddo
!--------------=======--------------
! --- Create the same block type ---
!--------------=======--------------
sizes(1) = nx
sizes(2) = ny
sizes(3) = nz
subsizes(1) = nx
subsizes(2) = R_coord(2)-R_coord(1)+1
subsizes(3) = C_coord(2)-C_coord(1)+1
starts(1) = 0 ! 0-based index
starts(2) = 0
starts(3) = 0
recvcnt(:)= 1
call MPI_TYPE_CREATE_SUBARRAY(3, sizes, subsizes, starts, &
MPI_ORDER_FORTRAN, MPI_REAL, newtype, ierr)
call MPI_Type_size(MPI_REAL, realsize, ierr)
extent = 1*realsize
lb = 0
call MPI_Type_create_resized(newtype, lb, extent, resizedrv, ierr)
call MPI_Type_commit(resizedrv, ierr)
Call MPI_AllgatherV(Temp0(1,R_coord(1),C_coord(1)), subsizes(1)*subsizes(2)*subsizes(3), MPI_REAL, &
u_xyz, recvcnt,displacement, resizedrv, MPI_COMM_WORLD, ierr)
call MPI_TYPE_FREE(resizedrv,ierr)
! If(myid.eq.10) then
! Count = 0
! do k=1,nz
! do J=1,ny
! do i=1,nx
! Count = Count + 1
! print*, u_xyz(count)- (i+j*10+k*100), i,j,k
! enddo; enddo; enddo
! end if
777 Format(15e25.16e3)
Call MPI_Barrier(MPI_COMM_WORLD, ierr)
Call MPI_Finalize ( ierr )
stop
end program main