Return to tp_ex1.f CVS log

Up to [CSRG BSD Unix] / 43BSDTahoe / new / help / src / f77

Annotation of 43BSDTahoe/new/help/src/f77/tp_ex1.f, revision 1.1.1.1

1.1       root        1: .TI F77/TP_EX1.F "Sep. 15, 1984"
                      2:  
                      3: .nf
                      4: .po 0
                      5: c      sample program to illustrate reading unblocked tape
                      6: c
                      7: c      this reads an unblocked tape (80 char/record).
                      8: c      it reads col 1-5 and 6-10 as integer fields
                      9: c         into ix1 and ix2 and prints them out.
                     10: 
                     11:        integer tlu
                     12:        character*80 rec
                     13:        logical eof
                     14: 
                     15:        nmrecs = 0
                     16: 
                     17:        tlu = 1
                     18:        call tpopen( tlu, .false., .false. )
                     19: 
                     20: 10     call getrec( tlu, rec, eof )
                     21:        if( eof ) go to 900
                     22:        nmrecs = nmrecs + 1
                     23: 
                     24:        read ( rec, 8100 ) ix1, ix2
                     25: 8100   format( 2i5 )
                     26: 
                     27:        print 8110, ix1, ix2
                     28: 8110   format( 1x,2i5 )
                     29:        go to 10
                     30: 
                     31: 900    continue
                     32:        end
                     33: c ------------------------------ getrec() -------------------------
                     34:        subroutine getrec( tlu, record, eof )
                     35:        integer tlu
                     36:        character record*(*)
                     37:        logical eof
                     38: 
                     39: c              getrec() returns in the character variable 'record'
                     40: c                 the next record on the tape
                     41: c              parameters:
                     42: c                 tlu - the "tape logical unit" as described in
                     43: c                       "man 3f topen".  getrec() assumes topen()
                     44: c                       was called by the calling program.
                     45: c                 record - buffer in which the record is returned
                     46: c                 eof - set to .true. after all records read.
                     47: 
                     48:        integer tread
                     49: 
                     50:        nbytes = tread(tlu, record)
                     51:        if(nbytes .eq. 0 ) then
                     52:                eof = .true.
                     53:                return
                     54:        else if(nbytes.lt.0) then
                     55:                call perror("getrec:")
                     56:                call tperr("tread() error:", nbytes)
                     57:        else if(nbytes.ne.len(record)) then
                     58:                call tperr("tread() error, wrong # of bytes read:",
                     59:      .                 nbytes)
                     60:        endif
                     61: 
                     62:        eof = .false.
                     63:        return
                     64:        end
                     65: c ------------------------------ tperr() --------------------------
                     66:        subroutine tperr( string, value )
                     67:        character string*(*)
                     68:        integer value
                     69: 
                     70:        write( 0, 8000 ) string, value
                     71: 8000   format("tape I/O error: ",a,i6)
                     72:        call exit(1)
                     73:        end
                     74: c ------------------------------ tpopen() -------------------------
                     75:        subroutine tpopen( tlu, label, rew )
                     76:        integer tlu
                     77:        logical label, rew
                     78: 
                     79: c         open tape logical unit 'tlu' to device named in
                     80: c              environment variable 'tape1'.
                     81: c         'label' is an input parameter which is .true. for
                     82: c              labeled tapes.
                     83: c         if 'rew' is .true., tape is rewound by tpopen().
                     84: 
                     85:        character tpdev*50
                     86:        integer retcde, topen, trewin
                     87: 
                     88:        call getenv( 'tape1', tpdev )
                     89:        if(tpdev .eq. ' ') call tperr("tape1 = ' '", 0 )
                     90: 
                     91:        retcde = topen(tlu, tpdev(:lnblnk(tpdev)), label )
                     92:        if(retcde .ne. 0) then
                     93:                call perror("tpopen")
                     94:                call tperr("topen() failed, error:", retcde)
                     95:        endif
                     96: 
                     97:        if(rew) then
                     98:                retcde = trewin( tlu )
                     99:                if(retcde .ne. 0) then
                    100:                   call perror("tpopen")
                    101:                   call tperr("trewin() failed, error:", retcde)
                    102:                endif
                    103:        endif
                    104: 
                    105:        end

This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.