1! { dg-do run } 2! Program to test the UNPACK intrinsic for the types usually present. 3program 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 135end program 136