1 ! This file created from test/mpi/f77/pt2pt/mprobef.f with f77tof90
2 ! -*- Mode: Fortran; -*-
4 ! (C) 2012 by Argonne National Laboratory.
5 ! See COPYRIGHT in top-level directory.
9 integer idx, ierr, rank, size, count
10 integer sendbuf(8), recvbuf(8)
11 integer s1(MPI_STATUS_SIZE), s2(MPI_STATUS_SIZE)
19 if (ierr .ne. MPI_SUCCESS) then
21 print *, ' Unexpected return from MPI_INIT', ierr
24 call mpi_comm_rank( MPI_COMM_WORLD, rank, ierr )
25 call mpi_comm_size( MPI_COMM_WORLD, size, ierr )
28 print *, ' This test requires at least 2 processes'
29 ! Abort now - do not continue in this case.
30 call mpi_abort( MPI_COMM_WORLD, 1, ierr )
33 print *, ' This test is running with ', size, ' processes,'
34 print *, ' only 2 processes are used.'
37 ! Test 0: simple Send and Mprobe+Mrecv.
39 sendbuf(1) = 1735928559
40 sendbuf(2) = 1277009102
41 call MPI_Send(sendbuf, 2, MPI_INTEGER, &
42 & 1, 5, MPI_COMM_WORLD, ierr)
44 do idx = 1, MPI_STATUS_SIZE
48 ! the error fields are initialized for modification check.
49 s1(MPI_ERROR) = MPI_ERR_DIMS
50 s2(MPI_ERROR) = MPI_ERR_OTHER
52 msg = MPI_MESSAGE_NULL
53 call MPI_Mprobe(0, 5, MPI_COMM_WORLD, msg, s1, ierr)
54 if (s1(MPI_SOURCE) .ne. 0) then
56 print *, 's1(MPI_SOURCE) != 0 at T0 Mprobe().'
58 if (s1(MPI_TAG) .ne. 5) then
60 print *, 's1(MPI_TAG) != 5 at T0 Mprobe().'
62 if (s1(MPI_ERROR) .ne. MPI_ERR_DIMS) then
64 print *, 's1(MPI_ERROR) != MPI_ERR_DIMS at T0 Mprobe().'
66 if (msg .eq. MPI_MESSAGE_NULL) then
68 print *, 'msg == MPI_MESSAGE_NULL at T0 Mprobe().'
72 call MPI_Get_count(s1, MPI_INTEGER, count, ierr)
73 if (count .ne. 2) then
75 print *, 'probed buffer does not have 2 MPI_INTEGERs.'
79 recvbuf(2) = 1309737967
80 call MPI_Mrecv(recvbuf, count, MPI_INTEGER, msg, s2, ierr)
81 if (recvbuf(1) .ne. 1735928559) then
83 print *, 'recvbuf(1) is corrupted at T0 Mrecv().'
85 if (recvbuf(2) .ne. 1277009102) then
87 print *, 'recvbuf(2) is corrupted at T0 Mrecv().'
89 if (s2(MPI_SOURCE) .ne. 0) then
91 print *, 's2(MPI_SOURCE) != 0 at T0 Mrecv().'
93 if (s2(MPI_TAG) .ne. 5) then
95 print *, 's2(MPI_TAG) != 5 at T0 Mrecv().'
97 if (s2(MPI_ERROR) .ne. MPI_ERR_OTHER) then
99 print *, 's2(MPI_ERROR) != MPI_ERR_OTHER at T0 Mrecv().'
101 if (msg .ne. MPI_MESSAGE_NULL) then
103 print *, 'msg != MPI_MESSAGE_NULL at T0 Mrecv().'
107 ! Test 1: simple Send and Mprobe+Imrecv.
108 if (rank .eq. 0) then
109 sendbuf(1) = 1735928559
110 sendbuf(2) = 1277009102
111 call MPI_Send(sendbuf, 2, MPI_INTEGER, &
112 & 1, 5, MPI_COMM_WORLD, ierr)
114 do idx = 1, MPI_STATUS_SIZE
118 ! the error fields are initialized for modification check.
119 s1(MPI_ERROR) = MPI_ERR_DIMS
120 s2(MPI_ERROR) = MPI_ERR_OTHER
122 msg = MPI_MESSAGE_NULL
123 call MPI_Mprobe(0, 5, MPI_COMM_WORLD, msg, s1, ierr)
124 if (s1(MPI_SOURCE) .ne. 0) then
126 print *, 's1(MPI_SOURCE) != 0 at T1 Mprobe().'
128 if (s1(MPI_TAG) .ne. 5) then
130 print *, 's1(MPI_TAG) != 5 at T1 Mprobe().'
132 if (s1(MPI_ERROR) .ne. MPI_ERR_DIMS) then
134 print *, 's1(MPI_ERROR) != MPI_ERR_DIMS at T1 Mprobe().'
136 if (msg .eq. MPI_MESSAGE_NULL) then
138 print *, 'msg == MPI_MESSAGE_NULL at T1 Mprobe().'
142 call MPI_Get_count(s1, MPI_INTEGER, count, ierr)
143 if (count .ne. 2) then
145 print *, 'probed buffer does not have 2 MPI_INTEGERs.'
148 rreq = MPI_REQUEST_NULL
149 recvbuf(1) = 19088743
150 recvbuf(2) = 1309737967
151 call MPI_Imrecv(recvbuf, count, MPI_INTEGER, msg, rreq, ierr)
152 if (rreq .eq. MPI_REQUEST_NULL) then
154 print *, 'rreq is unmodified at T1 Imrecv().'
156 call MPI_Wait(rreq, s2, ierr)
157 if (recvbuf(1) .ne. 1735928559) then
159 print *, 'recvbuf(1) is corrupted at T1 Imrecv().'
161 if (recvbuf(2) .ne. 1277009102) then
163 print *, 'recvbuf(2) is corrupted at T1 Imrecv().'
165 if (s2(MPI_SOURCE) .ne. 0) then
167 print *, 's2(MPI_SOURCE) != 0 at T1 Imrecv().'
169 if (s2(MPI_TAG) .ne. 5) then
171 print *, 's2(MPI_TAG) != 5 at T1 Imrecv().'
173 if (s2(MPI_ERROR) .ne. MPI_ERR_OTHER) then
175 print *, 's2(MPI_ERROR) != MPI_ERR_OTHER at T1 Imrecv().'
177 if (msg .ne. MPI_MESSAGE_NULL) then
179 print *, 'msg != MPI_MESSAGE_NULL at T1 Imrecv().'
183 ! Test 2: simple Send and Improbe+Mrecv.
184 if (rank .eq. 0) then
185 sendbuf(1) = 1735928559
186 sendbuf(2) = 1277009102
187 call MPI_Send(sendbuf, 2, MPI_INTEGER, &
188 & 1, 5, MPI_COMM_WORLD, ierr)
190 do idx = 1, MPI_STATUS_SIZE
194 ! the error fields are initialized for modification check.
195 s1(MPI_ERROR) = MPI_ERR_DIMS
196 s2(MPI_ERROR) = MPI_ERR_OTHER
198 msg = MPI_MESSAGE_NULL
199 call MPI_Improbe(0, 5, MPI_COMM_WORLD, found, msg, s1, ierr)
200 do while (.not. found)
201 call MPI_Improbe(0, 5, MPI_COMM_WORLD, &
202 & found, msg, s1, ierr)
204 if (msg .eq. MPI_MESSAGE_NULL) then
206 print *, 'msg == MPI_MESSAGE_NULL at T2 Improbe().'
208 if (s1(MPI_SOURCE) .ne. 0) then
210 print *, 's1(MPI_SOURCE) != 0 at T2 Improbe().'
212 if (s1(MPI_TAG) .ne. 5) then
214 print *, 's1(MPI_TAG) != 5 at T2 Improbe().'
216 if (s1(MPI_ERROR) .ne. MPI_ERR_DIMS) then
218 print *, 's1(MPI_ERROR) != MPI_ERR_DIMS at T2 Improbe().'
222 call MPI_Get_count(s1, MPI_INTEGER, count, ierr)
223 if (count .ne. 2) then
225 print *, 'probed buffer does not have 2 MPI_INTEGERs.'
228 recvbuf(1) = 19088743
229 recvbuf(2) = 1309737967
230 call MPI_Mrecv(recvbuf, count, MPI_INTEGER, msg, s2, ierr)
231 if (recvbuf(1) .ne. 1735928559) then
233 print *, 'recvbuf(1) is corrupted at T2 Mrecv().'
235 if (recvbuf(2) .ne. 1277009102) then
237 print *, 'recvbuf(2) is corrupted at T2 Mrecv().'
239 if (s2(MPI_SOURCE) .ne. 0) then
241 print *, 's2(MPI_SOURCE) != 0 at T2 Mrecv().'
243 if (s2(MPI_TAG) .ne. 5) then
245 print *, 's2(MPI_TAG) != 5 at T2 Mrecv().'
247 if (s2(MPI_ERROR) .ne. MPI_ERR_OTHER) then
249 print *, 's2(MPI_ERROR) != MPI_ERR_OTHER at T2 Mrecv().'
251 if (msg .ne. MPI_MESSAGE_NULL) then
253 print *, 'msg != MPI_MESSAGE_NULL at T2 Mrecv().'
257 ! Test 3: simple Send and Improbe+Imrecv.
258 if (rank .eq. 0) then
259 sendbuf(1) = 1735928559
260 sendbuf(2) = 1277009102
261 call MPI_Send(sendbuf, 2, MPI_INTEGER, &
262 & 1, 5, MPI_COMM_WORLD, ierr)
264 do idx = 1, MPI_STATUS_SIZE
268 ! the error fields are initialized for modification check.
269 s1(MPI_ERROR) = MPI_ERR_DIMS
270 s2(MPI_ERROR) = MPI_ERR_OTHER
272 msg = MPI_MESSAGE_NULL
273 call MPI_Improbe(0, 5, MPI_COMM_WORLD, found, msg, s1, ierr)
274 do while (.not. found)
275 call MPI_Improbe(0, 5, MPI_COMM_WORLD, &
276 & found, msg, s1, ierr)
278 if (msg .eq. MPI_MESSAGE_NULL) then
280 print *, 'msg == MPI_MESSAGE_NULL at T3 Improbe().'
282 if (s1(MPI_SOURCE) .ne. 0) then
284 print *, 's1(MPI_SOURCE) != 0 at T3 Improbe().'
286 if (s1(MPI_TAG) .ne. 5) then
288 print *, 's1(MPI_TAG) != 5 at T3 Improbe().'
290 if (s1(MPI_ERROR) .ne. MPI_ERR_DIMS) then
292 print *, 's1(MPI_ERROR) != MPI_ERR_DIMS at T3 Improbe().'
296 call MPI_Get_count(s1, MPI_INTEGER, count, ierr)
297 if (count .ne. 2) then
299 print *, 'probed buffer does not have 2 MPI_INTEGERs.'
302 rreq = MPI_REQUEST_NULL
303 recvbuf(1) = 19088743
304 recvbuf(2) = 1309737967
305 call MPI_Imrecv(recvbuf, count, MPI_INTEGER, msg, rreq, ierr)
306 if (rreq .eq. MPI_REQUEST_NULL) then
308 print *, 'rreq is unmodified at T3 Imrecv().'
310 call MPI_Wait(rreq, s2, ierr)
311 if (recvbuf(1) .ne. 1735928559) then
313 print *, 'recvbuf(1) is corrupted at T3 Imrecv().'
315 if (recvbuf(2) .ne. 1277009102) then
317 print *, 'recvbuf(2) is corrupted at T3 Imrecv().'
319 if (s2(MPI_SOURCE) .ne. 0) then
321 print *, 's2(MPI_SOURCE) != 0 at T3 Imrecv().'
323 if (s2(MPI_TAG) .ne. 5) then
325 print *, 's2(MPI_TAG) != 5 at T3 Imrecv().'
327 if (s2(MPI_ERROR) .ne. MPI_ERR_OTHER) then
329 print *, 's2(MPI_ERROR) != MPI_ERR_OTHER at T3 Imrecv().'
331 if (msg .ne. MPI_MESSAGE_NULL) then
333 print *, 'msg != MPI_MESSAGE_NULL at T3 Imrecv().'
337 ! Test 4: Mprobe+Mrecv with MPI_PROC_NULL
339 do idx = 1, MPI_STATUS_SIZE
343 ! the error fields are initialized for modification check.
344 s1(MPI_ERROR) = MPI_ERR_DIMS
345 s2(MPI_ERROR) = MPI_ERR_OTHER
347 msg = MPI_MESSAGE_NULL
348 call MPI_Mprobe(MPI_PROC_NULL, 5, MPI_COMM_WORLD, &
350 if (s1(MPI_SOURCE) .ne. MPI_PROC_NULL) then
352 print *, 's1(MPI_SOURCE) != MPI_PROC_NULL at T4 Mprobe().'
354 if (s1(MPI_TAG) .ne. MPI_ANY_TAG) then
356 print *, 's1(MPI_TAG) != MPI_ANY_TAG at T4 Mprobe().'
358 if (s1(MPI_ERROR) .ne. MPI_ERR_DIMS) then
360 print *, 's1(MPI_ERROR) != MPI_ERR_DIMS at T4 Mprobe().'
362 if (msg .ne. MPI_MESSAGE_NO_PROC) then
364 print *, 'msg != MPI_MESSAGE_NO_PROC at T4 Mprobe().'
368 call MPI_Get_count(s1, MPI_INTEGER, count, ierr)
369 if (count .ne. 0) then
371 print *, 'probed buffer does not have 0 MPI_INTEGER.'
374 recvbuf(1) = 19088743
375 recvbuf(2) = 1309737967
376 call MPI_Mrecv(recvbuf, count, MPI_INTEGER, msg, s2, ierr)
377 ! recvbuf() should remain unmodified
378 if (recvbuf(1) .ne. 19088743) then
380 print *, 'recvbuf(1) is corrupted at T4 Mrecv().'
382 if (recvbuf(2) .ne. 1309737967) then
384 print *, 'recvbuf(2) is corrupted at T4 Mrecv().'
386 if (s2(MPI_SOURCE) .ne. MPI_PROC_NULL) then
388 print *, 's2(MPI_SOURCE) != MPI_PROC_NULL at T4 Mrecv().'
390 if (s2(MPI_TAG) .ne. MPI_ANY_TAG) then
392 print *, 's2(MPI_TAG) != MPI_ANY_TAG at T4 Mrecv().'
394 if (s2(MPI_ERROR) .ne. MPI_ERR_OTHER) then
396 print *, 's2(MPI_ERROR) != MPI_ERR_OTHER at T4 Mrecv().'
398 if (msg .ne. MPI_MESSAGE_NULL) then
400 print *, 'msg != MPI_MESSAGE_NULL at T4 Mrecv().'
404 call MPI_Get_count(s2, MPI_INTEGER, count, ierr)
405 if (count .ne. 0) then
407 print *, 'recv buffer does not have 0 MPI_INTEGER.'
411 ! Test 5: Mprobe+Imrecv with MPI_PROC_NULL
413 do idx = 1, MPI_STATUS_SIZE
417 ! the error fields are initialized for modification check.
418 s1(MPI_ERROR) = MPI_ERR_DIMS
419 s2(MPI_ERROR) = MPI_ERR_OTHER
421 msg = MPI_MESSAGE_NULL
422 call MPI_Mprobe(MPI_PROC_NULL, 5, MPI_COMM_WORLD, &
424 if (s1(MPI_SOURCE) .ne. MPI_PROC_NULL) then
426 print *, 's1(MPI_SOURCE) != MPI_PROC_NULL at T5 Mprobe().'
428 if (s1(MPI_TAG) .ne. MPI_ANY_TAG) then
430 print *, 's1(MPI_TAG) != MPI_ANY_TAG at T5 Mprobe().'
432 if (s1(MPI_ERROR) .ne. MPI_ERR_DIMS) then
434 print *, 's1(MPI_ERROR) != MPI_ERR_DIMS at T5 Mprobe().'
436 if (msg .ne. MPI_MESSAGE_NO_PROC) then
438 print *, 'msg != MPI_MESSAGE_NO_PROC at T5 Mprobe().'
442 call MPI_Get_count(s1, MPI_INTEGER, count, ierr)
443 if (count .ne. 0) then
445 print *, 'probed buffer does not have 0 MPI_INTEGER.'
448 rreq = MPI_REQUEST_NULL
449 recvbuf(1) = 19088743
450 recvbuf(2) = 1309737967
451 call MPI_Imrecv(recvbuf, count, MPI_INTEGER, msg, rreq, ierr)
452 if (rreq .eq. MPI_REQUEST_NULL) then
454 print *, 'rreq == MPI_REQUEST_NULL at T5 Imrecv().'
457 call MPI_Test(rreq, flag, s2, ierr)
460 print *, 'flag is false at T5 Imrecv().'
462 ! recvbuf() should remain unmodified
463 if (recvbuf(1) .ne. 19088743) then
465 print *, 'recvbuf(1) is corrupted at T5 Imrecv().'
467 if (recvbuf(2) .ne. 1309737967) then
469 print *, 'recvbuf(2) is corrupted at T5 Imrecv().'
471 if (s2(MPI_SOURCE) .ne. MPI_PROC_NULL) then
473 print *, 's2(MPI_SOURCE) != MPI_PROC_NULL at T5 Imrecv().'
475 if (s2(MPI_TAG) .ne. MPI_ANY_TAG) then
477 print *, 's2(MPI_TAG) != MPI_ANY_TAG at T5 Imrecv().'
479 if (s2(MPI_ERROR) .ne. MPI_ERR_OTHER) then
481 print *, 's2(MPI_ERROR) != MPI_ERR_OTHER at T5 Imrecv().'
483 if (msg .ne. MPI_MESSAGE_NULL) then
485 print *, 'msg != MPI_MESSAGE_NULL at T5 Imrecv().'
489 call MPI_Get_count(s2, MPI_INTEGER, count, ierr)
490 if (count .ne. 0) then
492 print *, 'recv buffer does not have 0 MPI_INTEGER.'
496 ! Test 6: Improbe+Mrecv with MPI_PROC_NULL
498 do idx = 1, MPI_STATUS_SIZE
502 ! the error fields are initialized for modification check.
503 s1(MPI_ERROR) = MPI_ERR_DIMS
504 s2(MPI_ERROR) = MPI_ERR_OTHER
507 msg = MPI_MESSAGE_NULL
508 call MPI_Improbe(MPI_PROC_NULL, 5, MPI_COMM_WORLD, &
509 & found, msg, s1, ierr)
510 if (.not. found) then
512 print *, 'found is false at T6 Improbe().'
514 if (s1(MPI_SOURCE) .ne. MPI_PROC_NULL) then
516 print *, 's1(MPI_SOURCE) != MPI_PROC_NULL at T6 Improbe()'
518 if (s1(MPI_TAG) .ne. MPI_ANY_TAG) then
520 print *, 's1(MPI_TAG) != MPI_ANY_TAG at T6 Improbe().'
522 if (s1(MPI_ERROR) .ne. MPI_ERR_DIMS) then
524 print *, 's1(MPI_ERROR) != MPI_ERR_DIMS at T6 Improbe().'
526 if (msg .ne. MPI_MESSAGE_NO_PROC) then
528 print *, 'msg != MPI_MESSAGE_NO_PROC at T6 Improbe().'
532 call MPI_Get_count(s1, MPI_INTEGER, count, ierr)
533 if (count .ne. 0) then
535 print *, 'probed buffer does not have 0 MPI_INTEGER.'
538 recvbuf(1) = 19088743
539 recvbuf(2) = 1309737967
540 call MPI_Mrecv(recvbuf, count, MPI_INTEGER, msg, s2, ierr)
541 ! recvbuf() should remain unmodified
542 if (recvbuf(1) .ne. 19088743) then
544 print *, 'recvbuf(1) is corrupted at T6 Mrecv().'
546 if (recvbuf(2) .ne. 1309737967) then
548 print *, 'recvbuf(2) is corrupted at T6 Mrecv().'
550 if (s2(MPI_SOURCE) .ne. MPI_PROC_NULL) then
552 print *, 's2(MPI_SOURCE) != MPI_PROC_NULL at T6 Mrecv().'
554 if (s2(MPI_TAG) .ne. MPI_ANY_TAG) then
556 print *, 's2(MPI_TAG) != MPI_ANY_TAG at T6 Mrecv().'
558 if (s2(MPI_ERROR) .ne. MPI_ERR_OTHER) then
560 print *, 's2(MPI_ERROR) != MPI_ERR_OTHER at T6 Mrecv().'
562 if (msg .ne. MPI_MESSAGE_NULL) then
564 print *, 'msg != MPI_MESSAGE_NULL at T6 Mrecv().'
568 call MPI_Get_count(s2, MPI_INTEGER, count, ierr)
569 if (count .ne. 0) then
571 print *, 'recv buffer does not have 0 MPI_INTEGER.'
575 ! Test 7: Improbe+Imrecv with MPI_PROC_NULL
577 do idx = 1, MPI_STATUS_SIZE
581 ! the error fields are initialized for modification check.
582 s1(MPI_ERROR) = MPI_ERR_DIMS
583 s2(MPI_ERROR) = MPI_ERR_OTHER
586 msg = MPI_MESSAGE_NULL
587 call MPI_Improbe(MPI_PROC_NULL, 5, MPI_COMM_WORLD, &
588 & found, msg, s1, ierr)
589 if (.not. found) then
591 print *, 'found is false at T7 Improbe().'
593 if (s1(MPI_SOURCE) .ne. MPI_PROC_NULL) then
595 print *, 's1(MPI_SOURCE) != MPI_PROC_NULL at T7 Improbe()'
597 if (s1(MPI_TAG) .ne. MPI_ANY_TAG) then
599 print *, 's1(MPI_TAG) != MPI_ANY_TAG at T7 Improbe().'
601 if (s1(MPI_ERROR) .ne. MPI_ERR_DIMS) then
603 print *, 's1(MPI_ERROR) != MPI_ERR_DIMS at T7 Improbe().'
605 if (msg .ne. MPI_MESSAGE_NO_PROC) then
607 print *, 'msg != MPI_MESSAGE_NO_PROC at T7 Improbe().'
611 call MPI_Get_count(s1, MPI_INTEGER, count, ierr)
612 if (count .ne. 0) then
614 print *, 'probed buffer does not have 0 MPI_INTEGER.'
617 rreq = MPI_REQUEST_NULL
618 recvbuf(1) = 19088743
619 recvbuf(2) = 1309737967
620 call MPI_Imrecv(recvbuf, count, MPI_INTEGER, msg, rreq, ierr)
621 if (rreq .eq. MPI_REQUEST_NULL) then
623 print *, 'rreq == MPI_REQUEST_NULL at T7 Imrecv().'
626 call MPI_Test(rreq, flag, s2, ierr)
629 print *, 'flag is false at T7 Imrecv().'
631 ! recvbuf() should remain unmodified
632 if (recvbuf(1) .ne. 19088743) then
634 print *, 'recvbuf(1) is corrupted at T7 Imrecv().'
636 if (recvbuf(2) .ne. 1309737967) then
638 print *, 'recvbuf(2) is corrupted at T7 Imrecv().'
640 if (s2(MPI_SOURCE) .ne. MPI_PROC_NULL) then
642 print *, 's2(MPI_SOURCE) != MPI_PROC_NULL at T7 Imrecv().'
644 if (s2(MPI_TAG) .ne. MPI_ANY_TAG) then
646 print *, 's2(MPI_TAG) != MPI_ANY_TAG at T7 Imrecv().'
648 if (s2(MPI_ERROR) .ne. MPI_ERR_OTHER) then
650 print *, 's2(MPI_ERROR) != MPI_ERR_OTHER at T7 Imrecv().'
652 if (msg .ne. MPI_MESSAGE_NULL) then
654 print *, 'msg != MPI_MESSAGE_NULL at T7 Imrecv().'
658 call MPI_Get_count(s2, MPI_INTEGER, count, ierr)
659 if (count .ne. 0) then
661 print *, 'recv buffer does not have 0 MPI_INTEGER.'
665 call mtest_finalize( errs )
666 call mpi_finalize( ierr )