gcc-4_9/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) call abort
  30     if (size (a, 2) .ne. n2) call abort
  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)) call abort
  38         else
  39           if (a (i1, i2) .ne. field (i1, i2)) call abort
  40         end if
  41       end do
  42     end do
  43   end subroutine test
  44 end program main