Partition a 3D array AND use allgather - fortran

Question

I now want to use the allgather to rebuild a 3D array. 16 cups are claimed and the data of the Y-Z plane are partitioned into 4*4 parts.
Also a new type (newtype) is created for convenience.
Are the errors related to this new type, Thanks!
!==================================================================================================================================
!****** [ 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
The code had some error messages as follows:
[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

Answer 1

The correct code. Thanks to the comments above. Care should be taken when defining the type, such as.
recvcounts
integer array (of length group size) containing the number of elements that are to be received from each process
displs
integer array (of length group size). Entry i specifies the displacement (relative to recvbuf ) at which to place the incoming
data from process 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