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)) call abort
  36         end if
  37       end do
  38     end do
  39     if (size (b, 1) .ne. i) call abort
  40   end subroutine test1
  41
  42   subroutine test2 (b)
  43     character (len = slen), dimension (:) :: b
  44
  45     if (size (b, 1) .ne. nv) call abort
  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)) call abort
  52         end if
  53       end do
  54     end do
  55     do i = i + 1, nv
  56       if (b (i) .ne. vector (i)) call abort
  57     end do
  58   end subroutine test2
  59 end program main