gcc/testsuite/gfortran.dg/char_eoshift_3.f90

   1 ! 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