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