1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
|
! { dg-do compile }
! { dg-require-visibility "" }
!
! Checks that PRIVATE enities are visible to submodules.
!
! Contributed by Salvatore Filippone <salvatore.filippone@uniroma2.it>
!
module const_mod
integer, parameter :: ndig=8
integer, parameter :: ipk_ = selected_int_kind(ndig)
integer, parameter :: longndig=12
integer, parameter :: long_int_k_ = selected_int_kind(longndig)
integer, parameter :: mpik_ = kind(1)
integer(ipk_), parameter, public :: success_=0
end module const_mod
module error_mod
use const_mod
integer(ipk_), parameter, public :: act_ret_=0
integer(ipk_), parameter, public :: act_print_=1
integer(ipk_), parameter, public :: act_abort_=2
integer(ipk_), parameter, public :: no_err_ = 0
public error, errcomm, get_numerr, &
& error_handler, &
& ser_error_handler, par_error_handler
interface error_handler
module subroutine ser_error_handler(err_act)
integer(ipk_), intent(inout) :: err_act
end subroutine ser_error_handler
module subroutine par_error_handler(ictxt,err_act)
integer(mpik_), intent(in) :: ictxt
integer(ipk_), intent(in) :: err_act
end subroutine par_error_handler
end interface
interface error
module subroutine serror()
end subroutine serror
module subroutine perror(ictxt,abrt)
integer(mpik_), intent(in) :: ictxt
logical, intent(in), optional :: abrt
end subroutine perror
end interface
interface error_print_stack
module subroutine par_error_print_stack(ictxt)
integer(mpik_), intent(in) :: ictxt
end subroutine par_error_print_stack
module subroutine ser_error_print_stack()
end subroutine ser_error_print_stack
end interface
interface errcomm
module subroutine errcomm(ictxt, err)
integer(mpik_), intent(in) :: ictxt
integer(ipk_), intent(inout):: err
end subroutine errcomm
end interface errcomm
private
type errstack_node
integer(ipk_) :: err_code=0
character(len=20) :: routine=''
integer(ipk_),dimension(5) :: i_err_data=0
character(len=40) :: a_err_data=''
type(errstack_node), pointer :: next
end type errstack_node
type errstack
type(errstack_node), pointer :: top => null()
integer(ipk_) :: n_elems=0
end type errstack
type(errstack), save :: error_stack
integer(ipk_), save :: error_status = no_err_
integer(ipk_), save :: verbosity_level = 1
integer(ipk_), save :: err_action = act_abort_
integer(ipk_), save :: debug_level = 0, debug_unit, serial_debug_level=0
contains
end module error_mod
submodule (error_mod) error_impl_mod
use const_mod
contains
! checks whether an error has occurred on one of the processes in the execution pool
subroutine errcomm(ictxt, err)
integer(mpik_), intent(in) :: ictxt
integer(ipk_), intent(inout):: err
end subroutine errcomm
subroutine ser_error_handler(err_act)
implicit none
integer(ipk_), intent(inout) :: err_act
if (err_act /= act_ret_) &
& call error()
if (err_act == act_abort_) stop
return
end subroutine ser_error_handler
subroutine par_error_handler(ictxt,err_act)
implicit none
integer(mpik_), intent(in) :: ictxt
integer(ipk_), intent(in) :: err_act
if (err_act == act_print_) &
& call error(ictxt, abrt=.false.)
if (err_act == act_abort_) &
& call error(ictxt, abrt=.true.)
return
end subroutine par_error_handler
subroutine par_error_print_stack(ictxt)
integer(mpik_), intent(in) :: ictxt
call error(ictxt, abrt=.false.)
end subroutine par_error_print_stack
subroutine ser_error_print_stack()
call error()
end subroutine ser_error_print_stack
subroutine serror()
implicit none
end subroutine serror
subroutine perror(ictxt,abrt)
use const_mod
implicit none
integer(mpik_), intent(in) :: ictxt
logical, intent(in), optional :: abrt
end subroutine perror
end submodule error_impl_mod
program testlk
use error_mod
implicit none
call error()
stop
end program testlk
|
