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