home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Professional / OS2PRO194.ISO / os2 / prgramer / adaptor / examples / dalib / cshift / test4.f < prev    next >
Encoding:
Text File  |  1993-03-23  |  2.6 KB  |  116 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 test1 (a,b,n, 1, 1)
  17.       call test1 (a,b,n, 1, -1)
  18.       call test1 (a,b,n, 1, 49)
  19.       call test1 (a,b,n, 1, 51)
  20.       call test1 (a,b,n, 1, -51)
  21.       call test1 (a,b,n, 1, 13)
  22.  
  23.       call test (a,b,n, 2, 1)
  24.       call test (a,b,n, 2, -1)
  25.       call test (a,b,n, 2, 49)
  26.       call test (a,b,n, 2, 51)
  27.       call test (a,b,n, 2, -51)
  28.       call test (a,b,n, 2, 13)
  29.  
  30.       call test1 (a,b,n, 2, 1)
  31.       call test1 (a,b,n, 2, -1)
  32.       call test1 (a,b,n, 2, 49)
  33.       call test1 (a,b,n, 2, 51)
  34.       call test1 (a,b,n, 2, -51)
  35.       call test1 (a,b,n, 2, 13)
  36.  
  37.       call test (a,b,n, 3, 1)
  38.       call test (a,b,n, 3, -1)
  39.       call test (a,b,n, 3, 49)
  40.       call test (a,b,n, 3, 51)
  41.       call test (a,b,n, 3, -51)
  42.       call test (a,b,n, 3, 13)
  43.  
  44.       call test1 (a,b,n, 3, 1)
  45.       call test1 (a,b,n, 3, -1)
  46.       call test1 (a,b,n, 3, 49)
  47.       call test1 (a,b,n, 3, 51)
  48.       call test1 (a,b,n, 3, -51)
  49.       call test1 (a,b,n, 3, 13)
  50.  
  51.       call test (a,b,n, 4, 1)
  52.       call test (a,b,n, 4, -1)
  53.       call test (a,b,n, 4, 49)
  54.       call test (a,b,n, 4, 51)
  55.       call test (a,b,n, 4, -51)
  56.       call test (a,b,n, 4, 13)
  57.  
  58.       call test1 (a,b,n, 4, 1)
  59.       call test1 (a,b,n, 4, -1)
  60.       call test1 (a,b,n, 4, 49)
  61.       call test1 (a,b,n, 4, 51)
  62.       call test1 (a,b,n, 4, -51)
  63.       call test1 (a,b,n, 4, 13)
  64.  
  65.       end
  66.  
  67.       subroutine test (a, b, n, dim, pos)
  68.       integer n, dim
  69.       real a(n,n,n,n), b(n,n,n,n)
  70.       logical equal (n,n,n,n)
  71.       integer pos
  72.       integer errors
  73.  
  74.       a = b
  75.  
  76.       b = cshift (b, dim, pos)
  77.  
  78.       if (pos .gt. 0) then
  79.          do i = 1, pos
  80.             a = cshift (a, dim, 1)
  81.          end do
  82.       end if
  83.  
  84.       if (pos .lt. 0) then
  85.          do i = 1, -pos
  86.             a = cshift (a, dim, -1)
  87.          end do
  88.       end if
  89.  
  90.       equal = (b .eq. a)
  91.       errors = count (equal)
  92.       errors = n*n*n*n - errors
  93.  
  94.       print *, errors, ' Errors for one shift in dim', dim,' with pos = ', pos
  95.       end
  96.  
  97.       subroutine test1 (a, b, n, dim, pos)
  98.       integer n, dim
  99.       real a(n,n,n,n), b(n,n,n,n)
  100.       logical equal (n,n,n,n)
  101.       integer pos
  102.       integer errors
  103.  
  104.       a = b
  105.       do i = 1, n
  106.          a = cshift (a, dim, pos)
  107.       end do
  108.  
  109.       equal = (b .eq. a)
  110.       errors = count (equal)
  111.       errors = n*n*n*n - errors
  112.  
  113.       print *, errors, ' Errors for many shift in dim', dim,' with pos = ', pos
  114.       end
  115.  
  116.