src/libs/ck-libs/ampi/romio/test/fcoll_test.f.in

   1 ! -*- Mode: Fortran; -*-
   2 !
   3 !  (C) 2001 by Argonne National Laboratory.
   4 !      See COPYRIGHT in top-level directory.
   5 !
   6       program main
   7       implicit none
   8
   9       include 'mpif.h'
  10       @F77MPIOINC@
  11
  12 !     Fortran equivalent of coll_test.c
  13
  14       integer FILESIZE
  15       parameter (FILESIZE=32*32*32*4)
  16
  17 !     A 32^3 array. For other array sizes, change FILESIZE above and
  18 !     array_of_gsizes below.
  19
  20 !     Uses collective I/O. Writes a 3D block-distributed array to a file
  21 !     corresponding to the global array in row-major (C) order, reads it
  22 !     back, and checks that the data read is correct.
  23
  24 !     Note that the file access pattern is noncontiguous.
  25
  26       integer newtype, i, ndims, array_of_gsizes(3)
  27       integer order, intsize, nprocs, j, array_of_distribs(3)
  28       integer array_of_dargs(3), array_of_psizes(3)
  29       integer readbuf(FILESIZE), writebuf(FILESIZE), bufcount
  30       integer mynod, tmpbuf(FILESIZE), array_size, argc, iargc
  31       integer fh, status(MPI_STATUS_SIZE), request, ierr
  32       character*1024 str    ! used to store the filename
  33       integer errs, toterrs
  34       @FORTRAN_MPI_OFFSET@ disp
  35       @FTESTDEFINE@
  36
  37       errs = 0
  38       call MPI_INIT(ierr)
  39       call MPI_COMM_SIZE(MPI_COMM_WORLD, nprocs, ierr)
  40       call MPI_COMM_RANK(MPI_COMM_WORLD, mynod, ierr)
  41
  42 !     process 0 takes the file name as a command-line argument and
  43 !     broadcasts it to other processes
  44
  45       if (mynod .eq. 0) then
  46          argc = @F77IARGC@
  47          i = 0
  48          @F77GETARG@
  49          do while ((i .lt. argc) .and. (str .ne. '-fname'))
  50             i = i + 1
  51             @F77GETARG@
  52          end do
  53          if (i .ge. argc) then
  54             print *
  55             print *, '*#  Usage: fcoll_test -fname filename'
  56             print *
  57             call MPI_ABORT(MPI_COMM_WORLD, 1, ierr)
  58          end if
  59
  60          i = i + 1
  61          @F77GETARG@
  62          call MPI_BCAST(str, 1024, MPI_CHARACTER, 0,                    &
  63      &        MPI_COMM_WORLD, ierr)
  64       else
  65          call MPI_BCAST(str, 1024, MPI_CHARACTER, 0,                    &
  66      &        MPI_COMM_WORLD, ierr)
  67       end if
  68
  69
  70 !     create the distributed array filetype
  71
  72       ndims = 3
  73       order = MPI_ORDER_FORTRAN
  74
  75       array_of_gsizes(1) = 32
  76       array_of_gsizes(2) = 32
  77       array_of_gsizes(3) = 32
  78
  79       array_of_distribs(1) = MPI_DISTRIBUTE_BLOCK
  80       array_of_distribs(2) = MPI_DISTRIBUTE_BLOCK
  81       array_of_distribs(3) = MPI_DISTRIBUTE_BLOCK
  82
  83       array_of_dargs(1) = MPI_DISTRIBUTE_DFLT_DARG
  84       array_of_dargs(2) = MPI_DISTRIBUTE_DFLT_DARG
  85       array_of_dargs(3) = MPI_DISTRIBUTE_DFLT_DARG
  86
  87       do i=1, ndims
  88          array_of_psizes(i) = 0
  89       end do
  90
  91       call MPI_DIMS_CREATE(nprocs, ndims, array_of_psizes, ierr)
  92
  93       call MPI_TYPE_CREATE_DARRAY(nprocs, mynod, ndims,                 &
  94      &     array_of_gsizes, array_of_distribs, array_of_dargs,          &
  95      &     array_of_psizes, order, MPI_INTEGER, newtype, ierr)
  96
  97       call MPI_TYPE_COMMIT(newtype, ierr)
  98
  99 !     initialize writebuf
 100
 101       call MPI_TYPE_SIZE(newtype, bufcount, ierr)
 102       call MPI_TYPE_SIZE(MPI_INTEGER, intsize, ierr)
 103       bufcount = bufcount/intsize
 104       do i=1, bufcount
 105          writebuf(i) = 1
 106       end do
 107
 108       do i=1, FILESIZE
 109          tmpbuf(i) = 0
 110       end do
 111
 112       call MPI_IRECV(tmpbuf, 1, newtype, mynod, 10, MPI_COMM_WORLD,     &
 113      &     request, ierr)
 114       call MPI_SEND(writebuf, bufcount, MPI_INTEGER, mynod, 10,         &
 115      &     MPI_COMM_WORLD, ierr)
 116       call MPI_WAIT(request, status, ierr)
 117
 118       j = 1
 119       array_size = array_of_gsizes(1) * array_of_gsizes(2) *            &
 120      &     array_of_gsizes(3)
 121       do i=1, array_size
 122          if (tmpbuf(i) .ne. 0) then
 123             writebuf(j) = i
 124             j = j + 1
 125          end if
 126       end do
 127
 128 !     end of initialization
 129
 130 !     write the array to the file
 131
 132       call MPI_FILE_OPEN(MPI_COMM_WORLD, str,                           &
 133      &     MPI_MODE_CREATE+MPI_MODE_RDWR, MPI_INFO_NULL, fh, ierr)
 134
 135       disp = 0
 136       call MPI_FILE_SET_VIEW(fh, disp, MPI_INTEGER, newtype, "native",  &
 137      &     MPI_INFO_NULL, ierr)
 138       call MPI_FILE_WRITE_ALL(fh, writebuf, bufcount, MPI_INTEGER,      &
 139      &     status, ierr)
 140       call MPI_FILE_CLOSE(fh, ierr)
 141
 142 !    now read it back
 143
 144       call MPI_FILE_OPEN(MPI_COMM_WORLD, str,                           &
 145      &     MPI_MODE_CREATE+MPI_MODE_RDWR, MPI_INFO_NULL, fh, ierr)
 146
 147       call MPI_FILE_SET_VIEW(fh, disp, MPI_INTEGER, newtype, "native",  &
 148      &     MPI_INFO_NULL, ierr)
 149       call MPI_FILE_READ_ALL(fh, readbuf, bufcount, MPI_INTEGER,        &
 150      &     status, ierr)
 151       call MPI_FILE_CLOSE(fh, ierr)
 152
 153 !     check the data read
 154       do i=1, bufcount
 155          if (readbuf(i) .ne. writebuf(i)) then
 156             errs = errs + 1
 157              print *, 'Node ', mynod, '  readbuf ', readbuf(i),         &
 158      &          '  writebuf ', writebuf(i), '  i', i
 159          end if
 160       end do
 161
 162       call MPI_TYPE_FREE(newtype, ierr)
 163       call MPI_Allreduce( errs, toterrs, 1, MPI_INTEGER, MPI_SUM,       &
 164      $     MPI_COMM_WORLD, ierr )
 165       if (mynod .eq. 0) then
 166         if( toterrs .gt. 0 ) then
 167            print *, 'Found ', toterrs, ' errors'
 168         else
 169            print *, ' No Errors'
 170         endif
 171       endif
 172
 173       call MPI_FINALIZE(ierr)
 174
 175       stop
 176       end