BSD 4_4 development

[unix-history] / .ref-6294d633e80db8e89697db796e6f6025d5af0cae / usr / src / usr.bin / f77 / libU77 / test / taptst.f

C
C Copyright (c) 1980 The Regents of the University of California.
C All rights reserved.
C
C %sccs.include.proprietary.f%
C
C       @(#)taptst.f    5.2 (Berkeley) %G%
C

       program taptst
C
C Test the tape I/O routines
C
C       ierr = topen  (tlu, name, labelled)
C       ierr = tclose (tlu)
C       nbytes = tread  (tlu, buffer)
C       nbytes = twrite (tlu, buffer)
C       ierr = trewin (tlu)
C       ierr = tskipf (tlu, nfiles, nrecs)
C       ierr = tstate (tlu, fileno, recno, err, eof, eot, tcsr)
C
       character*20    devnam
       integer         topen, tclose, twrite, trewin, tskipf, tstate
       logical         labled, errf, eoff, eotf
       integer         tlu, file, rec, tcsr
       character*256   outbuf

       if (iargc() .ge. 1) then
               do 100 i = 1, iargc()
                       call getarg (i, outbuf)
                       if (outbuf(:5) .eq. '/dev/') devnam = outbuf
                       if (outbuf(:3) .eq. 'lab') labled = .true.
 100           continue
       else
               devnam = '/dev/rnmt0.1600'
               labled = .false.
       endif

       tlu = 3

       write(*,*) 'tstate before open ...'
       ierr = tstate(tlu, file, rec, errf, eoff, eotf, tcsr)
       if (ierr .ge. 0) then
               write(*,*) 'tstate: file', file, 'rec', rec,
    +                  'err', errf, 'eof', eoff, 'eot', eotf
               write(*,'("tcsr: ", 8ri6.6)') tcsr
       else
               call perror('tstate')
       endif

       write(*,*) '\ntopen', devnam, '  labelled =', labled
       ierr = topen(tlu, devnam, labled)
       if (ierr .lt. 0) then
               call perror('topen')
               stop
       endif

       write(*,*) '\ntwrite 4 records of 256 bytes each ...'
       do 120 i = 1, 4
               do 110 j = 1, 256
                       outbuf(j:j) = char(i + 16)
 110           continue

               ierr = twrite(tlu, outbuf)
               if (ierr .ne. 256) then
                       call perror('twrite')
               endif
 120   continue

       write(*,*) '\nrewinding ...'
       ierr = trewin(tlu)
       if (ierr .lt. 0) then
               call perror('trewin')
               ierr = tclose(tlu)
               ierr = topen(tlu, devnam, labled)
       endif

       write(*,*) '\ntread and dump ...'
       call scanf(tlu)

       write(*,*) '\nrewinding ...'
       ierr = trewin(tlu)
       if (ierr .lt. 0) then
               call perror('trewin')
               ierr = tclose(tlu)
               ierr = topen(tlu, devnam, labled)
       endif

       write(*,*) '\ntskip 2 records ...'
       ierr = tskipf(tlu, 0, 2)
       if (ierr .lt. 0) then
               call perror('tskipf')
       endif

       write(*,*) '\ntread & dump ...'
       call scanf(tlu)

       write(*,*) '\ntrewind and tskip to EOT ...'
       ierr = trewin(tlu)
       ierr = tskipf(tlu, 100, 0)

       write(*,*) '\ntwrite 4 more records of 256 bytes each ...'
       do 220 i = 1, 4
               do 210 j = 1, 256
                       outbuf(j:j) = char(i + 32)
 210           continue

               ierr = twrite(tlu, outbuf)
               if (ierr .ne. 256) then
                       call perror('twrite')
               endif
 220   continue

       write(*,*) '\ntrewind and tskip to 1 file & 3 records ...'
       ierr = trewin(tlu)
       ierr = tskipf(tlu, 1, 3)

       write(*,*) '\ntread & dump ...'
       call scanf(tlu)

       write(*,*) '\ntstate ...'
       ierr = tstate(tlu, file, rec, errf, eoff, eotf, tcsr)
       if (ierr .ge. 0) then
               write(*,*) 'tstate: file', file, 'rec', rec,
    +                  'err', errf, 'eof', eoff, 'eot', eotf
               write(*,'("tcsr: ", 8ri6.6)') tcsr
       else
               call perror('tstate')
       endif

       write(*,*) '\ntclose ...'
       ierr = tclose(tlu)
       if (ierr .lt. 0) then
               call perror('tclose')
       endif

       write(*,*) '\ntstate after tclose ...'
       ierr = tstate(tlu, file, rec, errf, eoff, eotf, tcsr)
       if (ierr .ge. 0) then
               write(*,*) 'tstate: file', file, 'rec', rec,
    +                  'err', errf, 'eof', eoff, 'eot', eotf
               write(*,'("tcsr: ", 8ri6.6)') tcsr
       else
               call perror('tstate')
       endif

       end

       subroutine scanf (tlu)
       integer tlu

       integer         tread, tstate
       logical         errf, eoff, eotf
       integer         file, rec, tcsr
       character*10240 buffer

C  100  nb = tread(tlu, buffer(:70))
 100   nb = tread(tlu, buffer)
       if (nb .gt. 0) then
               ierr = tstate(tlu, file, rec, errf, eoff, eotf, tcsr)
               if (ierr .lt. 0) then
                       call perror('tstate')
                       stop 'scanf'
               endif
               write(*,*) 'scanf: file', file+1, 'record', rec,
    +                  'length', nb
               do 110 i = 1, nb, 16
                       write(*, '(4x, $)')
                       nl = min0(nb, i + 15)
                       do 105 j = i, nl
                               ival = and(ichar(buffer(j:j)), 255)
                               write(*, '(su, 16r, i4.2, $)') ival
 105                   continue
               write(*,*)
 110           continue
               write(*,*)
       else if (nb .eq. 0) then
               write(*,*) 'EOF'
               return
       else
               call perror('tread')
               stop 'scanf'
       endif

       goto 100

       end