artu72
artu72

Reputation: 1

Error on file_set_view in a collective mpi_write

I am just trying to write in a collective way in MPI Fortran from a CFD code. In each process, data are divided in blocks, with a general number of cells, and a structure var(b) is created which hosts the two variables r and p of the block b. Then a double MPI structure derived type is created to collect all data in a process, the first type collecting all variables in a block, and the second one all the structures in a block. So, each process has to write one of this double derived datatype, where the offset is evaluated all the data amount in the previous processes (0 for rank 0, all data in the rank 0 for rank 1, and so one). The code is the following

module var_mod

  type vt
    sequence
    double precision,dimension(:,:,:),allocatable :: r,p
  end type vt
  type(vt),target,dimension(:),allocatable :: var

end module var_mod

PROGRAM main

  USE MPI_F08
  USE var_mod

  IMPLICIT NONE

! FILES

  INTEGER,PARAMETER :: NB = 4

  !----------------------------------------------------------------

  INTEGER :: b,i,j,k,me,np
  TYPE(MPI_File) :: mpifh
  INTEGER(KIND=MPI_OFFSET_KIND) :: mpidisp,sum_dim
  integer,dimension(:),allocatable :: ni,nj,nk,mpiblock,mpistride
  integer :: cont,mpierr
  INTEGER,dimension(nb) :: Blocks
  INTEGER(KIND=MPI_ADDRESS_KIND),dimension(:),allocatable :: Offsets,Pos
  INTEGER(KIND=MPI_COUNT_KIND) :: lb, ext8
  TYPE(MPI_Datatype),dimension(:),allocatable :: Elem_Type,Types
  TYPE(MPI_Datatype)  :: All_Type,mpiparflowtype
  TYPE(MPI_Status) :: status
  CHARACTER(LEN=MPI_MAX_ERROR_STRING) :: string
  INTEGER :: resultlen

  !----------------------------------------------------------------

  call mpi_init
  call mpi_comm_size(mpi_comm_world,np)
  call mpi_comm_rank(mpi_comm_world,me)

  allocate (ni(nb))
  allocate (nj(nb))
  allocate (nk(nb))

  allocate (var(nb))

  do b = 1,NB
    ni(b) = b/3+1
    nj(b) = b
    nk(b) = b/5+1
    allocate (var(b)%r(ni(b),nj(b),nk(b)))
    allocate (var(b)%p(ni(b),nj(b),nk(b)))
  END DO
  !
  ! Initialize the data
  !
  do b = 1,nb
    DO k = 1,nk(b)
      DO j = 1,nj(b)
        DO i = 1,ni(b)
          var(b)%r(i,j,k) = 10000*me+1000*b+i*100+j*10+k
          var(b)%p(i,j,k) = -var(b)%r(i,j,k)
        END DO
      END DO
    END DO
  end do

! (1) Create a separate structure datatype for each record

  allocate (Offsets(2),Pos(2),Types(2),Elem_Type(nb))

  DO b = 1,nb
    CALL MPI_GET_ADDRESS(var(b)%r,POS(1))
    CALL MPI_GET_ADDRESS(var(b)%p,POS(2))
    Offsets = POS-POS(1)
    Types = MPI_REAL8
    Blocks = ni(b)*nj(b)*nk(b)
    CALL MPI_TYPE_CREATE_STRUCT(2,Blocks,Offsets,Types,Elem_Type(b),mpierr)
  END DO
  deallocate (Offsets,Pos,Types)

! Create a structure of structures that describes the whole array

  allocate (Offsets(nb),Pos(nb))

  Blocks = 1
  DO b = 1,nb
    CALL MPI_GET_ADDRESS(var(b)%r,POS(b))
  END DO
  Offsets = POS-POS(1)

  CALL MPI_TYPE_CREATE_STRUCT(nb,Blocks,Offsets,Elem_Type,All_Type)
  CALL MPI_TYPE_COMMIT(All_Type,mpierr)

! Free the intermediate datatypes
  DO b = 1,nb
    CALL MPI_TYPE_FREE(Elem_Type(b))
  END DO
  deallocate(Offsets,Pos,Elem_Type)

! Set index

  cont = 1
  allocate(mpiblock(cont))
  allocate(mpistride(cont))
  mpiblock=1
  mpistride=0

  call MPI_TYPE_INDEXED(cont,mpiblock,mpistride,All_Type,mpiparflowtype)
  call MPI_TYPE_COMMIT(mpiparflowtype)
  deallocate(mpiblock,mpistride)

! Position where to write
  CALL MPI_Type_get_extent(MPI_REAL8, lb, ext8)
  mpidisp = 0
  do b = 1,nb
    mpidisp = mpidisp + (ni(b)*nj(b)*nk(b)) ! number of cell in the block b
  end do
  mpidisp = mpidisp*2*ext8*me  !multiply for number of variables and byte of each variable and shif to the process rank

! Open file
  call MPI_FILE_OPEN(MPI_COMM_WORLD,'MPIDATA',IOR(MPI_MODE_CREATE,MPI_MODE_WRONLY),MPI_INFO_NULL,mpifh)

! setting file view
  call MPI_FILE_SET_VIEW(mpifh,mpidisp,All_Type,mpiparflowtype,'native',MPI_INFO_NULL,mpierr)

  write(*,*) me,'error on file set view:',mpierr
  call MPI_Error_string(mpierr, string, resultlen)
  write(*,*) 'string:',trim(string),resultlen

! MPI Write file
  call MPI_FILE_WRITE_ALL(mpifh,var(1)%r,1,All_Type,status)

! Close file
  call MPI_FILE_CLOSE(mpifh)

! deallocations and free
  CALL MPI_TYPE_FREE(All_Type)
  CALL MPI_TYPE_FREE(mpiparflowtype)

  do b = 1,nb
    deallocate (var(b)%r,var(b)%p)
  END DO
  deallocate (var)
  deallocate (ni,nj,nk)

! end
  call mpi_finalize

END PROGRAM main

When the code is launched, for instance, on two processes (both Intel and gnu compilers no problem in compilation phase), the run concludes but an error MPI_TYPE_ERR in MPI_FILE_SET_VIEW is issued and the data file contains only rank 0 data.

I would expect a file with data from all ranks, but I can not understand what the problem is.

Upvotes: 0

Views: 59

Answers (0)

Related Questions