Relay-Version: version B 2.10 5/3/83; site utzoo.UUCP
Path: utzoo!mnetor!uunet!seismo!rutgers!ames!ucbcad!ucbvax!MIPL3.JPL.NASA.GOV!kka059
From: kka059@MIPL3.JPL.NASA.GOV
Newsgroups: comp.os.vms
Subject: TAPES Program Part 4 of 6
Message-ID: <870806094045.00j@Mipl3.JPL.Nasa.Gov>
Date: Thu, 6-Aug-87 12:40:45 EDT
Article-I.D.: Mipl3.870806094045.00j
Posted: Thu Aug  6 12:40:45 1987
Date-Received: Sun, 9-Aug-87 21:40:20 EDT
Sender: daemon@ucbvax.BERKELEY.EDU
Distribution: world
Organization: The ARPA Internet
Lines: 288

$Part4:
$ Copy VMS_SHAR_DUMMY.DUMMY,SYS$Input VMS_SHAR_DUMMY.DUMMY
X
X          if (bsize.ne.0) then  ! implies i=0: single eof
X            if (scan) then
X              write(mlun,1007) iblk, n
X            elseif (oblk.gt.0) then
X              write(mlun,1011) n, oblk
X            endif
X          elseif (i.ne.-1) then  !  double eof
X            if (scan) write(mlun,1008)
X          endif
X
X          n = n+1
X        enddo
Xc * * * * * end of file loop
X
X        if (tape) then
X          istat = mteof(odsn)  !  write 2nd eof
X          istat = mtskpf(odsn,-1)  !  back up in case more to be written
X        elseif (disk) then
X          close(1)
X        endif
X
Xc  normal end of processing:
X99      write(mlun,1018)
X        call exit
X
Xc  abnormal end of processing:
X100     write(mlun,1020) oname(:onamlen)
X        go to 200
X110     write(mlun,1012)
X200     write(mlun,1019)
X        call exit
X
X1000    format(8(1x,4z2))
X1001    format(' read error in record #', i5)
X1002    format(' end of tape, file:',i4,' record:',i5)
X1003    format(' Begin processing tape ', a<namlen>)
X1004    format(<recl>a1)
X1005    format(/)
X1006    format(1h0)
X1007    format(' EOF>',i5,' blocks in file ',i4/)
X1008    format(' ** EOF>'/)
X1009    format(' End of tape before specified file was reached')
X1010    format(' End of output tape after file #', i6,', block #',i6)
X1011    format(' Copied file #',i5,' containing ',i5,' blocks')
X1012    format(' Tape processing error.')
X1013    format(' *',i6,' bytes in block ',i5)
X1014    format(' Warning: bad recordsize, further results are suspect')
X1015    format(' Copy to disk file ',a<onamlen>)
X1016    format(' Copy to tape ',a<onamlen>)
X1017    format(' Scan mode.')
X1018    format(' Normal end of processing.')
X1019    format(' Normal processing aborted.')
X1020    format(' Error opening disk file ',a<onamlen>)
X
X        end
X
X
Xc****************************************************************
X        character*255 function tranlog( name0, len0)
X
Xc (same as the Vicar routine, but without the optional argument,
Xc  & calls to QPRINT & NARGS; also add ":" for MTINIT.)
X
Xc  Translate logical name NAME0, or a logical name contained in it.
Xc  The translated name is returned as the function value.  
Xc  The length of the name (up to the first non-leading blank) is
Xc  returned as LEN0 (optional).
X
Xc  If NAME0 contains a logical component terminated by ":", then only
Xc  this component is translated.
X
Xc  NAME0 and its translation must each be no longer than 255 characters.
X
X        implicit integer (a-z)
X        include '($SSDEF)'
X        include '($LNMDEF)'
X        character*(*) name0
X        character*255 name, namdes, name1
X        byte namdes1(255)
X        equivalence (namdes1,namdes)
X        integer*2 namlen, buflen, itemcode
X        common/itemlist/ buflen, itemcode, namadr, namlenadr
X
X        character*1 let
X        byte byt
X        equivalence (let,byt)
X
X        if (len(name0).gt.255) then
X          print *, 'Name is too long for function TRANLOG'
X          call exit
X        endif
X        name = name0
X
X        q = 1                           ! length of name
X        i = 0
X        do while (q.eq.1 .and. i.lt.255)
X          i = i+1
X          q = index( name, ' ')
X          if (q.eq.1) name = name(2:)   ! delete leading spaces
X        enddo
X        if (q.eq.0) q = 256
X        q = q-1
X
Xc  initialize for SYS$TRNLNM:
X        status = SS$_NORMAL
X        attr = 0
X        attr = ior ( attr, LNM$M_CASE_BLIND)
X        itemcode = LNM$_STRING
X        buflen = 255
X
Xc  set up the item-list addresses:
X        namadr = %loc( namdes1)
X        namlenadr = %loc (namlen)
X
X        do while (status.ne.SS$_NOLOGNAM)
X
X          namdes = ' '                  ! initialize
X          name1 = ' '
X          name1 = name(:q)              ! make a copy of name
X
X          p = index( name, ':')         ! length up to ":"
X          llen = p                      ! length of possible logical name
X          if (llen.eq.0) llen = q+1
X
Xc*** Currently call SYS$TRNLNM separately for the 2 tables -- would be
Xc*** better to implement a searchlist, as in:
Xc***      status = sys$trnlnm( attr, tables, name(:llen-1),, buflen)
X
X          status = sys$trnlnm( attr, 'LNM$PROCESS_TABLE', name(:llen-1),,
X     &     buflen)
X          if (status.eq.SS$_NOLOGNAM) then
X            status = sys$trnlnm( attr, 'LNM$JOB', name(:llen-1),, buflen)
X          elseif (status.ne.SS$_NORMAL) then
X            print *,' Function TRANLOG found invalid name'
X            call exit
X          endif
X
X          if (status.eq.SS$_NORMAL) then
X            name(:namlen) = namdes(:namlen)
X            if (p.ne.0 .and. p.ne.q) then  !if has component after the ":"
X              name(namlen+1:) = name1(p+1:)
X              q = q+namlen-p
X            else
X              q = namlen
X            endif
X          endif
X
X        enddo
X
Xc  add ":" for MTINIT:  (this is not absolutely necessary, but it
Xc  saves the user from being required to specify the ":")
X        if (p.eq.0 .and. (name(:2).eq.'TP' .or. name(:2).eq.'MT')) then
X          name(:q+1) = name(:q)//':'
X          q = q+1
X        endif
X        tranlog = name
X        len0 = q
X
X        return
X        end
X
Xc**********************************************************************
X        logical function istape( name)
X
Xc  Is unit NAME a tape drive?  (Returns .TRUE. if so.)
X
X        implicit integer (a-z)
X        character*63 name
X
X        structure /itmlst/
X          integer*2 buflen,code
X          integer*4 bufadr,retlenadr,end_list/0/
X        end structure
X        record/itmlst/dvi_list
X        include '($dvidef)/nolist'
X        include '($dcdef)/nolist'
X        integer type, retlen
X        integer sys$getdviw
X        external sys$getdviw
X
X        istape = .FALSE.
X
X        dvi_list.buflen = 4
X        dvi_list.code = DVI$_DEVCLASS
X        dvi_list.bufadr = %loc(type)
X        dvi_list.retlenadr = %loc(retlen)
X        status = sys$getdviw(,, name, dvi_list,,,,,)
X
X        if (type.eq.DC$_TAPE) istape = .TRUE.
X
X        return
X        end
X
Xc**********************************************************************
X        subroutine newtape( name, len, dsn)
X
Xc  Prompt for new output tape
X
X        implicit integer (a-z)
X        character*63 name
X        character*1 char
X
X        write(6,1000) name
X        i = mtrew( dsn)
X        if (i.eq.-2) then
X          write(6,1003)
X          call exit
X        endif
X
X        char = ' '
X        do while (char.ne.'Y' .and. char.ne.'y')
X          write(6,1001)
X          read(5,1002) char
X          if (char.eq.'N' .or. char.eq.'n') call exit
X        enddo
X
X        return
X
X1000    format( ' Please mount another tape on drive ', a<len>)
X1001    format( ' Continue? (Enter Y to continue, N to abort): ',$)
X1002    format( a1)
X1003    format( ' Error rewinding output tape -- job aborted')
X        end
X
Xc**********************************************************************
X        subroutine k029tra( buf, n)
X
Xc  Translate characters that are deviant due to 029 IBM keypunch
X
X        implicit integer (a-z)
X        byte buf(1), tab(128)
X        logical init/.FALSE./
X        save init, tab
X
X        if (.not.init) then     ! construct lookup table
X          do i=1,128
X            tab(i) = i-1
X          enddo
X          tab(36) = 61          ! # becomes =
X          tab(38) = 40          ! % becomes (
X          tab(39) = 43          ! & becomes +
X          tab(61) = 41          ! < becomes )
X        endif
X
X        do i=1,n
X          buf(i) = tab( buf(i)+1)
X        enddo
X
X        return
X        end
X
Xc***************************************************************
X        function getnum( char)
X
Xc  convert a character representation of a number to an integer
X
X        implicit integer(a-z)
X
X        character*(*) char
X        logical more
X
X        getnum = 0
X        p = 0
X        l = len(char)
X        more = .true.
X
X        do p = 1,l
X
X          j = ichar(char(p:p))
X          if (j.eq.32) then  !  blank
X            if (getnum.ne.0) more = .false.
X          elseif (j.lt.48.or.j.gt.57.or..not.more) then
X            print *, 'invalid number: ', char
X            call exit
X          else
X            j = j-48
X            getnum = 10*getnum+j
X          endif
X
X        enddo
X
X        return
X        end
X
$ Goto Part5