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     ! 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.