gcc/testsuite/gfortran.dg/char_eoshift_4.f90

   1 ! Test eoshift3 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), 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   filler (1, :) = (/ 'tic', 'tac', 'toe', 'tip' /)
  15   filler (2, :) = (/ 'zzz', 'yyy', 'xxx', 'www' /)
  16
  17   shift1 (1, :) = (/ 1, 3, 2, 2 /)
  18   shift1 (2, :) = (/ 2, 1, 1, 3 /)
  19   shift2 = shift1
  20   shift3 = shift1
  21   shift4 = shift1
  22
  23   do i3 = 1, n3
  24     do i2 = 1, n2
  25       do i1 = 1, n1
  26         a (i1, i2, i3) = 'ab'(i1:i1) // 'cdefg'(i2:i2) // 'hijk'(i3:i3)
  27       end do
  28     end do
  29   end do
  30
  31   call test (eoshift (a, shift1, filler, 2), .true.)
  32   call test (eoshift (a, shift2, filler, 2), .true.)
  33   call test (eoshift (a, shift3, filler, 2), .true.)
  34   call test (eoshift (a, shift4, filler, 2), .true.)
  35
  36   call test (eoshift (a, shift1, dim = 2), .false.)
  37   call test (eoshift (a, shift2, dim = 2), .false.)
  38   call test (eoshift (a, shift3, dim = 2), .false.)
  39   call test (eoshift (a, shift4, dim = 2), .false.)
  40 contains
  41   subroutine test (b, has_filler)
  42     character (len = slen), dimension (n1, n2, n3) :: b
  43     logical :: has_filler
  44     integer :: i2p
  45
  46     do i3 = 1, n3
  47       do i2 = 1, n2
  48         do i1 = 1, n1
  49           i2p = i2 + shift1 (i1, i3)
  50           if (i2p .le. n2) then
  51             if (b (i1, i2, i3) .ne. a (i1, i2p, i3)) call abort
  52           else if (has_filler) then
  53             if (b (i1, i2, i3) .ne. filler (i1, i3)) call abort
  54           else
  55             if (b (i1, i2, i3) .ne. '') call abort
  56           end if
  57         end do
  58       end do
  59     end do
  60   end subroutine test
  61 end program main