1! Test (non-scalar) pack for character arrays. 2! { dg-do run } 3program 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)) 26contains 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 59end program main 60