gcc/testsuite/gfortran.dg/char_unpack_1.f90

   1 ! Test unpack0 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) :: field
   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       field (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 test (unpack (vector, mask, field))
  25 contains
  26   subroutine test (a)
  27     character (len = slen), dimension (:, :) :: a
  28
  29     if (size (a, 1) .ne. n1) STOP 1
  30     if (size (a, 2) .ne. n2) STOP 2
  31
  32     i = 0
  33     do i2 = 1, n2
  34       do i1 = 1, n1
  35         if (mask (i1, i2)) then
  36           i = i + 1
  37           if (a (i1, i2) .ne. vector (i)) STOP 3
  38         else
  39           if (a (i1, i2) .ne. field (i1, i2)) STOP 4
  40         end if
  41       end do
  42     end do
  43   end subroutine test
  44 end program main