1 program taptst 2C 3C Test the tape I/O routines 4C 5C ierr = topen (tlu, name, labelled) 6C ierr = tclose (tlu) 7C nbytes = tread (tlu, buffer) 8C nbytes = twrite (tlu, buffer) 9C ierr = trewin (tlu) 10C ierr = tskipf (tlu, nfiles, nrecs) 11C ierr = tstate (tlu, fileno, recno, err, eof, eot, tcsr) 12C 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 148C 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 179