1:         program taptst
   2: C
   3: C Test the tape I/O routines
   4: C
   5: C	ierr = topen  (tlu, name, labelled)
   6: C	ierr = tclose (tlu)
   7: C	nbytes = tread  (tlu, buffer)
   8: C	nbytes = twrite (tlu, buffer)
   9: C	ierr = trewin (tlu)
  10: C	ierr = tskipf (tlu, nfiles, nrecs)
  11: C	ierr = tstate (tlu, fileno, recno, err, eof, eot, tcsr)
  12: C
  13:         character*20    devnam
  14:         integer         topen, tclose, twrite, trewin, tskipf, tstate
  15:         logical         labled, errf, eoff, eotf
  16:         integer         tlu, file, rec, tcsr
  17:         character*256   outbuf
  18: 
  19:         if (iargc() .ge. 1) then
  20:                 do 100 i = 1, iargc()
  21:                         call getarg (i, outbuf)
  22:                         if (outbuf(:5) .eq. '/dev/') devnam = outbuf
  23:                         if (outbuf(:3) .eq. 'lab') labled = .true.
  24:   100           continue
  25:         else
  26:                 devnam = '/dev/rnmt0.1600'
  27:                 labled = .false.
  28:         endif
  29: 
  30:         tlu = 3
  31: 
  32:         write(*,*) 'tstate before open ...'
  33:         ierr = tstate(tlu, file, rec, errf, eoff, eotf, tcsr)
  34:         if (ierr .ge. 0) then
  35:                 write(*,*) 'tstate: file', file, 'rec', rec,
  36:      +                  'err', errf, 'eof', eoff, 'eot', eotf
  37:                 write(*,'("tcsr: ", 8ri6.6)') tcsr
  38:         else
  39:                 call perror('tstate')
  40:         endif
  41: 
  42:         write(*,*) '\ntopen', devnam, '  labelled =', labled
  43:         ierr = topen(tlu, devnam, labled)
  44:         if (ierr .lt. 0) then
  45:                 call perror('topen')
  46:                 stop
  47:         endif
  48: 
  49:         write(*,*) '\ntwrite 4 records of 256 bytes each ...'
  50:         do 120 i = 1, 4
  51:                 do 110 j = 1, 256
  52:                         outbuf(j:j) = char(i + 16)
  53:   110           continue
  54: 
  55:                 ierr = twrite(tlu, outbuf)
  56:                 if (ierr .ne. 256) then
  57:                         call perror('twrite')
  58:                 endif
  59:   120   continue
  60: 
  61:         write(*,*) '\nrewinding ...'
  62:         ierr = trewin(tlu)
  63:         if (ierr .lt. 0) then
  64:                 call perror('trewin')
  65:                 ierr = tclose(tlu)
  66:                 ierr = topen(tlu, devnam, labled)
  67:         endif
  68: 
  69:         write(*,*) '\ntread and dump ...'
  70:         call scanf(tlu)
  71: 
  72:         write(*,*) '\nrewinding ...'
  73:         ierr = trewin(tlu)
  74:         if (ierr .lt. 0) then
  75:                 call perror('trewin')
  76:                 ierr = tclose(tlu)
  77:                 ierr = topen(tlu, devnam, labled)
  78:         endif
  79: 
  80:         write(*,*) '\ntskip 2 records ...'
  81:         ierr = tskipf(tlu, 0, 2)
  82:         if (ierr .lt. 0) then
  83:                 call perror('tskipf')
  84:         endif
  85: 
  86:         write(*,*) '\ntread & dump ...'
  87:         call scanf(tlu)
  88: 
  89:         write(*,*) '\ntrewind and tskip to EOT ...'
  90:         ierr = trewin(tlu)
  91:         ierr = tskipf(tlu, 100, 0)
  92: 
  93:         write(*,*) '\ntwrite 4 more records of 256 bytes each ...'
  94:         do 220 i = 1, 4
  95:                 do 210 j = 1, 256
  96:                         outbuf(j:j) = char(i + 32)
  97:   210           continue
  98: 
  99:                 ierr = twrite(tlu, outbuf)
 100:                 if (ierr .ne. 256) then
 101:                         call perror('twrite')
 102:                 endif
 103:   220   continue
 104: 
 105:         write(*,*) '\ntrewind and tskip to 1 file & 3 records ...'
 106:         ierr = trewin(tlu)
 107:         ierr = tskipf(tlu, 1, 3)
 108: 
 109:         write(*,*) '\ntread & dump ...'
 110:         call scanf(tlu)
 111: 
 112:         write(*,*) '\ntstate ...'
 113:         ierr = tstate(tlu, file, rec, errf, eoff, eotf, tcsr)
 114:         if (ierr .ge. 0) then
 115:                 write(*,*) 'tstate: file', file, 'rec', rec,
 116:      +                  'err', errf, 'eof', eoff, 'eot', eotf
 117:                 write(*,'("tcsr: ", 8ri6.6)') tcsr
 118:         else
 119:                 call perror('tstate')
 120:         endif
 121: 
 122:         write(*,*) '\ntclose ...'
 123:         ierr = tclose(tlu)
 124:         if (ierr .lt. 0) then
 125:                 call perror('tclose')
 126:         endif
 127: 
 128:         write(*,*) '\ntstate after tclose ...'
 129:         ierr = tstate(tlu, file, rec, errf, eoff, eotf, tcsr)
 130:         if (ierr .ge. 0) then
 131:                 write(*,*) 'tstate: file', file, 'rec', rec,
 132:      +                  'err', errf, 'eof', eoff, 'eot', eotf
 133:                 write(*,'("tcsr: ", 8ri6.6)') tcsr
 134:         else
 135:                 call perror('tstate')
 136:         endif
 137: 
 138:         end
 139: 
 140:         subroutine scanf (tlu)
 141:         integer tlu
 142: 
 143:         integer         tread, tstate
 144:         logical         errf, eoff, eotf
 145:         integer         file, rec, tcsr
 146:         character*10240 buffer
 147: 
 148: C  100	nb = tread(tlu, buffer(:70))
 149:   100   nb = tread(tlu, buffer)
 150:         if (nb .gt. 0) then
 151:                 ierr = tstate(tlu, file, rec, errf, eoff, eotf, tcsr)
 152:                 if (ierr .lt. 0) then
 153:                         call perror('tstate')
 154:                         stop 'scanf'
 155:                 endif
 156:                 write(*,*) 'scanf: file', file+1, 'record', rec,
 157:      +                  'length', nb
 158:                 do 110 i = 1, nb, 16
 159:                         write(*, '(4x, $)')
 160:                         nl = min0(nb, i + 15)
 161:                         do 105 j = i, nl
 162:                                 ival = and(ichar(buffer(j:j)), 255)
 163:                                 write(*, '(su, 16r, i4.2, $)') ival
 164:   105                   continue
 165:                 write(*,*)
 166:   110           continue
 167:                 write(*,*)
 168:         else if (nb .eq. 0) then
 169:                 write(*,*) 'EOF'
 170:                 return
 171:         else
 172:                 call perror('tread')
 173:                 stop 'scanf'
 174:         endif
 175: 
 176:         goto 100
 177: 
 178:         end
Last modified: 1987-02-18
Generated: 2016-12-26
Generated by src2html V0.67
page hit count: 914
Valid CSS Valid XHTML 1.0 Strict