gcc/testsuite/gfortran.dg/char_pack_1.f90

   1 ! Test (non-scalar) pack for character arrays.
   2 ! { dg-do run }
   3 program main
   4   implicit none
   5   integer, parameter :: n1 = 3, n2 = 4, nv = 10, slen = 9
   6   character (len = slen), dimension (n1, n2) :: a
   7   character (len = slen), dimension (nv) :: vector
   8   logical, dimension (n1, n2) :: 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   mask (1, :) = (/ .true., .false., .true., .true. /)
  17   mask (2, :) = (/ .true., .false., .false., .false. /)
  18   mask (3, :) = (/ .false., .true., .true., .true. /)
  19
  20   do i = 1, nv
  21     vector (i) = 'crespo' // '0123456789'(i:i)
  22   end do
  23
  24   call test1 (pack (a, mask))
  25   call test2 (pack (a, mask, vector))
  26 contains
  27   subroutine test1 (b)
  28     character (len = slen), dimension (:) :: b
  29
  30     i = 0
  31     do i2 = 1, n2
  32       do i1 = 1, n1
  33         if (mask (i1, i2)) then
  34           i = i + 1
  35           if (b (i) .ne. a (i1, i2)) STOP 1
  36         end if
  37       end do
  38     end do
  39     if (size (b, 1) .ne. i) STOP 2
  40   end subroutine test1
  41
  42   subroutine test2 (b)
  43     character (len = slen), dimension (:) :: b
  44
  45     if (size (b, 1) .ne. nv) STOP 3
  46     i = 0
  47     do i2 = 1, n2
  48       do i1 = 1, n1
  49         if (mask (i1, i2)) then
  50           i = i + 1
  51           if (b (i) .ne. a (i1, i2)) STOP 4
  52         end if
  53       end do
  54     end do
  55     do i = i + 1, nv
  56       if (b (i) .ne. vector (i)) STOP 5
  57     end do
  58   end subroutine test2
  59 end program main