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

Subversion Repositories openrisc

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

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


! Test reshape for character arrays.
! { dg-do run }
program main
  implicit none
  integer, parameter :: n = 20, slen = 9
  character (len = slen), dimension (n) :: a, pad
  integer, dimension (3) :: shape, order
  integer :: i
 
  do i = 1, n
    a (i) = 'abcdefghijklmnopqrstuvwxyz'(i:i+6)
    pad (i) = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'(i:i+6)
  end do
 
  shape = (/ 4, 6, 5 /)
  order = (/ 3, 1, 2 /)
  call test (reshape (a, shape, pad, order))
contains
  subroutine test (b)
    character (len = slen), dimension (:, :, :) :: b
    integer :: i1, i2, i3, ai, padi
 
    do i = 1, 3
      if (size (b, i) .ne. shape (i)) call abort
    end do
    ai = 0
    padi = 0
    do i2 = 1, shape (2)
      do i1 = 1, shape (1)
        do i3 = 1, shape (3)
          if (ai .lt. n) then
            ai = ai + 1
            if (b (i1, i2, i3) .ne. a (ai)) call abort
          else
            padi = padi + 1
            if (padi .gt. n) padi = 1
            if (b (i1, i2, i3) .ne. pad (padi)) call abort
          end if
        end do
      end do
    end do
  end subroutine test
end program main

Line No.	Rev	Author	Line
1	694	jeremybenn	`! Test reshape for character arrays.`
2			`! { dg-do run }`
3			`program main`
4			`implicit none`
5			`integer, parameter :: n = 20, slen = 9`
6			`character (len = slen), dimension (n) :: a, pad`
7			`integer, dimension (3) :: shape, order`
8			`integer :: i`
9
10			`do i = 1, n`
11			`a (i) = 'abcdefghijklmnopqrstuvwxyz'(i:i+6)`
12			`pad (i) = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'(i:i+6)`
13			`end do`
14
15			`shape = (/ 4, 6, 5 /)`
16			`order = (/ 3, 1, 2 /)`
17			`call test (reshape (a, shape, pad, order))`
18			`contains`
19			`subroutine test (b)`
20			`character (len = slen), dimension (:, :, :) :: b`
21			`integer :: i1, i2, i3, ai, padi`
22
23			`do i = 1, 3`
24			`if (size (b, i) .ne. shape (i)) call abort`
25			`end do`
26			`ai = 0`
27			`padi = 0`
28			`do i2 = 1, shape (2)`
29			`do i1 = 1, shape (1)`
30			`do i3 = 1, shape (3)`
31			`if (ai .lt. n) then`
32			`ai = ai + 1`
33			`if (b (i1, i2, i3) .ne. a (ai)) call abort`
34			`else`
35			`padi = padi + 1`
36			`if (padi .gt. n) padi = 1`
37			`if (b (i1, i2, i3) .ne. pad (padi)) call abort`
38			`end if`
39			`end do`
40			`end do`
41			`end do`
42			`end subroutine test`
43			`end program main`

Browse

Tools

Subversion Repositories openrisc

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