| 1 |
694 |
jeremybenn |
! { dg-do run }
|
| 2 |
|
|
! Program to test the UNPACK intrinsic for the types usually present.
|
| 3 |
|
|
program intrinsic_unpack
|
| 4 |
|
|
implicit none
|
| 5 |
|
|
integer(kind=1), dimension(3, 3) :: a1, b1
|
| 6 |
|
|
integer(kind=2), dimension(3, 3) :: a2, b2
|
| 7 |
|
|
integer(kind=4), dimension(3, 3) :: a4, b4
|
| 8 |
|
|
integer(kind=8), dimension(3, 3) :: a8, b8
|
| 9 |
|
|
real(kind=4), dimension(3,3) :: ar4, br4
|
| 10 |
|
|
real(kind=8), dimension(3,3) :: ar8, br8
|
| 11 |
|
|
complex(kind=4), dimension(3,3) :: ac4, bc4
|
| 12 |
|
|
complex(kind=8), dimension(3,3) :: ac8, bc8
|
| 13 |
|
|
type i4_t
|
| 14 |
|
|
integer(kind=4) :: v
|
| 15 |
|
|
end type i4_t
|
| 16 |
|
|
type(i4_t), dimension(3,3) :: at4, bt4
|
| 17 |
|
|
type(i4_t), dimension(3) :: vt4
|
| 18 |
|
|
|
| 19 |
|
|
logical, dimension(3, 3) :: mask
|
| 20 |
|
|
character(len=500) line1, line2
|
| 21 |
|
|
integer i
|
| 22 |
|
|
|
| 23 |
|
|
mask = reshape ((/.false.,.true.,.false.,.true.,.false.,.false.,&
|
| 24 |
|
|
&.false.,.false.,.true./), (/3, 3/));
|
| 25 |
|
|
a1 = reshape ((/1, 0, 0, 0, 1, 0, 0, 0, 1/), (/3, 3/));
|
| 26 |
|
|
b1 = unpack ((/2_1, 3_1, 4_1/), mask, a1)
|
| 27 |
|
|
if (any (b1 .ne. reshape ((/1, 2, 0, 3, 1, 0, 0, 0, 4/), (/3, 3/)))) &
|
| 28 |
|
|
call abort
|
| 29 |
|
|
write (line1,'(10I4)') b1
|
| 30 |
|
|
write (line2,'(10I4)') unpack((/2_1, 3_1, 4_1/), mask, a1)
|
| 31 |
|
|
if (line1 .ne. line2) call abort
|
| 32 |
|
|
b1 = -1
|
| 33 |
|
|
b1 = unpack ((/2_1, 3_1, 4_1/), mask, 0_1)
|
| 34 |
|
|
if (any (b1 .ne. reshape ((/0, 2, 0, 3, 0, 0, 0, 0, 4/), (/3, 3/)))) &
|
| 35 |
|
|
call abort
|
| 36 |
|
|
|
| 37 |
|
|
a2 = reshape ((/1, 0, 0, 0, 1, 0, 0, 0, 1/), (/3, 3/));
|
| 38 |
|
|
b2 = unpack ((/2_2, 3_2, 4_2/), mask, a2)
|
| 39 |
|
|
if (any (b2 .ne. reshape ((/1, 2, 0, 3, 1, 0, 0, 0, 4/), (/3, 3/)))) &
|
| 40 |
|
|
call abort
|
| 41 |
|
|
write (line1,'(10I4)') b2
|
| 42 |
|
|
write (line2,'(10I4)') unpack((/2_2, 3_2, 4_2/), mask, a2)
|
| 43 |
|
|
if (line1 .ne. line2) call abort
|
| 44 |
|
|
b2 = -1
|
| 45 |
|
|
b2 = unpack ((/2_2, 3_2, 4_2/), mask, 0_2)
|
| 46 |
|
|
if (any (b2 .ne. reshape ((/0, 2, 0, 3, 0, 0, 0, 0, 4/), (/3, 3/)))) &
|
| 47 |
|
|
call abort
|
| 48 |
|
|
|
| 49 |
|
|
a4 = reshape ((/1, 0, 0, 0, 1, 0, 0, 0, 1/), (/3, 3/));
|
| 50 |
|
|
b4 = unpack ((/2_4, 3_4, 4_4/), mask, a4)
|
| 51 |
|
|
if (any (b4 .ne. reshape ((/1, 2, 0, 3, 1, 0, 0, 0, 4/), (/3, 3/)))) &
|
| 52 |
|
|
call abort
|
| 53 |
|
|
write (line1,'(10I4)') b4
|
| 54 |
|
|
write (line2,'(10I4)') unpack((/2_4, 3_4, 4_4/), mask, a4)
|
| 55 |
|
|
if (line1 .ne. line2) call abort
|
| 56 |
|
|
b4 = -1
|
| 57 |
|
|
b4 = unpack ((/2_4, 3_4, 4_4/), mask, 0_4)
|
| 58 |
|
|
if (any (b4 .ne. reshape ((/0, 2, 0, 3, 0, 0, 0, 0, 4/), (/3, 3/)))) &
|
| 59 |
|
|
call abort
|
| 60 |
|
|
|
| 61 |
|
|
a8 = reshape ((/1, 0, 0, 0, 1, 0, 0, 0, 1/), (/3, 3/));
|
| 62 |
|
|
b8 = unpack ((/2_8, 3_8, 4_8/), mask, a8)
|
| 63 |
|
|
if (any (b8 .ne. reshape ((/1, 2, 0, 3, 1, 0, 0, 0, 4/), (/3, 3/)))) &
|
| 64 |
|
|
call abort
|
| 65 |
|
|
write (line1,'(10I4)') b8
|
| 66 |
|
|
write (line2,'(10I4)') unpack((/2_8, 3_8, 4_8/), mask, a8)
|
| 67 |
|
|
if (line1 .ne. line2) call abort
|
| 68 |
|
|
b8 = -1
|
| 69 |
|
|
b8 = unpack ((/2_8, 3_8, 4_8/), mask, 0_8)
|
| 70 |
|
|
if (any (b8 .ne. reshape ((/0, 2, 0, 3, 0, 0, 0, 0, 4/), (/3, 3/)))) &
|
| 71 |
|
|
call abort
|
| 72 |
|
|
|
| 73 |
|
|
ar4 = reshape ((/1._4, 0._4, 0._4, 0._4, 1._4, 0._4, 0._4, 0._4, 1._4/), &
|
| 74 |
|
|
(/3, 3/));
|
| 75 |
|
|
br4 = unpack ((/2._4, 3._4, 4._4/), mask, ar4)
|
| 76 |
|
|
if (any (br4 .ne. reshape ((/1._4, 2._4, 0._4, 3._4, 1._4, 0._4, &
|
| 77 |
|
|
0._4, 0._4, 4._4/), (/3, 3/)))) &
|
| 78 |
|
|
call abort
|
| 79 |
|
|
write (line1,'(9F9.5)') br4
|
| 80 |
|
|
write (line2,'(9F9.5)') unpack((/2._4, 3._4, 4._4/), mask, ar4)
|
| 81 |
|
|
if (line1 .ne. line2) call abort
|
| 82 |
|
|
br4 = -1._4
|
| 83 |
|
|
br4 = unpack ((/2._4, 3._4, 4._4/), mask, 0._4)
|
| 84 |
|
|
if (any (br4 .ne. reshape ((/0._4, 2._4, 0._4, 3._4, 0._4, 0._4, &
|
| 85 |
|
|
0._4, 0._4, 4._4/), (/3, 3/)))) &
|
| 86 |
|
|
call abort
|
| 87 |
|
|
|
| 88 |
|
|
ar8 = reshape ((/1._8, 0._8, 0._8, 0._8, 1._8, 0._8, 0._8, 0._8, 1._8/), &
|
| 89 |
|
|
(/3, 3/));
|
| 90 |
|
|
br8 = unpack ((/2._8, 3._8, 4._8/), mask, ar8)
|
| 91 |
|
|
if (any (br8 .ne. reshape ((/1._8, 2._8, 0._8, 3._8, 1._8, 0._8, &
|
| 92 |
|
|
0._8, 0._8, 4._8/), (/3, 3/)))) &
|
| 93 |
|
|
call abort
|
| 94 |
|
|
write (line1,'(9F9.5)') br8
|
| 95 |
|
|
write (line2,'(9F9.5)') unpack((/2._8, 3._8, 4._8/), mask, ar8)
|
| 96 |
|
|
if (line1 .ne. line2) call abort
|
| 97 |
|
|
br8 = -1._8
|
| 98 |
|
|
br8 = unpack ((/2._8, 3._8, 4._8/), mask, 0._8)
|
| 99 |
|
|
if (any (br8 .ne. reshape ((/0._8, 2._8, 0._8, 3._8, 0._8, 0._8, &
|
| 100 |
|
|
0._8, 0._8, 4._8/), (/3, 3/)))) &
|
| 101 |
|
|
call abort
|
| 102 |
|
|
|
| 103 |
|
|
ac4 = reshape ((/1._4, 0._4, 0._4, 0._4, 1._4, 0._4, 0._4, 0._4, 1._4/), &
|
| 104 |
|
|
(/3, 3/));
|
| 105 |
|
|
bc4 = unpack ((/(2._4, 0._4), (3._4, 0._4), (4._4, 0._4)/), mask, ac4)
|
| 106 |
|
|
if (any (real(bc4) .ne. reshape ((/1._4, 2._4, 0._4, 3._4, 1._4, 0._4, &
|
| 107 |
|
|
0._4, 0._4, 4._4/), (/3, 3/)))) &
|
| 108 |
|
|
call abort
|
| 109 |
|
|
write (line1,'(18F9.5)') bc4
|
| 110 |
|
|
write (line2,'(18F9.5)') unpack((/(2._4, 0._4), (3._4, 0._4), (4._4,0._4)/), &
|
| 111 |
|
|
mask, ac4)
|
| 112 |
|
|
if (line1 .ne. line2) call abort
|
| 113 |
|
|
|
| 114 |
|
|
ac8 = reshape ((/1._8, 0._8, 0._8, 0._8, 1._8, 0._8, 0._8, 0._8, 1._8/), &
|
| 115 |
|
|
(/3, 3/));
|
| 116 |
|
|
bc8 = unpack ((/(2._8, 0._8), (3._8, 0._8), (4._8, 0._8)/), mask, ac8)
|
| 117 |
|
|
if (any (real(bc8) .ne. reshape ((/1._8, 2._8, 0._8, 3._8, 1._8, 0._8, &
|
| 118 |
|
|
0._8, 0._8, 4._8/), (/3, 3/)))) &
|
| 119 |
|
|
call abort
|
| 120 |
|
|
write (line1,'(18F9.5)') bc8
|
| 121 |
|
|
write (line2,'(18F9.5)') unpack((/(2._8, 0._8), (3._8, 0._8), (4._8,0._8)/), &
|
| 122 |
|
|
mask, ac8)
|
| 123 |
|
|
if (line1 .ne. line2) call abort
|
| 124 |
|
|
|
| 125 |
|
|
at4%v = reshape ((/1, 0, 0, 0, 1, 0, 0, 0, 1/), (/3, 3/));
|
| 126 |
|
|
vt4%v = (/2_4, 3_4, 4_4/)
|
| 127 |
|
|
bt4 = unpack (vt4, mask, at4)
|
| 128 |
|
|
if (any (bt4%v .ne. reshape ((/1, 2, 0, 3, 1, 0, 0, 0, 4/), (/3, 3/)))) &
|
| 129 |
|
|
call abort
|
| 130 |
|
|
bt4%v = -1
|
| 131 |
|
|
bt4 = unpack (vt4, mask, i4_t(0_4))
|
| 132 |
|
|
if (any (bt4%v .ne. reshape ((/0, 2, 0, 3, 0, 0, 0, 0, 4/), (/3, 3/)))) &
|
| 133 |
|
|
call abort
|
| 134 |
|
|
|
| 135 |
|
|
end program
|
