[comp.os.vms] TAPES Program Part 3 of 6

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