2 ! { dg-require-effective-target fortran_large_real }
3 ! Program to test the UNPACK intrinsic for large real type
4 program intrinsic_unpack
6 integer,parameter :: k
= selected_real_kind (precision (0.0_8
) + 1)
8 real(kind
=k
), dimension(3,3) :: ark
, brk
9 complex(kind
=k
), dimension(3,3) :: ack
, bck
11 logical, dimension(3, 3) :: mask
12 character(len
=500) line1
, line2
15 mask
= reshape ((/.false
.,.true
.,.false
.,.true
.,.false
.,.false
.,&
16 &.false
.,.false
.,.true
./), (/3, 3/));
18 ark
= reshape ((/1._k
, 0._k
, 0._k
, 0._k
, 1._k
, 0._k
, 0._k
, 0._k
, 1._k
/), &
20 brk
= unpack ((/2._k
, 3._k
, 4._k
/), mask
, ark
)
21 if (any (brk
.ne
. reshape ((/1._k
, 2._k
, 0._k
, 3._k
, 1._k
, 0._k
, &
22 0._k
, 0._k
, 4._k
/), (/3, 3/)))) &
24 write (line1
,'(9F9.5)') brk
25 write (line2
,'(9F9.5)') unpack((/2._k
, 3._k
, 4._k
/), mask
, ark
)
26 if (line1
.ne
. line2
) call abort
28 brk
= unpack ((/2._k
, 3._k
, 4._k
/), mask
, 0._k
)
29 if (any (brk
.ne
. reshape ((/0._k
, 2._k
, 0._k
, 3._k
, 0._k
, 0._k
, &
30 0._k
, 0._k
, 4._k
/), (/3, 3/)))) &
33 ack
= reshape ((/1._k
, 0._k
, 0._k
, 0._k
, 1._k
, 0._k
, 0._k
, 0._k
, 1._k
/), &
35 bck
= unpack ((/(2._k
, 0._k
), (3._k
, 0._k
), (4._k
, 0._k
)/), mask
, ack
)
36 if (any (real(bck
) .ne
. reshape ((/1._k
, 2._k
, 0._k
, 3._k
, 1._k
, 0._k
, &
37 0._k
, 0._k
, 4._k
/), (/3, 3/)))) &
39 write (line1
,'(18F9.5)') bck
40 write (line2
,'(18F9.5)') unpack((/(2._k
, 0._k
), (3._k
, 0._k
), (4._k
,0._k
)/), &
42 if (line1
.ne
. line2
) call abort