1! { dg-do  run }
2! { dg-options "-fbounds-check" }
3!
4! Contributed by Juergen Reuter
5! Check that pr65548 is fixed and that the ICE is gone, when bounds-check
6! is requested.
7!
8
9module selectors
10  type :: selector_t
11     integer, dimension(:), allocatable :: map
12     real, dimension(:), allocatable :: weight
13   contains
14     procedure :: init => selector_init
15   end type selector_t
16
17contains
18
19  subroutine selector_init (selector, weight)
20    class(selector_t), intent(out) :: selector
21    real, dimension(:), intent(in) :: weight
22    real :: s
23    integer :: n, i
24    logical, dimension(:), allocatable :: mask
25    s = sum (weight)
26    allocate (mask (size (weight)), source = weight /= 0)
27    n = count (mask)
28    if (n > 0) then
29       allocate (selector%map (n), &
30            source = pack ([(i, i = 1, size (weight))], mask))
31       allocate (selector%weight (n), &
32            source = pack (weight / s, mask))
33    else
34       allocate (selector%map (1), source = 1)
35       allocate (selector%weight (1), source = 0.)
36    end if
37  end subroutine selector_init
38
39end module selectors
40
41module phs_base
42  type :: flavor_t
43  contains
44     procedure :: get_mass => flavor_get_mass
45  end type flavor_t
46
47  type :: phs_config_t
48     integer :: n_in = 0
49     type(flavor_t), dimension(:,:), allocatable :: flv
50  end type phs_config_t
51
52  type :: phs_t
53     class(phs_config_t), pointer :: config => null ()
54     real, dimension(:), allocatable :: m_in
55  end type phs_t
56
57contains
58
59  elemental function flavor_get_mass (flv) result (mass)
60    real :: mass
61    class(flavor_t), intent(in) :: flv
62    mass = 42.0
63  end function flavor_get_mass
64
65  subroutine phs_base_init (phs, phs_config)
66    class(phs_t), intent(out) :: phs
67    class(phs_config_t), intent(in), target :: phs_config
68    phs%config => phs_config
69    allocate (phs%m_in  (phs%config%n_in), &
70         source = phs_config%flv(:phs_config%n_in, 1)%get_mass ())
71  end subroutine phs_base_init
72
73end module phs_base
74
75module foo
76  type :: t
77     integer :: n
78     real, dimension(:,:), allocatable :: val
79   contains
80     procedure :: make => t_make
81     generic :: get_int => get_int_array, get_int_element
82     procedure :: get_int_array => t_get_int_array
83     procedure :: get_int_element => t_get_int_element
84  end type t
85
86contains
87
88  subroutine t_make (this)
89    class(t), intent(inout) :: this
90    real, dimension(:), allocatable :: int
91    allocate (int (0:this%n-1), source=this%get_int())
92  end subroutine t_make
93
94  pure function t_get_int_array (this) result (array)
95    class(t), intent(in) :: this
96    real, dimension(this%n) :: array
97    array = this%val (0:this%n-1, 4)
98  end function t_get_int_array
99
100  pure function t_get_int_element (this, set) result (element)
101    class(t), intent(in) :: this
102    integer, intent(in) :: set
103    real :: element
104    element = this%val (set, 4)
105  end function t_get_int_element
106end module foo
107module foo2
108  type :: t2
109     integer :: n
110     character(32), dimension(:), allocatable :: md5
111   contains
112     procedure :: init => t2_init
113  end type t2
114
115contains
116
117  subroutine t2_init (this)
118    class(t2), intent(inout) :: this
119    character(32), dimension(:), allocatable :: md5
120    allocate (md5 (this%n), source=this%md5)
121    if (md5(1) /= "tst                             ") STOP 1
122    if (md5(2) /= "                                ") STOP 2
123    if (md5(3) /= "fooblabar                       ") STOP 3
124  end subroutine t2_init
125end module foo2
126
127program test
128  use selectors
129  use phs_base
130  use foo
131  use foo2
132
133  type(selector_t) :: sel
134  type(phs_t) :: phs
135  type(phs_config_t) :: phs_config
136  type(t) :: o
137  type(t2) :: o2
138
139  call sel%init([2., 0., 3., 0., 4.])
140
141  if (any(sel%map /= [1, 3, 5])) STOP 4
142  if (any(abs(sel%weight - [2., 3., 4.] / 9.) > 1E-6)) STOP 5
143
144  phs_config%n_in = 2
145  allocate (phs_config%flv (phs_config%n_in, 1))
146  call phs_base_init (phs, phs_config)
147
148  if (any(abs(phs%m_in - [42.0, 42.0]) > 1E-6)) STOP 6
149
150  o%n = 2
151  allocate (o%val(0:1,4))
152  call o%make()
153
154  o2%n = 3
155  allocate(o2%md5(o2%n))
156  o2%md5(1) = "tst"
157  o2%md5(2) = ""
158  o2%md5(3) = "fooblabar"
159  call o2%init()
160end program test
161
162