FTN4,L
C 
C    VERSION   4 / 21 / 76   JRT
C    MODIFIED  6 / 08 /  7   MCC
C    MODIFIED  9 / 13 / 79   DHP
C 
      PROGRAM JSAVE(3,60),24999-16048 REV 1932  790913
C 
      LOGICAL RWIND,VERIFY
C 
      DIMENSION IREG(2),MBUF(50),IPBUF(33),ISTNG(40)
      DIMENSION IBUF(8321),JBUF(20000B),ICLST(4,32) 
      INTEGER FIRST,LAST,SFLAG,FILEN
C 
      DIMENSION MESS1(12),MESS2(29),MESS3(13),MESS4(15) 
      DIMENSION MESS5(13),MESS6(14),MESS7(23),MES71(13) 
      DIMENSION MESS8(8),MESS9(12),MES10(13),MES11(9) 
      DIMENSION IREV(25),JVMESS(9)
      DIMENSION MES12(11),MES13(9),MES14(15),MES15(19)
C 
      EQUIVALENCE (IA,IREG),(IB,IREG(2)),(X,IREG) 
      EQUIVALENCE (IBUF,ITRAK),(JBUF,IBUF(2)),(IBUF,ICLST)
      EQUIVALENCE (IPBUF(4),IWD4),(IPBUF(5),IWD5) 
      EQUIVALENCE (IPBUF(2),IWD2),(IPBUF(6),IWD6) 
C 
      EQUIVALENCE (JBUF(4),JBUF4),(JBUF(5),JBUF5),(JBUF(7),JBUF7),
     +            (JBUF(8),JBUF8),(JBUF(10),JBUF10) 
      EQUIVALENCE (MBUF(2),MBUF2),(MBUF(11),MBUF11),(MBUF(26),MBUF26),
     +            (MBUF(27),MBUF27),(MBUF(4),MBUF4) 
C 
      EQUIVALENCE (MES15(10),MS150),(MES15(11),MS151),(MES15(12),MS152) 
C 
      DATA SFLAG,JLNTH,MLNTH/0,128,29/
C 
      DATA MESS1/6412B,2H/J,2HSA,2HVE,2H: ,2HMA,2HG ,2HTA,2HPE, 
     &           2H L,2HU:,2H _/
      DATA MESS2/6412B,2H/J,2HSA,2HVE,2H: ,2HDI,2HSC,2H C,2HRN,2H[-,
     &            2HLU,2H]:,2H (, 
     &            2H[,,2HLA,2HST,2H T,2HRA,2HCK,2H] ,2H  ,
     &            2HLU,2H= ,2H0 ,2H=>,2H E,2HND,2H) ,2H _/
      DATA MESS3/2H/J,2HSA,2HVE,2H: ,2HTH,2HAT,2H'S,2H N,2HOT,
     &          2H A,2H D,2HIS,2HC!/
      DATA MESS4/2H/J,2HSA,2HVE,2H: ,2HTH,2HAT,2H'S,
     &           2H N,2HOT,2H A,2H M,2HAG,2H T, 
     &            2HAP,2HE!/
      DATA MESS5/2H/J,2HSA,2HVE,2H: ,2HCA,2HN',2HT ,
     &          2HDO,2H T,2HHA,2HT ,2HLU,2H! /
      DATA MESS6/2H/J,2HSA,2HVE,2H: ,2HMA,2HX ,2H= ,
     &          2H50,2H, ,2HMI,2HN ,2H= ,2H0!/
      DATA MESS7/2H/J,2HSA,2HVE,2H: ,2HEN,2HTE,2HR ,2HAN,2HY ,2HAD, 
     &           2HDI,2HTI,2HON,2HAL,2H C,2HOM,2HME,2HNT,2HS ,2HOR, 
     &           2H ",2H ",2HCR/
      DATA MES71/2H/J,2HSA,2HVE,2H: ,2HDE,2HFA,2HUL,2HT ,2HHE,2HAD, 
     &            2HER,2H I,2HS:/ 
      DATA MESS8/6412B,2H/J,2HSA,2HVE,2H: ,2HEN,2HD?,2H _/
      DATA MESS9/6412B,2H/J,2HSA,2HVE,2H: ,2HDO,2HNE,2H! ,6412B/
      DATA MES10/6412B,2H/J,2HSA,2HVE,2H: ,2HMA,2HG , 
     &          2HTA,2HPE,2H F,2HIL,2HE:,2H _/
      DATA MES11/2H/J,2HSA,2HVE,2H: ,2HEO,2HF ,2HFO,2HUN,2HD!/
      DATA MES12/2H/J,2HSA,2HVE,2H: ,2HNO,2HT ,2HJS,2HAV,2HE ,2HFI, 
     &           2HLE/
      DATA MES13/2H/J,2HSA,2HVE,2H: ,2H V,2HER,2HIF,2HYI,2HNG/
      DATA MES14/2H/J,2HSA,2HVE,2H: ,2HWA,2HIT,2HIN,2HG ,2HFO,
     &           2HR ,2HLU,2H# ,3*2H  / 
      DATA MES15/2H/J,2HSA,2HVE,2H: ,2HCA,2HRT,2HRI,2HDG,2HE ,3*2H  , 
     &           2H N,2HOT,2H M,2HOU,2HNT,2HED,2H. /
      DATA IREV /2H24,2H99,2H9-,2H16,2H04,2H8 ,2H19,2H32,2H S,2HOF, 
     &           2HTW,2HAR,2HE ,2HSE,2HRV,2HIC,2HE ,2HKI,2HT ,2HSY, 
     &           2HST,2HEM,2H 1,2H00,2H0 /
      DATA JVMESS/2H/J,2HSA,2HVE,2H: ,2HVE,2HRI,2HFY,2H ?,2H _/ 
C 
C     SET DEFAULTS AND CHECK TURN ON STRING 
C 
      DATA MBUF/2HCR,24*20040B,6412B,24*20040B/ 
      DATA ISTNG/40*0/,LEN,IDISC,NFILE/0,0,0/ 
      DATA IRCNT,ISTRC/1,1/,MTLU/8/,IMESS/0/
      DATA RWIND/.TRUE./,VERIFY/.FALSE./,LASTTR/0/
      DATA ICL  /3/,IDELT/0/
C 
C     GET SESION TERMINAL 
C 
      LU = LOGLU(ISES)
      ILU=LU+400B 
C 
C  GET TURN ON STRING 
C 
      CALL GETST(JBUF,-70,ILOG) 
      IF(ILOG .EQ. 0)GO TO 3
C 
C SAVE ORIGINAL STRING IN CASE OF " . . . "'S 
C 
      IOFF = IAND(ILOG,1) 
      IWDL = ILOG/2 + IOFF
      DO 700 I=1,IWDL 
      ISTNG(I) = JBUF(I)
 700  CONTINUE
