![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to tp_ex2.f CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 43BSDTahoe / new / help / src / f77|
Return to tp_ex2.f CVS log | Up to [CSRG BSD Unix] / 43BSDTahoe / new / help / src / f77 |
1.1 root 1: .TI F77/TP_EX2.F "Sep. 15, 1984"
2:
3: .nf
4: .po 0
5: c sample program to illustrate reading blocked tape
6: c
7: c this reads a blocked tape (80 char/record, 40 rec/block).
8: c it reads col 1-5 and 6-10 as integer fields into
9: c ix1 and ix2 and prints them out.
10: c
11:
12: integer tlu
13: character*80 rec
14: logical eof
15:
16: nmrecs = 0
17:
18: tlu = 1
19: call tpopen( tlu, .false., .false. )
20:
21: 10 call getrec( tlu, rec, eof )
22: if( eof ) go to 900
23: nmrecs = nmrecs + 1
24:
25: read ( rec, 8100 ) ix1, ix2
26: 8100 format( 2i5 )
27:
28: print 8110, ix1, ix2
29: 8110 format( 1x,2i5 )
30: go to 10
31:
32: 900 continue
33: end
34: c ---------------------- getrec() -------------------------------
35: subroutine getrec( tlu, record, eof )
36: integer tlu
37: character record*(*)
38: logical eof
39:
40: c getrec() returns in the character variable
41: c 'record' the next record from the tape,
42: c deblocking the tape as needed.
43: c parameters:
44: c tlu - the "tape logical unit" as described in
45: c "man 3f topen". getrec() assumes topen()
46: c was called by the calling program.
47: c record - buffer in which the record is returned
48: c eof - set to .true. after all records read.
49: c
50: c The characters/record and records/block are set
51: c up in the following parameter statement:
52:
53: parameter (mxrecs=40, mxbyts=80, mxbufl=mxrecs*mxbyts)
54: character bufrcs(mxrecs)*mxbyts, bufall*(mxbufl)
55: equivalence (bufrcs(1),bufall)
56:
57: integer recno, recsrd, tread
58: data recno/mxrecs/, recsrd/mxrecs/
59:
60: if(len(record) .lt. mxbyts)
61: 1 call tperr("record() arg to getrec() too short:", len(record))
62:
63: recno = recno+1
64: if(recno.gt.recsrd) then
65: nbytes = tread(tlu, bufall)
66: if(nbytes .eq. 0 ) then
67: eof = .true.
68: return
69: else if(nbytes.lt.0) then
70: call perror("getrec:")
71: call tperr("tread() error:", nbytes)
72: else if(nbytes.gt.mxbufl) then
73: call tperr("block too long:", nbytes)
74: else
75: recsrd = nbytes / mxbyts
76: if( nbytes.ne. recsrd*mxbyts)
77: 1 call tperr("invalid block length:", nbytes)
78: recno = 1
79: endif
80: endif
81:
82: record = bufrcs(recno)
83: eof = .false.
84: return
85: end
86: c -------------------------- tperr -------------------------------
87: subroutine tperr( string, value )
88: character string*(*)
89: integer value
90:
91: write( 0, 8000 ) string, value
92: 8000 format("tape I/O error: ",a,i6)
93: call exit(1)
94: end
95: c -------------------------- tpopen -------------------------------
96: subroutine tpopen( tlu, label, rew )
97: integer tlu
98: logical label, rew
99:
100: c open tape logical unit 'tlu' to device named in
101: c environment variable 'tape1'.
102: c 'label' is an input parameter which is .true. for
103: c labeled tapes.
104: c if 'rew' is .true., tape is rewound by tpopen().
105:
106: character tpdev*50
107: integer retcde, topen, trewin
108:
109: call getenv( 'tape1', tpdev )
110: if(tpdev .eq. ' ') call tperr("tape1 = ' '", 0 )
111:
112: retcde = topen(tlu, tpdev(:lnblnk(tpdev)), label )
113: if(retcde .ne. 0) then
114: call perror("tpopen")
115: call tperr("topen() failed, error:", retcde)
116: endif
117:
118: if(rew) then
119: retcde = trewin( tlu )
120: if(retcde .ne. 0) then
121: call perror("tpopen")
122: call tperr("trewin() failed, error:", retcde)
123: endif
124: endif
125:
126: end
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.