OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

u77-test.f: Don't bother declaring etime.

Browse Source 
* libU77/u77-test.f: Don't bother declaring etime.
        Use `implicit none' and declare mask and lenstr.
        Do ETIME/DTIME consistency check before loop, then
        use loop to verify that dtime "ticks" at some point.
        Check ETIME array-sum using single-precision add, to
        avoid spurious complaint on systems (like x86) that
        use more precision for intermediate results.
        Fix `Results of ETIME and DTIME...' message to print
        pertinent values (r1 and r2 instead of i and j).
        Change loop from 10M to 1K repeated up to 1000 times
        or until dtime "ticks".
        Print the number of 1K loops needed to see this tick.
        Answer a commented question.
        Split up a long line of output and do other prettying.
        Preset lognam in case GETLOG fails to overwrite it.
Patch from Craig.

From-SVN: r18861
This commit is contained in:
Craig Burley 1998-03-27 19:28:21 -05:00 committed by Jeff Law
parent 4d1d804584
commit a051827081
2 changed files with 77 additions and 16 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
libf2c/ChangeLog
View File

@ -1,3 +1,21 @@
Wed Mar 4 16:32:46 1998 Craig Burley <burley@gnu.org>
* libU77/u77-test.f: Don't bother declaring etime.
Use `implicit none' and declare mask and lenstr.
Do ETIME/DTIME consistency check before loop, then
use loop to verify that dtime "ticks" at some point.
Check ETIME array-sum using single-precision add, to
avoid spurious complaint on systems (like x86) that
use more precision for intermediate results.
Fix `Results of ETIME and DTIME...' message to print
pertinent values (r1 and r2 instead of i and j).
Change loop from 10M to 1K repeated up to 1000 times
or until dtime "ticks".
Print the number of 1K loops needed to see this tick.
Answer a commented question.
Split up a long line of output and do other prettying.
Preset lognam in case GETLOG fails to overwrite it.
Sat Feb 28 15:32:15 1998 Craig Burley <burley@gnu.org>
* libI77/open.c (f_open): Use sizeof(buf) instead of

67
libf2c/libU77/u77-test.f
View File

@ -3,15 +3,17 @@
* good squint at what it prints, though detected errors will cause
* starred messages.
implicit none
integer i, j, k, ltarray (9), idat (3), count, rate, count_max,
+ pid
real tarray1(2), tarray2(2), r1, r2, etime
+ pid, mask
real tarray1(2), tarray2(2), r1, r2, sum
intrinsic getpid, getuid, getgid, ierrno, gerror,
+ fnum, isatty, getarg, access, unlink, fstat,
+ stat, lstat, getcwd, gmtime, hostnm, etime, chmod,
+ chdir, fgetc, fputc, system_clock, second, idate, secnds,
+ time, ctime, fdate, ttynam
external lenstr
integer lenstr
logical l
character gerr*80, c*1
character ctim*25, line*80, lognam*20, wd*100, line2*80
@ -35,20 +37,23 @@
line = 'and 6 isn''t a tty device (ISATTY)'
end if
write (6,'(1X,A)') line(:lenstr(line))
pid = getpid()
WRITE (6,'(A,I10)') ' Process id (GETPID): ', pid
WRITE (6,'(A,I10)') ' User id (GETUID): ', GETUID ()
WRITE (6,'(A,I10)') ' Group id (GETGID): ', GETGID ()
WRITE (6,*) 'If you have the `id'' program, the following call of'
+ // ' SYSTEM should agree with the above'
WRITE (6, *) 'If you have the `id'' program, the following call'
write (6, *) 'of SYSTEM should agree with the above:'
call flush(6)
CALL SYSTEM ('echo " " `id`')
call flush
lognam = 'blahblahblah'
call getlog (lognam)
write (6,*) 'Login name (GETLOG): ', lognam
call umask(0, mask)
write(6,*) 'UMASK returns', mask
call umask(mask)
ctim = fdate()
write (6,*) 'FDATE returns: ', ctim
j=time()
@ -58,22 +63,53 @@
write (6,'(1x,a,9i4)') 'GMTIME returns:', ltarray
call system_clock(count, rate, count_max)
write(6,*) 'SYSTEM_CLOCK returns: ', count, rate, count_max
write (6,*) 'Sleeping for 1 second (SLEEP) ...'
call sleep (1)
write (6,*) 'Looping 10,000,000 times ...'
do i=1,10*1000*1000
end do
c consistency-check etime vs. dtime for first call
r1 = etime (tarray1)
if (r1.ne.tarray1(1)+tarray1(2))
+ write (6,*) '*** ETIME didn''t return sum of the array: ',
+ r1, ' /= ', tarray1(1), '+', tarray1(2)
r2 = dtime (tarray2)
if (abs (r1-r2).gt.1.0) write (6,*)
+ 'Results of ETIME and DTIME differ by more than a second:',
+ i, j
+ r1, r2
call sgladd (sum, tarray1(1), tarray1(2))
if (r1 .ne. sum)
+ write (6,*) '*** ETIME didn''t return sum of the array: ',
+ r1, ' /= ', tarray1(1), '+', tarray1(2)
call sgladd (sum, tarray2(1), tarray2(2))
if (r2 .ne. sum)
+ write (6,*) '*** DTIME didn''t return sum of the array: ',
+ r2, ' /= ', tarray2(1), '+', tarray2(2)
write (6, '(A,3F10.3)')
+ ' Elapsed total, user, system time (ETIME): ',
+ r1, tarray1
c now try to get times to change enough to see in etime/dtime
write (6,*) 'Looping until clock ticks at least once...'
do i = 1,1000
do j = 1,1000
end do
r2 = dtime (tarray2)
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)
+ write (6,*) '*** ETIME didn''t return sum of the array: ',
+ r1, ' /= ', tarray1(1), '+', tarray1(2)
call sgladd (sum, tarray2(1), tarray2(2))
if (r2 .ne. sum)
+ write (6,*) '*** DTIME didn''t return sum of the array: ',
+ r2, ' /= ', tarray2(1), '+', tarray2(2)
write (6, '(A,3F10.3)')
+ ' Differences in total, user, system time (DTIME): ',
+ r2, tarray2
write (6, '(A,3F10.3)')
+ ' Elapsed total, user, system time (ETIME): ',
+ r1, tarray1
write (6, *) '(Clock-tick detected after ', i, ' 1K loops.)'
call idate (i,j,k)
call idate (idat)
write (6,*) 'IDATE d,m,y: ',idat
@ -107,7 +143,8 @@
call fputc(3, 'c',i)
call fputc(3, 'd',j)
if (i+j.ne.0) write(6,*) '***FPUTC: ', i
C why is it necessary to reopen?
C why is it necessary to reopen? (who wrote this?)
C the better to test with, my dear! (-- burley)
close(3)
open(3,file='foo',status='old')
call fseek(3,0,0,*10)
@ -176,3 +213,9 @@ C return >0
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)
implicit none
real sum,left,right
sum = left+right
end