|
131
|
1 ! { dg-do compile }
|
|
|
2 ! { dg-options "-fdump-tree-original" }
|
|
|
3 !
|
|
|
4 ! Test the fix for the second part of PR87359 in which the reallocation on
|
|
|
5 ! assignment for components of associate names was disallowed by r264358.
|
|
|
6 ! -fcheck-all exposed the mismatch in array shapes. The deallocations at
|
|
|
7 ! the end of the main program are there to make sure that valgrind does
|
|
|
8 ! not report an memory leaks.
|
|
|
9 !
|
|
|
10 ! Contributed by Juergen Reuter <juergen.reuter@desy.de>
|
|
|
11 !
|
|
|
12 module phs_fks
|
|
|
13 implicit none
|
|
|
14 private
|
|
|
15 public :: phs_identifier_t
|
|
|
16 public :: phs_fks_t
|
|
|
17 type :: phs_identifier_t
|
|
|
18 integer, dimension(:), allocatable :: contributors
|
|
|
19 contains
|
|
|
20 procedure :: init => phs_identifier_init
|
|
|
21 end type phs_identifier_t
|
|
|
22
|
|
|
23 type :: phs_fks_t
|
|
|
24 type(phs_identifier_t), dimension(:), allocatable :: phs_identifiers
|
|
|
25 end type phs_fks_t
|
|
|
26 contains
|
|
|
27
|
|
|
28 subroutine phs_identifier_init &
|
|
|
29 (phs_id, contributors)
|
|
|
30 class(phs_identifier_t), intent(out) :: phs_id
|
|
|
31 integer, intent(in), dimension(:) :: contributors
|
|
|
32 allocate (phs_id%contributors (size (contributors)))
|
|
|
33 phs_id%contributors = contributors
|
|
|
34 end subroutine phs_identifier_init
|
|
|
35
|
|
|
36 end module phs_fks
|
|
|
37
|
|
|
38 !!!!!
|
|
|
39
|
|
|
40 module instances
|
|
|
41 use phs_fks
|
|
|
42 implicit none
|
|
|
43 private
|
|
|
44 public :: process_instance_t
|
|
|
45
|
|
|
46 type :: nlo_event_deps_t
|
|
|
47 type(phs_identifier_t), dimension(:), allocatable :: phs_identifiers
|
|
|
48 end type nlo_event_deps_t
|
|
|
49
|
|
|
50 type :: process_instance_t
|
|
|
51 type(phs_fks_t), pointer :: phs => null ()
|
|
|
52 type(nlo_event_deps_t) :: event_deps
|
|
|
53 contains
|
|
|
54 procedure :: init => process_instance_init
|
|
|
55 procedure :: setup_real_event_kinematics => pi_setup_real_event_kinematics
|
|
|
56 end type process_instance_t
|
|
|
57
|
|
|
58 contains
|
|
|
59
|
|
|
60 subroutine process_instance_init (instance)
|
|
|
61 class(process_instance_t), intent(out), target :: instance
|
|
|
62 integer :: i
|
|
|
63 integer :: i_born, i_real
|
|
|
64 allocate (instance%phs)
|
|
|
65 end subroutine process_instance_init
|
|
|
66
|
|
|
67 subroutine pi_setup_real_event_kinematics (process_instance)
|
|
|
68 class(process_instance_t), intent(inout) :: process_instance
|
|
|
69 integer :: i_real, i
|
|
|
70 associate (event_deps => process_instance%event_deps)
|
|
|
71 i_real = 2
|
|
|
72 associate (phs => process_instance%phs)
|
|
|
73 allocate (phs%phs_identifiers (3))
|
|
|
74 call phs%phs_identifiers(1)%init ([1])
|
|
|
75 call phs%phs_identifiers(2)%init ([1,2])
|
|
|
76 call phs%phs_identifiers(3)%init ([1,2,3])
|
|
|
77 process_instance%event_deps%phs_identifiers = phs%phs_identifiers ! Error: mismatch in array shapes.
|
|
|
78 end associate
|
|
|
79 end associate
|
|
|
80 end subroutine pi_setup_real_event_kinematics
|
|
|
81
|
|
|
82 end module instances
|
|
|
83
|
|
|
84 !!!!!
|
|
|
85
|
|
|
86 program main
|
|
|
87 use instances, only: process_instance_t
|
|
|
88 implicit none
|
|
|
89 type(process_instance_t), allocatable, target :: process_instance
|
|
|
90 allocate (process_instance)
|
|
|
91 call process_instance%init ()
|
|
|
92 call process_instance%setup_real_event_kinematics ()
|
|
|
93 if (associated (process_instance%phs)) deallocate (process_instance%phs)
|
|
|
94 if (allocated (process_instance)) deallocate (process_instance)
|
|
|
95 end program main
|
|
|
96 ! { dg-final { scan-tree-dump-times "__builtin_realloc" 2 "original" } }
|
