gcc/testsuite/gfortran.dg/char_eoshift_1.f90

   1 ! Test eoshift0 for character arrays.
   2 ! { dg-do run }
   3 program main
   4   implicit none
   5   integer, parameter :: n1 = 6, n2 = 5, n3 = 4, slen = 3
   6   character (len = slen), dimension (n1, n2, n3) :: a
   7   character (len = slen) :: 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   do i3 = 1, n3
  15     do i2 = 1, n2
  16       do i1 = 1, n1
  17         a (i1, i2, i3) = 'abcdef'(i1:i1) // 'ghijk'(i2:i2) // 'lmno'(i3:i3)
  18       end do
  19     end do
  20   end do
  21
  22   call test (eoshift (a, shift1, 'foo', 1), int (shift1), 0, 0, 'foo')
  23   call test (eoshift (a, shift2, 'foo', 2), 0, int (shift2), 0, 'foo')
  24   call test (eoshift (a, shift3, 'foo', 2), 0, int (shift3), 0, 'foo')
  25   call test (eoshift (a, shift4, 'foo', 3), 0, 0, int (shift4), 'foo')
  26
  27   filler = ''
  28   call test (eoshift (a, shift1, dim = 1), int (shift1), 0, 0, filler)
  29   call test (eoshift (a, shift2, dim = 2), 0, int (shift2), 0, filler)
  30   call test (eoshift (a, shift3, dim = 2), 0, int (shift3), 0, filler)
  31   call test (eoshift (a, shift4, dim = 3), 0, 0, int (shift4), filler)
  32 contains
  33   subroutine test (b, d1, d2, d3, filler)
  34     character (len = slen), dimension (n1, n2, n3) :: b
  35     character (len = slen) :: filler
  36     integer :: d1, d2, d3
  37
  38     do i3 = 1, n3
  39       do i2 = 1, n2
  40         do i1 = 1, n1
  41           if (i1 + d1 .gt. n1 .or. i2 + d2 .gt. n2 .or. i3 + d3 .gt. n3) then
  42             if (b (i1, i2, i3) .ne. filler) call abort
  43           else
  44             if (b (i1, i2, i3) .ne. a (i1 + d1, i2 + d2, i3 + d3)) call abort
  45           end if
  46         end do
  47       end do
  48     end do
  49   end subroutine test
  50 end program main