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