gcc/testsuite/gfortran.dg/eoshift_5.f90

   1 ! { dg-do  run }
   2 ! Check that eoshift works for three-dimensional arrays.
   3 module x
   4   implicit none
   5 contains
   6   subroutine eoshift_1 (array, shift, boundary, dim, res)
   7     real, dimension(:,:,:), intent(in) :: array
   8     real, dimension(:,:,:), intent(out) :: res
   9     integer, dimension(:,:), intent(in) :: shift
  10     real, optional, intent(in) :: boundary
  11     integer, optional, intent(in) :: dim
  12     integer :: s1, s2, s3
  13     integer :: n1, n2, n3
  14     integer :: sh
  15     real :: b
  16     integer :: d
  17
  18     if (present(boundary)) then
  19        b = boundary
  20     else
  21        b = 0.0
  22     end if
  23
  24     if (present(dim)) then
  25        d = dim
  26     else
  27        d = 1
  28     end if
  29
  30     n1 = size(array,1)
  31     n2 = size(array,2)
  32     n3 = size(array,3)
  33
  34     select case(dim)
  35     case(1)
  36        do s3=1,n3
  37           do s2=1,n2
  38              sh = shift(s2,s3)
  39              if (sh > 0) then
  40                 sh = min(sh, n1)
  41                 do s1= 1, n1 - sh
  42                    res(s1,s2,s3) = array(s1+sh,s2,s3)
  43                 end do
  44                 do s1 = n1 - sh + 1,n1
  45                    res(s1,s2,s3) = b
  46                 end do
  47              else
  48                 sh = max(sh, -n1)
  49                 do s1=1,-sh
  50                    res(s1,s2,s3) = b
  51                 end do
  52                 do s1= 1-sh,n1
  53                    res(s1,s2,s3) = array(s1+sh,s2,s3)
  54                 end do
  55              end if
  56           end do
  57        end do
  58     case(2)
  59        do s3=1,n3
  60           do s1=1,n1
  61              sh = shift(s1,s3)
  62              if (sh > 0) then
  63                 sh = min (sh, n2)
  64                 do s2=1, n2 - sh
  65                    res(s1,s2,s3) = array(s1,s2+sh,s3)
  66                 end do
  67                 do s2=n2 - sh + 1, n2
  68                    res(s1,s2,s3) = b
  69                 end do
  70              else
  71                 sh = max(sh, -n2)
  72                 do s2=1,-sh
  73                    res(s1,s2,s3) = b
  74                 end do
  75                 do s2=1-sh,n2
  76                    res(s1,s2,s3) = array(s1,s2+sh,s3)
  77                 end do
  78              end if
  79           end do
  80        end do
  81
  82     case(3)
  83        do s2=1, n2
  84           do s1=1,n1
  85              sh = shift(s1, s2)
  86              if (sh > 0) then
  87                 sh = min(sh, n3)
  88                 do s3=1,n3 - sh
  89                    res(s1,s2,s3) = array(s1,s2,s3+sh)
  90                 end do
  91                 do s3=n3 - sh + 1, n3
  92                    res(s1,s2,s3) = b
  93                 end do
  94              else
  95                 sh = max(sh, -n3)
  96                 do s3=1,-sh
  97                    res(s1,s2,s3) = b
  98                 end do
  99                 do s3=1-sh,n3
 100                    res(s1,s2,s3) = array(s1,s2,s3+sh)
 101                 end do
 102              end if
 103           end do
 104        end do
 105
 106     case default
 107        stop "Illegal dim"
 108     end select
 109   end subroutine eoshift_1
 110   subroutine fill_shift(x, n)
 111     integer, intent(out), dimension(:,:) :: x
 112     integer, intent(in) :: n
 113     integer :: n1, n2, s1, s2
 114     integer :: v
 115     v = -n - 1
 116     n1 = size(x,1)
 117     n2 = size(x,2)
 118     do s2=1,n2
 119        do s1=1,n1
 120           x(s1,s2) = v
 121           v = v + 1
 122           if (v > n + 1) v = -n - 1
 123        end do
 124     end do
 125   end subroutine fill_shift
 126 end module x
 127
 128 program main
 129   use x
 130   implicit none
 131   integer, parameter :: n1=20,n2=30,n3=40
 132   real, dimension(n1,n2,n3) :: a,b,c
 133   real, dimension(2*n1,n2,n3) :: a2, c2
 134   integer :: dim
 135   integer, dimension(n2,n3), target :: sh1
 136   integer, dimension(n1,n3), target :: sh2
 137   integer, dimension(n1,n2), target :: sh3
 138   real, dimension(n2,n3), target :: b1
 139   real, dimension(n1,n3), target :: b2
 140   real, dimension(n1,n2), target :: b3
 141
 142   integer, dimension(:,:), pointer :: sp
 143   real, dimension(:,:), pointer :: bp
 144
 145   call random_number(a)
 146   call fill_shift(sh1, n1)
 147   call fill_shift(sh2, n2)
 148   call fill_shift(sh3, n3)
 149
 150   do dim=1,3
 151      if (dim == 1) then
 152         sp => sh1
 153      else if (dim == 2) then
 154         sp => sh2
 155      else
 156         sp => sh3
 157      end if
 158      b = eoshift(a,shift=sp,dim=dim,boundary=-0.5)
 159      call eoshift_1 (a, shift=sp, dim=dim, boundary=-0.5,res=c)
 160      if (any (b /= c)) then
 161         print *,"dim = ", dim
 162         print *,"sp = ", sp
 163         print '(99F8.4)',b
 164         print '(99F8.4)',c
 165         call abort
 166      end if
 167      a2 = 42.
 168      a2(1:2*n1:2,:,:) = a
 169      b = eoshift(a2(1:2*n1:2,:,:), shift=sp, dim=dim, boundary=-0.5)
 170      if (any(b /= c)) then
 171         call abort
 172      end if
 173      c2 = 43.
 174      c2(1:2*n1:2,:,:) = eoshift(a, shift=sp, dim=dim, boundary=-0.5)
 175      if (any(c2(1:2*n1:2,:,:) /= c)) then
 176         call abort
 177      end if
 178      if (any(c2(2:2*n1:2,:,:) /= 43.)) then
 179         call abort
 180      end if
 181   end do
 182 end program main