allow slop in sum-checking

From-SVN: r26718

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index b4633b758169ef200ae8f7d872d0796593e4c10a..b71d2ba8b9a943c0bc413dbe6ee7d4827c06b504 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,11 @@
+Sat May  1 23:57:18 1999  Craig Burley  <craig@jcb-sc.com>
+
+       * g77.f-torture/execute/u77-test.f: Generalize sum-checking to
+       use a new function, which allows for some slop.
+       Clean up some commentary.
+       (issum): The new function.
+       (sgladd): Deleted subroutine.
+
 1999-05-01  Craig Burley  <craig@jcb-sc.com>
 
        * g77.f-torture/execute/u77-test.f: Modify to be more like

diff --git a/gcc/testsuite/g77.f-torture/execute/u77-test.f b/gcc/testsuite/g77.f-torture/execute/u77-test.f
index 25647191ddf3945969dafc7dfc715b0c7e524821..535d04ecce8ac12002ec9c128a67cfef9c5e4161 100644 (file)
--- a/gcc/testsuite/g77.f-torture/execute/u77-test.f
+++ b/gcc/testsuite/g77.f-torture/execute/u77-test.f
@@ -18,7 +18,8 @@
 
       integer i, j, k, ltarray (9), idat (3), count, rate, count_max,
      +     pid, mask
-      real tarray1(2), tarray2(2), r1, r2, sum
+      real tarray1(2), tarray2(2), r1, r2
+      logical issum
       intrinsic getpid, getuid, getgid, ierrno, gerror,
      +     fnum, isatty, getarg, access, unlink, fstat,
      +     stat, lstat, getcwd, gmtime, etime, chmod,
@@ -99,14 +100,12 @@ c consistency-check etime vs. dtime for first call
      +       r1, r2
         call doabort
       end if
-      call sgladd (sum, tarray1(1), tarray1(2))
-      if (r1 .ne. sum) then
+      if (.not. issum (r1, tarray1(1), tarray1(2))) then
         write (6,*) '*** ETIME didn''t return sum of the array: ',
      +       r1, ' /= ', tarray1(1), '+', tarray1(2)
         call doabort
       end if
-      call sgladd (sum, tarray2(1), tarray2(2))
-      if (r2 .ne. sum) then
+      if (.not. issum (r2, tarray2(1), tarray2(2))) then
         write (6,*) '*** DTIME didn''t return sum of the array: ',
      +       r2, ' /= ', tarray2(1), '+', tarray2(2)
         call doabort
@@ -124,14 +123,12 @@ c now try to get times to change enough to see in etime/dtime
       if (tarray2(1) .ne. 0. .or. tarray2(2) .ne. 0.) exit
       end do
       r1 = etime (tarray1)
-      call sgladd (sum, tarray1(1), tarray1(2))
-      if (r1 .ne. sum) then
+      if (.not. issum (r1, tarray1(1), tarray1(2))) then
         write (6,*) '*** ETIME didn''t return sum of the array: ',
      +       r1, ' /= ', tarray1(1), '+', tarray1(2)
         call doabort
       end if
-      call sgladd (sum, tarray2(1), tarray2(2))
-      if (r2 .ne. sum) then
+      if (.not. issum (r2, tarray2(1), tarray2(2))) then
         write (6,*) '*** DTIME didn''t return sum of the array: ',
      +       r2, ' /= ', tarray2(1), '+', tarray2(2)
         call doabort
@@ -280,33 +277,39 @@ C     WRITE (6,*) 'You should see exit status 1'
       CALL EXIT(0)
  99   END
 
+* Return length of STR not including trailing blanks, but always > 0.
       integer function lenstr (str)
-C     return length of STR not including trailing blanks, but always
-C     return >0
-      character *(*) str
+      character*(*) str
       if (str.eq.' ') then
         lenstr=1
       else
         lenstr = lnblnk (str)
       end if
       end
-* just make sure SECOND() doesn't "magically" work the second time.
+
+* Just make sure SECOND() doesn't "magically" work the second time.
       subroutine dumdum(r)
       r = 3.14159
       end
-* do an add that is most likely to be done in single precision.
-      subroutine sgladd(sum,left,right)
+
+* Test whether sum is approximately left+right.
+      logical function issum (sum, left, right)
       implicit none
-      real sum,left,right
-      sum = left+right
+      real sum, left, right
+      real mysum, delta, width
+      mysum = left + right
+      delta = abs (mysum - sum)
+      width = abs (left) + abs (right)
+      issum = (delta .le. .0001 * width)
       end
 
-*     signal handler
+* Signal handler
       subroutine ctrlc
       print *, 'Got ^C'
       call doabort
       end
 
+* A problem has been noticed, so maybe abort the test.
       subroutine doabort
 * For this version, call the ABORT intrinsic.
       intrinsic abort

