home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Professional / OS2PRO194.ISO / os2 / prgramer / adaptor / examples / dalib / overlap / test4.f < prev   
Encoding:
Text File  |  1993-04-27  |  1.7 KB  |  86 lines
  1.       program overlap_test
  2.  
  3.       parameter (n=10)
  4.  
  5.       real a(n, n, n, n)
  6.       call cmf_random (a)
  7.       call test_leftup1 (a,n)
  8.       call test_rightdown2 (a,n)
  9.       end
  10.  
  11.       subroutine test_leftup1 (a, n)
  12.  
  13.       integer n
  14.  
  15.       real a(n,n,n,n), b(n[1:0],n[1:0],n[1:0],n[1:0])
  16.       real a1(n,n,n,n)
  17.       logical equal (n,n,n,n)
  18.       integer errors
  19.  
  20. c     call print_a (a, n)
  21.  
  22.       b = a
  23.       forall (i=1:n,j=1:n,k=1:n,l=1:n)
  24.          a1 (l,k,j,i) = b (l-1,k-1,j-1,i-1)
  25.       end forall
  26. c     call print_a (a1, n)
  27.  
  28.  
  29.       a = cshift (a, 1, -1)
  30.       a = cshift (a, 2, -1)
  31.       a = cshift (a, 3, -1)
  32.       a = cshift (a, 4, -1)
  33. c     call print_a (a, n)
  34.  
  35.       equal = (a1 .eq. a)
  36.       errors = count (equal)
  37.       errors = n*n*n*n - errors
  38.  
  39.       print *, errors, ' Errors for left overlapping'
  40.       end
  41.  
  42.       subroutine test_rightdown2 (a, n)
  43.  
  44.       integer n
  45.  
  46.       real a(n,n,n,n), b(n[0:2],n[0:3],n[0:1],n[0:2])   
  47.       real a1(n,n,n,n)
  48.       logical equal (n,n,n,n)
  49.       integer errors
  50.  
  51. c     call print_a (a, n)
  52.  
  53.       b = a
  54.       forall (i=1:n,j=1:n,k=1:n,l=1:n)
  55.          a1 (j,i,k,l) = b (j+2,i+3,k+1,l+2)
  56.       end forall
  57. c     call print_a (a1, n)
  58.  
  59.       a = cshift (a, 1, 2)
  60.       a = cshift (a, 2, 3)
  61.       a = cshift (a, 3, 1)
  62.       a = cshift (a, 4, 2)
  63. c     call print_a (a, n)
  64.  
  65.       equal = (a1 .eq. a)
  66.       errors = count (equal)
  67.       errors = n*n*n*n - errors
  68.  
  69.       print *, errors, ' Errors for right overlapping'
  70.       end
  71.  
  72.       subroutine print_a (a, n)
  73.       real a(n,n,n,n)
  74.       integer i, j, k, l, n
  75.       do i = 1, n
  76.        do j = 1, n
  77.          do k = 1, n
  78.            do l = 1, n
  79.             print *, 'a(',i,',',j,',',k,',',l,') = ', a(i,j,k,l)
  80.            end do
  81.          end do
  82.        end do
  83.       end do
  84.       end
  85.  
  86.