Return to tp_ex2.f CVS log

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

Annotation of 43BSDTahoe/new/help/src/f77/tp_ex2.f, revision 1.1

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.