home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / adaptor.zip / adapt.zip / adaptor / examples / dalib / cshift / test4a.f < prev   
Text File  |  1993-03-23  |  1KB  |  69 lines
  1.       program shift_test
  2.  
  3.       parameter (n=15)
  4.  
  5.       real a(n,n,n,n), b(n,n,n,n)
  6.  
  7.       call cmf_random (b)
  8.  
  9.       call test (a,b,n, 1, 1)
  10.       call test (a,b,n, 1, -1)
  11.       call test (a,b,n, 1, 49)
  12.       call test (a,b,n, 1, 51)
  13.       call test (a,b,n, 1, -51)
  14.       call test (a,b,n, 1, 13)
  15.  
  16.       call test (a,b,n, 2, 1)
  17.       call test (a,b,n, 2, -1)
  18.       call test (a,b,n, 2, 49)
  19.       call test (a,b,n, 2, 51)
  20.       call test (a,b,n, 2, -51)
  21.       call test (a,b,n, 2, 13)
  22.  
  23.       call test (a,b,n, 3, 1)
  24.       call test (a,b,n, 3, -1)
  25.       call test (a,b,n, 3, 49)
  26.       call test (a,b,n, 3, 51)
  27.       call test (a,b,n, 3, -51)
  28.       call test (a,b,n, 3, 13)
  29.  
  30.       call test (a,b,n, 4, 1)
  31.       call test (a,b,n, 4, -1)
  32.       call test (a,b,n, 4, 49)
  33.       call test (a,b,n, 4, 51)
  34.       call test (a,b,n, 4, -51)
  35.       call test (a,b,n, 4, 13)
  36.  
  37.       end
  38.  
  39.       subroutine test (a, b, n, dim, pos)
  40.       integer n, dim
  41.       real a(n,n,n,n), b(n,n,n,n)
  42.       logical equal (n,n,n,n)
  43.       integer pos
  44.       integer errors
  45.  
  46.       a = b
  47.  
  48.       b = cshift (b, dim, pos)
  49.  
  50.       if (pos .gt. 0) then
  51.          do i = 1, pos
  52.             a = cshift (a, dim, 1)
  53.          end do
  54.       end if
  55.  
  56.       if (pos .lt. 0) then
  57.          do i = 1, -pos
  58.             a = cshift (a, dim, -1)
  59.          end do
  60.       end if
  61.  
  62.       equal = (b .eq. a)
  63.       errors = count (equal)
  64.       errors = n*n*n*n - errors
  65.  
  66.       print *, errors, ' Errors for one shift in dim', dim,' with pos = ', pos
  67.       end
  68.  
  69.