kka059@MIPL3.JPL.NASA.GOV (08/06/87)
$Part3: $ Copy VMS_SHAR_DUMMY.DUMMY,SYS$Input VMS_SHAR_DUMMY.DUMMY X Xc Restrictions on keywords for tape: X if (tape) then X if (recl.ne.0 .and. bfact.ne.1) recl=0 X if (nbytes.gt.0 .and. bfact.ne.1) nbytes=0 X if (recl.ne.0 .and. nbytes.gt.0) nbytes=0 X endif X Xc Other restrictions: X if (dump .and. (toasc.or.toebc)) then X print *, ' Cannot specify /DUMP with /TOASCI or /TOEBC' X call exit X endif X if (toasc .and. toebc) then X print *, ' Cannot specify both /TOASC and /TOEBC' X call exit X endif Xc Prepare output tape, if any: X if (tape .and. ofil.ne.0) then ! position output tape X i = mtrew(odsn) X if (i.eq.-2) call exit X if (ofil.gt.0) then X i = mtskpf(odsn,ofil) ! positions tape to start of file X if (i.eq.-1) print *, ' Output positioned to end of tape' X if (i.eq.-2) call exit X endif X endif X Xc Open disk file, if any: X if (disk) then X lun = 1 X mlun = 6 ! for error msgs in this step X if (scan) then X open(1, file=oname, status='new', err=100) X elseif (fixed) then X if (recl.gt.0) ! else wait for first read X . open(1, file=oname, status='new', recordtype='fixed', X . carriagecontrol='none', recl=recl, err=100) X elseif (dump .or. toasc .or. toebc .or. recl.gt.0) then X if (recl.le.0) recl = 80 X open(1, file=oname, carriagecontrol='list', status='new', X . recl=recl,err=100) ! formatted, sequential, variable-length X else X open(1, file=oname, form='unformatted', recordtype='segmented', X . status='new', err=100) X endif X endif X X if (.not.term .or. all) all = .TRUE. ! default unless "term" X if (scan) ignore = .TRUE. ! default for "scan" X if (toasc.or.toebc) tdescr(2) = %loc(buf) X mlun = lun X if (disk .and. .not.scan) mlun = 6 ! msg output unit X Xc Starting message: X write(mlun,1003) name(:namlen) X if (scan) then X write(mlun,1017) X else X if (disk) write(mlun,1015) oname(:onamlen) X if (tape) write(mlun,1016) oname(:onamlen) X endif X Xc*************************************************************** Xc Processing loop: X X n = 1 ! file counter X fil = 1 ! file group counter (index to fbeg,fend) X eof = 0 ! eof-count X Xc * * * * * start of file loop X do while (eof.lt.2 .and. n.le.nfil) X X if (n.lt.fbeg(fil)) then X i = mtskpf(idsn,fbeg(fil)-n) X if (i.lt.0) then X if (i.eq.-1) write(mlun,1009) ! end of tape X n = nfil+1 ! to exit loop X else X n = fbeg(fil) X i = 1 ! initialize status code for record loop X endif X else X i = 1 ! initialize status code for record loop X endif X X ! initializations: X inlimit = .FALSE. ! valid flag for files/blocks to copy X iblk = 0 ! block counter X oblk = 0 ! output block counter X rblk = 1 ! re-blocking counter X ipos = 1 ! buffer position (for reblocking) X bsize = 0 ! input block size X obsize = 0 ! output block size (for reblocking) X skipblk = .FALSE. ! set on read error if /SKIP X wflag = .FALSE. X Xc * * * * * start of record (block) loop X do while (i.gt.0) X X eotflag1 = eotflag ! pass EOTFLAG for MTREAD X i = mtread(idsn,buf,len,ipos) X X if (i.lt.-1) then X write(mlun,1001) iblk+1 X if (ignore .and. (i.lt.-14.or.scan)) then !14 = min. valid count X i = -i X if (skip) skipblk = .TRUE. X elseif (ignore) then X write (mlun,1014) X i = 14 X skipblk = .TRUE. X else X go to 99 X endif X endif X X if (fixed .and. recl.eq.0 .and. i.gt.0) then ! case of unknown recl X recl = i X if (disk) open(1, file=oname, status='new', recl=recl, X . recordtype='fixed', carriagecontrol='none', err=100) X endif X X bsize1 = i X if (tape) eotflag1 = 0 ! zero EOTFLAG for MTWRIT X X if (i.eq.-1) then ! end of tape X eof = 2 X bsize = 0 ! distinguished from double eof by i=-1 X write(mlun,1002) n, iblk X X elseif (i.eq.0) then ! end of file X eof = eof+1 ! don't reset bsize, so we can check for double eof X if (n.le.fend(fil)) then X if (tape) then X if (obsize.gt.0) then ! if anything in reblocking buffer X istat = mtwrit(odsn,buf,obsize) X jstat = istat !save it for next step X wflag = .TRUE. X if (istat.eq.-1) then !end of output tape X write(mlun,1010) n,iblk X if (.not.split) then !back up to end of last file X istat = mtskpf(odsn,-1) X istat = mtskpf(idsn,-1) X if (istat.lt.0) go to 110 X n = n-1 X bsize = 0 !to indicate double EOF X else !split input file X write(mlun,1011) n, oblk X oblk = 0 !initialize for second output file X rblk = 1 X ipos = 1 X obsize = 0 X endif X istat = mteof(odsn) !write double EOF X istat = mteof(odsn) X if (istat.lt.0) go to 110 X call newtape( oname, onamlen, odsn) X endif X endif X if (wflag .and. jstat.ne.-1) call mteof(odsn) X endif X if (n.eq.fend(fil)) fil = fil+1 X endif X X else ! we read a block X X iblk = iblk+1 X eof = 0 X X if (iblk.ge.bbeg .and. X . (bend.eq.-1 .or. iblk.le.bend)) then X inlimit = .TRUE. X elseif (iblk.gt.bend) then X inlimit = .FALSE. X i = mtskpf(idsn,1) ! skip to next file X i = 0 ! follow same procedure as for eof: X eof = eof+1 X if (n.le.fend(fil)) then X if (tape) then X if (obsize.gt.0) then X istat = mtwrit(odsn,buf,obsize) X jstat = istat !save it for next step X wflag = .TRUE. X if (istat.eq.-1) then !end of output tape X write(mlun,1010) n,iblk X if (.not.split) then !back up to end of last file X istat = mtskpf(odsn,-1) X istat = mtskpf(idsn,-1) X if (istat.lt.0) go to 110 X n = n-1 X bsize = 0 !to indicate double EOF X else !split input file X write(mlun,1011) n, oblk X oblk = 0 !initialize for second output file X rblk = 1 X ipos = 1 X obsize = 0 X endif X istat = mteof(odsn) !write double EOF X istat = mteof(odsn) X if (istat.lt.0) go to 110 X call newtape( oname, onamlen, odsn) X endif X endif X if (wflag .and. jstat.ne.-1) call mteof(odsn) X endif X if (n.eq.fend(fil)) fil = fil+1 X endif X endif X X if (scan) then X if (bsize.ne.bsize1) then ! list bsize if different X write(mlun,1013) bsize1,iblk X bsize = bsize1 X endif X X elseif (.not.skipblk) then X bsize = bsize1 X if (inlimit) then X if (tape .and. recl.ne.0) then X bsize = recl ! write recl bytes X do bb = bsize1+1,recl ! pad with zeroes X buf(bb) = 0 X enddo X elseif (nbytes.gt.0) then X bsize = min0(nbytes,bsize) X endif X obsize = obsize+bsize X X if (toasc.or.toebc) then X tdescr(1) = bsize X if (toasc) then X st = LIB$TRA_EBC_ASC(%ref(tdescr),%ref(tdescr)) X if (k029) call k029tra( buf, bsize) X else X st = LIB$TRA_ASC_EBC(%ref(tdescr),%ref(tdescr)) X endif X endif X X if (term .or. dump) then X if (all) then X write(lun,1000) (buf(j),j=1,bsize) X if (term) then X write(lun,1006) X else X write(lun,1005) X endif X else X write(lun,1000) (buf(j),j=1,80) X endif X elseif (disk) then X if (toasc .or. toebc .or. recl.gt.0) then X do jj = 1, bsize, recl X write(lun,1004) (buf(j),j=jj,min0(jj+recl-1,bsize)) X oblk = oblk+1 X enddo X else X write(lun,iostat=stat) (buf(j),j=1,bsize) X oblk = oblk+1 X endif X elseif (tape) then X if (rblk.eq.bfact .or. ipos+i.gt.65535) then X istat = mtwrit(odsn,buf,obsize) X jstat = istat !save it for next step X wflag = .TRUE. X if (istat.eq.-1) then !end of output tape X write(mlun,1010) n,iblk X if (.not.split) then !back up to end of last file X istat = mtskpf(odsn,-1) X istat = mtskpf(idsn,-1) X if (istat.lt.0) go to 110 X n = n-1 X bsize = 0 !to indicate double EOF X else !split input file X write(mlun,1011) n, oblk X oblk = 0 !initialize for second output file X rblk = 1 X ipos = 1 X obsize = 0 X endif X istat = mteof(odsn) !write double EOF X istat = mteof(odsn) X if (istat.lt.0) go to 110 X call newtape( oname, onamlen, odsn) X else X oblk = oblk+1 X rblk = 1 X ipos = 1 X obsize = 0 X endif X else X rblk = rblk+1 X ipos = ipos+i X endif X endif X endif X X endif X X skipblk = .FALSE. ! reset for next block X X endif X X enddo Xc * * * * * end of record (block) loop $ Goto Part4