diff options
Diffstat (limited to 'libf2c/libU77/u77-test.f')
| -rw-r--r-- | libf2c/libU77/u77-test.f | 178 |
1 files changed, 178 insertions, 0 deletions
diff --git a/libf2c/libU77/u77-test.f b/libf2c/libU77/u77-test.f new file mode 100644 index 0000000..11c5eca --- /dev/null +++ b/libf2c/libU77/u77-test.f @@ -0,0 +1,178 @@ +*** 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. + + integer i, j, k, ltarray (9), idat (3), count, rate, count_max, + + pid + real tarray1(2), tarray2(2), r1, r2, etime + 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 + logical l + character gerr*80, c*1 + character ctim*25, line*80, lognam*20, wd*100, line2*80 + integer fstatb (13), statb (13) + integer *2 i2zero + + 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 of' + + // ' SYSTEM should agree with the above' + call flush(6) + CALL SYSTEM ('echo " " `id`') + call flush + 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, 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 + r1= etime (tarray1) + if (r1.ne.tarray1(1)+tarray1(2)) + + write (6,*) '*** ETIME didn''t return sum of the array: ', + + r1, ' /= ', tarray1 + 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 + write (6,'(A,3F10.3)') + + ' Elapsed total, user, system time (ETIME): ', + + r1, tarray1 + 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 *, 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? + 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 |