C 
C CHANGE "=" 'S TO ":" 'S 
C 
      CALL EQCOL(JBUF,ILOG) 
C 
C SCAN STRING FOR WHAT TO DO. ORDER DOESN'T MATTER
C 
710   IF(NAMR(IPBUF,JBUF,ILOG,ISTRC))3,720
C 
720   NTYPE = IAND(IWD4,3)
      IF(NTYPE .LE. 1)GO TO 710 
      IPBUF = IOR(IAND(IPBUF,77400B),40B) 
      IF(IPBUF .EQ. 1HD)IDISC = IWD5
      IF(IPBUF .EQ. 1HF)NFILE = IWD5
      IF(IPBUF .EQ. 1HI)RWIND = .FALSE. 
      IF(IPBUF .EQ. 1HL)LASTTR= IWD5
      IF(IPBUF .EQ. 1HM)MTLU  = IWD5
      IF(IPBUF .EQ. 1HR)IRCNT = IWD5
      IF(IPBUF .EQ. 1HV)VERIFY= .TRUE.
      IF(IPBUF .EQ. 1H")CALL QUOTE(ISTNG,MBUF27,LEN)
      GO TO 710 
C 
   3  CALL EXEC(2,ILU,IREV,25)
      IF(ILOG .EQ. 0)NFILE = 1
      FILEN = NFILE 
C 
C   GET DISC AND MAG TAPE LU'S
C 
      IF(ILOG .GT. 0)GO TO 11 
 10   CALL EXEC(2,ILU,MESS1,12) 
      X=REIO(1,ILU,JBUF,-10)
      CALL PARSE(JBUF,IB,IPBUF) 
      MTLU=IWD2 
C 
 11   CALL EXEC(13,MTLU,ISTAT)
      IF(IAND(ISTAT,37400B)*2.EQ.23000B)GO TO 14
      IF(IAND(ISTAT,37400B)*2.EQ.24000B)GO TO 14
C 
C     NOT A MAG TAPE IF NOT DVR23 OR DVR24
C 
      CALL EXEC(2,ILU,MESS4,15) 
      GO TO 10
C 
14    IREG=LURQ(100001B,MTLU,1) 
      IF(IREG.EQ.0)GO TO 142
C 
C LOCK UNSUCCESSFUL, SO REPORT
C 
      CALL CNUMD(MTLU,MES14(13))
      IF (IMESS .EQ. 0)CALL EXEC(2,LU,MES14,15) 
C 
      IMESS = 1 
      CALL EXEC(12,0,2,0,-3)
      IF(IFBRK(IDMMY))99,14 
142   IF(NFILE .GE. 1)REWIND MTLU 
C 
      IF(ILOG .GT. 0 .AND. IDISC .NE. 0)GO TO 152 
C 
15    IF(SFLAG.EQ.0)GO TO 151 
      MESS2(13)=020137B 
      MLNTH=13
C 
C     GET DISK LU (LAST TRK) ETC. 
C 
151   CALL EXEC(2,ILU,MESS2,MLNTH)
      X=REIO(1,ILU,JBUF,-12)
      CALL PARSE(JBUF,IB,IPBUF) 
      IDISC=IWD2
      IF(IWD5 .GT. 0)LASTTR=IWD6
      ICL = 3 
C 
C     QUIT IF DISK LU GIVEN AS 0. 
C 
      IF(IDISC.EQ.0)GO TO 90
 152  IF(IDISC .GT. 0)GO TO 153 
      IDISC = IABS(IDISC) 
      ICL = 1 
 153  CALL FSTAT(ICLST) 
      DO 154 J=1,31 
      IF(ICLST(ICL,J) .NE. IDISC)GO TO 154
      IDISC = ICLST(1,J)
      IF(LASTTR .EQ. 0)LASTTR = ICLST(2,J)
      GO TO 158 
154   CONTINUE
C 
C IF THIS IS AN LU# LET HIM SAVE IT 
C 
      IF(ICL .EQ. 1)GO TO 158 
C 
C     TELL HIM THE CRN IS NOT MOUNTED 
C 
      MS150 = 20040B
      MS151 = 20040B
      MS152 = -1
      CALL ASCII(IDISC,MS152) 
      IF(MS152 .EQ. 2H  )CALL CNUMD(IDISC,MS150)
      CALL EXEC(2,ILU,MES15,19) 
      GO TO 15
C 
C     DISK LU < 7 NOT ALLOWED 
C 
 158  IF(IDISC .GT. 6)GO TO 16
      CALL EXEC(2,ILU,MESS5,13) 
      GO TO 15
C 
16    CALL EXEC(13,IDISC,ISTAT) 
      ITYPE=IAND(ISTAT,37000B)/256
C 
C     NOT A DISK IF DVR NOT 30 OR 32
C 
      IF((ITYPE.EQ.30B).OR.(ITYPE.EQ.32B))GO TO 20
      CALL EXEC(2,ILU,MESS3,13) 
      GO TO 15
C 
C   GET MAG TAPE FILE NUMBER AND IDENT
C 
 20   IF(SFLAG.NE.0)GO TO 30
      IF(ILOG .GT. 0)GO TO 205
C 
C     GET FILE # IF FIRST TIME. 
C 
21    CALL EXEC(2,ILU,MES10,13) 
      X=REIO(1,ILU,JBUF,-10)
      CALL PARSE(JBUF,IB,IPBUF) 
      NFILE=IWD2
      FILEN=NFILE 
C 
C     QUIT IF FILE # < 0 .
C 
 205  IF(NFILE.LT.0)GO TO 90
C 
C     GO POSITION THE TAPE IF FILE # <= 50. 
      IF(NFILE.LE.50)GO TO 22 
      CALL EXEC(2,ILU,MESS6,14) 
      GO TO 21
C 
C   POSITION THE TAPE 
C 
22    IF(NFILE.LE.1)GO TO 30
C 
C     READ ONE LONG (6145) RECORD FORM TAPE.
C 
23    X=EXEC(1,MTLU,IBUF,JLNTH+1) 
      IF(IB.GT.0)GO TO 211
      CALL EXEC(2,ILU,MES11,9)
      GO TO 30
211   IF(IB.LE.100)GO TO 212
C 
C     NOT A HEADER IF LENGTH > 100 WORDS. 
C 
      CALL EXEC(2,ILU,MES12,11) 
      GO TO 213 
C 
C     DISPLAY THE HEADER FOR THIS FILE THEN FF ONE FILE . 
C     (TO THE END OF THIS DISK COPY)
C 
212   CALL EXEC(2,ILU,IBUF,IB)
213   CALL EXEC(3,MTLU+1300B) 
      NFILE=NFILE-1 
      IF(NFILE .EQ. 1)30,23 
C 
C   GET HEADER AND WRITE TO TAPE
C 
C 
C     GET THE # OF TRKS BY FORCING A SEEK BEYOND THE POSIBLE END. 
C 
 30   X=EXEC(1,IDISC,JBUF,128,10000,0)
      ITRAK=IB-1
      IF(LASTTR.NE.0 .AND. LASTTR .LE. ITRAK)ITRAK=LASTTR 
      CALL EXEC(1,IDISC,JBUF,JLNTH,ITRAK,0) 
C 
C  CALCULATE BUFFER LENGTH FROM NUMBER OF SECTORS/TRACK 
C 
      JLNTH = JBUF7 * 64
C 
C PUT CR# LABEL INTO OUTPUT BUFFER & BLANK FILL THE CRN 
C 
      DO 305 I=1,3
      MBUF(I+5) = JBUF(I) 
      MBUF(I+1) = 20040B
305   CONTINUE
C 
C CHECK FOR POSSIBLE ASCII CR#
C 
      MBUF4 = -1
      CALL ASCII(JBUF4,MBUF4) 
      IF(MBUF4 .EQ. 2H  )CALL CNUMD(JBUF4,MBUF2)
C 
C CALL FTIME ROUTINE TO GET THE CURRENT DATE & TIME 
C 
      CALL FTIME(MBUF11)
C 
      MBUF26 = 6412B
      IF(ILOG .GT. 0)GO TO 33 
      DO 31 I=27,50 
       MBUF(I)=2H 
31    CONTINUE
C 
C     DISPLAY DEFAULT HEADER AND
C     PROMPT FOR HEADER.
C 
      CALL EXEC(2,ILU,MES71,13) 
      CALL EXEC(2,ILU,MBUF,25)
      CALL EXEC(2,ILU,MESS7,23) 
C 
C     READ THE HEADER.
C 
      X =  REIO(1,ILU,MBUF27,-48) 
      LEN = IB
C 
C     AND WRITE IT TO TAPE. 
C 
 33   IF(LEN .GT. 48)LEN = 48 
      CALL EXEC(2,ILU,MBUF,-(LEN+52)) 
      CALL EXEC(2,MTLU,MBUF,50) 
C 
C 
C    HAVE ALL LU'S, NOW GO COPY THE DISC... 
C       COPY ALL DIRECTORY TRACKS FIRST, FOLLOWED BY
C       ALL TRACKS USED BY FMP  (UN-USED TRACKS WON'T BE COPIED)
C 
      FIRST=JBUF5 
      LAST=JBUF10 
      IF(LAST.EQ.LASTTR)LAST=LAST-1 
      LOWDIR=JBUF8
C 
40    CALL EXEC(1,IDISC,JBUF,JLNTH,ITRAK,0) 
41    CALL EXEC(2,MTLU,IBUF,JLNTH+1)
      IF(IFBRK(IDUM))99,42
C 
C     GO COPY DATA TRKS IF DONE WITH DIRECTORY TRACKS.
C 
 42   IF(ITRAK.EQ.LOWDIR)GO TO 45 
C 
C     ELSE - DECREMENT TRK # TO NEXT DIRECTORY TRK. 
C 
      ITRAK=ITRAK-1 
      GO TO 40
C 
45    DO 49 ITRAK=FIRST,LAST
       CALL EXEC(1,IDISC,JBUF,JLNTH,ITRAK,0)
       CALL EXEC(2,MTLU,IBUF,JLNTH+1) 
       IF(IFBRK(IDUM))99,49 
49    CONTINUE
C 
C     PUT 2 EOF AT THE END. 
C 
      ENDFILE MTLU
      ENDFILE MTLU
C 
C     NOW SPACE BACK OVER ONE EOF.
C 
      CALL EXEC(3,MTLU+1400B) 
C 
C     INCREMENT THE REPEAT COUNTER
C 
      IRCNT = IRCNT - 1 
C 
      IF(ILOG .EQ. 0)GO TO 1000 
      IF(VERIFY)1005,50 
1000  CALL EXEC(2,ILU,JVMESS,9) 
      CALL REIO(1,ILU,IANS,1) 
      IF(IANS .NE. 2HYE) GO TO 50 
      VERIFY = .TRUE. 
C 
C     2-MORE BF & 1-FF REQUIRED IF NOT FIRST FILE 
C 
1005  IF(FILEN .EQ. 1) GO TO 1010 
      CALL EXEC(3,MTLU+1400B) 
      CALL EXEC(3,MTLU+1400B) 
C 
C  CHECK IF AT SOT. YES ? DON'T DO FF.
C 
      X =  EXEC(3,MTLU+600B)
      IA = IAND(IA,100B)
      IF(IA .EQ. 0)CALL EXEC(3,MTLU+1300B)
      GO TO 1020
C 
1010  REWIND MTLU 
C 
C     READ THE HEADER AGAIN & DISPLAY IT
C 
1020  CALL EXEC(2,ILU,MES13,9)
      X =  EXEC(1,MTLU,IBUF,100)
      CALL EXEC(2,ILU,IBUF,IB)
C 
C     VERIFY THE FILE 
C 
      CALL JVRFY(IBUF,LU,IDISC,MTLU,IDELT)
C 
C NO ERROR ? CONTINUE 
C 
      IF(IBUF .EQ. 0)GO TO 50 
C 
C IF INTERACTIVE CONTINUE 
C 
      IF(ILOG .EQ. 0)GO TO 50 
C 
C  IF INHIBIT REWIND SPICIFIED ASSUME POSSIBLE BATCH MODE 
C  AND DO A FORWARD FILE FOR NEXT JSAVE.
C 
      IF(RWIND)GO TO 50 
      CALL EXEC(3,MTLU+1300B) 
C 
 50   SFLAG=1 
      IF(FILEN .EQ. 0)FILEN = FILEN + 1 
      FILEN = FILEN + 1 
51    IF(IRCNT .GT. 0)GO TO 30
      IF(ILOG .GT. 0)GO TO 90 
      GO TO 15
C 
C  END:   REWIND TAPE OFF LINE
C 
90    IF(RWIND)CALL EXEC(3,MTLU+500B) 
      CALL EXEC(2,ILU,MESS9,12) 
C 
99    END 
      SUBROUTINE ASCII(BINARY,IA),CHECK FOR LEGAL ASCII 790720
C 
C     THIS ROUTINE PERFORMS TWO(2) FUNCTIONS: 
C 
C     1. CHECK THE CONTENTS OF A WORD TO ENSURE BOTH BYTES
C        ARE UPPER CASE PRINTING ASCII, IF EITHER BYTE FAILS
C        TWO ASCII BLANKS (20040B) WILL BE SENT BACK TO THE 
C        CALLER.  THIS MODE IS INVOKED BY SETTING THE SECOND
C        PARAMETER TO -1 WHEN CALLED. 
C 
C     2. GIVEN A BINARY VALUE. CHECK FOR UPPER AND LOWER CASE 
C        PRINTING ASCII, IF NOT, SET THE OFFENDING BYTE TO AN 
C        ASCII BLANK. 
C 
      INTEGER BINARY,RBYTE
      RBYTE = IAND(BINARY,377B) 
      LBYTE = IAND(BINARY,77400B) 
      IF(IA .NE. -1)GO TO 10
      IF(RBYTE .LT. 40B .OR. RBYTE .GT. 137B)GO TO 5
      IF(LBYTE .LE. 20000B .OR. LBYTE .GE. 60000B)GO TO 5 
      IA = BINARY 
      RETURN
5     IA = 20040B 
      RETURN
10    IF(RBYTE.LT.40B.OR.RBYTE.GT.176B)RBYTE = 40B
      IF(LBYTE.LT.20000B)LBYTE = 20000B 
      IF(LBYTE.GE. 77400B)LBYTE = 20000B
      IA = IOR(LBYTE,RBYTE) 
      RETURN
      END 
      SUBROUTINE JVRFY(IBUFF,LUCRT,LUDISK,LUMT,IDELT) 
     +,24999-16163 REV.1932  790810 
C 
C     THIS SUBROUTINE IS DESIGNED TO COMPARE THE CONTENTS OF
C     A MAG TAPE FILE AGAINST THE CONTENTS OF A DISK TRACK. 
C     THE MAG TAPE FORMAT SHOULD BE:
C                   6145 OR 8193 WORDS LONG 
C                   WHERE WORD #1 IS THE TRACK #. 
C                   TERMINATION WILL OCCUR UPON READING EOF.
C     THE MAG TAPE MUST BE POSITIONED TO THE FIRST DISC IMAGE RECORD
C     BEFORE SCHEDULING THIS SUBROUTINE.
C 
C     FORM OF CALL: 
C                   CALL JVRFY(IBUFF,LUCRT,LUDISK,LUMT,IDELT) 
C 
C     WHERE:
C                   LUCRT - LU WHERE MESSAGES WILL BE SENT
C 
C                   LUDISK - LU # OF THE DISK SUBCHANNEL
C                   TO BE VERIFIED. 
C 
C                   LUMT - LU # OF THE MAG TAPE.
C 
C                   IDELT = OFFSET BETWEEN THE OLD DIRECTORY AND A
C                           THE NEW DIRECTORY IF IT HAS BEEN MOVED
C 
C     IPBUF(1) = 0 - COMPARE GOOD.
C     IPBUF(2) = # OF MAG TAPE RECORDS TESTED.
C 
C     IPBUF(1) = -1 MAG TAPE COMPARE ERROR
C     IPBUF(2) = MAG TAPE RECORD NUMBER 
C     IPBUF(3) = TRACK #
C     IPBUF(4) = SECTR #
C     IPBUF(5) = WORD OFFSET
C 
C     IPBUF(1) = -2 - MAG TAPE STATUS ERROR 
C     IPBUF(2) = MAG TAPE RECORD NUMBER 
C     IPBUF(3) = EQT #5 STATUS INFO 
C 
C     IPBUF(1) = -3 - MAG TAPE RECORD LENGTH ERROR
C     IPBUF(2) = MAG TAPE RECORD NUMBER 
C     IPBUF(3) = LENGTH OF MAG TAPE RECORD. 
C 
C     IPBUF(1) = -4 - DISK READ ERROR.
C     IPBUF(2) = MAG TAPE RECORD NUMBER 
C     IPBUF(3) = EQT #5 STATUS INFO.
C 
      DIMENSION IBUFF(1),IPBUF(5),LENB(7),ISCTRS(7),IREG(2) 
      DIMENSION LENC(7) 
C 
      DIMENSION JVM10(28),JVM20(31),JVM30(28),JVM40(46),JVM50(18) 
C 
      EQUIVALENCE (REG,IREG),(IREG(2),IBREG)
C 
      EQUIVALENCE (IPBUF(1),IPBUF1),(IPBUF(2),IPBUF2),(IPBUF(3),IPBUF3),
     +            (IPBUF(4),IPBUF4),(IPBUF(5),IPBUF5) 
C 
      EQUIVALENCE (JVM10(18),JVM118),(JVM10(26),JVM126) 
      EQUIVALENCE (JVM20(21),JVM221),(JVM20(29),JVM229) 
      EQUIVALENCE (JVM30(18),JVM318),(JVM30(26),JVM326) 
      EQUIVALENCE (JVM40(17),JVM417),(JVM40(29),JVM429),
     +            (JVM40(37),JVM437),(JVM40(44),JVM444) 
      EQUIVALENCE (JVM50(12),JVM512)
C 
      DATA JVM10/2H /,2HJS,2HAV,2HE:,2H D,2HIS,2HK ,2HRE,2HAD,2H E,2HRR,
     &           2HOR,2H -,2H S,2HTA,2HTU,2HS ,3*2H  ,2H R,2HEC,2HOR, 
     &           2HD ,2H# ,3*2H  /
C 
      DATA JVM20/2H /,2HJS,2HAV,2HE:,2H M,2HT ,2HRE,2HCO,2HRD,2H L,2HEN,
     &           2HGT,2HH ,2HER,2HRO,2HR ,2H- ,2HLE,2HNG,2HTH,3*2H  , 
     &           2H R,2HEC,2HOR,2HD ,2H# ,3*2H  / 
C 
      DATA JVM30/2H /,2HJS,2HAV,2HE:,2H M,2HT ,2HST,2HAT,2HUS,2H E,2HRR,
     &           2HOR,2H -,2H S,2HTA,2HTU,2HS ,3*2H  ,2H R,2HEC,2HOR, 
     &           2HD ,2H# ,3*2H  /
C 
      DATA JVM40/2H /,2HJS,2HAV,2HE:,2H C,2HOM,2HPA,2HRE,2H E,2HRR,2HOR,
     &           2H R,2HEC,2HOR,2HD ,2H# ,3*2H  ,6412B, 
     &           2H /,2HJS,2HAV,2HE:,2H T,2HRA,2HCK,2H #,3*2H  ,2H S, 
     &           2HEC,2HTO,2HR ,2H# ,3*2H  ,2H O,2HFF,2HSE,2HT ,3*2H  / 
C 
      DATA JVM50/2H /,2HJS,2HAV,2HE:,2H C,2HOM,2HPA,2HRE,2H G,2HOO,2HD.,
     &           3*2H  ,2H R,2HEC,2HOR,2HDS/
C 
      DATA LENB/128,256,512,1024,2048,2176,2048/
      DATA LENC/129,257,513,1025,2049,4097,6273/
      DATA ISCTRS/0,2,6,14,30,62,96/
C 
C 
      ICOUNT = 0
C 
C     GET A MAG TAPE RECORD AND TEST FOR EOF
C 
10    IF(IFBRK(IDMY) .LT. 0) GO TO 100
      REG=EXEC(1,LUMT,IBUFF(128),8193)
C 
C  IF FIRST TIME THROGH SET VALUES
C     (IBUFF(136) == WORD 7 OF DIRECTORY [LOWEST DIRECTORY TRACK])
C     (IBUFF(138) == WORD 9 OF DIRECTORY [NEXT AVAILABLE TRACK])
C 
      IF(ICOUNT .GT. 0)GO TO 15 
      LODIR = IBUFF(136)
      IBUFF(136) = IBUFF(136) + IDELT 
      IF(IBUFF(138) .GT. IBUFF(136))IBUFF(138) = IBUFF(136) 
C 
C     FINISHED IF EOF FOUND 
C 
15    IF(IAND(IREG,200B) .NE. 0) GO TO 100
C 
C     ANY OTHER STATUS EXCEPT NO WRITE RING IS AN ABORT CONDITION.
C 
      IF(IAND(IREG,373B) .NE. 0) GO TO 200
C 
C     RECORD LENGTH MUST BE 6145 OR 8193
C 
      IF(IBREG .NE. 6145) GO TO 20
      ITMS = 6
      GO TO 40
20    IF(IBREG .NE. 8193) GO TO 300 
      ITMS = 7
C 
C     TRACK # IS IN FIRST WORD. 
C 
40    ITRK = IBUFF(128) 
      IF(ITRK .GE. LODIR)ITRK = ITRK + IDELT
       ICOUNT = ICOUNT + 1
      IF(ITRK .LT. LODIR .AND. ITRAK .GE. (LODIR+IDELT))GO TO 10
C 
C     NOW GET AND TEST THE CONTENTS OF ONE TRACK (6 READS)
C 
      DO 50 I=1,ITMS
      LENGTH = LENB(I)
      INDEX = LENC(I) 
C 
      REG = EXEC(1,LUDISK,IBUFF,LENGTH,ITRK,ISCTRS(I))
C 
      IF(IAND(IREG,1) .NE. 0) GO TO 400 
C 
      CALL CMPWD(IBUFF,IBUFF(INDEX),LENGTH,IERR)
      IF(IERR .NE. 0) GO TO 500 
C 
50    CONTINUE
      GO TO 10
C 
C     GOOD COMPLETION 
C 
100   IPBUF1 = 0
      GO TO 1000
C 
C     MAG TAPE STATUS ERROR.
C 
200   IPBUF1 = -2 
      IPBUF3 = IREG 
      GO TO 1000
C 
C     MAG TAPE RECORD LENGTH ERROR. 
C 
300   IPBUF1 = -3 
      IPBUF3 = IBREG
      GO TO 1000
C 
C     DISK READ ERROR.
C 
400   IPBUF1 = -4 
      IPBUF3 = IREG 
      GO TO 1000
C 
C     COMPARE ERROR.
C 
500   IPBUF1 = -1 
      IPBUF3 = ITRK 
      IPBUF4 = ISCTRS(I) + IERR/64
      IPBUF5 = MOD(IERR,64) 
C 
C     FINISHED. 
C 
C     WRITE A MESG IF LUCRT IS GIVEN
C 
1000  IPBUF2 = ICOUNT 
C 
      IGO = IPBUF1 + 5
      GO TO (1010,1020,1030,1040,1050),IGO
C 
1010  CALL CNUMO(IPBUF3,JVM118) 
      CALL CNUMD(IPBUF2,JVM126) 
      CALL EXEC(2,LUCRT,JVM10,28) 
C011  FORMAT(" /JVRFY: DISK READ ERROR - STATUS ",K6," RECORD #",I4)
      GO TO 2000
C 
1020  CALL CNUMD(IPBUF3,JVM221) 
      CALL CNUMD(IPBUF2,JVM229) 
      CALL EXEC(2,LUCRT,JVM20,31) 
C021  FORMAT(" /JVRFY: MT RECORD LENGTH ERROR - LENGTH ", 
C    +       I5," RECORD #",I4) 
      GO TO 2000
C 
1030  CALL CNUMO(IPBUF3,JVM318) 
      CALL CNUMD(IPBUF2,JVM326) 
      CALL EXEC(2,LUCRT,JVM30,28) 
C031  FORMAT(" /JVRFY: MT STATUS ERROR - STATUS ",K6," RECORD #",I4)
      GO TO 2000
C 
C 
1040  CALL CNUMD(IPBUF2,JVM417) 
      CALL CNUMD(IPBUF3,JVM429) 
      CALL CNUMD(IPBUF4,JVM437) 
      CALL CNUMD(IPBUF5,JVM444) 
      CALL EXEC(2,LUCRT,JVM40,46) 
C041  FORMAT(" /JVRFY: COMPARE ERROR RECORD #",I4/, 
C    +       " /JVRFY: TRACK #",I4," SECTOR #",I4," OFFSET",I4) 
      GO TO 2000
C 
1050  CALL CNUMD(IPBUF2,JVM512) 
      CALL EXEC(2,LUCRT,JVM50,18) 
C051  FORMAT(" /JVRFY: COMPARE GOOD. ",I4," RECORDS") 
C 
2000  IBUFF = IPBUF1
      RETURN
      END 
      END$
ASMB,R,L,C,Z
      IFN 
      HED WORD COMPARE FOR 2100 & EARLIER CPU 
      NAM CMPWD,7 WORD COMPARE FOR 2100 & EARLIER CPU 6/10/77 
      XIF 
      IFZ 
      HED WORD COMPARE FOR 21MX & LATER CPU 
      NAM CMPWD,7 WORD COMPARE FOR 21MX & LATER CPU 6/10/77 
      XIF 
      ENT CMPWD 
      EXT .ENTR 
      SKP 
*     THIS PROGRAM WILL COMPARE THE CONTENTS OF TWO BUFFERS 
*      AND RETURN:
*                   IERR = 0  -  GOOD COMPARE 
*                   IERR = +N -  ERROR DETECTED.
*     WHERE N = BUFFER INDEX OF FAILED COMPARISON.
* 
*     THIS PROGRAM WILL RETURN AFTER ENCOUNTERING THE FIRST 
*     COMPARE FAILURE.
* 
*     THIS PROGRAM IS FORTRAN CALLABLE AS FOLLOWS:
*     CALL CMPWD(BUF1,BUF2,LENGTH,IERR) 
*            - OR - 
*     REG = CMPWD(BUF1,BUF2,LENGTH,IERR)
*     WHERE IERR IS RETURNED IN THE 'A' REGISTER. 
* 
*     CONDITIONAL ASSEMBLY REQUIRED FOR COMPUTER TYPE:
*                   N FOR 2100 OR EARLIER MODELS
*                   Z FOR 21MX OR LATER MODELS
* 
*     MCC 6/10/77 
* 
      SKP 
BUFF1 NOP 
BUFF2 NOP 
LENTH NOP 
IERR  NOP 
CMPWD NOP 
      SPC 1 
      JSB .ENTR 
      DEF BUFF1 
      SPC 1 
      IFN 
      LDA LENTH,I    GET THE BUFFER LENGTH
      CMA,INA       COMPLEMENT AND SAVE IT
      STA COUNT 
      SPC 1 
LOOP  LDA BUFF1,I   GET FIRST WORD
      XOR BUFF2,I   XOR WITH SECOND 
      SZA           OK IF ZERO RESULTS. 
      JMP ERROR     NO - ERROR. 
      SPC 1 
      ISZ COUNT     YES - FINISHED IF COUNT = 0 
      JMP INCR
      SPC 1 
      JMP OUT         FINISHED
      SPC 1 
INCR  ISZ BUFF1     INCREMENT BOTH BUFFER ADDRESSES 
      ISZ BUFF2 
      JMP LOOP      GO TEST THE NEXT TWO. 
      SPC 1 
ERROR ISZ COUNT     SET UP THE
      LDA LENTH,I   ERROR COUNT 
      ADA COUNT     FOR RETURN
      JMP BAD       THEN RETURN 
      SKP 
      XIF 
      IFZ 
      LDA BUFF1     GET THE TWO ADDRESSES IN 'A' & 'B'
      LDB BUFF2 
      CMW LENTH,I   GO TEST THESE ARRAYS
      JMP OUT       GOOD RETURN HERE. 
      SPC 1 
      NOP           ERROR RETURN HERE 
      LDB BUFF1     GET THE START ADDRESS 
      CMB,INB       AND SUBTRACT FROM 
      ADA B         PRESENT ADDRESS FOUND IN 'B'
      INA 
      JMP BAD       RETURN THE ERROR INDEX
      XIF 
      SKP 
OUT   CLA           GOOD RETURN HERE. 
      SPC 1 
BAD   STA IERR,I
      JMP CMPWD,I 
      SKP 
COUNT NOP 
A     EQU 0 
B     EQU 1 
      END 
*   1430 HRS   THU  24 MAY 79 
      NAM QUOTE,7 QUOTE STRING SUBROUTINE FOR JSAVE  790524 
      ENT QUOTE,EQCOL 
      EXT .ENTR,.SFB,.MBT 
* 
*     CALLING SEQUENCE: 
* 
*       CALL QUOTE(IBUF,QBUF,QLEN)
* 
*     WHERE : 
*                   IBUF = ASCII BUFFER TO CHECK FOR " . . . "
*                   QBUF = BUFFER TO CONTAIN " . . . "
*                   QLEN = LENGTH OF " . . . " BUFFER 
*                          ( 0 IF NOT FOUND)
* 
*     NOTE:  IBUF SHOULD CONTAIN TWO(2) QUOTE MARKS(") IN THE BUFFER
*            OR SHOULD BE INITIALIZED WITH NULLS(OCT 0). THIS IS
*            TO PREVENT POSSIBLE ERRORS DUE TO MEMORY SCAN RUNAWAY. 
*            (THE 'SFB' INSTRUCTION STOPS ONLY ON THE TEST BYTE OR
*             A TERMINATE BYTE.(WHICH IS NULL(0) IN THIS SUBROUTINE)
* 
*            QUOTE USES TWO(2) MX INSTRUCTIONS WHICH ARE: 
*             1) SFB   SCAN FOR BYTE
*             2) MBT   MOVE BYTE
* 
IBUF  NOP           STRING BUFFER 
QBUF  NOP            QUOTE BUFFER(" . . " RETURNED HERE)
QLEN  NOP             QUOTE BUFFER LENGTH 
QUOTE NOP           ENTRY POINT 
      JSB .ENTR 
      DEF IBUF
      CLA           SET ERROR RETURN FLAG 
      STA QLEN,I
      LDA ."        GET TERMINATOR/TEST BYTE
      LDB IBUF       AND ADDRESS OF SOURCE BUFFER 
      RBL           FORM BYTE ADDRESS 
      JSB .SFB      START LOOKING FOR ' " ' 
      RSS             FOUND IT !!!
      JMP QUOTE,I   WE HAVE AN ERROR, GET OUT 
      INB           BUMP BUF. ADD. PAST THE " 
      STB FBAD      SAVE BUF. ADD. LOCALLY
      JSB .SFB      START SCAN FOR 2ND. BYTE
      RSS           FOUND 
      JMP QUOTE,I   NOT FOUND, GET OUT !!!
      ELB,CLE,ERB   KILL HIGH BIT FOR ADDITION
      LDA FBAD      START TO CALCULATE
      ELA,CLE,ERA   DO SAME FOR LOW ADDRESS 
      CMA,INA        THE LENGTH 
      ADB A            OF THE QUOTE 
      STB QLEN,I    TELL USER TOO 
      LDA FBAD      NOW SET UP FOR MOVE BYTE
      LDB QBUF      GET DESTINATION ADDRESS 
      RBL           SET TO BYTE ADDRESS 
      JSB .MBT        MOVE THE QUOTE TO USER
      DEF QLEN,I
      NOP 
      JMP QUOTE,I    AND RETURN 
* 
A     EQU 0 
* 
."    OCT 42
FBAD  NOP           ADDRESS OF 1ST BYTE IN QUOTE
      SPC 3 
* 
*      THIS SUBROUTINE, GIVEN AN ADDRESS AND LENGTH OF A BUFFER,
*  WILL CHECK FOR IMBEDDED EQUALS(=) AND REPLACE THEM WITH COLONS(:)
*  FOR THE NAMR LIBRARY ROUTINE.
* 
*     THE BUFFER CAN BE ANY LENGTH AND SHOULD SPECIFY 
*  THE NUMBER OF CHARACTERS IN THE BUFFER.
* 
BUFAD NOP           BUFFER ADDRESS
BUFLA NOP           BUFFER LENGTH 
EQCOL NOP           WHERE IT ALL BEGINS 
      JSB .ENTR     GO GET THE ADDRESSES
      DEF BUFAD       OF THE PARAMATERS 
      LDA BUFLA,I   HOW ABOUT THE LENGTH? 
      CLE,ERA       IS IT AN ODD CHARACTER COUNT? 
      SEZ           NO,  ITS ALL READY TO GO
      INA           YES, INCREASE THE WORD COUNT BY ONE 
      CMA,INA       LET'S MAKE IT NEG. FOR COUNTING 
      STA BUFL      AND SAVE IT 
      SZA,RSS       IS IT A ZERO LENGTH BUFFER? 
      JMP EQCOL,I   WELL GET THE HECK OUT OF HERE THEN. 
START LDA BUFAD,I   ORIGINAL NAME HUH ? 
      STA TEMP      LET'S GET A WORD AND GET ON WITH IT 
      AND M177        HOW ABOUT THE LOW BYTE? 
      CPA LO=           AN ='S ?
      JMP LFIX      YES, GO MAKE IT A COLON 
PAR1  LDA TEMP      NO, PREPARE TO CONTINUE 
      AND M774      THIS TIME LOOK AT THE HI BYTE 
      CPA HI=       AN ='S ?
      JMP HFIX      YES, GO MAKE IT A COLON 
      JMP TERM1     NO, LETS SAVE WHAT WE HAVE AND GO ON
LFIX  LDA TEMP      GET ORIGINAL WORD 
      ADA M3        MAKE THAT = A COLON 
      STA TEMP        AND SAVE
      JMP PAR1+1    GO CHECK HI BYTE
HFIX  LDA TEMP      GET PRESENT VALUE 
      ADA M1400     MAKE THE HI BYTE = A COLON
      RSS              AND SAVE IN ORIGINAL BUFFER
TERM1 LDA TEMP      LETS GET THE CURRENT VALUE
      STA BUFAD,I     AND SAVE IN ORIGINAL BUFFER 
      ISZ BUFAD     INCREMENT THE BUFFER ADDRESS
      ISZ BUFL      ANY MORE WORDS? 
      JMP START     YES, HERE WE GO AGIAN 
      JMP EQCOL,I   NOPE, LETS GET OUT!!
      SPC 1 
*     CONSTANTS AND STORAGE 
* 
BUFL  NOP 
TEMP  NOP 
M177  OCT 177 
M774  OCT 77400 
LO=   OCT 75
HI=   OCT 36400 
M3    OCT -3
M1400 OCT -1400 
      END 
ASMB,R,L,Q
      NAM MXLIB,0 ("MX" INSTRUCTION SET--SIMULATED) 6/78 DGA
      ENT .MBT,.CBT,.SFB,.SBL,.SBT,.LBT,IDRCT 
      SPC 3 
*   NAME    SIZE(10)    ENTRIES               EXTERNALS 
* 
*   !1MBT     25       .MBT                     IDRCT,.LBT,.SBT 
* 
*   !1CBT     41       .CBT                     IDRCT,.LBT
* 
*   !1SFB     25       .SFB                    .LBT 
* 
*   !1SBL     14       .SBL                    .LBT 
* 
*   !1SBT     23       .SBT 
* 
*   !1LBT     11       .LBT 
* 
*   !1DRK     17        IDRCT 
* 
* 
* 
FROM  NOP 
LCNT  NOP 
* 
AREG  EQU 0 
BREG  EQU 1 
* 
      HED SIMULATION OF "MOVE BYTES" 21MX INSTRUCTION 
      SPC 2 
*   CALL SEQUENCE:
*     <LDA SOURC>         A-REG. TO CONTAIN SOURCE ADDRESS
*     <LDB DESTN>         B-REG. TO CONTAIN SOURCE ADDRESS
*     JSB .MBT           CALL SUB. OR OCT 105765
*     DEF CNT(,I)        ADDRESS OF # OF BYTES TO MOVE
*     NOP                RESERVED FOR MICROCODE 
*     <RETURN>             BOTH A & B INCREMENTED BY CNT
* 
* 
.MBT  NOP 
      STA FROM           SOURCE BYTE ADDRESS
      STB TO             DESTINATION BYTE ADDRESS 
* 
      LDA .MBT,I
      JSB IDRCT          TRACK DOWN INDIRECTS 
      LDA AREG,I         PICK UP ACTUAL BYTE COUNT
      CMA,INA 
      STA BCNT           USE AS LOOP COUNTER
* 
      SZA,RSS       COUNT = 0?
      JMP EXIT2     YES, DO NOTHING 
* 
LOOP2 LDB FROM
      JSB .LBT           TAKE A BYTE
      STB FROM           BYTE ADDRESS INCREMENTED BY LBT
* 
      LDB TO
      JSB .SBT           PUT IT HERE
      STB TO             PREPARE FOR NEXT BYTE, IF ANY. 
* 
      ISZ BCNT           MOVE ENOUGH? 
      JMP LOOP2          NOPE 
* 
      LDA FROM           NEXT BYTE IN SOURCE ARRAY
EXIT2 ISZ .MBT
      ISZ .MBT      SET UP RETURN ADDRESS 
      JMP .MBT,I          B-REG. ALREADY CORRECT. 
* 
TO    NOP 
BCNT  NOP 
* 
      SPC 2 
*   CALLING SEQUENCE: 
*    <LDA ARAY1>        A-REG. TO CONTAIN STRING 1 ADDRESS
*    <LDB ARAY2>        B-REG. TO CONTAIN STRING 2 ADDRESS
*     JSB .CBT           SUB. CALL OR OCT 105766
*     DEF CNT(,I)        ADDRESS OF BYTE COUNT
*     NOP                RESERVED FOR MICROCODE 
*     JMP EQUAL          THE BYTE STRINGS WERE EQUAL
*     JMP LESS           STRING 1 LESS THAN STRING 2
*     JMP MORE           STRING 1 MORE THAN STRING 2
* 
*   RESULTS:
*     ON ALL RETURNS B-REG. CONTAINS ORIGINAL VALUE 
*     INCREMENTED BY "CNT". 
*     ON EQUAL RETURN A-REG. HAS ALSO BEEN INCREMENTED
*     BY "CNT". 
*     ON UNEQUAL RETURNS A-REG. CONTAINS STRING 1 
*     ADDRESS WHERE INEQUALITY FOUND. 
* 
.CBT  NOP 
      STA ARAY1 
      STB ARAY2 
* 
      LDA .CBT,I
      JSB IDRCT 
      LDA AREG,I         GET ACTUAL BYTE COUNT
* 
      ADB AREG
      STB BSAVE          B-REG.'S RETURN VALUE
* 
      CMA,INA 
      STA BCNT          SET UP LOOP COUNTER 
      SZA,RSS       COUNT = 0?
      JMP NEQL1+1   YES, TAKE EQUAL EXIT! 
* 
      ISZ .CBT
      ISZ .CBT           SET UP FOR EQUAL RETURN
* 
LOOP3 LDB ARAY1 
      JSB .LBT           TAKE A BYTE FROM STRING 1
      STB ARAY1          SAVE INCREMENTED BYTE ADDRESS
      STA BYTE1 
* 
      LDB ARAY2 
      JSB .LBT
      STB ARAY2 
      CMA,INA 
      ADA BYTE1          STRING 1 MINUS STRING 2
* 
      SZA                EQUAL? 
      JMP NEQL1          NO ! 
      ISZ BCNT           EXAMINED ALL BYTES?
      JMP LOOP3          NO 
* 
      LDA ARAY1          "A" SET TO ORIGINAL + CNT
      JMP .CBT,I          "B" ALREADY CORRECT, EQUAL
*                        RETURN ! 
* 
NEQL1 SSA,RSS            STRING 1 LARGEST?
      ISZ .CBT           YES, SKIP TWO WORDS
      ISZ .CBT           ELSE SKIP ONE
* 
      CCA 
      ADA ARAY1          STRING 1 ADDRESS AT NON-MATCH
      LDB BSAVE          STRING 2 ADDRESS + CNT 
      JMP .CBT,I
* 
ARAY1 NOP 
ARAY2 NOP 
BYTE1 NOP 
ATEMP NOP 
BTEMP NOP 
AWORK NOP 
BSAVE NOP 
* 
      HED SIMULATION OF "SCAN FOR BYTE" 21MX INSTRUCTION
* 
*   CALLING SEQUENCE: 
*     <LDA BYTES>     A-REG. TO CONTAIN TERMINATION BYTE AND TEST BYTE
*     <LDB STRING>    B-REG. TO CONTAIN ADDRESS OF FIRST BYTE 
*      JSB .SFB       CALL SUB. OR OCT 105767 
*     <JMP TEST>      EXIT IF BYTE FOUND TO MATCH TEST BYTE 
*     <JMP TERM>      EXIT IF BYTE FOUND TO MATCH TERMINATION BYTE
* 
.SFB  NOP 
      STA ATEMP 
      AND BMASK     ISOLATE TEST BYTE 
      STA TEST
* 
      LDA ATEMP 
      ALF,ALF 
      AND BMASK     ISOLATE TERMINATION BYTE
      STA TERM
* 
LOOP4 JSB .LBT      FETCH A BYTE
      CPA TEST      EQUAL TEST BYTE?
      JMP T.OUT     YES 
* 
      CPA TERM      EQUALS TERMINATION BYTE?
      JMP DONE      YES 
      JMP LOOP4     NOPE, LOOK SOME MORE
* 
DONE  ISZ .SFB      RETURN TO P + 2 
      LDA ATEMP     RESTORE A-REG.
      JMP .SFB,I
* 
T.OUT ADB M.1       DECREMENT B 
      LDA ATEMP 
      JMP .SFB,I     RETURN TO P + 1
* 
TEST  NOP 
TERM  NOP 
BMASK OCT 377 
M.1   DEC -1
* 
      HED "SCAN BYTES LEFT" SUBROUTINE
* 
*   CALLING SEQUENCE: 
* 
*       LDA FILL     CHARACTER TO REMOVE
*       LDB BYTAD   BYTE ADDRESS TO START 
*       JSB .SBL
*      <RETURN>       B-REG. CONTAINS ADDRESS 
*                     OF FIRST OPEN BYTE
* 
*   PURPOSE:
*       USED TO REMOVE TRAILING BLANKS. 
* 
* 
.SBL  NOP 
      AND M377      ISOLATE BYTE TO REMOVE
      STA SAVE
      ADB M1        DECREMENT BYTE ADDRESS
* 
SLOOP JSB .LBT      FETCH IT
      CPA SAVE      REMOVE THIS ONE?
      RSS           YES 
      JMP .SBL,I     NO, DONE!
* 
      ADB M2        LBT INCREMENTS B, 
      JMP SLOOP     THEREFORE, GO BACK 2
* 
SAVE  NOP 
M1    DEC -1
M2    DEC -2
M377  OCT 377 
* 
      HED SIMULATION OF "STORE BYTE" 21MX INSTRUCTION 
      SPC 2 
*   CALLING SEQUENCE: 
*    <LDA BYTE>        A-REG. TO CONTAIN BYTE TO BE STORED
*    <LDB BADRS>       B-REG. TO CONTAIN BYTE ADDRESS 
*     JSB .SBT         CALL SUB. OR OCT 105764
*    <RETURN>          B-REG INCREMENTED BY ONE 
* 
.SBT  NOP 
      STA ATEMP 
      AND MASK      ISOLATE BYTE OF INTEREST
      ALF,ALF 
      STA AWORK     SAVE IT IN LEFT BYTE
* 
      STB BTEMP 
      CLE,ERB       CONVERT TO WORD ADDRESS,
      LDA BREG,I    "E" = B 
      SEZ           0 = STORE IN LEFT BYTE, THEREFORE SAVE RIGHT BYTE 
      ALF,ALF       SWAP BYTES
      AND MASK      ISOLATE BYTE TO SAVE
      IOR AWORK     MERGE BYTES 
      SEZ           WORD IN PROPER POSITION?
      ALF,ALF       NO, SWAP IT BACK
      STA BREG,I    REPLACE IN MEMORY 
* 
      LDA ATEMP     RESTORE A-REG.
      LDB BTEMP     RESTORE B-REG.
      INB           POINT TO NEXT BYTE
      JMP .SBT,I
* 
MASK  OCT 377 
* 
      HED SIMULATION OF "LOAD BYTE" 21MX INSTRUCTION
      SPC 2 
*   CALLING SEQUENCE: 
*    <LDB BYTAD>       B-REG. TO CONTAIN BYTE ADDRESS 
C     JSB .LBT         CALL SUB. OR OCT 105763
*    <RETURN>          BYTE REQUESTED IN RIGHT HALF OF A-REG. 
*                      B-REG. INCREMENTED BY ONE
* 
.LBT  NOP 
      CLE,ERB       PRODUCE WORD ADDRESS, BYTE FLAG IN "E"
      LDA BREG,I    GET WORD
      SEZ,RSS       0 INDICATES LEFT BYTE 
      ALF,ALF       SWAP BYTES
      AND MASK      ISOLATE BYTE OF INTEREST
* 
      ELB           RESTORE "B" 
      INB           POINT TO NEXT BYTE
      JMP .LBT,I
* 
* 
      SPC 2 
* 
      HED INDIRECT TRACKING SUBROUTINE
      SPC 2 
*    CALLING SEQUENCE:
*       <LDA MEMRY[,I]>    LOC. CONTAINING AN ADDRESS 
*        JSB IDRCT
*       <RETURN>           A-REG. HAS DIRECT ADDRESS
* 
*    RESULTS: 
*       "B","E", AND "O" UNAFFECTED.
* 
IDRCT NOP 
      STA ATEMP 
      CLA 
      ELA 
      STA AWORK    SAVE "E" 
* 
      LDA ATEMP     PICK UP START OF CHAIN
      RSS 
      LDA AREG,I   GO ONE MORE LEVEL
      RAL,CLE,SLA,ERA   TEST AND TURN OFF BIT 15
      JMP *-2           PLAY IT AGAIN SAM!
* 
      STA ATEMP    NOW HAVE DIRECT ADDRESS
      LDA AWORK 
      ERA         RESTORE "E" 
      LDA ATEMP 
      JMP IDRCT,I 
* 
* 
      END 
      END$
                                                                                                                                                                                      