gcc/testsuite/gfortran.dg/intrinsic_unpack_1.f90

   1 ! { 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