1! { dg-do run }
2!
3! Check that pr65548 is fixed.
4! Contributed by Juergen Reuter  <juergen.reuter@desy.de>
5
6module allocate_with_source_5_module
7
8  type :: selector_t
9    integer, dimension(:), allocatable :: map
10    real, dimension(:), allocatable :: weight
11  contains
12    procedure :: init => selector_init
13  end type selector_t
14
15contains
16
17  subroutine selector_init (selector, weight)
18    class(selector_t), intent(out) :: selector
19    real, dimension(:), intent(in) :: weight
20    real :: s
21    integer :: n, i
22    logical, dimension(:), allocatable :: mask
23    s = sum (weight)
24    allocate (mask (size (weight)), source = weight /= 0)
25    n = count (mask)
26    if (n > 0) then
27       allocate (selector%map (n), &
28            source = pack ([(i, i = 1, size (weight))], mask))
29       allocate (selector%weight (n), &
30            source = pack (weight / s, mask))
31    else
32       allocate (selector%map (1), source = 1)
33       allocate (selector%weight (1), source = 0.)
34    end if
35  end subroutine selector_init
36
37end module allocate_with_source_5_module
38
39program allocate_with_source_5
40  use allocate_with_source_5_module
41
42  class(selector_t), allocatable :: sel;
43  real, dimension(5) :: w = [ 1, 0, 2, 0, 3];
44
45  allocate (sel)
46  call sel%init(w)
47
48  if (any(sel%map /= [ 1, 3, 5])) call abort()
49  if (any(abs(sel%weight - [1, 2, 3] / 6) < 1E-6)) call abort()
50end program allocate_with_source_5
51! { dg-final { cleanup-modules "allocate_with_source_5_module" } }
52
53