gcc/testsuite/gfortran.dg/cshift_1.f90

   1 ! { dg-do  run }
   2 ! Take cshift through its paces to make sure no boundary
   3 ! cases are wrong.
   4
   5 module kinds
   6   integer, parameter :: sp = selected_real_kind(6) ! Single precision
   7 end module kinds
   8
   9 module replacements
  10   use kinds
  11 contains
  12   subroutine cshift_sp_3_v1 (array, shift, dim, res)
  13     integer, parameter :: wp = sp
  14     real(kind=wp), dimension(:,:,:), intent(in) :: array
  15     integer, intent(in) :: shift, dim
  16     real(kind=wp), dimension(:,:,:), intent(out) :: res
  17     integer :: i,j,k
  18     integer :: sh, rsh
  19     integer :: n
  20     integer :: n2, n3
  21     res = 0
  22     n3 = size(array,3)
  23     n2 = size(array,2)
  24     n1 = size(array,1)
  25     if (dim == 1) then
  26        n = n1
  27        sh = modulo(shift, n)
  28        rsh = n - sh
  29        do k=1, n3
  30           do j=1, n2
  31              do i=1, rsh
  32                 res(i,j,k) = array(i+sh,j,k)
  33              end do
  34              do i=rsh+1,n
  35                 res(i,j,k) = array(i-rsh,j,k)
  36              end do
  37           end do
  38        end do
  39     else if (dim == 2) then
  40        n = n2
  41        sh = modulo(shift,n)
  42        rsh = n - sh
  43        do k=1, n3
  44           do j=1, rsh
  45              do i=1, n1
  46                 res(i,j,k) = array(i,j+sh, k)
  47              end do
  48           end do
  49           do j=rsh+1, n
  50              do i=1, n1
  51                 res(i,j,k) = array(i,j-rsh, k)
  52              end do
  53           end do
  54        end do
  55     else if (dim == 3) then
  56        n = n3
  57        sh = modulo(shift, n)
  58        rsh = n - sh
  59        do k=1, rsh
  60           do j=1, n2
  61              do i=1, n1
  62                 res(i,j,k) = array(i, j, k+sh)
  63              end do
  64           end do
  65        end do
  66        do k=rsh+1, n
  67           do j=1, n2
  68              do i=1, n1
  69                 res(i,j, k) = array(i, j, k-rsh)
  70              end do
  71           end do
  72        end do
  73     else
  74        stop "Wrong argument to dim"
  75     end if
  76   end subroutine cshift_sp_3_v1
  77 end module replacements
  78
  79 program testme
  80   use kinds
  81   use replacements
  82   implicit none
  83   integer, parameter :: wp = sp  ! Working precision
  84   INTEGER, PARAMETER :: n = 7
  85   real(kind=wp), dimension(:,:,:), allocatable :: a,b,c
  86   integer i, j, k
  87   real:: t1, t2
  88   integer, parameter :: nrep = 20
  89
  90   allocate (a(n,n,n), b(n,n,n),c(n,n,n))
  91   call random_number(a)
  92   do k = 1,3
  93    do i=-3,3,2
  94      call cshift_sp_3_v1 (a, i, k, b)
  95      c = cshift(a,i,k)
  96      if (any (c /= b)) call abort
  97    end do
  98   end do
  99   deallocate (b,c)
 100   allocate (b(n-1,n-1,n-1),c(n-1,n-1,n-1))
 101   do k=1,3
 102      do i=-3,3,2
 103         call cshift_sp_3_v1 (a(1:n-1,1:n-1,1:n-1), i, k, b)
 104         c = cshift(a(1:n-1,1:n-1,1:n-1), i, k)
 105         if (any (c /= b)) call abort
 106      end do
 107   end do
 108 end program testme