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