DISPATCH
mpi_file_mod.f90
1 !*******************************************************************************
2 !> Module for handling blocking and non-blocking MPI parallel I/O to a single file.
3 !*******************************************************************************
5  USE mpi_mod, only: mp=>mpi
6  USE omp_mod
7  USE omp_timer_mod
8  USE io_mod
9  USE trace_mod
10 #ifdef MPI
11  USE mpi
12 #endif
13  implicit none
14  private
15  type, public:: mpi_file_t
16  integer:: handle = 0
17  integer:: comm = 0
18  integer:: mode = 0
19  integer:: err = 0
20  logical:: closed=.true.
21  character(len=64):: filename
22  contains
23  procedure:: request_open
24  procedure:: request_close
25  procedure:: open_and_close
26  procedure:: open
27  procedure:: openw
28  procedure:: openr
29  procedure:: close
30  procedure, private:: write1
31  procedure, private:: write5
32  generic, public :: write => write1, write5
33  procedure:: assert
34  end type
35 #ifndef MPI
36  integer:: mpi_real=1, mpi_status_size=8
37 #endif
38  integer, save:: verbose=2
39 CONTAINS
40 
41 !===============================================================================
42 !> Request that a file is opened, when convenient
43 !===============================================================================
44 SUBROUTINE request_open (self, filename)
45  class(mpi_file_t):: self
46  character(len=*) filename
47  character(len=120):: id = &
48  '$Id: 1baebf6720d4e419e467bb40548dc47c63ba7563 $ mpi/mpi_file_mod.f90'
49  !-----------------------------------------------------------------------------
50  call trace%begin ('mpi_file_t%request_open')
51  call trace%print_id (id)
52 #ifdef MPI
53  if (self%closed) then
54  self%mode = mpi_mode_create + mpi_mode_rdwr
55  self%filename = filename
56  self%closed = .false.
57  end if
58 #endif
59  call trace%end()
60 END SUBROUTINE request_open
61 
62 !===============================================================================
63 !> Request that a file is closed, when convenient
64 !===============================================================================
65 SUBROUTINE request_close (self)
66  class(mpi_file_t):: self
67  !-----------------------------------------------------------------------------
68  call trace%begin ('mpi_file_t%request_close')
69  self%closed = .true.
70  call trace%end()
71 END SUBROUTINE request_close
72 
73 !===============================================================================
74 !> Make a files actual status match the requested status
75 !===============================================================================
76 SUBROUTINE open_and_close (self)
77  class(mpi_file_t):: self
78  !-----------------------------------------------------------------------------
79  call trace%begin ('mpi_file_t%open_and_close',2)
80  if (self%closed .and. self%handle/=0) then
81  call self%close ()
82  write(io_unit%mpi,'(g12.5,i4,2x,a)') wallclock(), omp%thread, &
83  'mpi_file_t%open_and_close: closed '//trim(self%filename)
84  flush (io_unit%mpi)
85  else if (.not. self%closed .and. self%handle==0) then
86  call self%openw (self%filename)
87  write(io_unit%mpi,'(g12.5,i4,2x,a)') wallclock(), omp%thread, &
88  'mpi_file_t%open_and_close: opened '//trim(self%filename)
89  flush (io_unit%mpi)
90  end if
91  call trace%end()
92 END SUBROUTINE open_and_close
93 
94 !===============================================================================
95 !> Open a file with given mode, and given local size self%lsize. It is not
96 !> necessary that all threads execute this code, but at least one thread must
97 !> do it, before other threads can use the file.
98 !===============================================================================
99 SUBROUTINE open (self, filename, mode)
100  class(mpi_file_t):: self
101  character(len=*) filename
102  integer:: mode
103  !.............................................................................
104  integer:: n
105 #ifdef MPI
106  integer(kind=MPI_OFFSET_KIND):: pos
107 #endif
108  !-----------------------------------------------------------------------------
109 #ifdef MPI
110  !call mp%barrier ('mpi_file_t%open')
111  if (self%handle == 0) then
112  self%filename = filename
113  call mpi_file_open (mp%comm, filename, mode, mpi_info_null, self%handle, self%err)
114  if (io%verbose > 0) then
115  write(io_unit%mpi,'(a," status:",i4)') &
116  ' MPI_File_open: file='//trim(filename)//' mode='// &
117  trim(merge('MPI_MODE_CREATE', &
118  ' ' ,iand(mode,mpi_mode_create) .ne. 0)) // &
119  trim(merge('+MPI_MODE_RDWR' , &
120  ' ' ,iand(mode,mpi_mode_rdwr) .ne. 0)) // &
121  trim(merge('MPI_MODE_RDONLY', &
122  ' ' ,iand(mode,mpi_mode_rdonly) .ne. 0)), self%err
123  flush (io_unit%mpi)
124  end if
125  end if
126  self%closed = .false.
127 #endif
128 END SUBROUTINE open
129 
130 !===============================================================================
131 !> Open a file for writing, relieving the user from having to remember (and
132 !> having access to) the appropriate mode integers
133 !===============================================================================
134 SUBROUTINE openw (self, filename, recl)
135  class(mpi_file_t):: self
136  character(len=*) filename
137  integer, optional:: recl
138  integer mode
139  !-----------------------------------------------------------------------------
140  call trace%begin ('mpi_file_t%openw')
141 #ifdef MPI
142  if (mp%mode == mpi_thread_multiple) then
143  call self%open (filename, mpi_mode_create + mpi_mode_rdwr)
144  else
145  !$omp critical (mpi_cr)
146  call self%open (filename, mpi_mode_create + mpi_mode_rdwr)
147  !$omp end critical (mpi_cr)
148  end if
149 #endif
150  if (present(recl)) then
151  write (io%output,*) 'open:', trim(filename), recl
152  open (unit=io_unit%direct, file=filename, access='direct', recl=recl, &
153  status='unknown')
154  end if
155  call trace%end()
156 END SUBROUTINE openw
157 
158 !===============================================================================
159 !> Open a file for reading, releaving the user from having to remember (and
160 !> having access to) the appropriate mode integers
161 !===============================================================================
162 SUBROUTINE openr (self, filename)
163  class(mpi_file_t):: self
164  character(len=*) filename
165  integer mode
166  !-----------------------------------------------------------------------------
167  call trace%begin ('mpi_file_t%openr')
168 #ifdef MPI
169  if (mp%mode == mpi_thread_multiple) then
170  call self%open (filename, mpi_mode_rdonly)
171  else
172  !$omp critical (mpi_cr)
173  call self%open (filename, mpi_mode_rdonly)
174  !$omp end critical (mpi_cr)
175  end if
176 #endif
177  call trace%end()
178 END SUBROUTINE openr
179 
180 !===============================================================================
181 !> Close a file that is open for MPI parallel I/O. It is not necessary that all
182 !> threads execute this code, but all threads must have finalized I/O before one
183 !> thread closes the file here. This may require an !$omp barrier in the calling
184 !> code.
185 !===============================================================================
186 SUBROUTINE close (self)
187  class(mpi_file_t):: self
188  !-----------------------------------------------------------------------------
189  call trace%begin ('mpi_file_t%close')
190 #ifdef MPI
191  if (self%handle /= 0) then
192  if (mp%mode == mpi_thread_multiple) then
193  call mpi_file_close (self%handle, self%err)
194  else
195  !$omp critical (mpi_cr)
196  call mpi_file_close (self%handle, self%err)
197  !$omp end critical (mpi_cr)
198  end if
199  if (io%verbose > 0) then
200  write (io_unit%mpi,'(1x,a,i8)') &
201  'mpi_file_t%close: '//trim(self%filename)//' err:', self%err
202  flush (io_unit%mpi)
203  end if
204  self%handle = 0
205  end if
206 #endif MPI
207  call trace%end()
208 END SUBROUTINE close
209 
210 !===============================================================================
211 !> Write out a buffer at a given offset into the file
212 !===============================================================================
213 SUBROUTINE write1 (self, off, size, buffer)
214  class(mpi_file_t):: self
215  integer(8):: off
216  integer:: size, st(mpi_status_size), err
217  integer:: buffer(:)
218  !-----------------------------------------------------------------------------
219  call trace%begin ('mpi_io_t%write1')
220 #ifdef MPI
221  if (mp%mode == mpi_thread_multiple) then
222  call mpi_file_write_at (self%handle, off, buffer, size, mpi_real, st, err)
223  else
224  !$omp critical (mpi_cr)
225  call mpi_file_write_at (self%handle, off, buffer, size, mpi_real, st, err)
226  !$omp end critical (mpi_cr)
227  end if
228 #endif MPI
229  call trace%end ()
230 END SUBROUTINE write1
231 
232 !===============================================================================
233 !> Write out a buffer at a given offset into the file
234 !===============================================================================
235 SUBROUTINE write5 (self, off, size, buffer)
236  class(mpi_file_t):: self
237  integer(8):: off
238  integer:: size, st(mpi_status_size), err
239  real:: buffer(:,:,:,:,:)
240  !-----------------------------------------------------------------------------
241  call trace%begin ('mpi_io_t%write5')
242 #ifdef MPI
243  if (mp%mode == mpi_thread_multiple) then
244  call mpi_file_write_at (self%handle, off, buffer, size, mpi_real, st, err)
245  else
246  !$omp critical (mpi_cr)
247  call mpi_file_write_at (self%handle, off, buffer, size, mpi_real, st, err)
248  !$omp end critical (mpi_cr)
249  end if
250 #endif MPI
251  call trace%end ()
252 END SUBROUTINE write5
253 
254 !===============================================================================
255 !> Assert no error
256 !===============================================================================
257 SUBROUTINE assert (self, label, err)
258  class(mpi_file_t):: self
259  character(len=*):: label
260  logical, optional:: err
261  !-----------------------------------------------------------------------------
262  if (present(err)) then
263  if (err) then
264  call mp%abort (label)
265  end if
266  else if (self%err /= 0) then
267  print*,mp%rank,'error =',self%err
268  call mp%abort (label)
269  end if
270 END SUBROUTINE assert
271 
272 END MODULE mpi_file_mod
Support tic/toc timing, as in MATLAB, and accurate wallclock() function. The timing is generally much...
Module for handling blocking and non-blocking MPI parallel I/O to a single file.
Definition: mpi_file_mod.f90:4
Definition: io_mod.f90:4