From:	CSBVAX::MRGATE!@KL.SRI.Com:kka059@Mipl3.JPL.Nasa.Gov@SMTP  8-AUG-1987 08:39
To:	EVERHART
Subj:	TAPES Program Part 2 of 6

Received: from Mipl3.JPL.Nasa.Gov by KL.SRI.COM with TCP; Thu 6 Aug 87 19:39:25-PDT
Date:    Thu, 6 Aug 87 09:39:39 PDT
From:     kka059@Mipl3.JPL.Nasa.Gov
Message-Id: <870806093939.00h@Mipl3.JPL.Nasa.Gov>
Subject: TAPES Program Part 2 of 6
To:       info-vax@kl.sri.com
X-ST-Vmsmail-To: ST%"info-vax@kl.sri.com",KKA059      

$Part2:
$ Copy VMS_SHAR_DUMMY.DUMMY,SYS$Input VMS_SHAR_DUMMY.DUMMY
X
X        implicit integer (a-z)
X
X        byte buf(65535), cntrlr
X        character*100 params
X        character delim/'/'/
X        character*80 qual
X        character*3 fkey/'FIL'/, bkey/'BLO'/, akey/'ALL'/, okey/'OUT'/,
X     .   ikey/'IGN'/, tekey/'TOE'/, takey/'TOA'/, rkey/'REC'/, 
X     .   afkey/'AFT'/, rwkey/'REW'/, fxkey/'FIX'/, rbkey/'REB'/,
X     .   skkey/'SKI'/, bykey/'BYT'/, ckey/'COP'/, k29key/'029'/,
X     .   dukey/'DUM'/, eotkey/'EOT'/, spkey/'SPL'/
X        integer fbeg(10), fend(10), tdescr(2)
X        logical tape, disk, term, scan, all, toasc, toebc, wflag, fixed,
X     .   inlimit, skip, ignore, more, skipblk, k029, dump, split
X        integer idsn/1/, odsn/2/
X        character*63 name, oname, tranlog
X        logical istape
X        external tranlog, istape
X
X        integer len/65535/
X
X        common/lun/ mlun, eotflag1
X
X        lun = 6                 !  default
X
Xc get parameters:
X        params = ' '
X        do while (params.eq.' ')
X          st = LIB$GET_FOREIGN( params, 'enter tape unit:', plen)
X        enddo
X
Xc parse them:
X
Xc First, tape name
X        p1 = index(params, delim)
X        if (p1.le.0) then
X          name = params
X        elseif (p1.gt.1) then
X          name = params(1:p1-1)
X        else
X          print *, 'invalid tape name'
X          call exit
X        endif
X
X        name = tranlog( name, namlen)  !  translate logical name
X        i = mtinit( idsn, name)
X        if (i.lt.0) then
X          p0 = index(name(p:),' ')-1
X          print *, name(:p0), ' unavailable'
X          call exit
X        endif
X
Xc Next, qualifiers:
X        term = .TRUE.  !  default output units
X        disk = .FALSE.
X        tape = .FALSE.
X        scan = .TRUE.  !  default modes
X        dump = .FALSE.
X        all = .FALSE.
X        fixed = .FALSE.
X        toasc = .FALSE.
X        k029 = .FALSE.
X        toebc = .FALSE.
X        ignore = .FALSE.
X        skip = .FALSE.
X        recl = 0        !  initializations
X        ofil = 0
X        fbeg(1) = 1  !  default file/block numbers
X        fend(1) = 65536
X        nfil = 65536
X        bbeg = 1
X        bend = -1
X        bfact = 1       ! default reblocking factor
X        nbytes = 0      ! default bytes per block
X        eotflag = 0     ! flag to allow reads past EOT
X        eotflag1 = 0    ! variable to pass EOTFLAG to MTEX
X        split = .FALSE.
X
X        do while (p1.gt.0)
X          params = params(p1+1:)
X          plen = plen-p1-1
X
X          p2 = index(params,delim)  !  next "/"
X          if (p2.gt.0) then
X            qual = params(:p2-1)
X          else
X            qual = params
X          endif
X
X          if (index(qual,okey).eq.1) then  !  /OUT:
X            disk = .TRUE.
X            term = .FALSE.
X            po = index(qual,'=')
X            if (po.le.0) then
X              oname = 'TDUMP.DAT'
X            else
X              oname = qual(po+1:)
X              oname = tranlog( oname, onamlen)  !  translate logical name
X              if (istape( oname)) then
X                if (oname.eq.name) then
X                  print *, ' Output cannot be input tape'
X                  call exit
X                endif
X                tape = .TRUE.
X                disk = .FALSE.
X                scan = .FALSE.
X                i = mtinit( odsn, oname)
X                if (i.lt.0) then
X                  print *, name(:4), ' unavailable'
X                  call exit
X                endif
X              endif
X
X            endif
X
X          elseif (index(qual,fkey).eq.1) then  !  /FILES:
X            scan = .FALSE.
X            pq1 = index(qual,'=')
X            if (pq1.gt.0) then
X              qual = qual(pq1+1:)
X              fil = 0
X              more = .TRUE.
X              do while (more)
X                fil = fil+1
X                pq1 = index(qual,':')
X                pq2 = index(qual,',')
X                if (pq2.eq.0) then
X                  if (pq1.eq.0) then
X                    fbeg(fil) = getnum(qual)
X                    fend(fil) = fbeg(fil)
X                  else
X                    fbeg(fil) = getnum(qual(:pq1-1))
X                    fend(fil) = getnum(qual(pq1+1:))
X                  endif
X                  more = .FALSE.
X                else
X                  if (pq1.eq.0) then
X                    fbeg(fil) = getnum(qual(:pq2-1))
X                    fend(fil) = fbeg(fil)
X                  else
X                    fbeg(fil) = getnum(qual(:pq1-1))
X                    fend(fil) = getnum(qual(pq1+1:pq2-1))
X                  endif
X                  qual = qual(pq2+1:)
X                endif
X                if (fil.eq.10) more = .FALSE.
X              enddo
X              nfil = fend(fil)
X            endif
X
X          elseif (index(qual,bkey).eq.1) then  !  /BLOCKS:
X            scan = .FALSE.
X            pq1 = index(qual,'=')
X            if (pq1.gt.0) then
X              pq2 = index(qual,':')
X              if (pq2.gt.pq1) then
X                bbeg = getnum(qual(pq1+1:pq2-1))
X                bend = getnum(qual(pq2+1:))
X              else
X                bbeg = getnum(qual(pq1+1:))
X                bend = bbeg
X              endif
X            else
X              print *, ' /BLOCKS must have a block specification'
X              call exit
X            endif
X
X          elseif (index(qual,bykey).eq.1) then  !  /BYTES
X            scan = .FALSE.
X            pq1 = index(qual,'=')
X            if (pq1.gt.0) then
X              nbytes = getnum(qual(pq1+1:))
X              if (nbytes.gt.65535) then
X                print *, ' max. value allowed for BYTES is 65535'
X                call exit
X              endif
X              if (nbytes.lt.14) then
X                print *, ' min. value allowed for BYTES is 14'
X                call exit
X              endif
X            else
X              print *, ' /BYTES must have a block specification'
X              call exit
X            endif
X
X          elseif (index(qual,ckey).eq.1) then  !  /COPY
X            scan = .FALSE.
X
X          elseif (index(qual,akey).eq.1) then  !  /ALL
X            scan = .FALSE.
X            all = .TRUE.
X
X          elseif (index(qual,ikey).eq.1) then  !  /IGNORE
X            scan = .FALSE.
X            ignore = .TRUE.
X
X          elseif (index(qual,skkey).eq.1) then  !  /SKIP
X            scan = .FALSE.
X            skip = .TRUE.
X            ignore = .TRUE.
X
X          elseif (index(qual,fxkey).eq.1) then  !  /FIXED
X            fixed = .TRUE.
X            disk = .TRUE.
X            scan = .FALSE.
X
X          elseif (index(qual,rwkey).eq.1) then  !  /REWIND
X            i = mtrew(idsn)
X
X          elseif (index(qual,dukey).eq.1) then  !  /DUMP
X            dump = .TRUE.
X            scan = .FALSE.
X
X          elseif (index(qual,takey).eq.1) then  !  /TOASCII
X            toasc = .TRUE.
X            scan = .FALSE.
X
X          elseif (index(qual,K29key).eq.1) then  !  /029
X            k029 = .TRUE.
X
X          elseif (index(qual,eotkey).eq.1) then  !  /EOT
X            eotflag = 1
X
X          elseif (index(qual,spkey).eq.1) then   !  /SPLIT
X            split = .TRUE.
X
X          elseif (index(qual,tekey).eq.1) then   !  /TOEBCDIC
X            toebc = .TRUE.
X            scan = .FALSE.
X
X          elseif (index(qual,rkey).eq.1) then  !  /RECLEN
X            scan = .FALSE.
X            pq1 = index(qual,'=')
X            if (pq1.gt.0) then
X              recl = getnum(qual(pq1+1:))
X            else
X              print *, ' /RECLEN must have a length specification'
X              call exit
X            endif
X
X          elseif (index(qual,rbkey).eq.1) then  !  /REBLOCK
X            scan = .FALSE.
X            pq1 = index(qual,'=')
X            if (pq1.gt.0) then
X              bfact = getnum(qual(pq1+1:))
X            else
X              print *, ' /REBLOCK must have a factor specification'
X              call exit
X            endif
X
X          elseif (index(qual,afkey).eq.1) then  !  /AFTER
X            pq1 = index(qual,'=')
X            if (pq1.gt.0) then
X              ofil = getnum(qual(pq1+1:))
X              if (ofil.le.0) ofil = -1  ! flag to rewind output
X            else
X              ofil = 32767      !  after last file
X            endif
X
X          else
X            print *, ' invalid qualifier:', qual
X            call exit
X          endif
X
X          p1 = p2
X        enddo
X
X        if (.not.tape) bfact = 1
$ Goto Part3
