gcc/testsuite/gfortran.dg/char_pack_2.f90

   1 ! Test scalar pack for character arrays.
   2 ! { dg-do run }
   3 program main
   4   implicit none
   5   integer, parameter :: n1 = 3, n2 = 4, nv = 16, slen = 9
   6   character (len = slen), dimension (n1, n2) :: a
   7   character (len = slen), dimension (nv) :: vector
   8   logical :: mask
   9   integer :: i1, i2, i
  10
  11   do i2 = 1, n2
  12     do i1 = 1, n1
  13       a (i1, i2) = 'abc'(i1:i1) // 'defg'(i2:i2) // 'cantrip'
  14     end do
  15   end do
  16
  17   do i = 1, nv
  18     vector (i) = 'crespo' // '0123456789abcdef'(i:i)
  19   end do
  20
  21   mask = .true.
  22   call test1 (pack (a, mask))
  23   call test2 (pack (a, mask, vector))
  24 contains
  25   subroutine test1 (b)
  26     character (len = slen), dimension (:) :: b
  27
  28     i = 0
  29     do i2 = 1, n2
  30       do i1 = 1, n1
  31         i = i + 1
  32         if (b (i) .ne. a (i1, i2)) call abort
  33       end do
  34     end do
  35     if (size (b, 1) .ne. i) call abort
  36   end subroutine test1
  37
  38   subroutine test2 (b)
  39     character (len = slen), dimension (:) :: b
  40
  41     if (size (b, 1) .ne. nv) call abort
  42     i = 0
  43     do i2 = 1, n2
  44       do i1 = 1, n1
  45         i = i + 1
  46         if (b (i) .ne. a (i1, i2)) call abort
  47       end do
  48     end do
  49     do i = i + 1, nv
  50       if (b (i) .ne. vector (i)) call abort
  51     end do
  52   end subroutine test2
  53 end program main