kka059@MIPL3.JPL.NASA.GOV (08/06/87)
$Part5:
$ Copy VMS_SHAR_DUMMY.DUMMY,SYS$Input VMS_SHAR_DUMMY.DUMMY
Xc==================================================
Xc No-nonsense tape routines
Xc Adapted for VAX (VMS) from the PDP-11 routines
Xc Julian E. Gomez, Jet Propulsion Laboratory, July 1981
Xc Modified by Tom Wolfe,Jet Propulsion Laboratory, June 1982
Xc Modified by Mike Girard, May 1983
XC 83-6-24 ..LWK... modified for COPYTP
XC 84-2-15 ..LWK... modified for tapes
Xc==================================================
X integer function mtinit(dsrn,unitc)
X
X include 'tapes.hed'
X
X integer SYS$ASSIGN,SS$_NORMAL
X external SS$_NORMAL
X
X byte cntlr
X character*15 unitc
X
X i = SYS$ASSIGN(unitc,mtchan(dsrn),,)
X iosb(1,dsrn) = i
X iosb(2,dsrn) = mtchan(dsrn)
X mtinit = mtex(dsrn,'assignment')
X return
X end
X
Xc==================================================
Xc Read tape record into buffer
Xc==================================================
X integer function mtread(dsrn,buffer,length,pos)
X
X include 'tapes.hed'
X
X integer length
X byte buffer(length)
X
X external IO$_READLBLK
X
X i = SYS$QIOW(,%val(mtchan(dsrn)),IO$_READLBLK,iosb(1,dsrn),
X # ,,buffer(pos),%val(length+1-pos),,,,)
X
X mtread = mtex(dsrn,'read attempt')
X
X if (mtread.eq.-2) then ! on error pass neg. byte count
X iosb2 = iosb(2,dsrn)
X if (iosb2.lt.0) iosb2 = 65536+iosb2 ! byte count is unsigned int*2
X if (iosb2.ge.14) mtread = -iosb2 ! 14 is min. valid byte count
X endif
X
X return
X end
X
Xc==================================================
Xc Write buffer onto tape
Xc==================================================
X integer function mtwrit(dsrn,buffer,length)
X
X include 'tapes.hed'
X
X common/lun/ lun, eotflag
X integer length
X byte buffer(length)
X
X integer SS$_WRITLCK
X external IO$_WRITELBLK,SS$_WRITLCK
X
X i = SYS$QIOW(,%val(mtchan(dsrn)),IO$_WRITELBLK,iosb(1,dsrn),
X # ,,buffer,%val(length),,,,)
X if (i .eq. %loc(SS$_WRITLCK)) then
X write(lun,10)
X call exit
X endif
X mtwrit = mtex(dsrn,'write attempt')
X
X return
X
X10 format(' ** Tape needs write ring **')
X end
X
Xc==================================================
Xc Rewind
Xc==================================================
X integer function mtrew(dsrn)
X
X include 'tapes.hed'
X
X external IO$_REWIND
X
X i = SYS$QIOW(,%val(mtchan(dsrn)),IO$_REWIND,iosb(1,dsrn),
X # ,,,,,,,)
X
Xc i = SYS$QIOW(,%val(mtchan(dsrn)),IO$_REWIND,,,,,,,,,)
Xc iosb(1,dsrn) = 1
Xc iosb(2,dsrn) = 1
X
X mtrew = mtex(dsrn,'rewind attempt')
X end
X
Xc==================================================
Xc Skip tape filemarks
Xc==================================================
X integer function mtskpf (dsrn,nfiles)
X
X include 'tapes.hed'
X
X integer nfiles
X
X external IO$_SKIPFILE
X
X i = SYS$QIOW(,%val(mtchan(dsrn)),IO$_SKIPFILE,iosb(1,dsrn),
X # ,,%val(nfiles),,,,,)
X mtskpf = mtex(dsrn,'skip files attempt')
X return
X end
X
Xc==================================================
Xc Write end-of-file mark on tape
Xc==================================================
X integer function mteof(dsrn)
X
X include 'tapes.hed'
X
X external IO$_WRITEOF
X
X i = SYS$QIOW(,%val(mtchan(dsrn)),IO$_WRITEOF,,,,,,,,,)
X iosb(1,dsrn) = i
X iosb(2,dsrn) = 1
X mteof = mtex(dsrn,'write eof mark attempt')
X end
X
Xc==================================================
Xc Examine the return value from a system service request. If there
Xc was an error, print the system error message and return a flag
Xc value. Otherwise return the default value. If EOF return a value
Xc of zero.
Xc==================================================
X integer function mtex (dsrn,message)
X
X include 'tapes.hed'
X
X character*(*) message
X character*40 output
X
X common/lun/ lun, eotflag
X
X integer SS$_NORMAL,SS$_ENDOFFILE,SS$_ENDOFTAPE,SS$_ENDOFVOLUME,
X . SS$_DATACHECK,SS$_DRVERR,SS$_OPINCOMPL,SS$_CTRLERR,
X . SS$_DATAOVERUN,SS$_FORMAT,SS$_ILLIOFUNC,SS$_PARITY,
X . SS$_VOLINV,SS$_MEDOFL
X external SS$_NORMAL,SS$_ENDOFFILE,SS$_ENDOFTAPE,SS$_ENDOFVOLUME,
X . SS$_DATACHECK,SS$_DRVERR,SS$_OPINCOMPL,SS$_CTRLERR,
X . SS$_DATAOVERUN,SS$_FORMAT,SS$_ILLIOFUNC,SS$_PARITY,
X . SS$_VOLINV,SS$_MEDOFL
X
X if (iosb(1,dsrn).eq.%loc(SS$_ENDOFFILE)) then
X mtex = 0
X return
X
X elseif (iosb(1,dsrn).eq.%loc(SS$_ENDOFVOLUME)) then
X mtex = -1
X return
X
X elseif (iosb(1,dsrn).eq.%loc(SS$_ENDOFTAPE)) then
X if (iosb(2,dsrn).gt.0 .and. eotflag.eq.1) then
X mtex = iosb(2,dsrn)
X else
X mtex = -1
X endif
X return
X
X elseif (iosb(1,dsrn).eq. %loc(SS$_DATACHECK)) then
X output = 'Tape '//message//' error:'
X write(lun,10) output,iosb(1,dsrn)
X output = 'write check'
X write(lun,10) output
X mtex = -2
X
X elseif (iosb(1,dsrn).eq. %loc(SS$_DRVERR)) then
X output = 'Tape '//message//' error:'
X write(lun,10) output,iosb(1,dsrn)
X output = 'drive error'
X write(lun,10) output
X mtex = -2
X
X elseif (iosb(1,dsrn).eq. %loc(SS$_OPINCMPL)) then
X output = 'Tape '//message//' error:'
X write(lun,10) output,iosb(1,dsrn)
X output = 'some hardware error?'
X write(lun,10) output
X mtex = -2
X
X elseif (iosb(1,dsrn).eq. %loc(SS$_CTRLERR)) then
X output = 'Tape '//message//' error:'
X write(lun,10) output,iosb(1,dsrn)
X output = 'controller error'
X write(lun,10) output
X mtex = -2
X
X elseif (iosb(1,dsrn).eq. %loc(SS$_DATAOVERUN)) then
X output = 'Tape '//message//' error:'
X write(lun,10) output,iosb(1,dsrn)
X output = 'bad buffer, probable bug'
X write(lun,10) output
X mtex = -2
X
X elseif (iosb(1,dsrn).eq. %loc(SS$_FORMAT)) then
X output = 'Tape '//message//' error:'
X write(lun,10) output,iosb(1,dsrn)
X output = 'invalid format of medium'
X write(lun,10) output
X mtex = -2
X
X elseif (iosb(1,dsrn).eq. %loc(SS$_ILLIOFUNC)) then
X output = 'Tape '//message//' error:'
X write(lun,10) output,iosb(1,dsrn)
X output = 'illegal function code'
X write(lun,10) output
X mtex = -2
X
X elseif (iosb(1,dsrn).eq. %loc(SS$_PARITY)) then
X output = 'Tape '//message//' error:'
X write(lun,10) output,iosb(1,dsrn)
X output = 'parity error'
X write(lun,10) output
X mtex = -2
X
X elseif (iosb(1,dsrn).eq. %loc(SS$_VOLINV)) then
X output = 'Tape '//message//' error:'
X write(lun,10) output,iosb(1,dsrn)
X output = 'bad vol valid bit; probable bug'
X write(lun,10) output
X mtex = -2
X
X elseif (iosb(1,dsrn).eq.0 .or. ! empirically determined!!
X . iosb(1,dsrn).eq. %loc(SS$_MEDOFL)) then
X output = 'device not ready'
X write(lun,10) output
X call exit
X
X elseif (iosb(1,dsrn).ne. %loc(SS$_NORMAL)) then
X output = 'Tape '//message//' error:'
X write(lun,10) output,iosb(1,dsrn)
X mtex = -2
X
X else
X mtex = iosb(2,dsrn)
X if (mtex.lt.0) mtex = 65536+mtex ! byte count is unsigned
X endif
X
X return
X
X10 format(5x,a40,i5)
X end
$ GoSub Convert_File
$ File_is="TAPES.HED"
$ Check_Sum_is=2504417
$ Copy SYS$Input VMS_SHAR_DUMMY.DUMMY
X implicit integer (a-z)
X
X integer mtchan(10)
X integer*2 iosb(4,10)
X common /nonon/ mtchan,iosb
X
X integer SYS$QIOW
X
$ GoSub Convert_File
$ File_is="COMPILE_AND_LINK.COM"
$ Check_Sum_is=2021091832
$ Copy SYS$Input VMS_SHAR_DUMMY.DUMMY
X$!
X$! Run this procedure to compile and link the TAPES program
X$!
X$ fort/nolist TAPES
X$ link/nomap TAPES
X$ exit
$ GoSub Convert_File
$ Goto Part6