| *** Some random stuff for testing libU77. Should be done better. It's |
| * hard to test things where you can't guarantee the result. Have a |
| * 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, 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, date_and_time |
| external lenstr |
| integer lenstr |
| logical l |
| character gerr*80, c*1 |
| character ctim*25, line*80, lognam*20, wd*100, line2*80, ddate*8, |
| + ttime*10, zone*5 |
| integer fstatb (13), statb (13) |
| integer *2 i2zero |
| integer values(8) |
| |
| ctim = ctime(time()) |
| WRITE (6,'(A/)') '1 GNU libU77 test at: ' // ctim |
| write (6,'(A,I3,'', '',I3)') |
| + ' Logical units 5 and 6 correspond (FNUM) to' |
| + // ' Unix i/o units ', fnum(5), fnum(6) |
| if (lnblnk('foo ').ne.3 .or. len_trim('foo ').ne.3) then |
| print *, 'LNBLNK or LEN_TRIM failed' |
| call exit(1) |
| end if |
| l= isatty(6) |
| line2 = ttynam(6) |
| if (l) then |
| line = 'and 6 is a tty device (ISATTY) named '//line2 |
| else |
| 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' |
| 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() |
| call ltime (j, ltarray) |
| write (6,'(1x,a,9i4)') 'LTIME returns:', ltarray |
| call gmtime (j, ltarray) |
| write (6,'(1x,a,9i4)') 'GMTIME returns:', ltarray |
| call system_clock(count) ! omitting optional args |
| call system_clock(count, rate, count_max) |
| write(6,*) 'SYSTEM_CLOCK returns: ', count, rate, count_max |
| call date_and_time(ddate) ! omitting optional args |
| call date_and_time(ddate, ttime, zone, values) |
| write(6, *) 'DATE_AND_TIME returns: ', ddate, ' ', ttime, ' ', |
| + zone, ' ', values |
| |
| write (6,*) 'Sleeping for 1 second (SLEEP) ...' |
| call sleep (1) |
| |
| 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:', |
| + 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 |
| print *, '... and the VXT version: ', i,j,k |
| call time(line(:8)) |
| print *, 'TIME: ', line(:8) |
| write (6,*) 'SECNDS(0.0) returns: ',secnds(0.0) |
| write (6,*) 'SECOND returns: ', second() |
| call dumdum(r1) |
| call second(r1) |
| write (6,*) 'CALL SECOND returns: ', r1 |
| i = getcwd(wd) |
| if (i.ne.0) then |
| call perror ('*** getcwd') |
| else |
| write (6,*) 'Current directory is "'//wd(:lenstr(wd))//'"' |
| end if |
| call chdir ('.',i) |
| if (i.ne.0) write (6,*) '***CHDIR to ".": ', i |
| i=hostnm(wd) |
| if(i.ne.0) then |
| call perror ('*** hostnm') |
| else |
| write (6,*) 'Host name is ', wd(:lenstr(wd)) |
| end if |
| i = access('/dev/null ', 'rw') |
| if (i.ne.0) write (6,*) '***Read/write ACCESS to /dev/null: ', i |
| write (6,*) 'Creating file "foo" for testing...' |
| open (3,file='foo',status='UNKNOWN') |
| rewind 3 |
| 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? (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) |
| go to 20 |
| 10 write(6,*) '***FSEEK failed' |
| 20 call fgetc(3, c,i) |
| if (i.ne.0) write(6,*) '***FGETC: ', i |
| if (c.ne.'c') write(6,*) '***FGETC read the wrong thing: ', |
| + ichar(c) |
| i= ftell(3) |
| if (i.ne.1) write(6,*) '***FTELL offset: ', i |
| call chmod ('foo', 'a+w',i) |
| if (i.ne.0) write (6,*) '***CHMOD of "foo": ', i |
| i = fstat (3, fstatb) |
| if (i.ne.0) write (6,*) '***FSTAT of "foo": ', i |
| i = stat ('foo', statb) |
| if (i.ne.0) write (6,*) '***STAT of "foo": ', i |
| write (6,*) ' with stat array ', statb |
| if (statb(5).ne.getuid () .or. statb(6).ne.getgid() .or. statb(4) |
| + .ne. 1) write (6,*) '*** FSTAT uid, gid or nlink is wrong' |
| do i=1,13 |
| if (fstatb (i) .ne. statb (i)) |
| + write (6,*) '*** FSTAT and STAT don''t agree on '// ' |
| + array element ', i, ' value ', fstatb (i), statb (i) |
| end do |
| i = lstat ('foo', fstatb) |
| do i=1,13 |
| if (fstatb (i) .ne. statb (i)) |
| + write (6,*) '*** LSTAT and STAT don''t agree on '// ' |
| + array element ', i, ' value ', fstatb (i), statb (i) |
| end do |
| |
| C in case it exists already: |
| call unlink ('bar',i) |
| call link ('foo ', 'bar ',i) |
| if (i.ne.0) |
| + write (6,*) '***LINK "foo" to "bar" failed: ', i |
| call unlink ('foo',i) |
| if (i.ne.0) write (6,*) '***UNLINK "foo" failed: ', i |
| call unlink ('foo',i) |
| if (i.eq.0) write (6,*) '***UNLINK "foo" again: ', i |
| call gerror (gerr) |
| i = ierrno() |
| write (6,'(A,I3,A/1X,A)') ' The current error number is: ', |
| + i, |
| + ' and the corresponding message is:', gerr(:lenstr(gerr)) |
| write (6,*) 'This is sent to stderr prefixed by the program name' |
| call getarg (0, line) |
| call perror (line (:lenstr (line))) |
| call unlink ('bar') |
| WRITE (6,*) 'You should see exit status 1' |
| CALL EXIT(1) |
| 99 END |
| |
| integer function lenstr (str) |
| C return length of STR not including trailing blanks, but always |
| C return >0 |
| 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. |
| 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 |
