Skip to content

Commit d501299

Browse files
naughtont3naughtont3
committed
envmgmt: add fortran test to check remove_error_*
Signed-off-by: Thomas Naughton <[email protected]>
1 parent bf41c56 commit d501299

File tree

6 files changed

+402
-1
lines changed

6 files changed

+402
-1
lines changed

‎environ-mgmt/README.md‎

Lines changed: 7 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -25,6 +25,13 @@ Usage
2525
mpirun -np 1 ./src/test_add_del_err_codes
2626
```
2727

28+
- (Fortran) Build/Run
29+
```
30+
./autogen.sh && ./configure FC=mpifort && make
31+
mpirun -np 1 ./src/test_add_err_codes_usempi
32+
mpirun -np 1 ./src/test_add_err_codes_usempif08
33+
```
34+
2835
Example Output
2936
--------------
3037

‎environ-mgmt/configure.ac‎

Lines changed: 5 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -67,6 +67,11 @@ CFLAGS_save=$CFLAGS
6767
AC_PROG_CC
6868
CFLAGS=$CFLAGS_save
6969

70+
FFLAGS_save=$FFLAGS
71+
AC_PROG_FC
72+
FFLAGS=$FFLAGS_save
73+
74+
7075
dnl
7176
dnl Because these are meant to be used for debugging, after all
7277
dnl

‎environ-mgmt/src/Makefile.am‎

Lines changed: 15 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -6,7 +6,21 @@
66
# $COPYRIGHT$
77
#
88

9-
noinst_PROGRAMS = test_add_del_err_codes
9+
noinst_PROGRAMS = test_add_del_err_codes \
10+
test_add_err_codes_usempi \
11+
test_add_del_err_codes_usempi \
12+
test_add_del_err_codes_usempif08
1013

1114
test_add_del_err_codes_SOURCES = \
1215
test_add_del_err_codes.c
16+
17+
test_add_err_codes_usempi_SOURCES = \
18+
test_add_err_codes_usempi.f90
19+
20+
test_add_del_err_codes_usempi_SOURCES = \
21+
test_add_del_err_codes_usempi.f90
22+
23+
test_add_del_err_codes_usempif08_SOURCES = \
24+
test_add_del_err_codes_usempif08.f90
25+
26+

‎environ-mgmt/src/test_add_del_err_codes_usempi.f90‎

Lines changed: 161 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,161 @@
1+
!
2+
! Copyright (c) 2025 UT-Battelle, LLC. All rights reserved.
3+
!
4+
! Tests for MPI_LASTUSEDCODE, MPI_Add_error_{class,code,string}, and
5+
! MPI_Remove_error{class,code,string}.
6+
!
7+
! File: test_add_del_err_codes_usempi.f90
8+
!
9+
! Referenced examples online and in ompi-tests:
10+
! - "ompi-tests/random/add_error_class.c"
11+
! - example from Lisandro Dalcin
12+
! https://www.open-mpi.org/community/lists/devel/2014/04/14578.php
13+
!
14+
program main
15+
use mpi
16+
implicit none
17+
integer :: ierr, rank, size, eclass, ecode
18+
integer(kind=MPI_ADDRESS_KIND) :: last
19+
integer(kind=MPI_ADDRESS_KIND) :: newlast
20+
logical :: flag
21+
character(len=*), parameter :: estr = "My Dummy Error String"
22+
23+
call MPI_INIT(ierr)
24+
if (ierr /= MPI_SUCCESS) then
25+
write(*,*) 'Error: MPI_INIT failed (ierr=', ierr, ')'
26+
stop 1
27+
end if
28+
29+
call MPI_COMM_RANK(MPI_COMM_WORLD, rank, ierr)
30+
if (ierr /= MPI_SUCCESS) then
31+
write(*,*) 'Error: MPI_COMM_RANK failed (ierr=', ierr, ')'
32+
stop 1
33+
end if
34+
35+
call MPI_COMM_SIZE(MPI_COMM_WORLD, size, ierr)
36+
if (ierr /= MPI_SUCCESS) then
37+
write(*,*) 'Error: MPI_COMM_SIZE failed (ierr=', ierr, ')'
38+
stop 1
39+
end if
40+
41+
write(*, '("Hello rank: ", i2, " of ", i2)') &
42+
rank, size
43+
44+
call MPI_COMM_GET_ATTR(MPI_COMM_WORLD, MPI_LASTUSEDCODE, last, flag, ierr)
45+
if (ierr /= MPI_SUCCESS) then
46+
write(*,*) 'Error: MPI_COMM_GET_ATTR failed (ierr=', ierr, ')'
47+
stop 1
48+
end if
49+
write(*, '("DBG last: ", i0)') &
50+
last
51+
52+
! Add error class/code/string
53+
call MPI_ADD_ERROR_CLASS(eclass, ierr)
54+
if (ierr /= MPI_SUCCESS) then
55+
write(*,*) 'Error: MPI_ADD_ERROR_CLASS failed (ierr=', ierr, ')'
56+
stop 1
57+
end if
58+
59+
call MPI_ADD_ERROR_CODE(eclass, ecode, ierr)
60+
if (ierr /= MPI_SUCCESS) then
61+
write(*,*) 'Error: MPI_ADD_ERROR_CODE failed (ierr=', ierr, ')'
62+
stop 1
63+
end if
64+
65+
call MPI_ADD_ERROR_STRING(ecode, estr, ierr)
66+
if (ierr /= MPI_SUCCESS) then
67+
write(*,*) 'Error: MPI_ADD_ERROR_STRING failed (ierr=', ierr, ')'
68+
stop 1
69+
end if
70+
71+
call MPI_COMM_GET_ATTR(MPI_COMM_WORLD, MPI_LASTUSEDCODE, newlast, flag, ierr)
72+
if (ierr /= MPI_SUCCESS) then
73+
write(*,*) 'Error: MPI_COMM_GET_ATTR failed (ierr=', ierr, ')'
74+
stop 1
75+
end if
76+
77+
! Check that last error code increased
78+
if (newlast > last) then
79+
write(*, '("TEST: Success creating error class/code/string last: ", i0, " newlast: ", i0)') &
80+
last, newlast
81+
else
82+
write(*, '("Error: MPI_Add_error_xxx failed LastUsedCode not increased last: ", i0, " newlast: ", i0)') &
83+
last, newlast
84+
end if
85+
86+
write(*,*) '==== Adds done ===='
87+
88+
! Remove error string
89+
write(*,*) '==== Remove estring ===='
90+
call MPI_REMOVE_ERROR_STRING(ecode, ierr)
91+
if (ierr /= MPI_SUCCESS) then
92+
write(*,*) 'Error: MPI_REMOVE_ERROR_STRING failed (ierr=', ierr, ')'
93+
stop 1
94+
end if
95+
write(*,*) 'TEST: Success removing error string'
96+
97+
! Remove error code
98+
write(*,*) '==== Remove ecode ===='
99+
call MPI_COMM_GET_ATTR(MPI_COMM_WORLD, MPI_LASTUSEDCODE, last, flag, ierr)
100+
if (ierr /= MPI_SUCCESS) then
101+
write(*,*) 'Error: MPI_COMM_GET_ATTR failed (ierr=', ierr, ')'
102+
stop 1
103+
end if
104+
105+
call MPI_REMOVE_ERROR_CODE(ecode, ierr)
106+
if (ierr /= MPI_SUCCESS) then
107+
write(*,*) 'Error: MPI_REMOVE_ERROR_CODE failed (ierr=', ierr, ')'
108+
stop 1
109+
end if
110+
111+
call MPI_COMM_GET_ATTR(MPI_COMM_WORLD, MPI_LASTUSEDCODE, newlast, flag, ierr)
112+
if (ierr /= MPI_SUCCESS) then
113+
write(*,*) 'Error: MPI_COMM_GET_ATTR failed (ierr=', ierr, ')'
114+
stop 1
115+
end if
116+
117+
! Check that last error code decreased
118+
if (newlast < last) then
119+
write(*, '("TEST: Success removed error code last: ", i0, " newlast: ", i0)') &
120+
last, newlast
121+
else
122+
write(*, '("Error: MPI_REMOVE_ERROR_CODE failed LastUsedCode not decreased last: ", i0, " newlast: ", i0)') &
123+
last, newlast
124+
end if
125+
126+
! Remove error class
127+
write(*,*) '==== Remove eclass ===='
128+
call MPI_COMM_GET_ATTR(MPI_COMM_WORLD, MPI_LASTUSEDCODE, last, flag, ierr)
129+
if (ierr /= MPI_SUCCESS) then
130+
write(*,*) 'Error: MPI_COMM_GET_ATTR failed (ierr=', ierr, ')'
131+
stop 1
132+
end if
133+
134+
call MPI_REMOVE_ERROR_CLASS(eclass, ierr)
135+
if (ierr /= MPI_SUCCESS) then
136+
write(*,*) 'Error: MPI_REMOVE_ERROR_CLASS failed (ierr=', ierr, ')'
137+
stop 1
138+
end if
139+
140+
call MPI_COMM_GET_ATTR(MPI_COMM_WORLD, MPI_LASTUSEDCODE, newlast, flag, ierr)
141+
if (ierr /= MPI_SUCCESS) then
142+
write(*,*) 'Error: MPI_COMM_GET_ATTR failed (ierr=', ierr, ')'
143+
stop 1
144+
end if
145+
146+
! Check that last error code decreased
147+
if (newlast < last) then
148+
write(*, '("TEST: Success removed error class last: ", i0, " newlast: ", i0)') &
149+
last, newlast
150+
else
151+
write(*, '("Error: MPI_REMOVE_ERROR_CLASS failed LastUsedCode not decrea sed last: ", i0, " newlast: ", i0)') &
152+
last, newlast
153+
end if
154+
155+
call MPI_FINALIZE(ierr)
156+
if (ierr /= MPI_SUCCESS) then
157+
write(*,*) 'Error: MPI_FINALIZE failed (ierr=', ierr, ')'
158+
stop 1
159+
end if
160+
end
161+

‎environ-mgmt/src/test_add_del_err_codes_usempif08.f90‎

Lines changed: 162 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,162 @@
1+
! -*- f90 -*-
2+
!
3+
! Copyright (c) 2025 UT-Battelle, LLC. All rights reserved.
4+
!
5+
! Tests for MPI_LASTUSEDCODE, MPI_Add_error_{class,code,string}, and
6+
! MPI_Remove_error{class,code,string}.
7+
!
8+
! File: test_add_del_err_codes_usempif08.f90
9+
!
10+
! Referenced examples online and in ompi-tests:
11+
! - "ompi-tests/random/add_error_class.c"
12+
! - example from Lisandro Dalcin
13+
! https://www.open-mpi.org/community/lists/devel/2014/04/14578.php
14+
!
15+
program main
16+
use mpi_f08
17+
implicit none
18+
integer :: rank, size, eclass, ecode, ierr
19+
integer(kind=MPI_ADDRESS_KIND) :: last
20+
integer(kind=MPI_ADDRESS_KIND) :: newlast
21+
logical :: flag
22+
character(len=*), parameter :: estr = "My Dummy Error String"
23+
24+
call MPI_INIT(ierr)
25+
if (ierr /= MPI_SUCCESS) then
26+
write(*,*) 'Error: MPI_INIT failed (ierr=', ierr, ')'
27+
stop 1
28+
end if
29+
30+
call MPI_COMM_RANK(MPI_COMM_WORLD, rank, ierr)
31+
if (ierr /= MPI_SUCCESS) then
32+
write(*,*) 'Error: MPI_COMM_RANK failed (ierr=', ierr, ')'
33+
stop 1
34+
end if
35+
36+
call MPI_COMM_SIZE(MPI_COMM_WORLD, size, ierr)
37+
if (ierr /= MPI_SUCCESS) then
38+
write(*,*) 'Error: MPI_COMM_SIZE failed (ierr=', ierr, ')'
39+
stop 1
40+
end if
41+
42+
write(*, '("Hello rank: ", i2, " of ", i2)') &
43+
rank, size
44+
45+
call MPI_COMM_GET_ATTR(MPI_COMM_WORLD, MPI_LASTUSEDCODE, last, flag, ierr)
46+
if (ierr /= MPI_SUCCESS) then
47+
write(*,*) 'Error: MPI_COMM_GET_ATTR failed (ierr=', ierr, ')'
48+
stop 1
49+
end if
50+
write(*, '("DBG last: ", i0)') &
51+
last
52+
! Add error class/code/string
53+
call MPI_ADD_ERROR_CLASS(eclass, ierr)
54+
if (ierr /= MPI_SUCCESS) then
55+
write(*,*) 'Error: MPI_ADD_ERROR_CLASS failed (ierr=', ierr, ')'
56+
stop 1
57+
end if
58+
59+
call MPI_ADD_ERROR_CODE(eclass, ecode, ierr)
60+
if (ierr /= MPI_SUCCESS) then
61+
write(*,*) 'Error: MPI_ADD_ERROR_CODE failed (ierr=', ierr, ')'
62+
stop 1
63+
end if
64+
65+
call MPI_ADD_ERROR_STRING(ecode, estr, ierr)
66+
if (ierr /= MPI_SUCCESS) then
67+
write(*,*) 'Error: MPI_ADD_ERROR_STRING failed (ierr=', ierr, ')'
68+
stop 1
69+
end if
70+
71+
call MPI_COMM_GET_ATTR(MPI_COMM_WORLD, MPI_LASTUSEDCODE, newlast, flag, ierr)
72+
if (ierr /= MPI_SUCCESS) then
73+
write(*,*) 'Error: MPI_COMM_GET_ATTR failed (ierr=', ierr, ')'
74+
stop 1
75+
end if
76+
77+
! Check that last error code increased
78+
if (newlast > last) then
79+
write(*, '("TEST: Success creating error class/code/string last: ", i0, " newlast: ", i0)') &
80+
last, newlast
81+
else
82+
write(*, '("Error: MPI_Add_error_xxx failed LastUsedCode not increased l ast: ", i0, " newlast: ", i0)') &
83+
last, newlast
84+
end if
85+
86+
write(*,*) '==== Adds done ===='
87+
88+
! Remove error string
89+
write(*,*) '==== Remove estring ===='
90+
call MPI_REMOVE_ERROR_STRING(ecode, ierr)
91+
if (ierr /= MPI_SUCCESS) then
92+
write(*,*) 'Error: MPI_REMOVE_ERROR_STRING failed (ierr=', ierr, ')'
93+
stop 1
94+
end if
95+
write(*,*) 'TEST: Success removing error string'
96+
97+
! Remove error code
98+
write(*,*) '==== Remove ecode ===='
99+
call MPI_COMM_GET_ATTR(MPI_COMM_WORLD, MPI_LASTUSEDCODE, last, flag, ierr)
100+
if (ierr /= MPI_SUCCESS) then
101+
write(*,*) 'Error: MPI_COMM_GET_ATTR failed (ierr=', ierr, ')'
102+
stop 1
103+
end if
104+
105+
call MPI_REMOVE_ERROR_CODE(ecode, ierr)
106+
if (ierr /= MPI_SUCCESS) then
107+
write(*,*) 'Error: MPI_REMOVE_ERROR_CODE failed (ierr=', ierr, ')'
108+
stop 1
109+
end if
110+
111+
call MPI_COMM_GET_ATTR(MPI_COMM_WORLD, MPI_LASTUSEDCODE, newlast, flag, ierr)
112+
if (ierr /= MPI_SUCCESS) then
113+
write(*,*) 'Error: MPI_COMM_GET_ATTR failed (ierr=', ierr, ')'
114+
stop 1
115+
end if
116+
117+
! Check that last error code decreased
118+
if (newlast < last) then
119+
write(*, '("TEST: Success removed error code last: ", i0, " newlast: ", i0)') &
120+
last, newlast
121+
else
122+
write(*, '("Error: MPI_REMOVE_ERROR_CODE failed LastUsedCode not decreas ed last: ", i0, " newlast: ", i0)') &
123+
last, newlast
124+
end if
125+
126+
! Remove error class
127+
write(*,*) '==== Remove eclass ===='
128+
call MPI_COMM_GET_ATTR(MPI_COMM_WORLD, MPI_LASTUSEDCODE, last, flag, ierr)
129+
if (ierr /= MPI_SUCCESS) then
130+
write(*,*) 'Error: MPI_COMM_GET_ATTR failed (ierr=', ierr, ')'
131+
stop 1
132+
end if
133+
134+
call MPI_REMOVE_ERROR_CLASS(eclass, ierr)
135+
if (ierr /= MPI_SUCCESS) then
136+
write(*,*) 'Error: MPI_REMOVE_ERROR_CLASS failed (ierr=', ierr, ')'
137+
stop 1
138+
end if
139+
140+
call MPI_COMM_GET_ATTR(MPI_COMM_WORLD, MPI_LASTUSEDCODE, newlast, flag, ierr)
141+
if (ierr /= MPI_SUCCESS) then
142+
write(*,*) 'Error: MPI_COMM_GET_ATTR failed (ierr=', ierr, ')'
143+
stop 1
144+
end if
145+
146+
147+
! Check that last error code decreased
148+
if (newlast < last) then
149+
write(*, '("TEST: Success removed error class last: ", i0, " newlast: ", i0)') &
150+
last, newlast
151+
else
152+
write(*, '("Error: MPI_REMOVE_ERROR_CLASS failed LastUsedCode not decreased last: ", i0, " newlast: ", i0)') &
153+
last, newlast
154+
end if
155+
156+
call MPI_FINALIZE(ierr)
157+
if (ierr /= MPI_SUCCESS) then
158+
write(*,*) 'Error: MPI_FINALIZE failed (ierr=', ierr, ')'
159+
stop 1
160+
end if
161+
end
162+

0 commit comments

Comments
 (0)