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

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-old/] [gcc-4.2.2/] [gcc/] [testsuite/] [gfortran.dg/] [char_eoshift_3.f90] - Blame information for rev 853

Go to most recent revision | Details | Compare with Previous | View Log

Line No. Rev Author Line
1 149 jeremybenn 
! Test eoshift2 for character arrays.
2 
! { dg-do run }
3 
program main
4 
  implicit none
5 
  integer, parameter :: n1 = 2, n2 = 5, n3 = 4, slen = 3
6 
  character (len = slen), dimension (n1, n2, n3) :: a
7 
  character (len = slen), dimension (n1, n3) :: filler
8 
  integer (kind = 1) :: shift1 = 4
9 
  integer (kind = 2) :: shift2 = 2
10 
  integer (kind = 4) :: shift3 = 3
11 
  integer (kind = 8) :: shift4 = 1
12 
  integer :: i1, i2, i3
13 
 
14 
  filler (1, :) = (/ 'tic', 'tac', 'toe', 'tip' /)
15 
  filler (2, :) = (/ 'zzz', 'yyy', 'xxx', 'www' /)
16 
 
17 
  do i3 = 1, n3
18 
    do i2 = 1, n2
19 
      do i1 = 1, n1
20 
        a (i1, i2, i3) = 'ab'(i1:i1) // 'cdefg'(i2:i2) // 'hijk'(i3:i3)
21 
      end do
22 
    end do
23 
  end do
24 
 
25 
  call test (eoshift (a, shift1, filler, 2), int (shift1), .true.)
26 
  call test (eoshift (a, shift2, filler, 2), int (shift2), .true.)
27 
  call test (eoshift (a, shift3, filler, 2), int (shift3), .true.)
28 
  call test (eoshift (a, shift4, filler, 2), int (shift4), .true.)
29 
 
30 
  call test (eoshift (a, shift1, dim = 2), int (shift1), .false.)
31 
  call test (eoshift (a, shift2, dim = 2), int (shift2), .false.)
32 
  call test (eoshift (a, shift3, dim = 2), int (shift3), .false.)
33 
  call test (eoshift (a, shift4, dim = 2), int (shift4), .false.)
34 
contains
35 
  subroutine test (b, d2, has_filler)
36 
    character (len = slen), dimension (n1, n2, n3) :: b
37 
    logical :: has_filler
38 
    integer :: d2
39 
 
40 
    do i3 = 1, n3
41 
      do i2 = 1, n2
42 
        do i1 = 1, n1
43 
          if (i2 + d2 .le. n2) then
44 
            if (b (i1, i2, i3) .ne. a (i1, i2 + d2, i3)) call abort
45 
          else if (has_filler) then
46 
            if (b (i1, i2, i3) .ne. filler (i1, i3)) call abort
47 
          else
48 
            if (b (i1, i2, i3) .ne. '') call abort
49 
          end if
50 
        end do
51 
      end do
52 
    end do
53 
  end subroutine test
54 
end program main

powered by: WebSVN 2.1.0

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