diff --git a/libf2c/ChangeLog b/libf2c/ChangeLog
index 9d3403a84b215202817c92002a7757d00327117b..180ba1485a164bdfd1ffaf6530000992ae065ff6 100644 (file)
--- a/libf2c/ChangeLog
+++ b/libf2c/ChangeLog
@@ -1,3 +1,11 @@
+Sat May  1 23:57:18 1999  Craig Burley  <craig@jcb-sc.com>
+
+       * libU77/u77-test.f: Generalize sum-checking to
+       use a new function, which allows for some slop.
+       Clean up some commentary.
+       (issum): The new function.
+       (sgladd): Deleted subroutine.
+
 Sat May  1 23:35:18 1999  Craig Burley  <craig@jcb-sc.com>
 
        * libU77/u77-test.f: Modify to be more like testsuite

diff --git a/libf2c/libU77/u77-test.f b/libf2c/libU77/u77-test.f
index e45132ad95aa44aa4384f7a856b24a900510704d..50ae41d6b7e10f0077cc6b1cc31f5eea12398830 100644 (file)
--- a/libf2c/libU77/u77-test.f
+++ b/libf2c/libU77/u77-test.f
@@ -21,7 +21,8 @@
 
       integer i, j, k, ltarray (9), idat (3), count, rate, count_max,
      +     pid, mask
-      real tarray1(2), tarray2(2), r1, r2, sum
+      real tarray1(2), tarray2(2), r1, r2
+      logical issum
       intrinsic getpid, getuid, getgid, ierrno, gerror,
      +     fnum, isatty, getarg, access, unlink, fstat,
      +     stat, lstat, getcwd, gmtime, etime, chmod,
@@ -102,14 +103,12 @@ c consistency-check etime vs. dtime for first call
      +       r1, r2
         call doabort
       end if
-      call sgladd (sum, tarray1(1), tarray1(2))
-      if (r1 .ne. sum) then
+      if (.not. issum (r1, tarray1(1), tarray1(2))) then
         write (6,*) '*** ETIME didn''t return sum of the array: ',
      +       r1, ' /= ', tarray1(1), '+', tarray1(2)
         call doabort
       end if
-      call sgladd (sum, tarray2(1), tarray2(2))
-      if (r2 .ne. sum) then
+      if (.not. issum (r2, tarray2(1), tarray2(2))) then
         write (6,*) '*** DTIME didn''t return sum of the array: ',
      +       r2, ' /= ', tarray2(1), '+', tarray2(2)
         call doabort
@@ -127,14 +126,12 @@ c now try to get times to change enough to see in etime/dtime
       if (tarray2(1) .ne. 0. .or. tarray2(2) .ne. 0.) exit
       end do
       r1 = etime (tarray1)
-      call sgladd (sum, tarray1(1), tarray1(2))
-      if (r1 .ne. sum) then
+      if (.not. issum (r1, tarray1(1), tarray1(2))) then
         write (6,*) '*** ETIME didn''t return sum of the array: ',
      +       r1, ' /= ', tarray1(1), '+', tarray1(2)
         call doabort
       end if
-      call sgladd (sum, tarray2(1), tarray2(2))
-      if (r2 .ne. sum) then
+      if (.not. issum (r2, tarray2(1), tarray2(2))) then
         write (6,*) '*** DTIME didn''t return sum of the array: ',
      +       r2, ' /= ', tarray2(1), '+', tarray2(2)
         call doabort
@@ -283,33 +280,39 @@ C     in case it exists already:
       CALL EXIT(1)
  99   END
 
+* Return length of STR not including trailing blanks, but always > 0.
       integer function lenstr (str)
-C     return length of STR not including trailing blanks, but always
-C     return >0
-      character *(*) str
+      character*(*) str
       if (str.eq.' ') then
         lenstr=1
       else
         lenstr = lnblnk (str)
       end if
       end
-* just make sure SECOND() doesn't "magically" work the second time.
+
+* Just make sure SECOND() doesn't "magically" work the second time.
       subroutine dumdum(r)
       r = 3.14159
       end
-* do an add that is most likely to be done in single precision.
-      subroutine sgladd(sum,left,right)
+
+* Test whether sum is approximately left+right.
+      logical function issum (sum, left, right)
       implicit none
-      real sum,left,right
-      sum = left+right
+      real sum, left, right
+      real mysum, delta, width
+      mysum = left + right
+      delta = abs (mysum - sum)
+      width = abs (left) + abs (right)
+      issum = (delta .le. .0001 * width)
       end
 
-*     signal handler
+* Signal handler
       subroutine ctrlc
       print *, 'Got ^C'
       call doabort
       end
 
+* A problem has been noticed, so maybe abort the test.
       subroutine doabort
 * For this version, print out all problems noticed.
 *     intrinsic abort