! This file created from f77/io/miscfilef.f with f77tof90
! -*- Mode: Fortran; -*-
!
! (C) 2004 by Argonne National Laboratory.
! See COPYRIGHT in top-level directory.
!
program main
use mpi
! iooffset.h provides a variable "offset" that is of type MPI_Offset
! (in Fortran 90, kind=MPI_OFFSET_KIND)
integer (kind=MPI_OFFSET_KIND) offset
! iodisp.h declares disp as an MPI_Offset integer
integer (kind=MPI_OFFSET_KIND) disp
integer rank, size
integer fh, i, group, worldgroup, result
integer ierr, errs
integer BUFSIZE
parameter (BUFSIZE=1024)
integer buf(BUFSIZE)
character*(50) filename
character*(MPI_MAX_DATAREP_STRING) datarep
integer amode
logical atomicity
integer newtype, etype, filetype
integer integer_size, type_size
!
errs = 0
call mtest_init( ierr )
call mpi_comm_rank( MPI_COMM_WORLD, rank, ierr )
call mpi_comm_size( MPI_COMM_WORLD, size, ierr )
!
! Create a file that we'll then query properties
filename = "testfile.txt"
call mpi_file_open( MPI_COMM_WORLD, filename, MPI_MODE_CREATE + &
& MPI_MODE_RDWR, MPI_INFO_NULL, fh, ierr )
if (ierr .ne. MPI_SUCCESS) then
print *, "Unable to create file ", filename
call mpi_abort( MPI_COMM_WORLD, 1, ierr )
endif
!
! Fill in some data
do i=1, BUFSIZE
buf(i) = i
enddo
call mpi_file_write( fh, buf, BUFSIZE, MPI_INTEGER, &
& MPI_STATUS_IGNORE, ierr )
call MPI_File_sync( fh, ierr )
!
! Now, query properties of the file and the file handle
call MPI_File_get_amode(fh, amode, ierr )
if (amode .ne. MPI_MODE_CREATE + MPI_MODE_RDWR) then
errs = errs + 1
print *, " Amode was different than expected"
endif
!
call MPI_File_get_atomicity( fh, atomicity, ierr )
if (atomicity) then
errs = errs + 1
print *, " Atomicity was true but should be false"
endif
!
call MPI_File_set_atomicity( fh, .true., ierr )
call MPI_File_get_atomicity( fh, atomicity, ierr )
if (.not. atomicity) then
errs = errs + 1
print *, " Atomicity was set to true but ", &
& "get_atomicity returned false"
endif
call MPI_File_set_atomicity( fh, .false., ierr )
!
! FIXME: original code use 10,10,20, and the following code
! assumed the original
!
! Create a vector type of 10 elements, each of 20 elements, with a stride of
! 30 elements
call mpi_type_vector( 10, 20, 30, MPI_INTEGER, newtype, ierr )
call mpi_type_commit( newtype, ierr )
!
! All processes are getting the same view, with a 1000 byte offset
offset = 1000
call mpi_file_set_view( fh, offset, MPI_INTEGER, newtype, "native" &
& , MPI_INFO_NULL, ierr )
call mpi_file_get_view( fh, offset, etype, filetype, datarep, ierr &
& )
if (offset .ne. 1000) then
print *, " displacement was ", offset, ", expected 1000"
errs = errs + 1
endif
if (datarep .ne. "native") then
print *, " data representation form was ", datarep, &
& ", expected native"
errs = errs + 1
endif
! Find the byte offset, given an offset of 20 etypes relative to the
! current view (the same as the blockcount of the filetype, which
! places it at the beginning of the next block, hence a stride
! distance away).
offset = 20
call mpi_file_get_byte_offset( fh, offset, disp, ierr )
call mpi_type_size( MPI_INTEGER, integer_size, ierr )
if (disp .ne. 1000 + 30 * integer_size) then
errs = errs + 1
print *, " (offset20)Byte offset = ", disp, ", should be ", &
& 1000+20*integer_size
endif
!
! We should also compare file and etypes. We just look at the
! sizes and extents for now
call mpi_type_size( etype, type_size, ierr )
if (type_size .ne. integer_size) then
print *, " Etype has size ", type_size, ", but should be ", &
& integer_size
errs = errs + 1
endif
call mpi_type_size( filetype, type_size, ierr )
if (type_size .ne. 10*20*integer_size) then
print *, " filetype has size ", type_size, ", but should be ", &
& 10*20*integer_size
errs = errs + 1
endif
!
! Only free derived type
call mpi_type_free( filetype, ierr )
call mpi_file_get_group( fh, group, ierr )
call mpi_comm_group( MPI_COMM_WORLD, worldgroup, ierr )
call mpi_group_compare( group, worldgroup, result, ierr )
if (result .ne. MPI_IDENT) then
print *, " Group of file does not match group of comm_world"
errs = errs + 1
endif
call mpi_group_free( group, ierr )
call mpi_group_free( worldgroup, ierr )
offset = 1000+25*integer_size
call mpi_file_set_size(fh, offset, ierr )
call mpi_barrier(MPI_COMM_WORLD, ierr )
call mpi_file_sync(fh, ierr )
call mpi_file_get_size( fh, offset, ierr )
if (offset .ne. 1000+25*integer_size) then
errs = errs + 1
print *, " File size is ", offset, ", should be ", 1000 + 25 &
& * integer_size
endif
!
! File size is 1000+25ints. Seek to end. Note that the file size
! places the end of the file into the gap in the view, so seeking
! to the end, which is relative to the view, needs to give the end
! of the first block of 20 ints)
offset = 0
call mpi_file_seek( fh, offset, MPI_SEEK_END, ierr )
call mpi_file_get_position( fh, disp, ierr )
if (disp .ne. 20) then
errs = errs + 1
print *, "File pointer position = ", disp, ", should be 20"
if (disp .eq. 25) then
! See MPI 2.1, section 13.4, page 399, lines 7-8. The disp must be
! relative to the current view, in the etype units of the current view
print *, " MPI implementation failed to position the "// &
& "displacement within the current file view"
endif
! Make sure we use the expected position in the next step.
disp = 20
endif
call mpi_file_get_byte_offset(fh, disp, offset, ierr )
if (offset .ne. 1000+30*integer_size) then
errs = errs + 1
print *, " (seek)Byte offset = ", offset, ", should be ", 1000 &
& +30*integer_size
endif
call mpi_barrier(MPI_COMM_WORLD, ierr )
offset = -20
call mpi_file_seek(fh, offset, MPI_SEEK_CUR, ierr )
call mpi_file_get_position(fh, disp, ierr )
call mpi_file_get_byte_offset(fh, disp, offset, ierr )
if (offset .ne. 1000) then
errs = errs + 1
print *, " File pointer position in bytes = ", offset, &
& ", should be 1000"
endif
offset = 8192
call mpi_file_preallocate(fh, offset, ierr )
offset = 0
call mpi_file_get_size( fh, offset, ierr )
if (offset .lt. 8192) then
errs = errs + 1
print *, " Size after preallocate is ", offset, &
& ", should be at least 8192"
endif
call mpi_file_close( fh, ierr )
call mpi_barrier(MPI_COMM_WORLD, ierr )
if (rank .eq. 0) then
call MPI_File_delete(filename, MPI_INFO_NULL, ierr )
endif
call mpi_type_free( newtype, ierr )
call mtest_finalize( errs )
end