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