41 USE mpi
, only: mpi_offset_kind, mpi_real, mpi_status_size, mpi_thread_multiple
49 integer:: req, handle, words
51 integer(kind=MPI_OFFSET_KIND):: pos
55 real,
dimension(:,:,:),
pointer:: buffer3 => null()
56 real,
dimension(:,:,:,:),
pointer:: buffer => null()
62 logical:: first_time=.true.
63 logical:: active=.false.
73 integer:: req, nwrite=-1
74 integer(8):: rec_words
77 real,
dimension(:,:,:),
allocatable:: buf
80 integer:: status(mpi_status_size)
88 procedure:: check_init
89 procedure,
private:: write3
90 procedure,
private:: write4
91 generic,
public ::
write => write3, write4
92 procedure,
private:: iwrite3
93 procedure,
private:: iwrite4
94 generic,
public :: iwrite => iwrite3, iwrite4
95 procedure,
private:: read3
96 procedure,
private:: read4
97 generic,
public ::
read => read3, read4
100 character(len=32),
save:: fmt=
'(1x,a,4i8,1p,5e12.3)' 101 integer,
save:: verbose=0
102 logical,
save:: direct=.false.
109 SUBROUTINE use (self, file)
113 call trace%begin (
'mpi_io_t%use')
121 SUBROUTINE init (self)
124 logical,
save:: first_time=.true.
125 namelist /mpi_io_params/ verbose, direct
127 call trace%begin (
'mpi_io_t%init')
137 read (io%input, mpi_io_params, iostat=iostat)
138 if (io%master)
write (io%output, mpi_io_params)
142 if (self%iwrite_list%first_time)
then 143 self%iwrite_list%first_time = .false.
144 call self%iwrite_list%init (
'iwrite_list')
146 print *,
'mpi_io_t%init done' 155 SUBROUTINE set (self, rec_words, chunk_words, nwrite)
157 integer(8),
optional:: rec_words, chunk_words
158 integer,
optional:: nwrite
160 call trace%begin (
'mpi_io_t%set')
161 if (
present(rec_words))
then 162 self%rec_words = rec_words
163 if (verbose > 2) print *,
'mpi_io_t%init: setting rec_words =', rec_words
165 if (
present(chunk_words))
then 166 self%chunk_words = chunk_words
167 if (verbose > 2) print *,
'mpi_io_t%init: setting chunk_words =', chunk_words
169 if (
present(nwrite))
then 170 mpi_io%nwrite = nwrite
171 if (verbose > 2) print *,
'mpi_io_t%init: setting nwrite =', nwrite
179 SUBROUTINE check_init (self)
182 call self%assert (
'mpi_io_t:rec_words is not positive', err=self%rec_words <= 0)
183 call self%assert (
'mpi_io_t:chunk_words is not positive', err=self%chunk_words <= 0)
184 END SUBROUTINE check_init
189 SUBROUTINE write3 (self, f, rec, id)
191 real(kind=4),
dimension(:,:,:):: f
194 integer(kind=MPI_OFFSET_KIND):: pos
196 call trace%begin (
'mpi_io_t%write')
198 pos = 4_8*((rec-1_8)*self%rec_words + (id-1_8)*self%chunk_words)
200 write (io_unit%output,
'(a,3i8,i15,1p,2e14.6)')
' mpi_io_t%write3: rec, id, words, pos =', &
201 rec, id, self%chunk_words, pos, minval(f), maxval(f)
202 if (mp%mode == mpi_thread_multiple)
then 203 call mpi_file_write_at (self%file%handle, pos, f, self%chunk_words, mpi_real, &
204 self%status, self%err)
207 call mpi_file_write_at (self%file%handle, pos, f, self%chunk_words, mpi_real, &
208 self%status, self%err)
211 call self%assert (
'mpi_io_mod::write MPI_File_write_at '//trim(self%file%filename))
214 END SUBROUTINE write3
219 SUBROUTINE write4 (self, f, rec, id)
221 real(kind=4),
dimension(:,:,:,:):: f
224 integer(kind=MPI_OFFSET_KIND):: pos
226 call trace%begin (
'mpi_io_t%write')
228 pos = 4_8*((rec-1_8)*self%rec_words + (id-1_8)*self%chunk_words)
230 write (io_unit%output,
'(a,2i6,i12,i15,1p,2e14.6)') &
231 ' mpi_io_t%write4: rec, id, words, pos, min/max =', &
232 rec, id, self%chunk_words, pos, minval(f), maxval(f)
233 if (verbose > 0)
then 234 write(io_unit%mpi,
'(g12.5,i4,2x,a)') wallclock(), omp%thread, &
235 'mpi_io_t%write4: writing to '//trim(self%file%filename)
238 if (mp%mode == mpi_thread_multiple)
then 239 call mpi_file_write_at (self%file%handle, pos, f, self%chunk_words, mpi_real, &
240 self%status, self%err)
243 call mpi_file_write_at (self%file%handle, pos, f, self%chunk_words, mpi_real, &
244 self%status, self%err)
247 call self%assert (
'mpi_io_mod::write MPI_File_write_at '//trim(self%file%filename))
250 END SUBROUTINE write4
255 SUBROUTINE iwrite3 (self, f, rec, id)
257 real(kind=4),
dimension(:,:,:),
pointer:: f
258 integer:: rec, id, unit
260 integer(kind=MPI_OFFSET_KIND):: pos
264 integer,
save:: itimer=0
266 call trace%begin (
'mpi_io_t%iwrite', itimer=itimer)
268 pos = 4_8*((rec-1_8)*self%rec_words + (id-1_8)*self%chunk_words)
269 if (verbose > 1)
then 270 if (verbose > 2)
then 271 unit = io_unit%output
275 write (unit,
'(a,3i8,i15,1p,2e14.6)') &
276 ' mpi_io_t%read3: rec, id, words, pos =', &
277 rec, id, self%chunk_words, pos, minval(f), maxval(f)
283 item%handle = self%file%handle
284 item%words = self%chunk_words
290 call self%iwrite_list%append (node)
291 self%iwrite_list%active = .true.
292 n = self%iwrite_list%n
295 write(io%output,
'(f12.6,i5,2x,a,i7,i4)') &
296 wallclock(), omp%thread,
'appended req, n =', item%req, n
297 call trace%end (itimer)
299 END SUBROUTINE iwrite3
304 SUBROUTINE iwrite4 (self, f, rec, id)
306 real(kind=4),
dimension(:,:,:,:),
pointer:: f
307 integer:: rec, id, unit
309 integer(kind=MPI_OFFSET_KIND):: pos
313 integer,
save:: itimer=0
315 call trace%begin (
'mpi_io_t%iwrite', itimer=itimer)
317 pos = 4_8*((rec-1_8)*self%rec_words + (id-1_8)*self%chunk_words)
318 if (verbose > 1)
then 319 if (verbose > 2)
then 320 unit = io_unit%output
324 write (unit,
'(a,3i8,i15,1p,2e14.6)') &
325 ' mpi_io_t%read3: rec, id, words, pos =', &
326 rec, id, self%chunk_words, pos, minval(f), maxval(f)
332 item%handle = self%file%handle
333 item%words = self%chunk_words
339 call self%iwrite_list%append (node)
340 self%iwrite_list%active = .true.
341 n = self%iwrite_list%n
344 write(io%output,
'(f12.6,i5,2x,a,i7,i4)') &
345 wallclock(), omp%thread,
'appended req, n =', item%req, n
346 call trace%end (itimer)
348 END SUBROUTINE iwrite4
353 SUBROUTINE read3 (self, f, rec, id)
355 real(kind=4),
dimension(:,:,:):: f
356 integer rec, id, unit
358 integer(kind=MPI_OFFSET_KIND):: pos
361 call io%abort (
'mpi_io_t%read4: illegal record number')
362 call trace%begin (
'mpi_io_t%read3')
364 pos = 4_8*((rec-1_8)*self%rec_words + (id-1_8)*self%chunk_words)
365 if (mp%mode == mpi_thread_multiple)
then 366 call mpi_file_read_at (self%file%handle, pos, f, self%chunk_words, mpi_real, &
367 self%status, self%err)
370 call mpi_file_read_at (self%file%handle, pos, f, self%chunk_words, mpi_real, &
371 self%status, self%err)
374 if (verbose > 1)
then 375 if (verbose > 2)
then 376 unit = io_unit%output
380 write (unit,
'(a,3i8,i15,1p,2e14.6)') &
381 ' mpi_io_t%read3: rec, id, words, pos =', &
382 rec, id, self%chunk_words, pos, minval(f), maxval(f)
391 SUBROUTINE read4 (self, f, rec, id)
393 real(kind=4),
dimension(:,:,:,:):: f
394 integer rec, id, unit
396 integer(kind=MPI_OFFSET_KIND):: pos
399 call io%abort (
'mpi_io_t%read4: illegal record number')
400 call trace%begin (
'mpi_io_t%read4')
402 pos = 4_8*((rec-1_8)*self%rec_words + (id-1_8)*self%chunk_words)
403 if (mp%mode == mpi_thread_multiple)
then 404 call mpi_file_read_at (self%file%handle, pos, f, self%chunk_words, mpi_real, &
405 self%status, self%err)
408 call mpi_file_read_at (self%file%handle, pos, f, self%chunk_words, mpi_real, &
409 self%status, self%err)
412 if (verbose > 1)
then 413 if (verbose > 2)
then 414 unit = io_unit%output
418 write (unit,
'(a,3i8,i15,1p,2e14.6)') &
419 ' mpi_io_t%read4: rec, id, words, pos =', &
420 rec, id, self%chunk_words, pos, minval(f), maxval(f)
429 SUBROUTINE assert (self, label, err)
431 character(len=*):: label
432 logical,
optional:: err
434 if (
present(err))
then 436 call mp%abort (label)
438 else if (self%err /= 0)
then 439 print*,mp%rank,omp%thread,
' error =',self%err
440 call mp%abort (label)
442 END SUBROUTINE assert
450 SUBROUTINE check (self)
455 integer:: status(mpi_status_size), err
457 integer:: status(8), err
460 integer,
save:: itimer=0, nprint=3
461 integer:: done, omp_get_thread_num, rec
463 real(8):: start, wc, dwc
467 if (.not.io%do_output .or. .not.self%active) &
469 if (self%n < mpi_io%nwrite .or. self%thread >=0)
then 470 if (verbose > 1 .and. self%thread >= 0) &
471 write(io%output,
'(f12.6,i5,2x,a,i7,i4)') &
472 wallclock(), omp%thread,
' returning immediately', self%n, self%thread
475 call trace%begin (
'iwrite_list_t%check', itimer=itimer)
481 ok = (self%thread == -1)
483 self%thread = omp_get_thread_num()
490 if (verbose > 0 .and. .not.io_unit%do_validate) &
491 write(io%output,
'(1p,g14.6,i6,3x,a,i6)') &
492 wallclock(), self%thread,
'I/O start, n =', self%n
498 do while (self%n > 0 .and.
associated(node))
503 if (
associated(item%buffer) .or.
associated(item%buffer3))
then 506 rec = 1 + item%pos/item%words/4
507 write (io_unit%direct, rec=rec) item%buffer
508 deallocate (item%buffer)
509 else if (
associated(item%buffer3))
then 511 if (mp%mode == mpi_thread_multiple)
then 512 call mpi_file_write_at (item%handle, item%pos, item%buffer3, &
513 item%words, mpi_real, status, err)
516 call mpi_file_write_at (item%handle, item%pos, item%buffer3, &
517 item%words, mpi_real, status, err)
521 call io%assert (err==0,
'MPI_File_write_at: error code non-zero')
522 deallocate (item%buffer3)
523 nullify (item%buffer3)
526 if (mp%mode == mpi_thread_multiple)
then 527 call mpi_file_write_at (item%handle, item%pos, item%buffer, &
528 item%words, mpi_real, status, err)
531 call mpi_file_write_at (item%handle, item%pos, item%buffer, &
532 item%words, mpi_real, status, err)
536 call io%assert (err==0,
'MPI_File_write_at: error code non-zero')
537 deallocate (item%buffer)
539 nullify (item%buffer)
541 if (verbose > 0 .and. nprint > 0 .and. .not.io_unit%do_validate)
then 545 write(io%output,
'(10x,a,f12.6)')
'direct access write time:', dwc
547 write(io%output,
'(10x,a,f12.6)')
'MPI_File_write_at time:', dwc
558 self%thread,
'buffer not associated on req', item%req
562 if (.not.io_unit%do_validate)
then 564 write(io%output,
'(1p,g14.6,i6,3x,a,2i7)') &
565 wallclock(), self%thread,
'I/O req =', item%req, done
566 if (verbose > 0 .and. mod(done,1000) == 0) &
567 write(io%output,
'(1p,g14.6,i6,3x,a,i7)') &
568 wallclock(), self%thread,
'I/O done =', done
572 call self%remove (node)
577 if (verbose > 0 .and. .not.io_unit%do_validate) &
578 write(io%output,
'(1p,g14.6,i6,3x,a,i6,0p,f12.3," s")') &
579 wallclock(), self%thread,
'I/O final, n =', done, wallclock()-start
585 write(io%output,
'(1p,g14.6,i6,3x,a,i7)') wallclock(), omp_get_thread_num(),
'I/O skip' 587 call trace%end (itimer)
Module for handling blocking and non-blocking MPI parallel I/O to a single file. The module is initia...
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.
Doubly linked list (DLL), carrying anything, as simply as possible.