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