3 ! Test the fix for PR55763 comment 9 as part of the overall fix for PR34640.
5 ! Contributed by Tobias Burnus <burnus@gcc.gnu.org>
7 program change_field_type
8 use, intrinsic :: iso_c_binding
10 REAL(kind
=c_float
), POINTER :: vector_comp(:)
11 TYPE, BIND(C
) :: scalar_vector
12 REAL(kind
=c_float
) :: scalar
13 REAL(kind
=c_float
) :: vec(3)
15 TYPE, BIND(C
) :: scalar_vector_matrix
16 REAL(kind
=c_float
) :: scalar
17 REAL(kind
=c_float
) :: vec(3)
18 REAL(kind
=c_float
) :: mat(3,3)
20 CLASS(*), ALLOCATABLE
, TARGET
:: one_d_field(:)
21 real, pointer :: v1(:)
23 allocate(one_d_field(3), &
24 source
= (/ scalar_vector( 1.0, (/ -1.0, 0.0, 1.0 /) ), &
25 scalar_vector( 1.1, (/ -1.2, 0.2, 0.9 /) ), &
26 scalar_vector( 1.2, (/ -1.4, 0.4, 0.8 /) ) /) )
28 call extract_vec(one_d_field
, 1, 2)
29 if (any (abs (vector_comp
- [0.0,0.2,0.4]) .gt
. 1e-4)) call abort
30 deallocate(one_d_field
) ! v1 becomes undefined
32 allocate(one_d_field(1), &
33 source
= (/ scalar_vector_matrix( 1.0, (/ -1.0, 0.0, 1.0 /), &
34 reshape( (/ 1.0, 0.0, 0.0, 0.0, 1.0, 0.0, 0.0, 0.0, 1.0 /), &
37 call extract_vec(one_d_field
, 2, 1)
38 if (abs (vector_comp(1) + 1.0) > 1e-4) call abort
39 call extract_vec(one_d_field
, 2, 3)
40 if (abs (vector_comp(1) - 1.0) > 1e-4) call abort
41 deallocate(one_d_field
) ! v1 becomes undefined
43 subroutine extract_vec(field
, tag
, ic
)
44 use, intrinsic :: iso_c_binding
45 CLASS(*), TARGET
:: field(:)
46 INTEGER(kind
=c_int
), value
:: tag
, ic
48 type(scalar_vector
), pointer :: sv(:)
49 type(scalar_vector_matrix
), pointer :: svm(:)
52 type is (real(c_float
))
58 vector_comp
=> sv(:)%vec(ic
)
61 vector_comp
=> svm(:)%vec(ic
)