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!
8module 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
17end module const_mod
18
19
20module 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
95contains
96end module error_mod
97
98submodule (error_mod) error_impl_mod
99  use const_mod
100contains
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
160end submodule error_impl_mod
161
162program testlk
163  use error_mod
164  implicit none
165
166  call error()
167
168  stop
169end program testlk
170