shpositionf90.f90

fortran并行计算包

! This file created from test/mpi/f77/io/shpositionf.f with f77tof90
! -*- Mode: Fortran; -*-
!
!  (C) 2003 by Argonne National Laboratory.
!      See COPYRIGHT in top-level directory.
!
        program main
        use mpi
        integer comm, fh, r, s, i
        integer fileintsize
        integer errs, err, ierr
        character *(100) filename
        integer (kind=MPI_OFFSET_KIND) offset

        integer (kind=MPI_ADDRESS_KIND) aint


        errs = 0
        call MTest_Init( ierr )

        filename = "iotest.txt"
        comm = MPI_COMM_WORLD
        call mpi_comm_size( comm, s, ierr )
        call mpi_comm_rank( comm, r, ierr )
! Try writing the file, then check it
        call mpi_file_open( comm, filename, MPI_MODE_RDWR +  &
      &                      MPI_MODE_CREATE, MPI_INFO_NULL, fh, ierr )
        if (ierr .ne. MPI_SUCCESS) then
           errs = errs + 1
           if (errs .le. 10) then
              call MTestPrintError( ierr )
           endif
        endif
!
! Get the size of an INTEGER in the file
        call mpi_file_get_type_extent( fh, MPI_INTEGER, aint, ierr )
        fileintsize = aint
!
! We let each process write in turn, getting the position after each 
! write
        do i=1, s
           if (i .eq. r + 1) then
              call mpi_file_write_shared( fh, i, 1, MPI_INTEGER,  &
      &            MPI_STATUS_IGNORE, ierr )
           endif
           call mpi_barrier( comm, ierr )
           call mpi_file_get_position_shared( fh, offset, ierr )
           if (offset .ne. fileintsize * i) then
              errs = errs + 1
              print *, r, ' Shared position is ', offset,' should be ', &
      &                 fileintsize * i
           endif
           call mpi_barrier( comm, ierr )
        enddo
        call mpi_file_close( fh, ierr )
        if (r .eq. 0) then
            call mpi_file_delete( filename, MPI_INFO_NULL, ierr )
        endif
        if (ierr .ne. MPI_SUCCESS) then
           errs = errs + 1
           if (errs .le. 10) then
              call MTestPrintError( ierr )
           endif
        endif
!
        call MTest_Finalize( errs )
        call mpi_finalize( ierr )
        end