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