38 logical:: mpi_trace=.false.
39 logical:: master=.true.
43 logical:: first_time = .true.
54 procedure,
private:: init4
55 procedure,
private:: init8
56 generic:: init => init4, init8
57 procedure,
private:: reset4
58 procedure,
private:: reset8
59 generic:: reset => reset4, reset8
60 procedure,
private:: update4
61 procedure,
private:: update8
62 generic:: update => update4, update8
68 integer:: size=1, rank=0, comm, verbose=0
71 logical:: ok = .false.
75 procedure:: barrier => barrier_
76 procedure:: print => print_
78 procedure:: abort => abort_mpi
79 procedure:: end => end_mpi
80 procedure,
nopass:: delay
82 type(
mpi_t),
public:: mpi
91 SUBROUTINE init (self, mpi_dims, dims)
93 integer,
optional,
dimension(3):: mpi_dims, dims
95 character(len=120):: ids = &
96 '$Id: a35de29b50d29cead00bbb68266e199dd78e3c86 $ mpi/mpi_mod.f90' 105 call mpi_bcast (omp%ncores, 1, mpi_integer, 0, self%comm, mpi_err)
106 call omp_timer%get (offset)
107 call mpi_bcast (offset, 1, mpi_real8, 0, self%comm, mpi_err)
108 call omp_timer%set (offset)
114 mpi%master = mpi_rank==0
119 mpi%master = (mpi_rank==0)
122 if (mpi%master .and. first_time) &
123 print
'(1x,a)', trim(ids)
131 self%master = mpi%master
135 call mpi%file_size%init (0_8)
139 flush (io_unit%output)
140 call self%barrier (delay=0.1)
145 SUBROUTINE print_ (self)
147 if (master) print *,
'mpi%size =', mpi%size
153 SUBROUTINE barrier_ (self, label, delay)
155 character(len=*),
optional:: label
156 real,
optional:: delay
160 if (.not.self%ok)
return 161 if (
present(delay))
then 163 do while (wallclock()-wc < delay)
166 if (
present(label))
then 167 call barrier_mpi (self, label)
169 call barrier_mpi (self,
'mpi%barrier')
171 END SUBROUTINE barrier_
174 SUBROUTINE init_mpi (self)
177 character(len=mch):: id=
'mpi.f90 $Id: a35de29b50d29cead00bbb68266e199dd78e3c86 $' 178 character(len=mch):: filename
179 integer:: mpi_provided
185 call mpi_init_thread (mpi_thread_single, mpi_provided, mpi_err)
187 call mpi_init_thread (mpi_thread_multiple, mpi_provided, mpi_err)
189 self%mode = mpi_provided
190 call mpi_comm_dup (mpi_comm_world, self%comm, mpi_err)
191 call mpi_comm_size (self%comm, mpi_size, mpi_err)
192 call mpi_comm_rank (self%comm, mpi_rank, mpi_err)
193 mpi_master = (mpi_rank == 0)
196 print 1,
'--------------------------------------------------------------------------------' 198 print 1,
' MPI initialized, mpi%size =', mpi_size
200 select case (mpi_provided)
201 case(mpi_thread_multiple)
202 print 1,
' MPI implementation provides support for simultaneous MPI calls by different threads' 203 case(mpi_thread_single)
204 print 1,
' MPI implementation only provides support for MPI calls in one thread at a time' 205 case(mpi_thread_funneled)
206 print 1,
' MPI implementation only provides support for MPI calls in master regions' 207 case(mpi_thread_serialized)
208 print 1,
' MPI implementation only provides support for serial MPI calls by any thread' 210 print 1,
' unknown MPI implementation' 212 print 1,
'--------------------------------------------------------------------------------' 214 if (self%verbose > 1)
then 215 write (filename,
'(a,i4.4,a)')
'rank_', mpi_rank,
'.dat' 216 open (output, file=filename, form=
'formatted', status=
'unknown')
220 mpi_master = (mpi_rank == 0)
222 print*,
'MPI is not enabled!' 224 END SUBROUTINE init_mpi
227 SUBROUTINE end_mpi (self, label)
229 character(len=*),
optional:: label
232 if (mpi_rank==0)
then 233 if (
present(label))
then 234 print*,
'MPI finalized with message: "'//trim(label)//
'"' 238 write (io_unit%mpi,*) self%rank, wallclock(),
'calling MPI_Finalize' 240 call mpi_finalize (mpi_err)
241 write (io_unit%mpi,*) self%rank, wallclock(),
'returned from MPI_Finalize' 248 SUBROUTINE abort_mpi (self, reason)
250 character(len=*),
optional:: reason
256 flush (io_unit%output)
257 call message (stderr)
258 call message (io_unit%log)
260 call mpi_abort (mpi_comm_world, 127, mpi_err)
264 subroutine message (unit)
267 if (
present(reason))
then 268 write (unit,
'("ABORT: rank",i5,4x,"thread",i4,4x,"reason: ",a)') &
269 mpi_rank, omp%thread, trim(reason)
271 write (unit,
'("ABORT: rank",i5,4x,"thread",i4,4x,"generic")') &
276 END SUBROUTINE abort_mpi
279 SUBROUTINE clean_stop
282 call mpi_abort (mpi_comm_world, 127, mpi_err)
285 END SUBROUTINE clean_stop
288 SUBROUTINE barrier_mpi (self, label)
290 character(len=*) label
292 if (mpi_trace) print *, mpi_rank,
'barrier_mpi: '//label
293 if (self%verbose > 2)
then 294 write (output,*) mpi_rank,
'barrier_mpi: '//label
298 call mpi_barrier (mpi_comm_world, mpi_err)
300 END SUBROUTINE barrier_mpi
303 SUBROUTINE assert (self, message, code)
305 character(len=*):: message
307 character (len=16):: codemsg
310 write (codemsg,
'("code =",i10)') code
311 write(*,*) mpi_rank,
' error: '//trim(message)
312 if (self%verbose > 1)
then 313 write(output,*) mpi_rank,
' error: '//trim(message)
317 END SUBROUTINE assert
325 SUBROUTINE detect_cores
326 character(len=32):: file=
"/proc/cpuinfo" 327 character(len=32):: line
329 integer:: i, iostat, id, oid, n_socket, n_core
331 type(socket_t),
pointer:: next => null()
334 type(socket_t),
pointer:: p, o, head
340 inquire (file=file, exist=exist)
343 open (file=file, unit=io_unit%os, form=
'formatted', status=
'old')
345 read (io_unit%os,
'(a32)',iostat=iostat) line
350 if (line(1:8)==
'cpu core')
then 351 read (line(i+1:),*) n_core
352 else if (line(1:8)==
'physical')
then 353 read (line(i+1:),*) id
355 n_socket = n_socket + 1
362 if (wc > 5) print
'(a)',
'############################################################' 364 print
'(a,f6.1,a)',
'reading /proc/cpuinfo:', wc,
' sec' 365 if (wc > 5) print
'(a)',
'############################################################' 367 if (n_socket>0) n_core = n_core*n_socket
375 do while (
associated(p))
381 logical function new(id)
388 do while (
associated(p))
401 if (
associated(o))
then 408 END SUBROUTINE detect_cores
413 SUBROUTINE delay (ms)
418 do while ((wallclock()-wc) < 1e-3*ms)
425 SUBROUTINE init4 (self, n)
430 integer(kind=MPI_ADDRESS_KIND):: nbytes=8
434 call mpi_win_create (self%i, nbytes, 8, mpi_info_null, mpi_comm_world, &
435 self%window, mpi_err)
436 call mpi%assert (
'MPI_Win_create', mpi_err)
443 SUBROUTINE init8 (self, n)
448 integer(kind=MPI_ADDRESS_KIND):: nbytes=8
452 call mpi_win_create (self%i, nbytes, 8, mpi_info_null, mpi_comm_world, &
453 self%window, mpi_err)
454 call mpi%assert (
'MPI_Win_create', mpi_err)
461 SUBROUTINE reset4 (self, n)
467 END SUBROUTINE reset4
472 SUBROUTINE reset8 (self, n)
478 END SUBROUTINE reset8
484 FUNCTION update4 (self, i, n)
RESULT (j)
487 integer,
optional:: n
490 j= update8(self, int(i,kind=8), int(n,kind=8))
492 j= update8(self, int(i,kind=8))
496 FUNCTION update8 (self, i, n)
RESULT (j)
499 integer(8),
optional:: n
501 integer:: master=0, mpi_err
503 integer(kind=MPI_ADDRESS_KIND):: offset=0
505 if (io_unit%verbose > 0) &
506 write (io_unit%log,
'(a,2(2x,3i4))') &
507 'mpi_counter_t%update(1): incr, sum, rank, size =', &
508 i, self%i, mpi%rank, mpi%size
509 if (mpi%mode == mpi_thread_multiple)
then 526 subroutine accumulate (i)
529 call mpi_win_lock (mpi_lock_exclusive, master, 0, self%window, mpi_err)
531 call mpi_win_flush (master, self%window, mpi_err)
537 if (io_unit%verbose > 0) &
538 write (io_unit%log,
'(a,2(2x,3i4))') &
539 'mpi_counter_t%update(2): val, sum, rank, size =', &
540 j, self%i, mpi%rank, mpi%size
541 call mpi_win_unlock (master, self%window, mpi_err)
543 end subroutine accumulate
550 call mpi_get_accumulate (i, 1, mpi_integer8, &
551 j, 1, mpi_integer8, master, offset, &
552 1, mpi_integer8, mpi_sum, self%window, mpi_err)
553 call mpi%assert (
'MPI_Accumulate', mpi_err)
568 SUBROUTINE anonymous_copy (n, a, b)
572 END SUBROUTINE anonymous_copy
Support tic/toc timing, as in MATLAB, and accurate wallclock() function. The timing is generally much...