From:	CSBVAX::MRGATE!@KL.SRI.Com:kka059@Mipl3.JPL.Nasa.Gov@SMTP  8-AUG-1987 09:43
To:	EVERHART
Subj:	TAPES Program Part 5 of 6

Received: from Mipl3.JPL.Nasa.Gov by KL.SRI.COM with TCP; Thu 6 Aug 87 21:38:29-PDT
Date:    Thu, 6 Aug 87 09:41:15 PDT
From:     kka059@Mipl3.JPL.Nasa.Gov
Message-Id: <870806094115.00k@Mipl3.JPL.Nasa.Gov>
Subject: TAPES Program Part 5 of 6
To:       info-vax@kl.sri.com
X-ST-Vmsmail-To: ST%"info-vax@kl.sri.com",KKA059      

$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
