OpenCores
URL https://opencores.org/ocsvn/openrisc/openrisc/trunk

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [testsuite/] [gfortran.dg/] [char_pack_1.f90] - Blame information for rev 694

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 694 jeremybenn
! 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

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.