fmisc.f.in

fortran并行计算包

! -*- Mode: Fortran; -*- 
!  
!  (C) 2001 by Argonne National Laboratory.
!      See COPYRIGHT in top-level directory.
!
      program main
      implicit none

      include 'mpif.h'
      @F77MPIOINC@

!     Fortran equivalent of misc.c
!     tests various miscellaneous functions.

      integer buf(1024), amode, fh, status(MPI_STATUS_SIZE)
      logical flag
      integer ierr, newtype, i, group
      integer etype, filetype, mynod, argc, iargc
      integer errs, toterrs
      logical verbose
      character*7 datarep
      character*1024 str    ! used to store the filename
      @FORTRAN_MPI_OFFSET@ disp, offset, filesize
      @FTESTDEFINE@

      errs = 0
      verbose = .false.
      call MPI_INIT(ierr)
      call MPI_COMM_RANK(MPI_COMM_WORLD, mynod, ierr)

!     process 0 takes the file name as a command-line argument and 
!     broadcasts it to other processes

      if (mynod .eq. 0) then
         argc = @F77IARGC@
         i = 0
         @F77GETARG@
         do while ((i .lt. argc) .and. (str .ne. '-fname'))
            i = i + 1
            @F77GETARG@
         end do
         if (i .ge. argc) then
            print *
            print *, '*#  Usage: fmisc -fname filename'
            print *
            call MPI_ABORT(MPI_COMM_WORLD, 1, ierr)
         end if

         i = i + 1
         @F77GETARG@
         call MPI_BCAST(str, 1024, MPI_CHARACTER, 0,                    &
     &        MPI_COMM_WORLD, ierr)
      else 
         call MPI_BCAST(str, 1024, MPI_CHARACTER, 0,                    &
     &        MPI_COMM_WORLD, ierr)
      end if


      call MPI_FILE_OPEN(MPI_COMM_WORLD, str,                           &
     &     MPI_MODE_CREATE + MPI_MODE_RDWR, MPI_INFO_NULL, fh, ierr)

      call MPI_FILE_WRITE(fh, buf, 1024, MPI_INTEGER, status, ierr)

      call MPI_FILE_SYNC(fh, ierr)

      call MPI_FILE_GET_AMODE(fh, amode, ierr)
      if (mynod .eq. 0 .and. verbose) then
         print *, ' testing MPI_FILE_GET_AMODE'
      end if
      if (amode .ne. (MPI_MODE_CREATE + MPI_MODE_RDWR)) then
         errs = errs + 1
         print *, 'amode is ', amode, ', should be ', MPI_MODE_CREATE   &
     &           + MPI_MODE_RDWR
      end if

      call MPI_FILE_GET_ATOMICITY(fh, flag, ierr)
      if (flag) then
         errs = errs + 1
         print *, 'atomicity is ', flag, ', should be .FALSE.'
      end if
      if (mynod .eq. 0 .and. verbose) then
         print *, ' setting atomic mode'
      end if
      call MPI_FILE_SET_ATOMICITY(fh, .TRUE., ierr)
      call MPI_FILE_GET_ATOMICITY(fh, flag, ierr)
      if (.not. flag) then
         errs = errs + 1
         print *, 'atomicity is ', flag, ', should be .TRUE.'
      end if
      call MPI_FILE_SET_ATOMICITY(fh, .FALSE., ierr)
      if (mynod .eq. 0 .and. verbose) then
         print *, ' reverting back to nonatomic mode'
      end if

      call MPI_TYPE_VECTOR(10, 10, 20, MPI_INTEGER, newtype, ierr)
      call MPI_TYPE_COMMIT(newtype, ierr)

      disp = 1000
      call MPI_FILE_SET_VIEW(fh, disp, MPI_INTEGER, newtype, 'native',  & 
     &     MPI_INFO_NULL, ierr)
      if (mynod .eq. 0 .and. verbose) then
         print *, ' testing MPI_FILE_GET_VIEW'
      end if

      disp = 0
      call MPI_FILE_GET_VIEW(fh, disp, etype, filetype, datarep, ierr)
      if ((disp .ne. 1000) .or. (datarep .ne. 'native')) then
         errs = errs + 1
         print *, 'disp = ', disp, ', datarep = ', datarep,             &
     &     ', should be 1000, native'
      end if

      if (mynod .eq. 0 .and. verbose) then
         print *, ' testing MPI_FILE_GET_BYTE_OFFSET'
      end if
      offset = 10
      call MPI_FILE_GET_BYTE_OFFSET(fh, offset, disp, ierr)
      if (disp .ne. 1080) then 
         errs = errs + 1
         print *, 'byte offset = ', disp, ', should be 1080'
      end if

      call MPI_FILE_GET_GROUP(fh, group, ierr)

      if (mynod .eq. 0 .and. verbose) then
         print *, ' setting file size to 1060 bytes'
      end if
      filesize = 1060
      call MPI_FILE_SET_SIZE(fh, filesize, ierr)
      call MPI_BARRIER(MPI_COMM_WORLD, ierr)
      call MPI_FILE_SYNC(fh, ierr)
      filesize = 0
      call MPI_FILE_GET_SIZE(fh, filesize, ierr)
      if (filesize .ne. 1060) then
         errs = errs + 1
         print *, 'file size = ', filesize, ', should be 1060'
      end if
 
      if (mynod .eq. 0 .and. verbose) then
         print *, ' seeking to eof and testing MPI_FILE_GET_POSITION'
      end if
      offset = 0
      call MPI_FILE_SEEK(fh, offset, MPI_SEEK_END, ierr)
      call MPI_FILE_GET_POSITION(fh, offset, ierr)
      if (offset .ne. 10) then 
         errs = errs + 1
         print *, 'file pointer posn = ', offset, ', should be 10'
      end if

      if (mynod .eq. 0 .and. verbose) then
         print *, ' testing MPI_FILE_GET_BYTE_OFFSET'
      end if
      call MPI_FILE_GET_BYTE_OFFSET(fh, offset, disp, ierr)
      if (disp .ne. 1080) then
         errs = errs + 1
         print *, 'byte offset = ', disp, ', should be 1080'
      end if
      call MPI_BARRIER(MPI_COMM_WORLD, ierr)

      if (mynod .eq. 0 .and. verbose) then
         print *, ' testing MPI_FILE_SEEK with MPI_SEEK_CUR'
      end if
      offset = -10
      call MPI_FILE_SEEK(fh, offset, MPI_SEEK_CUR, ierr)
      call MPI_FILE_GET_POSITION(fh, offset, ierr)
      call MPI_FILE_GET_BYTE_OFFSET(fh, offset, disp, ierr)
      if (disp .ne. 1000) then 
         errs = errs + 1
         print *, 'file pointer posn in bytes = ', disp,                &
     &     ', should be 1000'
      end if

      if (mynod .eq. 0 .and. verbose) then
         print *, ' preallocating disk space up to 8192 bytes'
      end if
      filesize = 8192
      call MPI_FILE_PREALLOCATE(fh, filesize, ierr)

      if (mynod .eq. 0 .and. verbose) then
         print *, ' closing the file and deleting it'
      end if
      call MPI_FILE_CLOSE(fh, ierr)

      call MPI_BARRIER(MPI_COMM_WORLD, ierr)
      if (mynod .eq. 0) then
         call MPI_FILE_DELETE(str, MPI_INFO_NULL, ierr)
      end if

      call MPI_Allreduce( errs, toterrs, 1, MPI_INTEGER, MPI_SUM,       &
     $     MPI_COMM_WORLD, ierr )  
      if (mynod .eq. 0) then
        if( toterrs .gt. 0 ) then
           print *, 'Found ', toterrs, ' errors'
        else
           print *, ' No Errors'
        endif
      endif

      call MPI_TYPE_FREE(newtype, ierr)    
      call MPI_TYPE_FREE(filetype, ierr)    
      call MPI_GROUP_FREE(group, ierr)
      call MPI_FINALIZE(ierr)

      stop
      end