gcc/testsuite/gfortran.dg/char_eoshift_2.f90

   1 ! Test eoshift1 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) :: filler
   8   integer (kind = 1), dimension (n1, n3) :: shift1
   9   integer (kind = 2), dimension (n1, n3) :: shift2
  10   integer (kind = 4), dimension (n1, n3) :: shift3
  11   integer (kind = 8), dimension (n1, n3) :: shift4
  12   integer :: i1, i2, i3
  13
  14   shift1 (1, :) = (/ 1, 3, 2, 2 /)
  15   shift1 (2, :) = (/ 2, 1, 1, 3 /)
  16   shift2 = shift1
  17   shift3 = shift1
  18   shift4 = shift1
  19
  20   do i3 = 1, n3
  21     do i2 = 1, n2
  22       do i1 = 1, n1
  23         a (i1, i2, i3) = 'ab'(i1:i1) // 'cdefg'(i2:i2) // 'hijk'(i3:i3)
  24       end do
  25     end do
  26   end do
  27
  28   call test (eoshift (a, shift1, 'foo', 2), 'foo')
  29   call test (eoshift (a, shift2, 'foo', 2), 'foo')
  30   call test (eoshift (a, shift3, 'foo', 2), 'foo')
  31   call test (eoshift (a, shift4, 'foo', 2), 'foo')
  32
  33   filler = ''
  34   call test (eoshift (a, shift1, dim = 2), filler)
  35   call test (eoshift (a, shift2, dim = 2), filler)
  36   call test (eoshift (a, shift3, dim = 2), filler)
  37   call test (eoshift (a, shift4, dim = 2), filler)
  38 contains
  39   subroutine test (b, filler)
  40     character (len = slen), dimension (n1, n2, n3) :: b
  41     character (len = slen) :: filler
  42     integer :: i2p
  43
  44     do i3 = 1, n3
  45       do i2 = 1, n2
  46         do i1 = 1, n1
  47           i2p = i2 + shift1 (i1, i3)
  48           if (i2p .gt. n2) then
  49             if (b (i1, i2, i3) .ne. filler) call abort
  50           else
  51             if (b (i1, i2, i3) .ne. a (i1, i2p, i3)) call abort
  52           end if
  53         end do
  54       end do
  55     end do
  56   end subroutine test
  57 end program main