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