kka059@MIPL3.JPL.NASA.GOV (08/06/87)
$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