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