1C -*- Mode: Fortran; -*-
2C
3C  (C) 2004 by Argonne National Laboratory.
4C      See COPYRIGHT in top-level directory.
5C
6      program main
7      implicit none
8      include 'mpif.h'
9      include 'iodisp.h'
10C tests whether atomicity semantics are satisfied for overlapping accesses
11C in atomic mode. The probability of detecting errors is higher if you run
12C it on 8 or more processes.
13C This is a version of the test in romio/test/atomicity.c .
14      integer BUFSIZE
15      parameter (BUFSIZE=10000)
16      integer writebuf(BUFSIZE), readbuf(BUFSIZE)
17      integer i, mynod, nprocs, len, ierr, errs, toterrs
18      character*50 filename
19      integer newtype, fh, info, status(MPI_STATUS_SIZE)
20
21      errs = 0
22
23      call MPI_Init(ierr)
24      call MPI_Comm_rank(MPI_COMM_WORLD, mynod, ierr )
25      call MPI_Comm_size(MPI_COMM_WORLD, nprocs, ierr )
26
27C Unlike the C version, we fix the filename because of the difficulties
28C in accessing the command line from different Fortran environments
29      filename = "testfile.txt"
30C test atomicity of contiguous accesses
31
32C initialize file to all zeros
33      if (mynod .eq. 0) then
34         call MPI_File_delete(filename, MPI_INFO_NULL, ierr )
35         call MPI_File_open(MPI_COMM_SELF, filename, MPI_MODE_CREATE +
36     $        MPI_MODE_RDWR, MPI_INFO_NULL, fh, ierr )
37         do i=1, BUFSIZE
38            writebuf(i) = 0
39         enddo
40         call MPI_File_write(fh, writebuf, BUFSIZE, MPI_INTEGER, status,
41     $        ierr)
42         call MPI_File_close(fh, ierr )
43      endif
44      call MPI_Barrier(MPI_COMM_WORLD, ierr )
45
46      do i=1, BUFSIZE
47         writebuf(i) = 10
48         readbuf(i)  = 20
49      enddo
50
51      call MPI_File_open(MPI_COMM_WORLD, filename, MPI_MODE_CREATE +
52     $     MPI_MODE_RDWR, MPI_INFO_NULL, fh, ierr )
53
54C set atomicity to true
55      call MPI_File_set_atomicity(fh, .true., ierr)
56      if (ierr .ne. MPI_SUCCESS) then
57         print *, "Atomic mode not supported on this file system."
58         call MPI_Abort(MPI_COMM_WORLD, 1, ierr )
59      endif
60
61      call MPI_Barrier(MPI_COMM_WORLD, ierr )
62
63C process 0 writes and others concurrently read. In atomic mode,
64C the data read must be either all old values or all new values; nothing
65C in between.
66
67      if (mynod .eq. 0) then
68         call MPI_File_write(fh, writebuf, BUFSIZE, MPI_INTEGER, status,
69     $        ierr)
70      else
71         call MPI_File_read(fh, readbuf, BUFSIZE, MPI_INTEGER, status,
72     $        ierr )
73         if (ierr .eq. MPI_SUCCESS) then
74            if (readbuf(1) .eq. 0) then
75C              the rest must also be 0
76               do i=2, BUFSIZE
77                  if (readbuf(i) .ne. 0) then
78                     errs = errs + 1
79                     print *, "(contig)Process ", mynod, ": readbuf(", i
80     $                    ,") is ", readbuf(i), ", should be 0"
81                     call MPI_Abort(MPI_COMM_WORLD, 1, ierr )
82                  endif
83               enddo
84            else if (readbuf(1) .eq. 10) then
85C              the rest must also be 10
86               do i=2, BUFSIZE
87                  if (readbuf(i) .ne. 10) then
88                     errs = errs + 1
89                     print *, "(contig)Process ", mynod, ": readbuf(", i
90     $                    ,") is ", readbuf(i), ", should be 10"
91                     call MPI_Abort(MPI_COMM_WORLD, 1, ierr )
92                  endif
93               enddo
94            else
95               errs = errs + 1
96               print *, "(contig)Process ", mynod, ": readbuf(1) is ",
97     $              readbuf(1), ", should be either 0 or 10"
98            endif
99         endif
100      endif
101
102      call MPI_File_close( fh, ierr )
103
104      call MPI_Barrier( MPI_COMM_WORLD, ierr )
105
106
107C repeat the same test with a noncontiguous filetype
108
109      call MPI_Type_vector(BUFSIZE, 1, 2, MPI_INTEGER, newtype, ierr)
110      call MPI_Type_commit(newtype, ierr )
111
112      call MPI_Info_create(info, ierr )
113C I am setting these info values for testing purposes only. It is
114C better to use the default values in practice. */
115      call MPI_Info_set(info, "ind_rd_buffer_size", "1209", ierr )
116      call MPI_Info_set(info, "ind_wr_buffer_size", "1107", ierr )
117
118      if (mynod .eq. 0) then
119         call MPI_File_delete(filename, MPI_INFO_NULL, ierr )
120         call MPI_File_open(MPI_COMM_SELF, filename, MPI_MODE_CREATE +
121     $        MPI_MODE_RDWR, info, fh, ierr )
122        do i=1, BUFSIZE
123           writebuf(i) = 0
124        enddo
125        disp = 0
126        call MPI_File_set_view(fh, disp, MPI_INTEGER, newtype, "native"
127     $       ,info, ierr)
128        call MPI_File_write(fh, writebuf, BUFSIZE, MPI_INTEGER, status,
129     $       ierr )
130        call MPI_File_close( fh, ierr )
131      endif
132      call MPI_Barrier( MPI_COMM_WORLD, ierr )
133
134      do i=1, BUFSIZE
135         writebuf(i) = 10
136         readbuf(i)  = 20
137      enddo
138
139      call MPI_File_open(MPI_COMM_WORLD, filename, MPI_MODE_CREATE +
140     $     MPI_MODE_RDWR, info, fh, ierr )
141      call MPI_File_set_atomicity(fh, .true., ierr)
142      disp = 0
143      call MPI_File_set_view(fh, disp, MPI_INTEGER, newtype, "native",
144     $     info, ierr )
145      call MPI_Barrier(MPI_COMM_WORLD, ierr )
146
147      if (mynod .eq. 0) then
148         call MPI_File_write(fh, writebuf, BUFSIZE, MPI_INTEGER, status,
149     $        ierr )
150      else
151         call MPI_File_read(fh, readbuf, BUFSIZE, MPI_INTEGER, status,
152     $        ierr )
153         if (ierr .eq. MPI_SUCCESS) then
154            if (readbuf(1) .eq. 0) then
155               do i=2, BUFSIZE
156                  if (readbuf(i) .ne. 0) then
157                     errs = errs + 1
158                     print *, "(noncontig)Process ", mynod, ": readbuf("
159     $                    , i,") is ", readbuf(i), ", should be 0"
160                     call MPI_Abort(MPI_COMM_WORLD, 1, ierr )
161                  endif
162               enddo
163            else if (readbuf(1) .eq. 10) then
164               do i=2, BUFSIZE
165                  if (readbuf(i) .ne. 10) then
166                     errs = errs + 1
167                     print *, "(noncontig)Process ", mynod, ": readbuf("
168     $                    , i,") is ", readbuf(i), ", should be 10"
169                     call MPI_Abort(MPI_COMM_WORLD, 1, ierr )
170                  endif
171               enddo
172            else
173               errs = errs + 1
174               print *, "(noncontig)Process ", mynod, ": readbuf(1) is "
175     $              ,readbuf(1), ", should be either 0 or 10"
176            endif
177         endif
178      endif
179
180      call MPI_File_close( fh, ierr )
181
182      call MPI_Barrier(MPI_COMM_WORLD, ierr )
183
184      call MPI_Allreduce( errs, toterrs, 1, MPI_INTEGER, MPI_SUM,
185     $     MPI_COMM_WORLD, ierr )
186      if (mynod .eq. 0) then
187         if( toterrs .gt. 0) then
188            print *, "Found ", toterrs, " errors"
189         else
190            print *, " No Errors"
191         endif
192      endif
193
194      call MPI_Type_free(newtype, ierr )
195      call MPI_Info_free(info, ierr )
196
197      call MPI_Finalize(ierr)
198      end
199