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