From 92e38ab5f340e16ee21c2b8634d91530ed484d63 Mon Sep 17 00:00:00 2001 From: Craig Burley Date: Sat, 1 May 1999 22:32:23 +0000 Subject: [PATCH] allow slop in sum-checking From-SVN: r26718 --- gcc/testsuite/ChangeLog | 8 ++++ .../g77.f-torture/execute/u77-test.f | 39 ++++++++++--------- libf2c/ChangeLog | 8 ++++ libf2c/libU77/u77-test.f | 39 ++++++++++--------- 4 files changed, 58 insertions(+), 36 deletions(-) diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index b4633b75816..b71d2ba8b9a 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,11 @@ +Sat May 1 23:57:18 1999 Craig Burley + + * 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 * 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 25647191ddf..535d04ecce8 100644 --- 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 9d3403a84b2..180ba1485a1 100644 --- a/libf2c/ChangeLog +++ b/libf2c/ChangeLog @@ -1,3 +1,11 @@ +Sat May 1 23:57:18 1999 Craig Burley + + * 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 * 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 e45132ad95a..50ae41d6b7e 100644 --- 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 -- 2.30.2