FTN4,L
      PROGRAM LMOD(3,89), 24999-16296 REV.2024 79.11.01 
      IMPLICIT INTEGER (A-Z)
      COMMON/TERM/LU,LIST 
      COMMON/INPUT/LENG,INPUT(40) 
      COMMON/SNDAT/NENTS,NLIBS,LWABG,FWABG,FWART, 
     .            SYBP,BGBP,RTBP,FWAC,LCOM,SYSID,CKSUM
      COMMON/SNAP/SNAP(9),SNERR,DCBSN(144),RECSN(128) 
      COMMON/SYSTM/SYSTM(9),SYERR,DCBSY(144),RECSY(128) 
      COMMON/RTE/SYTYPE 
  
      LOGICAL NAMR,PARM,SKIP,FMPER,NEWFIL,QUIT,FOPEN
      REAL STATUS,STRNG,GETEM,REIO
  
      DIMENSION ABREG (2) 
  
      EQUIVALENCE (ABREG(1),RESULT),  (ABREG,STATUS), 
     .            (ABREG(2),SIZE) 
  
      DATA LEN/40/,    POS/1/,      EMPTY/1/,   ECHO/400B/, 
     .     RD/1/,      WR/2/,       HONEST/2000B/,
     .     EXCLS/0/,   EOF/-1/,     SPACE/40B/
  
C  FUNCTION STATEMENTS
  
      PARM (BUF,POS) = .NOT. (NAMR(BUF,INPUT,SIZE,POS)) 
      STRNG (BUF,LN) =  EXEC (14,1,BUF,LN)
      GETEM (BUF,LN) =  REIO (RD,LU+ECHO,BUF,LN)
  
C  START OF PROGRAM. GET TERMINAL LOGICAL UNIT. THEN GET
C                    RUN STRING. IF EMPTY, REQUEST FROM TERMINAL
  
      LU = LOGLU (DUMMY)
      LIST = LU 
C SYTPE CONTAINS $OPSY.  ADJUST FOR PROPER FUDGE FACTOR TO
C     MAKE EXEC READ/WRITE TO DISC DRIVER.
      TYPE = IGET (SYTYPE)
      SYTYPE = 177400B
      IF (TYPE.EQ.-31) SYTYPE = 7700B 
      STATUS = STRNG (INPUT,-2*LEN) 
      CALL EXEC (2,LU,40H RTE-L MEMORY/DISC UTILITY VERS 79.11.01,-40)
      CALL EXEC (2,LU,17H TYPE ?? FOR HELP,-17) 
C  MOVE POS PAST FIRST TWO COMMAS (:RU,PROG,<PARAMETER LIST>) 
  
      SKIP = PARM (SNAP,POS)
      SKIP = PARM (SNAP,POS)
C                           ABOVE TWO STATEMENTS OMITTED FOR RTE-M
  
      IF (RESULT .NE. EMPTY) GO TO 20 
  
10    POS = 1 
      CALL EXEC (WR,LU+HONEST,26H  SNAP FILE,  SYSTEM FILE:,-26)
      STATUS = GETEM (INPUT,-2*LEN) 
  
C   GET 1ST TWO PARAMETERS FROM RUN STRING OR FROM TERMINAL LU. 
C   IF OK, PROCEED. EITHER NAMR MAY BE A DEVICE RATHER A FILE.
  
20    IF (.NOT.(PARM(SNAP,POS)) .OR. .NOT.(PARM(SYSTM,POS))) GO TO 10 
  
      NEWFIL = FOPEN (SNAP) 
         IF (.NOT. NEWFIL) GO TO 99 
         LENGTH = FREAD (SNAP,1)
         IF (LENGTH .NE. 12) GO TO 99 
         CALL MOVE (RECSN,NENTS,12) 
  
      NEWFIL = FOPEN (SYSTM)
         IF (.NOT. NEWFIL) GO TO 99 
  
C     REPEAT
  
50    CONTINUE
  
         CALL EXEC (WR,LU+HONEST,2H>>,1)
         STATUS = GETEM (INPUT,-2*LEN)
         LENG = SIZE
         CALL CMDLN (INPUT,SIZE,QUIT) 
  
C     UNTIL QUIT
  
      IF (.NOT.QUIT) GO TO 50 
  
99    CALL CLOSE (DCBSN)
      CALL CLOSE (DCBSY)
      END 
      BLOCK DATA
      IMPLICIT INTEGER (A-Z)
      LOGICAL REL,DECML 
      COMMON/TERM/LU,LIST 
      COMMON/INPUT/LENG,INPUT(40) 
      COMMON/RBUF/RBUF(33)
      COMMON/NSECTS/NSECTS
      COMMON/BASE/BASE,REL,DECML,MODE 
      COMMON/SNDAT/NENTS,NLIBS,LWABG,FWABG,FWART, 
     .            SYBP,BGBP,RTBP,FWAC,LCOM,SYSID,CKSUM
      COMMON/SNAP/SNAP(9),SNERR,DCBSN(144),RECSN(128) 
      COMMON/SYSTM/SYSTM(9),SYERR,DCBSY(144),RECSY(128) 
      COMMON/IO/INPT,OUTP,NAME(3),SC,CART 
      DATA REL/.FALSE./ 
      DATA DECML/.FALSE./ 
      DATA BASE/0/
      DATA MODE/0/
      DATA LU/1/
      DATA SC/0/,CART/0/
      DATA NSECTS/96/ 
      DATA INPT/2HME/,OUTP/2HME/
      END 
      LOGICAL FUNCTION FOPEN (BUFF) 
      IMPLICIT INTEGER (A-Z)
      LOGICAL FMPER 
      DIMENSION BUFF(11)
      CALL  OPEN  (BUFF(11),BUFF(10),BUFF,0,BUFF(5),BUFF(6))
      FOPEN = (.NOT.(FMPER (5HOPENF ,BUFF)))
      RETURN
      END 
      INTEGER FUNCTION FREAD (BUFF,NUM) 
      IMPLICIT INTEGER (A-Z)
      LOGICAL FMPER 
      DIMENSION BUFF(372) 
      CALL  READF (BUFF(11),BUFF(10),BUFF(155),128,LEN,NUM) 
      FREAD = LEN 
      IF (FMPER (5HREADF ,BUFF)) FREAD = - 2
      RETURN
      END 
      SUBROUTINE CMDLN (INPUT,SIZE,QUIT)
      IMPLICIT INTEGER (A-Z)
      LOGICAL REL,DEC,PARMS 
      DIMENSION INPUT(1),LOC(2) 
      COMMON/TERM/LU,LIST 
      COMMON/RBUF/RBUF(33)
      COMMON/SNAP/SNAP(9),SNERR,DCBSN(144),RECSN(128) 
      COMMON/SYSTM/SYSTM(9),SYERR,DCBSY(144),RECSY(128) 
      COMMON/BASE/BASE,REL,DEC,MODE 
      DIMENSION NUMBR (4),PBUF (10) 
      LOGICAL QUIT,REL,DEC,DECML
  
      CALL  PARSE (INPUT,SIZE,RBUF) 
      IF (.NOT.(RBUF(1).EQ.0)) GO TO 100
  
C  NULL ENTRY 
  
      GO TO 777 
  
100   IF (.NOT.(RBUF(1).EQ.1)) GO TO 200
  
C  NUMERIC ENTRY    -   INTERPRET AS OCTAL INPUT
  
      CALL UPDAT
        GO TO 999 
  
 200   IF (RBUF(2).NE.2H/E) GO TO 210 
         QUIT = .TRUE.
         GO TO 999
 210   IF (RBUF(2).NE.2HLI) GO TO 220 
         CALL SYMBL (LU,VALUE,RBUF(6))
         GO TO 999
 220   IF (RBUF(2).NE.2HDI) GO TO 240 
         CALL STABL 
         GO TO 999
 240   IF (RBUF(2).NE.2H??) GO TO 250 
         CALL CLIST 
         GO TO 999
 250   IF (RBUF(2).NE.2HDL) GO TO 260 
         CALL DLIST 
         GO TO 999
 260   IF (RBUF(2).NE.2HDM) GO TO 270 
         CALL DMODF 
         GO TO 999
 270   IF (RBUF(2).NE.2HIO) GO TO 280 
         CALL SETIO 
         GO TO 999
 280   IF (RBUF(2).NE.2HDS) GO TO 290 
         CALL FWORD 
         GO TO 999
 290   IF (RBUF(2).NE.2HFI) GO TO 300 
         CALL FWORD 
         GO TO 999
 300   IF (RBUF(2).NE.2HNS) GO TO 310 
         CALL SECTS 
         GO TO 999
 310   IF (RBUF(2).NE.2HLM) GO TO 315 
         CALL MEMRY 
         GO TO 999
 315   IF (RBUF(2).NE.2HLR) GO TO 320 
         CALL MEMRY 
         GO TO 999
 320   IF (RBUF(2).NE.2HMD) GO TO 330 
         CALL MDUMP 
         GO TO 999
 330   IF (RBUF(2).NE.2HBA) GO TO 340 
         CALL SETBA 
         GO TO 999
 340   IF (RBUF(2).NE.2HTR) GO TO 350 
          CALL TRACE
          GO TO 999 
 350   IF (RBUF(2).NE.2HCA) GO TO 360 
          CALL CALC 
          GO TO 999 
 360   IF (RBUF(2).NE.2HDV) GO TO 370 
          CALL DVT
          GO TO 999 
 370   IF (RBUF(2).NE.2HIF) GO TO 380 
          CALL IFT
          GO TO 999 
 380   IF (RBUF(2).NE.2HID) GO TO 390 
          CALL ID 
          GO TO 999 
  
 390   CONTINUE 
777   CALL EXEC (2,LU,8H WHAT?? ,4) 
  
  
999   REL = .FALSE. 
      DEC = .FALSE. 
      RETURN
      END 
      SUBROUTINE MOVE (BUF1,BUF2,LEN) 
      IMPLICIT INTEGER (A-Z)
      DIMENSION BUF1(1),BUF2(1) 
      DO 100 I = 1, LEN 
100   BUF2 (I) = BUF1 (I) 
      RETURN
      END 
      END$
ASMB,R,L
      NAM RTE,7 Pick up $OPSY 
      ENT RTE 
      EXT $OPSY 
RTE   DEF $OPSY+0 
      END 
FTN4,L
      INTEGER FUNCTION GPARM (NUM,DFLT) 
      IMPLICIT INTEGER (A-Z)
      COMMON/TERM/LU
      COMMON/RBUF/RBUF(33)
      P = 4 * NUM + 1 
      GPARM = RBUF (P+1)
      IF (RBUF(P) .EQ. 0) GPARM = DFLT
      RETURN
      END 
      LOGICAL FUNCTION PARMS (NUM)
      IMPLICIT INTEGER (A-Z)
      COMMON/TERM/LU
      COMMON/RBUF/RBUF(33)
      PARMS = .TRUE.
      DO 10 J = 1,NUM 
      IF (RBUF(4*J+1).EQ.0) PARMS = .FALSE. 
10    CONTINUE
      IF (.NOT.PARMS) 
     .   CALL EXEC (2,LU,25H INSUFFICIENT PARAMETERS!,-25)
      RETURN
      END 
      LOGICAL FUNCTION PATCH (ADDR,VALUE,PLACE) 
      IMPLICIT INTEGER (A-Z)
      LOGICAL STATUS,FWRIT
      COMMON/SYSTM/SYSTM(9),SYERR,DCBSY(144),RECSY(128) 
      COMMON/TERM/LU
      LOC = IABS (ADDR) 
      IF (PLACE .NE. 2HME) GO TO 20 
          CALL IPUT (LOC,VALUE) 
          PATCH = .TRUE.
          GO TO 900 
  
20    IF (PLACE .NE. 2HDI) GO TO 900
      REC = LOC/128 + 1 
      WORD = MOD (LOC,128) + 1
      LEN = FREAD (SYSTM,REC) 
      RECSY (WORD) = VALUE
      PATCH = FWRIT (SYSTM,REC,128) 
900   RETURN
      END 
      LOGICAL FUNCTION FWRIT (BUF,RECNO,LEN)
      IMPLICIT INTEGER (A-Z)
      LOGICAL FMPER 
      DIMENSION BUF (282) 
      FWRIT = .FALSE. 
      CALL WRITF (BUF(11),BUF(10),BUF(155),LEN,RECNO) 
      FWRIT = .NOT. FMPER (5HWRITF ,BUF)
      RETURN
      END 
      LOGICAL FUNCTION GETEM (LOC,VALUE,PLACE)
      IMPLICIT INTEGER (A-Z)
      COMMON/TERM/LU
      COMMON/SYSTM/SYSTM(9),SYERR,DCBSY(144),RECSY(128) 
      COMMON/IO/INPT,OUTPT,NAME(3),SEC,CART 
         GETEM = .FALSE.
5     IF (LOC.GT.1) GO TO 10
C    A, B REGISTERS OUT OF BOUNDS 
         GO TO 900
10    IF (PLACE .NE. 2HME) GO TO 20 
         VALUE = IGET (LOC) 
         GETEM = .TRUE. 
         GO TO 900
  
20    IF (PLACE .NE. 2HDI) GO TO 900
      REC = LOC/128 + 1 
      WORD = MOD (LOC,128) + 1
      LEN = FREAD (SYSTM,REC) 
      VALUE = RECSY (WORD)
      IF (LEN .GE. 0) GETEM = .TRUE.
  
900   RETURN
      END 
      END$
FTN4,L
      SUBROUTINE DIGITS (VALUE,BASE,OUTPT)
      IMPLICIT INTEGER (A-Z)
      DIMENSION OUTPT (3), TEMP (5) 
      IF (BASE .EQ. 10) GO TO 5 
      SIGN = 1H0
      WORD = IAND (VALUE,77777B)
      IF (VALUE .LT. 0) SIGN = 1H1
      GO TO 10
5     SIGN = 1H 
      WORD = IABS (VALUE) 
      IF (VALUE .LT. 0) SIGN = 1H-
10    DO 20 I = 5,1,-1
      TEMP (I) = MOD (WORD,BASE)
20    WORD = WORD/BASE
      S = 0 
      CALL SETDB (OUTPT,S)
      CALL CPUT (SIGN)
      DO 30 I = 1, 5
30    CALL CPUT ((TEMP(I)+60B)*256 + 40B) 
      RETURN
      END 
      END$
FTN4,L
      LOGICAL FUNCTION SHOW (LU,LOC,PLACE)
      IMPLICIT INTEGER (A-Z)
      LOGICAL DISPL 
      DIMENSION MESS (40) 
      SHOW = DISPL (LOC,PLACE,MESS,VALU)
      CALL INVRS (LOC,VALU,MESS(20),20,NWORD) 
      IF (SHOW) CALL EXEC (2,LU,MESS,19+NWORD)
      RETURN
      END 
      END$
FTN4,L
      LOGICAL FUNCTION DISPL (LOC,PLACE,USER,VALU)  
C FORMAT BUFFER AS OCTAL,DECIMAL,ACSII AND SHOW DISC/MEM SOURCE 
C USER IS ASSUMED TO HAVE AT LEAST 19 WORDS AND IS FILLED BY
C DISPL 
      IMPLICIT INTEGER (A-Z)
      DIMENSION LOC (2),USER(19)
      LOGICAL GETEM,TEST,REL,DEC
      COMMON/BASE/BASE,REL,DEC,OFSET
      DIMENSION MESS (19) 
      EQUIVALENCE (MESS(5),MEMR),  (MESS(10),OCTAL), (MESS(14),DECML),
     .            (MESS(18),CHARS)
  
      DATA MESS/3*2H  ,2H (,3*2H  ,2H  ,2H: ,10*2H  / 
C NOTE: LOC < 0 MEANS SHOW ABS(LOC) BUT USE LOC(2) AS ADDR TO DISPAY
      BA = 8
      MESS (8) = 2H ) 
      ADDR = LOC
      DISP = ADDR 
      IF (.NOT.REL) GO TO 10
         DISP = LOC (2) 
         IF (DEC) BA = 10 
         MESS (8) = 2HR)
10    TEST = GETEM (ADDR,VALUE,PLACE) 
      VALU = VALUE
      IF (.NOT.TEST) GO TO 900
      MESS (2) = PLACE
      MESS (3) = 2HSC 
      IF (MESS(2).EQ.2HME) MESS(3) = 2HM
      IF (REL) DISP = DISP + OFSET
      CALL DIGITS (DISP,BA,MEMR)
      CALL DIGITS (VALUE,8,OCTAL) 
      CALL DIGITS (VALUE,10,DECML)
      CHARS = ASCII (VALUE) 
      CALL MOVE (MESS,USER,19)
  
900   DISPL = TEST
      RETURN
      END 
      END$
FTN4,L
      SUBROUTINE SHOWB (LU,INDEX,VALUE) 
  
C  SHOW DISC BUFFER AT INDEX. INDEX STARTS WITH 1.
  
      IMPLICIT INTEGER (A-Z)
      DIMENSION MESS (16) 
      EQUIVALENCE (MESS(2),WORD), (MESS(5),OCTAL), (MESS(9),DECML), 
     .            (MESS(13),CHARS)
  
      DATA MESS/2H (,2H  ,2H):,13*2H  / 
  
      WORD = KCVT (INDEX) 
      CALL DIGITS (VALUE,8,OCTAL) 
      CALL DIGITS (VALUE,10,DECML)
      CHARS = ASCII (VALUE) 
      MESS (1) = 2H ( 
      MESS (3) = 2H): 
      IF (INDEX.GT.0) GO TO 100 
          MESS (1) = 2H 
          MESS (2) = 2H 
          MESS (3) = 2H 
100   CALL EXEC (2,LU,MESS,16)
  
      RETURN
      END 
      END$
FTN4,L
      SUBROUTINE BITS (WORD,LIST) 
      IMPLICIT INTEGER (A-Z)
      DIMENSION BUF (12)
      S = 0 
      CALL SETDB (BUF,S)
      CALL CPUT (1H  )
      DO 10 J = 16,1,-1 
       IF (MOD(J,3).EQ.0) CALL CPUT (1H  )
       CHAR = 1H0 
       TEST = ROTATE (WORD,J) 
       IF (TEST.LT.0) CHAR = 1H1
10     CALL CPUT (CHAR) 
      CALL EXEC (2,LIST,BUF,-S) 
      RETURN
      END 
      END$
ASMB,L      
      NAM ROTAE,7 INTEGER FUNCTION TO ROTATE WORD 
      ENT ROTAE 
      EXT .ENTR 
WORD  BSS 1        16 BIT WORD TO ROTATE
NBITS BSS 1        NUMBER BITS TO ROTATE RIGHT
ROTAE NOP 
      JSB .ENTR 
      DEF WORD     GET PARAMETERS 
      LDA NBITS,I  NUMBER OF BITS 
      AND =B17     PERMIT ONLY LOW 4 BITS TO SPECIFY ROTATE 
      LDB WORD,I   GET WORD TO ROTATE 
      SWP          SWAP REGISTERS 
      SZB,RSS 
      JMP ROTAE,I  ZERO BITS TO ROTATE. LEAVE ALONE.
      CMB,INB      SET B TO NEGATIVE OF COUNT 
* 
LOOP  RAR          ROTATE RIGHT 1 BIT 
      INB,SZB 
      JMP LOOP
* 
      JMP ROTAE,I 
      END 
FTN4,L
      INTEGER FUNCTION OCTAL (P)
      IMPLICIT INTEGER (A-Z)
      COMMON/INPUT/LENG,INPUT(40) 
      DIMENSION BUF(10),PBUF(10)
      INCNT = 1 
      OUCNT = 0 
      CALL SETSB (INPUT,INCNT,LENG) 
      CALL SETDB (BUF,OUCNT)
      CMCNT = P - 1 
      PBUF = 0
C   P = PARAMETER NUMBER. COUNT NUMBER OF COMMAS = P - 1
10    IF (CMCNT.EQ.0) GO TO 20
      CHAR = KHAR (CHAR)
      IF (CHAR.EQ.1H, ) CMCNT = CMCNT - 1 
      IF (CHAR.EQ.0) GO TO 700
      GO TO 10
20    CHAR = KHAR (CHAR)
      IF (CHAR.EQ.1H, .OR. CHAR.EQ.0 .OR. CHAR.EQ.1HD ) GO TO 30
      CALL CPUT (CHAR)
      GO TO 20
30    CALL ZPUT (2HB, ,1,2) 
      POS = 1 
      CALL NAMR (PBUF,BUF,OUCNT,POS)
700   OCTAL = PBUF
      RETURN
      END 
  
FTN4,L
      SUBROUTINE UPDAT
      IMPLICIT INTEGER (A-Z)
      LOGICAL SHOW,PATCH,TEST,REL,DEC 
      DIMENSION ANSR (5),MESS(10),CHECK(3),VERIF(22),LOC(2) 
      COMMON/RBUF/RBUF(33)
      COMMON/IO/INPT,OUTP 
      COMMON/TERM/LU
      COMMON/BASE/BASE,REL,DEC,MODE 
      COMMON/SNDAT/NENTS,NLIBS,LWABG,FWABG,FWART,SYBP,BGBP,RTBP,
     .             FWAC,LCOM,SYSID,CKSUM
      COMMON/SYSTM/SYSTM(9),SYERR,DCBSY(144),RECSY(128) 
      EQUIVALENCE (MESS(9),PLACE) 
  
      DATA MESS/2H  ,2HPA,2HTC,2HH ,2HMA,2HDE,2H T,2HO ,2*2H  / 
      DATA CHECK/2HPA,2HTC,2HH /
      DATA VERIF/10*2H  ,2HTO,10*2H  ,2H ?/ 
      DATA NULL/0/
      LOC = RBUF (2)
      IF (RBUF(6).EQ.1HR ) REL = .TRUE. 
      IF (RBUF(10).EQ.1HD ) DEC = .TRUE.
      IF (.NOT.DEC) LOC = OCTAL (1) 
      LOC (2) = LOC (1) 
      IF (REL) LOC = LOC + BASE 
  
5     IF (LOC.LT.2) GO TO 900 
  
C     IF ((LOC - FWABG).LT. 0) GO TO 20      \
C     CALL EXEC (2,LU,13HOUT OF BOUNDS,-13)   +  MAY PUT BACK IN
C     GO TO 900                              /
20    CONTINUE
      IF (.NOT.(SHOW(LU+2000B,LOC,INPT))) GO TO 900 
      CALL REIO (1,LU+400B,ANSR,-10)
         CALL ABREG (STATUS,SIZE) 
         CALL PARSE (ANSR,SIZE,RBUF)
             RESULT = RBUF
  
C  ANSWER IS OF FORM     cr  = Advance to next mem/disc loc 
C                      N cr  = Patch current output shown by
C                              IO command and exit whether or 
C                              not patch actually made. 
C                       ,/E  = Exit (1st parameter null)
  
C   INCR = INCREMENT (+ OR -) ON NULL RETURN
         INCR = + 1 
         IF (RBUF (6).EQ.2H^ )  INCR = - 1
  
C       ADVANCE/DECREMENT WILL BE MADE ON NULL UNLESS SECOND
C       PARAMETER IS /E 
  
         IF (RESULT.NE.NULL) GO TO 30 
             IF (RBUF(6).EQ.2H/E) GO TO 900 
             LOC = LOC + INCR 
             LOC (2) = LOC (2) + INCR 
             GO TO 5
  
30           PLACE = OUTP 
  
             CALL EXEC (2,LU+2000B,CHECK,3) 
                CALL SHOW (LU,LOC,PLACE)
                CALL DIGITS (RBUF(2),8,VERIF(13)) 
                CALL DIGITS (RBUF(2),10,VERIF(17))
                VERIF(21) = ASCII (RBUF(2)) 
                CALL EXEC (2,LU+2000B,VERIF,22) 
  
             CALL REIO (1,LU+400B,REPLY,1)
  
             IF (REPLY.NE.2HYE) GO TO 900 
  
             TEST = PATCH (LOC,RBUF(2),PLACE) 
  
             IF (.NOT.TEST) GO TO 900 
                 MESS (10) = 2HSC 
                 IF (PLACE.EQ.2HME) MESS(10) = 2HM
                 CALL EXEC (2,LU,MESS,10) 
  
             CALL SHOW (LU,LOC,PLACE) 
900   RETURN
      END 
      END$
ASMB,L
      NAM ASCII,7 MAKE WORD INTO TWO ASCII CHARS
      EXT .ENTR 
      ENT ASCII 
A     EQU 0 
B     EQU 1 
WORD  BSS 1 
ASCII NOP 
      JSB .ENTR 
      DEF WORD
      LDA WORD,I
      ALF,ALF 
      AND =B377 
      JSB CNVRT 
      ALF,ALF 
      STA CHARS 
      LDA WORD,I
      AND =B377 
      JSB CNVRT 
      IOR CHARS 
      JMP ASCII,I 
CNVRT NOP 
      STA B 
      ADB =B-40 
      SSB 
      LDA =B40
      ADB =B-140
      SSB,RSS 
      LDA =B40
      JMP CNVRT,I 
CHARS NOP 
      END 
FTN4,L
      LOGICAL FUNCTION FMPER (SUBR,PBUF),REPORT FMP ERRORS
      IMPLICIT INTEGER (A-Z)
      COMMON/TERM/LU
  
      DIMENSION PBUF(10), SUBR (3), MBUFR (19)
  
C  PBUF IS THE OUTPUT PARSE BUFFER FROM NAMR FUNCTION.
C  FMPER CODE IS STORED IN PBUF (10). 
C  SUBR IS THE FMP SUBR FROM WHICH ERROR WAS RETURNED.  
  
C MESSAGE =  "FFFFFF: FMP ERROR - NN IN FILE  AAAAAA" 
C WORD    =    1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9
  
      DATA MBUFR/2H  ,2H  ,2H  ,2H: ,2HFM,2HP ,2HER,2HRO, 
     .           2HR ,2H- ,2H  ,2H I,2HN ,2HFI,2HLE,2H  , 
     .           2H  ,2H  ,2H  /
  
      DATA WR/2/,        ASCII/3/ 
  
C    FUNCTIONS
  
      TYPE (K) = IAND (K,3) 
  
C  START OF LOGICAL FUNCTION TO REPORT FMP ERRORS 
  
      FMPER = .FALSE. 
      IF (PBUF(10) .GE. 0) GO TO 99 
  
      FMPER = .TRUE.
      MBUFR ( 1) = SUBR ( 1)
      MBUFR ( 2) = SUBR ( 2)
      MBUFR ( 3) = SUBR ( 3)
      MBUFR (11) = KCVT (-PBUF(10)) 
      MBUFR (17) = PBUF ( 1)
      MBUFR (18) = PBUF ( 2)
      MBUFR (19) = PBUF ( 3)
      IF (TYPE(PBUF(4)).EQ.ASCII) GO TO 10
            IF (PBUF(1) .GE. 0) GO TO 5 
               PBUF(1) = - PBUF(1)
               MBUFR (16) = 2H -
5           CALL CNUMD (PBUF,MBUFR(17)) 
10    CALL EXEC (WR,LU,MBUFR,19)
99    RETURN
      END 
      END$
FTN4,L
      LOGICAL FUNCTION ISEQL (STR1,STR2,LEN)
      IMPLICIT INTEGER (A-Z)
      DIMENSION STR1(1),STR2(1) 
  
      ISEQL = .FALSE. 
      DO 100 I = 1, LEN 
      IF (STR1(I).NE.STR2(I)) GO TO 900 
100   CONTINUE
      ISEQL = .TRUE.
  
900   RETURN
      END 
      END$
ASMB,Q,C
      NAM INVRS,7 MOD FOR L-SERIES J. BRIDGES 10.18.79
* 
*     THIS ROUTINE INVERSE ASSEMBLES HP 21MX
*     INSTRUCTIONS
* 
*     THE CALLING SEQUENCE IS AS FOLLOWS
* 
*        JSB INVRS
*        DEF RTRN 
*        DEF ADDRSS    LOGICAL ADDRESS OF INSTRUCTION 
*        DEF VALUE     INSTRUCTION AT ADDRSS
*        DEF IBUF      OUTPUT BUFFER
*        DEF ISIZE     SIZE OF OUTPUT BUFFER
*        DEF IWRDS     RETURNED NO OF WORDS FILLED
*  RTRN  ...
* 
*     FORTRAN CALL: 
* 
*       CALL INVRS(IADRS,VALUE,IBUF,ISIZE,IWRDS)
* 
* 
      ENT INVRS 
      EXT .ENTR,.DIV,.SBT 
* 
* 
A     EQU 0 
B     EQU 1 
* 
* 
ADDRS BSS 1 
VALUE BSS 1 
BUFAD BSS 1 
BSIZE BSS 1 
WCNT  BSS 1 
INVRS NOP 
      JSB .ENTR 
      DEF ADDRS 
      LDA BUFAD 
      RAL           MAKE BYTE ADDRESS 
      STA BUFAD 
      STA BPNTR 
      LDB BSIZE,I   GET BUFFER SIZE 
      RBL           MAKE INTO BYTES 
      ADA B         COMPUTE END OF BUFFER 
      STA BFEND 
      LDA ADDRS,I 
      STA IADR      SAVE ADDRESS OF INSTRUCTION 
      LDA B2        SET NO OF WORDS/ENTRY 
      STA  INCR     IN INCREMENT
      JSB LOAD      FETCH INSTRUCTION 
      STA INSTR 
      STA TEMP
      AND B70K      IS IT A MEMORY REFERENCE
      SZA 
      JMP MRGI      YES GO GET IT 
      LDA INSTR     NO
      ELA,ALF       PUT SIGN  IN E REG
      RAL           AND BITS 10&11 IN BITS 0&1
      SEZ           IF E SET(I.E. SIGN) MUST BE I/O OR EIG
      JMP IOGI
* 
      AND B3        SET UP OP CODE TABLE COUNTER
      LDB M18       SHIFT ROTATE
      SLA 
      LDB M12       ALTER SKIP
      STB CNTR
      ADA GRTBL     GET ADDRESS OF GROUP TABLE
      LDB A,I 
* 
LOOP1 LDA TEMP      FETCH REMAINING BITS OF INSTRUCTION 
      AND B,I       ARE ALL REQUIRED BITS SET 
      XOR B,I 
      SZA,RSS 
      JMP FOND1     YES GO GET MNEMONIC 
LOP1A ADB INCR      BUMP ADDRESS
      ISZ CNTR
      JMP LOOP1 
* 
NFND  LDA BUFAD     IF WE FALL THROUGH NOT COMPLETELY 
      STA BPNTR     DEFINED SO JUST PRINT OCTAL 
      LDA INSTR 
      JSB PN
      JMP EXIT
* 
IADR  BSS 1 
INCR  BSS 1 
INSTR BSS 1 
TEMP  BSS 1 
CNTR  BSS 1 
BPNTR BSS 1 
* 
B2    OCT 2 
B3    OCT 3 
B70K  OCT 70000 
M12   DEC -12 
M18   DEC -18 
BFEND BSS 1 
* 
GRTBL DEF *+1 
      DEF SRGA
      DEF ASGA
      DEF SRGB
      DEF ASGB
* 
MRGA1 DEF MRG-4 
* 
FOND1 JSB POPCD     PRINT MNEMONIC
      LDA B,I       REMOVE OPCODE FROM
      AND B1777     INSTRUCTION 
      XOR TEMP
      STA TEMP
      AND B1777     ARE ANY BITS LEFT 
      SZA,RSS 
      JMP EXIT   NO,THEN RETURN 
      LDA COMMA 
      JSB TYO       PRINT COMMA 
      JMP LOP1A     GO LOOK FOR REST
* 
B1777 OCT 001777
COMMA OCT 54
* 
MRGI  LDA INSTR 
      ALF,RAL 
      AND B17 
      RAL           TIMES 2 
      ADA MRGA1     COMPUTE TABLE POSITION
      LDB A 
      JSB POPCD     PRINT MNEMONIC
      LDA INSTR     COMPUTE ADDRESS 
      AND B2000     MERGE WITH PROPER PAGE
      SZA 
      LDA IADR
      XOR INSTR 
      AND B76K
      XOR INSTR 
      JSB PADR      PRINT ADDRESS 
      JMP EXIT
* 
B17   OCT 17
B2000 OCT 2000
B76K  OCT 76000 
* 
IOGI  LDB IOGTB     FETCH TABLE OF LOOP FOR I/O 
      SLA,RSS       IF EIG INSTEAD
      LDB DSGTB     THEN GET TABLE FOR EIG'S
      STB PNTR      PARMETERS 
      LDB PNTR,I    SET B TO START
      ISZ PNTR
LOOP2 LDA PNTR,I    GET COUNT FOR THIS TYPE 
      SSA 
      JMP LOP2A     IF NEGATIVE CONTINUE
* 
      SZA,RSS       IF ZERO THEN DONE 
      JMP NFND
      LDA B3
      STA INCR      ELSE SET INCREMENT TO 3 
      LDA PNTR,I    AND MAKE COUNT NEGATIVE 
      CMA,INA 
* 
LOP2A STA CNTR
      ISZ PNTR
LOOP3 LDA INSTR     FETCH INSTRUCTION 
      XOR B,I       SEARCH FOR MATCH
      AND PNTR,I    MASK UNWANTED BITS
      SZA,RSS 
      JMP FOND2 
      ADB INCR      BUMP ADDRESS IN OPCTBL
      ISZ CNTR      DONE WITH THIS TYPE
      JMP LOOP3     NO CONTINUE 
      ISZ PNTR
      JMP LOOP2     YES GO TO NEXT TYPE 
* 
* 
PNTR  BSS 1 
* 
FOND2 JSB POPCD     GO PRINT MNEMONIC 
      LDA PNTR,I    FETCH MASK
      CMA           IF EXACT NO OPERAND IN SAME WORD
      AND B77 
      SZA,RSS 
      JMP OPRND 
* 
      AND INSTR     STRIP OFF OPERAND 
      STA TEMP      SAVE FOR COMMA C TEST 
      LDB PNTR,I    IS MASK FOR 
      CPB DSMSK     A DOUBLE SHIFT GROUP
      SZA           AND OPERAND EQUAL 0 
      RSS 
      LDA B20       YES MAKE OPERAND IT 16
      AND B77       AND MASK C BIT
      JSB PNUMB     GO PRINT NUMBER 
      LDA TEMP
      AND B1000     IS A COMMA C REQUIRED 
      SZA,RSS       NO RETURN 
      JMP EXIT
      LDA COMMA 
      JSB TYO       PRINT COMMA 
      LDA "C
      JSB TYO       PRINT "C" 
      JMP EXIT
* 
* 
*     PRINTS MULTI WORD OPERANDS
* 
OPRND LDA TFLAG     TRACING 
      SZA,RSS 
      JMP EXIT   NO THEN RETURN 
* 
*     MUTIWORD PRINT HERE 
* 
      JMP EXIT
* 
* 
TFLAG OCT 0 
* 
B20   OCT 20
B77   OCT 77
B1000 OCT 1000
"C    OCT 103 
* 
* 
*     PRINT ONE CHARACTER 
* 
TYO   NOP 
      STB TEMP2     SAVE B REG
      LDB BPNTR 
      CPB BFEND 
      JMP EXIT   IF FULL THEN COMPLETE
      JSB .SBT      ELSE STORE BYTE 
      STB BPNTR     UPDATE POINTER
      LDB TEMP2     RESTORE B REG 
      JMP TYO,I 
* 
IOGTB DEF *+1 
      DEF OVFG
      DEC -4        OVERFLOW GROUP
      OCT 177777
      DEC -1        CLF 
      OCT 177700
      DEC -12       I/O GROUP 
      OCT 176700
      OCT 0         INDICATES END OF IO TABLE 
DSGTB DEF *+1 
      DEF DSG 
      DEC -6        DOUBLE SHIFT GROUP
DSMSK OCT 5760
      DEC -90       REST OF BASE SET
      OCT 5777
*                   MICROCODED INSTRUCTIONS 
      DEC 27        POSITIVE COUNT MEANS CHANGE INCREMENT 
      OCT 5777
      OCT 0         THIS INDICATES END
* 
LOAD  NOP 
      LDA VALUE,I 
      JMP LOAD,I
* 
TEMP2 BSS 1 
* 
*     PRINT MNEMONIC
POPCD NOP 
      STB TEMP3 
      INB 
      LDA B,I       FETCH FIRST 3 CHARS 
      JSB DSQZ      GO PRINT THEM 
      LDA INCR
      CPA B2        DOES MNEMONIC HAVE MORE THAN 3 CHARS
      JMP POP1      NO,GO TO RETURN 
      LDB TEMP3 
      ADB B2        YES FETCH NEXT 3 CHARS
      LDA B,I 
      JSB DSQZ      GO TO PRINT THEM
POP1  LDB TEMP3     RESTORE B REG 
      JMP POPCD,I   RETURN
* 
* 
DSQZ  NOP 
      CLB           A=SQOZE CODE
      JSB .DIV  
      DEF D1600 
      JSB CONV      A=FIRST CHAR,B=2ND,3RD
      LDA B 
      CLB 
      JSB .DIV      SPLIT SECOND 2 CHARS
      DEF D40 
      JSB CONV
      LDA B 
      JSB CONV
      JMP DSQZ,I
* 
*     A REG = ONE SQOZE CHARACTER 
* 
CONV  NOP 
      SZA,RSS       IF ZERO THEN TERMINATE DSQZ 
      JMP DSQZ,I
* 
      CPA B45       IS IT A "." 
      CCA           YES SET TO CONVERT TO 56B 
      ADA M13B       IS IT A LETTER 
      SSA,RSS 
      ADA B7        YES ADD 101B
      ADA B72       NO ADD 57B
      JSB TYO       GO PRINT IT 
      JMP CONV,I    RETURN
* 
B7    OCT 7 
B45   OCT 45
B72   OCT 72
M13B  OCT -13 
D40   DEC 40
D1600 DEC 1600
* 
TEMP3 BSS 1 
* 
* 
*     A =ADDRESS TO BE PRINTED
* 
* 
PADR  NOP           PRINT ADDRESS 
      STA SIGN      SAVE INDIRECT BIT 
      ELA,CLE,ERA   REMOVE SIGN BIT 
* 
************INSERT SYMBOL SEARCH HERE 
* 
      JSB PNUMB     GO PRINT  NUMBER
      LDA SIGN
      SSA,RSS       IS ",I" REQUIRED
      JMP PADR,I    NO THEN RETURN
* 
      LDA COMMA     YES THEN PRINT ",I" 
      JSB TYO 
      LDA "I
      JSB TYO 
      JMP PADR,I    AND RETURN
* 
"I    OCT 111 
RADIX DEC 8 
* 
SIGN BSS 1
* 
*     A =NUMBER TO BE PRINTED 
* 
PNUMB NOP 
      STA TEMP3 
      LDA BLANK 
      JSB TYO       PRINT BLANK 
      LDA TEMP3 
      JSB PN        PRINT NUMBER
      JMP PNUMB,I 
* 
PN    NOP 
      LDB TBADD     SET TEMP BUFFER 
      STB TBPTR 
PN1   CLB           CLEAR B FOR DIV 
      JSB .DIV  
      DEF RADIX 
      ADB M12B      CONVERT TO ASCII
      SSB,RSS 
      ADB B7
      ADB B72 
      JSB SRBT      PUT IN TEMP BUFFER
      SZA           IF QUOTIENT NON ZERO CONTINUE 
      JMP PN1 
* 
      LDB TBADD     ELSE MOVE TO OUTPUT BUFFER
      CMB,INB       SET UP CHAR COUNT 
      ADB TBPTR 
      STB TEMP3 
* 
PN2 ISZ TBPTR       BUMP POINTER
      LDA TBPTR,I   FETCH CHARACTER 
      JSB TYO       PRINT CHARACTER 
      ISZ TEMP3 
      JMP PN2       CONTINUE UNTIL ALL ARE MOVED
      JMP PN,I      AND THEN RETURN 
* 
* 
SRBT  NOP           SAVE CHARACTERS IN REVERSE ORDER
      STB TBPTR,I 
      CCB 
      ADB TBPTR     DECREMENT POINTER 
      STB TBPTR 
      JMP SRBT,I    AND RETURN
* 
BLANK OCT 40
M12B  OCT -12 
* 
TBPTR BSS 1 
      BSS 16
TBADD DEF *-1 
* 
EXIT  LDA BLANK     FILL WITH BLANK CHAR
      JSB TYO 
      LDA BUFAD     COMPUTE WORD COUNT
      CMA,INA 
      ADA BPNTR 
      ARS 
      STA WCNT,I
      JMP INVRS,I   AND RETURN
* 
* 
MRG   EQU *         MEMORY REFERENCE GROUP
      AND 0 
      OCT 044216
      JSB 0 
      OCT 100624
      XOR 0 
      OCT 154204
      JMP 0 
      OCT 100262
      IOR 0 
      OCT 075304
      ISZ 0 
      OCT 075554
      ADA 0 
      OCT 043373
      ADB 0 
      OCT 043374
      CPA 0 
      OCT 052533
      CPB 0 
      OCT 052534
      LDA 0 
      OCT 105673
      LDB 0 
      OCT 105674
      STA 0 
      OCT 134773
      STB 0 
      OCT 134774
SRGA  EQU *         SHIFT ROTATE GROUP
      ALF 
      OCT 044100
      ELA 
      OCT 060473
      ERA 
      OCT 061053
      ALR 
      OCT 044114
      RAR 
      OCT 130324
      RAL 
      OCT 130316
      ARS 
      OCT 044475
      ALS 
      OCT 044115
      OCT 40        CLE 
      OCT 052277
      SLA 
      OCT 134273
      OCT 27        ALF 
      OCT 044100
      OCT 26        ELA 
      OCT 060473
      OCT 25        ERA 
      OCT 061053
      OCT 24        ALR 
      OCT 044114
      OCT 23        RAR 
      OCT 130324
      OCT 22        RAL 
      OCT 130316
      OCT 21        ARS 
      OCT 044475
      OCT 20        ALS 
      OCT 044115
SRGB  EQU * 
      BLF 
      OCT 047200
      ELB 
      OCT 060474
      RBR 
      OCT 130374
      RBL 
      OCT 130366
      BRS 
      OCT 047575
      BLS 
      OCT 047215
      OCT 4040      CLE 
      OCT 052277
      SLB 
      OCT 134274
      OCT 4027      BLF 
      OCT 047200
      OCT 4026      ELB 
      OCT 060474
      OCT 4025      ERB 
      OCT 061054
      OCT 4024      BLR 
      OCT 047214
      OCT 4023      RBR 
      OCT 130374
      OCT 4022      RBL 
      OCT 130366
      OCT 4021      BRS 
      OCT 047575
      OCT 4020      BLS 
      OCT 047215
ASGA  EQU *         ALTER SKIP GROUP
      CCA 
      OCT 051523
      CLA 
      OCT 052273
      CMA 
      OCT 052343
      SEZ 
      OCT 133674
      CCE 
      OCT 051527
      OCT 2100      CLE 
      OCT 052277
      CME 
      OCT 052347
      SSA 
      OCT 134723
      SLA 
      OCT 134273
      INA 
      OCT 075213
      SZA 
      OCT 135353
      RSS 
      OCT 131645
ASGB  EQU * 
      CCB 
      OCT 051524
      CLB 
      OCT 052274
      CMB 
      OCT 052344
      OCT 6040      SEZ 
      OCT 133674
      OCT 6300      CCE 
      OCT 051527
      OCT 6100      CLE 
      OCT 052277
      OCT 6200      CME 
      OCT 052347
      SSB 
      OCT 134724
      SLB 
      OCT 134274
      INB 
      OCT 075214
      SZB 
      OCT 135354
      OCT 6001      RSS 
      OCT 131645
OVFG  EQU *         OVERFLOW GROUP
      CLO 
      OCT 052311
      STO 
      OCT 135011
      SOS 
      OCT 134505
      SOC 
      OCT 134465
CLF   EQU *         CLEAR FLAG
      CLF 0 
      OCT 052300
IOG   EQU *         I/O GROUP 
      CLC 0 
      OCT 052275
      STC 0 
      OCT 134775
      OTB 0 
      OCT 120374
      OTA 0 
      OCT 120373
      LIB 0 
      OCT 106204
      LIA 0 
      OCT 106203
      MIB 0 
      OCT 111304
      MIA 0 
      OCT 111303
      SFS 0 
      OCT 133735
      SFC 0 
      OCT 133715
      STF 0 
      OCT 135000
      HLT 0 
      OCT 072016
DSG   EQU *         DOUBLE SHIFT GROUP
      OCT 003100    RRR    1 WORD 
      OCT 131574
      OCT 003040    LSR    1 WORD 
      OCT 107044
      OCT 003020    ASR    1 WORD 
      OCT 044544
      OCT 002100    RRL    1 WORD 
      OCT 131566
      OCT 002040    LSL    1 WORD 
      OCT 107036
      OCT 002020    ASL    1 WORD 
      OCT 044536
EIG1  EQU *         1 WORD EXTENDED AND DMS GROUP 
      OCT 003741    CAX    1 WORD 
      OCT 051432
      OCT 003751    CAY    1 WORD 
      OCT 051433
      OCT 007741    CBX    1 WORD 
      OCT 051502
      OCT 007751    CBY    1 WORD 
      OCT 051503
      OCT 003744    CXA    1 WORD 
      OCT 053233
      OCT 007744    CXB    1 WORD 
      OCT 053234
      OCT 003754    CYA    1 WORD 
      OCT 053303
      OCT 007754    CYB    1 WORD 
      OCT 053304
      OCT 007761    DSX    1 WORD 
      OCT 056052
      OCT 007771    DSY    1 WORD 
      OCT 056053
      OCT 007760    ISX    1 WORD 
      OCT 075552
      OCT 007770    ISY    1 WORD 
      OCT 075553
      OCT 003747    XAX    1 WORD 
      OCT 153132
      OCT 003757    XAY    1 WORD 
      OCT 153133
      OCT 007747    XBX    1 WORD 
      OCT 153202
      OCT 007757    XBY    1 WORD 
      OCT 153203
      OCT 007763    LBT    1 WORD 
      OCT 105576
      OCT 007764    SBT    1 WORD 
      OCT 133476
      OCT 007767    SFB    1 WORD 
      OCT 133714
      OCT 007100    FIX    1 WORD 
      OCT 063432
      OCT 007120    FLT    1 WORD 
      OCT 063616
      OCT 003727    LFA    1 WORD 
      OCT 106013
      OCT 007727    LFB    1 WORD 
      OCT 106014
      OCT 007703    MBF    1 WORD 
      OCT 110660
      OCT 007702    MBI    1 WORD 
      OCT 110663
      OCT 007704    MBW    1 WORD 
      OCT 110701
      OCT 007706    MWF    1 WORD 
      OCT 112370
      OCT 007705    MWI    1 WORD 
      OCT 112373
      OCT 007707    MWW    1 WORD 
      OCT 112411
      OCT 003712    PAA    1 WORD 
      OCT 122103
      OCT 007712    PAB    1 WORD 
      OCT 122104
      OCT 003713    PBA    1 WORD 
      OCT 122153
      OCT 007713    PBB    1 WORD 
      OCT 122154
      OCT 003730    RSA    1 WORD 
      OCT 131623
      OCT 007730    RSB    1 WORD 
      OCT 131624
      OCT 003731    RVA    1 WORD 
      OCT 132013
      OCT 007731    RVB    1 WORD 
      OCT 132014
      OCT 003710    SYA    1 WORD 
      OCT 135303
      OCT 007710    SYB    1 WORD 
      OCT 135304
      OCT 003711    USA    1 WORD 
      OCT 143123
      OCT 007711    USB    1 WORD 
      OCT 143124
      OCT 003722    XMA    1 WORD 
      OCT 154043
      OCT 007722    XMB    1 WORD 
      OCT 154044
      OCT 007720    XMM    1 WORD 
      OCT 154057
      OCT 007721    XMS    1 WORD 
      OCT 154065
EIG2  EQU *         2 WORD EXTENDED AND DMS GROUP 
      OCT 010400    DIV    2 WORDS
      OCT 055230
      OCT 014200    DLD    2 WORDS
      OCT 055376
      OCT 014400    DST    2 WORDS
      OCT 056046
      OCT 010200    MPY    2 WORDS
      OCT 111763
      OCT 015000    FAD    2 WORDS
      OCT 062706
      OCT 015060    FDV    2 WORDS
      OCT 063120
      OCT 015040    FMP    2 WORDS
      OCT 063662
      OCT 015020    FSB    2 WORDS
      OCT 064224
      OCT 015746    ADX    2 WORDS
      OCT 043422
      OCT 015756    ADY    2 WORDS
      OCT 043423
      OCT 011742    LAX    2 WORDS
      OCT 105532
      OCT 011752    LAY    2 WORDS
      OCT 105533
      OCT 015742    LBX    2 WORDS
      OCT 105602
      OCT 015752    LBY    2 WORDS
      OCT 105603
      OCT 015745    LDX    2 WORDS
      OCT 105722
      OCT 015755    LDY    2 WORDS
      OCT 105723
      OCT 011740    SAX    2 WORDS
      OCT 133432
      OCT 011750    SAY    2 WORDS
      OCT 133433
      OCT 015740    SBX    2 WORDS
      OCT 133502
      OCT 015750    SBY    2 WORDS
      OCT 133503
      OCT 015743    STX    2 WORDS
      OCT 135022
      OCT 015753    STY    2 WORDS
      OCT 135023
      OCT 015714    SSM    2 WORDS
      OCT 134737
      OCT 011726    XCA    2 WORDS
      OCT 153223
      OCT 015726    XCB    2 WORDS
      OCT 153224
      OCT 011724    XLA    2 WORDS
      OCT 153773
      OCT 015724    XLB    2 WORDS
      OCT 153774
      OCT 011725    XSA    2 WORDS
      OCT 154423
      OCT 015725    XSB    2 WORDS
      OCT 154424
EIG2J EQU *         2 WORD JUMPS
      OCT 015762    JLY    2 WORDS
      OCT 100223
      OCT 015772    JPY    2 WORDS
      OCT 100463
      OCT 015732    DJP    2 WORDS
      OCT 055272
      OCT 015733    DJS    2 WORDS
      OCT 055275
      OCT 015734    SJP    2 WORDS
      OCT 134172
      OCT 015735    SJS    2 WORDS
      OCT 134175
      OCT 015736    UJP    2 WORDS
      OCT 142372
      OCT 015737    UJS    2 WORDS
      OCT 142375
EIG3  EQU *         3 WORD
JRS   OCT 017715    JRS    3 WORDS
      OCT 100575
      OCT 017766    CBT    3 WORDS
      OCT 051476
      OCT 017765    MBT    3 WORDS
      OCT 110676
      OCT 017776    CMW    3 WORDS
      OCT 052371
      OCT 017777    MVW    3 WORDS
      OCT 112341
      OCT 017774    CBS    3 WORDS
      OCT 051475
      OCT 017773    SBS    3 WORDS
      OCT 133475
      OCT 017775    TBS    3 WORDS
      OCT 136575
MIC   EQU *         MICRO CODED MACROS
      OCT 005201    DBLE   0 FORTRAN CALLABLE 
      OCT 054566
      OCT 056700
      OCT 005202    SNGL   0 FORTRAN CALLABLE 
      OCT 134421
      OCT 104600
      OCT 025203    .XMPY  4 WORD(S)
      OCT 166247
      OCT 123770
      OCT 025204    .XDIV  4 WORD(S)
      OCT 166236
      OCT 075700
      OCT 017205    .DFER  3 WORD(S)
      OCT 164600
      OCT 061040
      OCT 025213    .XADD  4 WORD(S)
      OCT 166233
      OCT 054660
      OCT 025214    .XSUB  4 WORD(S)
      OCT 166255
      OCT 141640
      OCT 177221    .GOTO 31 SPECIAL PROCESSING 
      OCT 165001
      OCT 137550
      OCT 175222    ..MAP 30 SPECIAL PROCESSING 
      OCT 166437
      OCT 044320
      OCT 167223    .ENTR 29 SPECIAL PROCESSING 
      OCT 164660
      OCT 137740
      OCT 167224    .ENTP 29 SPECIAL PROCESSING 
      OCT 164660
      OCT 137620
      OCT 015225    .PWR2  2 WORD(S)
      OCT 165561
      OCT 127570
      OCT 007226    .FLUN  1 WORD(S)
      OCT 164726
      OCT 142600
      OCT 015227    .SETP  2 WORD(S)
      OCT 165727
      OCT 137620
      OCT 015230    .PACK  2 WORD(S)
      OCT 165533
      OCT 052210
      OCT 007220    .XFER  1 WORD(S)
      OCT 166240
      OCT 061040
      OCT 015206    .XPAK  2 WORD(S)
      OCT 166252
      OCT 044010
      OCT 005207    XADD   0 FORTRAN CALLABLE 
      OCT 153106
      OCT 053600
      OCT 005210    XSUB   0 FORTRAN CALLABLE 
      OCT 154447
      OCT 045400
      OCT 005211    XMPY   0 FORTRAN CALLABLE 
      OCT 154062
      OCT 155300
      OCT 005212    XDIV   0 FORTRAN CALLABLE 
      OCT 153303
      OCT 144000
      OCT 015215    .XCOM  2 WORD(S)
      OCT 166235
      OCT 117730
      OCT 015216    ..DCM  2 WORD(S)
      OCT 166426
      OCT 052330
      OCT 005217    DDINT  0 FORTRAN CALLABLE 
      OCT 054703
      OCT 115260
      OCT 005257    .EMAP  0 FORTRAN CALLABLE 
      OCT 164657
      OCT 044320
      OCT 005240    .EMIO  0 FORTRAN CALLABLE 
      OCT 164657
      OCT 075250
      OCT 005241    MMAP   0 FORTRAN CALLABLE 
      OCT 111543
      OCT 121200
      END 
      END 
MCEND EQU * 
      END 
      END 
ASMB,R,L
      NAM OCVT,7 Convert to two digit octal ASCII 
      ENT OCVT
      EXT .ENTR 
WORD  BSS 1 
OCVT  NOP 
      JSB .ENTR 
      DEF WORD
      LDA WORD,I    GET WORD
      AND MASK1     LOW OCTAL DIGIT 
      STA 1         SAVE IN B REG 
      LDA WORD,I
      AND MASK2     HIGH OCTAL DIGIT
      ALF,RAL       5 BITS TO THE LEFT
      ADA 1 
      ADA ZEROS 
      JMP OCVT,I
MASK1 OCT 7 
MASK2 OCT 70
ZEROS ASC 1,00
      END 
  
FTN4,L
      SUBROUTINE MEMRY ,Process LM and LR commands
      IMPLICIT INTEGER (A-Z)
      LOGICAL PARMS 
      COMMON/TERM/LU
      COMMON/RBUF/RBUF(33)
      COMMON/BASE/BASE,REL,DEC,MODE 
      IF (.NOT.PARMS(1)) GO TO 900
      FWA = OCTAL (2) 
      CNT = GPARM (2,1) 
      LST = GPARM (3,LU)
      IF (RBUF(2).NE.2HLM) GO TO 100
      CALL LMEM (FWA,CNT,0,.FALSE.,LST) 
      RETURN
100   CALL LMEM (FWA,CNT,BASE,.FALSE.,LST)
900   RETURN
      END 
FTN4,L
      SUBROUTINE LMEM (FIRST,COUNT,ADDR,DECML,LST)
C IF ADDR # 0, USE AS BASE.  IF DECML, SET DEC TRUE 
      IMPLICIT INTEGER (A-Z)
      DIMENSION FWA (2),MESS(12)
      LOGICAL REL,DEC,DECML 
      COMMON/BASE/BASE,REL,DEC,OFSET
      COMMON/TERM/LU,LIST 
      DATA MESS/2H R,2HEL,2H D,2HIS,2HPL,2HAY ,2H F,2HRO,2HM ,3*2H  / 
  
      FWA = FIRST 
      SAVE = BASE 
      BASE = ADDR 
  
      IF (BASE.EQ.0) GO TO 20 
          REL = .TRUE.
          FWA (2) = FWA 
          IF (DECML) DEC = .TRUE. 
          FWA = FWA + BASE
20    CONTINUE
      IF (.NOT.REL) GO TO 25
        CALL DIGITS (FWA,8,MESS(10))
        CALL EXEC (2,LST,MESS,12) 
        CALL EXEC (2,LST,2H  ,1)
25    CALL LSTM (FWA,COUNT,LST) 
      REL = .FALSE. 
      DEC = .FALSE. 
      BASE = SAVE 
900   RETURN
      END 
      SUBROUTINE LSTM (FWA,COUNT,LIST)
      IMPLICIT INTEGER (A-Z)
      LOGICAL REL,DEC 
      DIMENSION FWA (2),LOC(2),CTR(2),MESS (38) 
      COMMON/BASE/BASE,REL,DEC
      COMMON/IO/INPT,OUTP 
      DATA MESS/2H (,2H  ,2H) / 
        CTR = FWA 
        LWA = FWA + COUNT - 1 
        IF (LWA .LT. FWA) LWA = FWA 
        N = 0 
        CTR (2) = FWA (2) 
      DO 100 LOCN  = FWA,LWA
         IF (IFBRK(D)) 900,10 
10       CTR (1) = LOCN 
         CALL GETEM (CTR,VALUE,INPT)
         CALL DISPL (CTR,INPT,MESS(4),D)
         N = N + 1
         MESS (2) = KCVT (N)
         CALL INVRS (CTR,VALUE,MESS(23),16,NWRD)
         CALL EXEC (2,LIST,MESS,22+NWRD)
100   CTR (2) = CTR (2) + 1 
900   RETURN
      END 
      END$
  
FTN4,L
      SUBROUTINE IFT ,Display IFT 
      IMPLICIT INTEGER (A-Z)
      COMMON/TERM/LU
      COMMON/RBUF/RBUF(33)
      COMMON/IO/INPT,OUTPT
      DIMENSION HEAD (14) 
      DATA HEAD/2H I,2HD.,2H  ,2H  ,2H# ,2HEX,2HT ,2HWO,2HRD,2HS ,
     $          2H= ,2H  ,2H  ,2H  /
      LST = GPARM (2,LU)
      IFTN = GPARM (1,1)
      N = IFTN
        CALL SYMBL (0,IFTS,6H$IFTA )
        CALL GETEM (IFTS,IFTA,INPT) 
        CALL SYMBL (0,TOTAL,6H$IFT#  )
        IF (IFTN.GT.TOTAL .OR. IFTN.LE.0) GO TO 900 
  
10      CALL GETEM (IFTA+6,WD7,INPT)
        EXTN = IAND (WD7,777B)
        N = N - 1 
        IF (N.EQ.0) GO TO 20
        IFTA = IFTA + 7 + EXTN
        GO TO 10
  
20      CALL CNUMD (EXTN,HEAD (12)) 
        CALL GETEM (IFTA+5,TYPE,INPT) 
        TYPE = ROTATE (TYPE,8)
        TYPE = IAND (TYPE,77B)
        HEAD (3) = OCVT (TYPE)
        CALL EXEC (2,LST,HEAD,14) 
  
        CALL LSTM (IFTA,7,LST)
  
        IF (EXTN.EQ.0) GO TO 900
        CALL EXEC (2,LST,2H  ,1)
        CALL EXEC (2,LST,15H IFT EXTENSION:,-15)
  
        CALL LSTM (IFTA+7,EXTN,LST) 
900   RETURN
      END 
  
FTN4,L
      SUBROUTINE DVT ,Display DVT 
      IMPLICIT INTEGER (A-Z)
      COMMON/IO/INPT,OUTPT
      COMMON/TERM/LU
      COMMON/RBUF/RBUF(33)
      DIMENSION HEAD (14) 
      DATA HEAD/2H D,2HD.,2H  ,2H  ,2H# ,2HDV,2HR ,2HPA,2HRM,2HS ,
     $          2H= ,2H  ,2H  ,2H  /
      LST = GPARM (2,LU)
      N =   GPARM (1,1) 
        CALL SYMBL (0,DVTS,6H$DVTA )
        CALL GETEM (DVTS,DVTA,INPT) 
        CALL SYMBL (0,DVNUM,6H$DVT#  )
        IF (N.GT.DVNUM .OR. N.LE.0) GO TO 900 
  
10      CALL GETEM (DVTA+20,WD21,INPT)
        WD21 = ROTATE (WD21,9)
        NP = IAND (WD21,177B) 
        N = N - 1 
        IF (N.EQ.0) GO TO 20
        DVTA = DVTA + 22 + NP 
        GO TO 10
  
20      CALL CNUMD (NP,HEAD (12)) 
        CALL GETEM (DVTA+5,TYPE,INPT) 
        TYPE = ROTATE (TYPE,8)
        TYPE = IAND (TYPE,77B)
        HEAD (3) = OCVT (TYPE)
        CALL EXEC (2,LST,HEAD,14) 
  
        CALL LSTM (DVTA,22,LST) 
  
        CALL EXEC (2,LST,2H  ,1)
        CALL EXEC (2,LST,11H DVR PARMS:,-11)
  
        CALL LSTM (DVTA+22,NP,LST)
  
900   RETURN
      END 
  
FTN4,L
      SUBROUTINE ID ,Display ID 
      IMPLICIT INTEGER (A-Z)
      COMMON/TERM/LU
      COMMON/IO/INPT,OUTPT
      IDN = GPARM (1,1) 
      LST = GPARM (2,LU)
  
        CALL SYMBL (0,IDS,6H$IDA  ) 
        CALL GETEM (IDS,IDA,INPT) 
        CALL SYMBL (0,TOT,6H$ID#   )
        CALL GETEM (TOT,TOTAL,INPT) 
        IF (IDN.GT.TOTAL .OR. IDN.LE.0) GO TO 900 
  
        CALL SYMBL (0,IDME,6H$IDSZ )
        CALL GETEM (IDME,IDSZ,INPT) 
  
        FWA = (IDN - 1) * IDSZ + IDA
  
        CALL LSTM (FWA,IDSZ,LST)
  
900   RETURN
      END 
  
FTN4,L
      SUBROUTINE CALC 
      IMPLICIT INTEGER (A-Z)
      LOGICAL PARMS 
      COMMON/TERM/LU
      COMMON/RBUF/RBUF(33)
      IF (RBUF(33).GT.2) GO TO 100
          CALL SHOWB (LU+2000B,-1,RBUF(6))
          CALL BITS (RBUF(6),LU)
          GO TO 900 
100   IF (.NOT.PARMS(3)) GO TO 900
      WD1 = GPARM (1,1) 
      OP = GPARM (2,2H/ ) 
      WD2 = GPARM (3,1) 
      IF (OP.EQ.2H+ ) ANS = WD1 + WD2 
      IF (OP.EQ.2H- ) ANS = WD1 - WD2 
      IF (OP.EQ.2H* ) ANS = WD1 * WD2 
      IF (OP.EQ.2H/ ) ANS = WD1 / WD2 
      CALL SHOWB (LU+2000B,-1,ANS)
      CALL BITS (ANS,LU)
900   RETURN
      END 
      END$
  
FTN4,L
      SUBROUTINE TRACE
      IMPLICIT INTEGER (A-Z)
      LOGICAL PARMS 
      DIMENSION MESS (24), LABEL (23) 
      COMMON/TERM/LU
      COMMON/IO/INPT,OUTP 
      EQUIVALENCE (ADLOC,MESS(2)),(CNLOC,MESS(6)),
     .            (ADLINK,MESS(18)),(CNLINK,MESS(22)) 
      DATA MESS/2H (,2H  ,2H  ,2H  ,2H):,2H  ,2H  ,2H  ,
     .          8*2H  , 
     .          2H (,2H  ,2H  ,2H  ,2H):,2H  ,2H  ,2H  /
      DATA LABEL/2H F,2HWA,2H O,2HF ,2HME,2HM ,2H B,2HLK, 
     .          8*2H  , 
     .          2H C,2HON,2HTE,2HNT,2HS ,2HLI,2HNK/ 
      IF (.NOT.PARMS(1)) GO TO 900
        LABEL (5) = INPT
        LABEL (6) = 2HM 
        IF (INPT.EQ.2HDI) LABEL (6) =2HSC 
      FWA = OCTAL (2) 
      OFSET = GPARM (2,0) 
      TERM = GPARM (3,0)
      LIST = GPARM (4,LU) 
      LOC = FWA 
      CALL EXEC (2,LIST,LABEL,23) 
      CALL EXEC (2,LIST,2H  ,1) 
10    LINK = LOC + OFSET
      CALL GETEM (LOC,VLOC,INPT)
      CALL GETEM (LINK,VLINK,INPT)
      CALL DIGITS (LOC,8,ADLOC) 
           CALL DIGITS (VLOC,8,CNLOC) 
      CALL DIGITS (LINK,8,ADLINK) 
           CALL DIGITS (VLINK,8,CNLINK) 
      CALL EXEC (2,LIST,MESS,24)
      IF (VLINK.EQ.FWA .OR. VLINK .EQ. TERM) GO TO 900
      LOC = IAND (VLINK,77777B) 
      IF (LOC.EQ.FWA) GO TO 900 
      IF (IFBRK(D)) 900,10
  
900   RETURN
      END 
      END$
FTN4,L
      SUBROUTINE SETBA
      IMPLICIT INTEGER (A-Z)
      COMMON/TERM/LU
      COMMON/BASE/BASE,REL,DEC,MODE 
      COMMON/RBUF/RBUF(33)
      DIMENSION MESS(9) 
      DATA MESS/2H B,2HAS,2HE ,2HAD,2HDR,2H =,3*2H  / 
      IF (RBUF(5).NE.0 ) GO TO 20 
  
         CALL CNUMO (BASE,MESS(7))
         CALL EXEC (2,LU,MESS,9)
         GO TO 900
  
20    BASE = OCTAL (2)
  
  
900   RETURN
      END 
      END$
FTN4,L
      SUBROUTINE SECTS
      IMPLICIT INTEGER (A-Z)
      COMMON/NSECTS/NSECTS
      COMMON/TERM/LU
      COMMON/RBUF/RBUF(33)
      DIMENSION MESS (11) 
      DATA MESS/2H# ,2HSE,2HCT,2HOR,2HS/,2HTR,2HAC,2HK=,3*2H  / 
      IF (RBUF(5).EQ.0) GO TO 100 
          NSECTS = RBUF (6) 
          GO TO 900 
100   CALL CNUMD (NSECTS,MESS(9)) 
      CALL EXEC (2,LU,MESS,11)
900   RETURN
      END 
      END$
FTN4,L
      SUBROUTINE SETIO
      IMPLICIT INTEGER (A-Z)
      COMMON/IO/INPT,OUTPT,NAME(3),SEC,CART 
      COMMON/RBUF/RBUF(33)
      COMMON/TERM/LU
      DIMENSION MESS (11) 
      DATA MESS/2HIN,2HPU,2HT=,2H  ,2H  ,2H/O,2HUT,2HPU,2HT=/ 
      IF (.NOT.(RBUF(5).EQ.0 .AND. RBUF(9) .EQ.0)) GO TO 100
      MESS(4) = INPT
      MESS(10) = OUTPT
      MESS (5) = 2HM
      MESS (11) = 2HSC
      IF (MESS(4).EQ.2HDI) MESS (5) = 2HSC
      IF (MESS(10).EQ.2HME) MESS (11) = 2HM 
      CALL EXEC (2,LU,MESS,11)
      GO TO 900 
100   IF (RBUF(6).EQ.2HME .OR. RBUF(6).EQ.2HDI) INPT = RBUF(6)
      IF (RBUF(10).EQ.2HME .OR. RBUF(10).EQ.2HDI) OUTPT = RBUF(10)
900   RETURN
      END 
      END$
FTN4,L
      LOGICAL FUNCTION SYMBL (LIST,VALUE,NAME)
C IF LIST = 0 DONT DONT LIST SYMBOL VALUE. ALWAYS RETURN
C VALUE IN PARAMETER OF THAT NAME.
      IMPLICIT INTEGER (A-Z)
      DIMENSION NAME (3)
      LOGICAL ISEQL, IFBRK, DISPL 
      COMMON/RBUF/RBUF(33)
      COMMON/TERM/LU
      COMMON/IO/INPT,OUTPT
      COMMON/SNAP/SNAP(9),SNERR,DCBSN(144),RECSN(128) 
      COMMON/SNDAT/NENTS,NLIBS,LWABG,FWABG,FWART, 
     .            SYBP,BGBP,RTBP,FWAC,LCOM,SYSID,CKSUM
      DIMENSION MESS (24),TYPES(5)
      EQUIVALENCE (NUMBR,MESS(3)) 
      DATA MESS/2H  ,2H  ,2H  ,2H  ,2H  ,2H  ,2H  ,2H  /
      DATA TYPES/2HMR,2HUN,2HCM,2HAB,2HRP/
      CALL RWNDF (DCBSN,SNERR)
      CALL FREAD (SNAP,1) 
  
      DO 100 I = 1,NENTS
  
        IF (IFBRK(DUM)) 900,10
10      LEN = FREAD (SNAP,I)
        IF (LEN .LT. 0)  GO TO 900
  
        IF (.NOT.(ISEQL(NAME,RECSN(2),RECSN(1))))  GO TO 100
  
        SYMBL = .TRUE.
        VALUE = RECSN (6) 
        IF (LIST .EQ. 0) GO TO 900
  
        MESS (1) = TYPES (RECSN(5)+1) 
        CALL CNUMO (VALUE,NUMBR)
        SIZE = 5
        IF (DISPL(VALUE,INPT,MESS(6),D).AND.(MESS.NE.2HRP)) 
     $       SIZE = SIZE + 19 
        CALL EXEC (2,LU,MESS,SIZE)
        GO TO 900 
  
100   CONTINUE
  
      SYMBL = .FALSE. 
      IF (LIST .EQ. 0) GO TO 900
      CALL EXEC (2,LU,10H NOT FOUND,-10)
  
900   RETURN
      END 
      END$
FTN4,L
      SUBROUTINE STABL
      IMPLICIT INTEGER (A-Z)
      LOGICAL IFBRK, DISPL, TEST
      COMMON/RBUF/RBUF(33)
      COMMON/TERM/LU
      COMMON/IO/INPT,OUTPT
      COMMON/SNAP/SNAP(9),SNERR,DCBSN(144),RECSN(128) 
      COMMON/SNDAT/NENTS,NLIBS,LWABG,FWABG,FWART, 
     .            SYBP,BGBP,RTBP,FWAC,LCOM,SYSID,CKSUM
      DIMENSION MESS (12),TYPES(5),SYMBL(3),OBUF(32)
      EQUIVALENCE (NUMBR,MESS(3)),(MESS(7),SYMBL),(MESS,OBUF(2))
      DATA MESS/2H  ,2H  ,2H  ,2H  ,2H  ,2H  ,2H  ,2H  ,2H  / 
      DATA TYPES/2HMR,2HUN,2HCM,2HAB,2HRP/
      DATA OBUF/2H  / 
      CALL RWNDF (DCBSN,SNERR)
      CALL FREAD (SNAP,1) 
      LIST = LU 
      IF (RBUF(5) .NE. 0) LIST = RBUF (6) 
      DO 100 I = 1,NENTS
  
        IF (IFBRK(DUM)) 900,10
10      LEN = FREAD (SNAP,I+1)
        IF (LEN .LT. 0)  GO TO 900
  
        MESS (1) = TYPES (RECSN(5)+1) 
        CALL CNUMO (RECSN(6),NUMBR) 
        CALL MOVE (RECSN(2),SYMBL,3)
        TEST =  DISPL (RECSN(6),INPT,OBUF(14),D)
        SIZE = 13 
        IF (TEST .AND. (MESS(1).NE.2HRP)) SIZE = SIZE + 19
        CALL EXEC (2,LIST,OBUF,SIZE)
  
100   CONTINUE
  
900   RETURN
      END 
      END$
FTN4,L
      SUBROUTINE CLIST
      IMPLICIT INTEGER (A-Z)
      COMMON/RBUF/RBUF(33)
      COMMON/TERM/LU
      EQUIVALENCE (LIST,RBUF(10)), (COMND,RBUF(6))
      IF (RBUF(9).NE.1) LIST = LU 
      IF (RBUF(5).EQ.0) COMND = 2H
         CALL HELP (COMND,LIST) 
      RETURN
      END 
      END$
ASMB,L
      NAM HELP,7
      SUP 
      ENT HELP
      EXT .ENTR,PRINT 
A     EQU 0 
B     EQU 1 
CHARS BSS 1         CHAR CODE FOR COMMAND 
LU    BSS 1         LIST DEVICE LU
HELP  NOP 
      JSB .ENTR 
      DEF CHARS 
      LDB .MESS     ADDR OF MESSAGE LIST
LOOP  LDA B,I       GET ASCII CODE OR ZERO
      INB           POINT TO ADDRESS OF MESSAGE 
      SZA,RSS 
      JMP NG        NOT FOUND 
* 
      CPA CHARS,I 
      JMP OK        FOUND IT
* 
      INB           POINT TO NEXT CODE
      JMP LOOP
NG    LDA .WHAT 
      STA ADDR
      JMP DOIT
OK    LDA B,I       GET ADDRESS 
      STA ADDR
DOIT  JSB PRINT 
      DEF RETN
ADDR  NOP 
      DEF LU,I
RETN  JMP HELP,I
* 
BIT15 OCT 100000
.MESS DEF MESS
MESS  ASC 1,        NEED MASTER LIST OF COMMANDS
      DEF MLIST 
      ASC 1,??
      DEF ??
      ASC 1,/E      EXIT
      DEF NONE
      ASC 1,N       VIEW/MODIFY ADDR
      DEF N 
      ASC 1,LI
      DEF LI
      ASC 1,MD
      DEF MD
      ASC 1,DI
      DEF DI
      ASC 1,DS
      DEF DS
      ASC 1,FI
      DEF FI
      ASC 1,LM
      DEF LM
      ASC 1,LR
      DEF LR
      ASC 1,BA
      DEF BA
      ASC 1,TR
      DEF TR
      ASC 1,CA
      DEF CA
      ASC 1,NS
      DEF NS
      ASC 1,IO
      DEF IO
      ASC 1,DL
      DEF DL
      ASC 1,DM
      DEF DM
      ASC 1,DV
      DEF DV
      ASC 1,IF
      DEF IF
      ASC 1,ID
      DEF ID
      DEC 0         END OF LIST 
* $ TERMINATES LINE 
* @ CONTINUES LINE
* \ TERMINATES LIST 
MLIST ASC 10, INPUT  Function$  $ 
      ASC  5, ??  Help$ 
      ASC  5, /E  Exit$ 
      ASC 12, N   See/modify system $ 
      ASC 14, LI  List Symbol from SNAP $ 
      ASC  9, LM  List Memory $ 
      ASC 18, LR  List memory relative to BASE  $ 
      ASC  8, TR  TRace list$ 
      ASC 13, CA  CAlculate or display$ 
      ASC 19, BA  Set BASE addr for LR command    $ 
      ASC  9, MD  Memory Dump $ 
      ASC 15, DI  Display snap & contents $ 
      ASC  8, DL  List disc $ 
      ASC  9, DM  Disc Modify $ 
      ASC 13, IO  See/set input/output$ 
      ASC 19, FI  FInd (search) system for values $ 
      ASC 14, DS  Search disc for values$ 
      ASC  9, DV  Device Table$ 
      ASC 11, IF  Interface Table $ 
      ASC  8, ID  ID Segment$ 
      ASC 20, NS  See/set # sectors/track (for DS)$ $ 
      ASC 17,    Type ??,INPUT for more help$\
* END OF MASTER HELP LIST 
FI    ASC 18, FI,1st addr,last addr,<3 words max@ 
      ASC 15, or ASCII word of 6 chars> $\
MD    ASC 12, MD,1st addr,last addr$\ 
??    ASC 13, ??[,command][,list LU]$\
LI    ASC 16, Symbol value (octal) shown as:$ 
      ASC 18,    RP = value replaces JSB symbol $ 
      ASC 15,    MR = memory resident addr$ 
      ASC 13,    CM = addr in COMMON$\
DS    ASC 13, DS,LU,TRAK,<3 words max @   
      ASC 14,or ASCII word of 6 chars> $\ 
DL    ASC 14, DL,LU,TR[,SECT][,# SECTS]$\ 
NS    ASC 14, NS[,# sectors (64 word)]$\
DI    ASC  8, DI[,list LU] $\ 
TR    ASC 20, TR,fwa[,ofset][,terminator][list LU] $\ 
CA    ASC 17, CA,P1[,Operator (+,-,*,/)][,P2]$\ 
LM    ASC 16, LM,1st ADDR[,count][,list lu]$\ 
LR    ASC 16, LR,1st ADDR[,count][,list lu] $ 
      ASC 16,   ADDR added to base (See BA) $ 
      ASC 14,   LRX > dec disp rel loc $\ 
BA    ASC 10, BA[,New BAse addr]$ 
      ASC 12,   Use for LR command $\ 
IO    ASC 17, IO[,MEm or DIsc][,MEm or DIsc]$\
DV    ASC  6, DV,DVT # $\ 
IF    ASC  6, IF,IFT # $\ 
ID    ASC  6, ID,ID #  $\ 
.NONE DEF NONE
NONE  ASC 8, NO MORE HELP!$\
DM    ASC 11, DM,LU,track[,sector]$ 
      ASC 19, DISC MOD SUBPROCESSOR (PROMPT = --) $ 
      ASC 18, Reads disc tr/sect into 64 wd buff$ 
      ASC 10,   LI = List Buffer$ 
      ASC 18,   N  = See/modify word N in buffer$ 
      ASC 18,        This is just like N command$ 
      ASC 18,        for system. View or modify $ 
      ASC 18,        buffer and exit in same way$ 
      ASC 17,   /E = Exit subprocessor. If any$ 
      ASC 19,        patch to buffer, you will be $ 
      ASC 20,        asked if you wish to write the $ 
      ASC 20,        buffer to the disc before exit$\ 
N     ASC  6, N[,R[,D]] $ 
      ASC 18,    R : N is added to BASE address $ 
      ASC 19,    D : In R mode, read N as decimal $ 
      ASC 19, N = octal addr. Location of addr is $ 
      ASC 18,     input (memory or system file) $ 
      ASC 20,     shown by IO command. Contents are $ 
      ASC 19,     shown in octal, decimal & ascii.$ 
      ASC  7,     Enter:$ $ 
      ASC 16,        cr    View next address$ 
      ASC 15,              cr = return key$ 
      ASC 19,      N cr    Patch current loc to N $ 
      ASC 19,              (trailing B for octal) $ 
      ASC 17,       ,/E cr Exit from view mode$ 
      ASC  1, $ 
      ASC 20,     Patches go to output shown by IO$ \ 
.WHAT DEF NOCOM 
NOCOM ASC 12, NOT A VALID COMMAND $\
      END MLIST 
FTN4,L
      SUBROUTINE PRINT (ADDR,LU)
      IMPLICIT INTEGER (A-Z)
      DIMENSION OBUF (40) 
      PTR = 1 
      CALL SETSB (ADDR,PTR,32000) 
50    SIZE = 0
      CALL SETDB (OBUF,SIZE)
100   CHAR = KHAR (CHAR)
      IF (CHAR .EQ. 1H\ ) GO TO 900 
      IF (CHAR .EQ. 1H@ ) GO TO 100 
      IF (CHAR .EQ. 1H$ ) GO TO 200 
      CALL CPUT (CHAR)
      IF (SIZE .EQ. 80) GO TO 200 
      GO TO 100 
200   CALL EXEC (2,LU,OBUF,-SIZE) 
      GO TO  50 
900   RETURN
      END 
      END$
FTN4,L
      SUBROUTINE MDUMP
      IMPLICIT INTEGER (A-Z)
      LOGICAL PARMS 
      COMMON/TERM/LU
      COMMON/IO/INPT,OUTP 
      DIMENSION BUF(8),OBUF(40),MESS(19)
      DATA OBUF/2H (,2H  ,2H):/ 
      DATA MESS/2H L,2HOC,5*2H  ,2HTH,2HRU,5*2H  ,2HFR,2HOM,2H  / 
      IF (.NOT.PARMS(2)) GO TO 900
      LIST = GPARM (3,LU) 
      FWA = OCTAL (2) 
      LWA = OCTAL (3) 
      FWA = FWA - MOD (FWA,8) 
      LWA = LWA + 8 - MOD (LWA+8,8) -1
      LINE = 0
      NUMB = 0
      MESS (18) = INPT
      MESS (19) = 2HSC
      IF (INPT.EQ.2HME) MESS (19) = 2HM 
      DO 100 MEM = FWA, LWA, 64 
        IF (IFBRK(D)) 900,10
10      LAST = MIN0 (MEM+63,LWA)
        IF (LAST.LE.MEM) GO TO 100
        DO 90 LOC = MEM, LAST, 8
         LINE = MOD (LINE,8)
         NUMB = MOD (NUMB,80) 
         IF (LINE.NE.0) GO TO 20
            CALL CNUMO (MEM,MESS(4))
            N = MIN0 (LOC+63,LWA) 
            CALL CNUMO (N,MESS(11)) 
            CALL EXEC (2,LIST,2H  ,1) 
            CALL EXEC (2,LIST,MESS,19)
20       DO 30 L = 0,7
30          CALL GETEM (LOC+L,BUF(L+1),INPT)
            CALL FLINE (BUF,OBUF(3),SIZE) 
            OBUF (2) = KCVT (NUMB)
            OBUF (3) = IAND (OBUF(3),377B) + 24400B 
            CALL EXEC (2,LIST,OBUF,-(SIZE+4)) 
         LINE = LINE + 1
90       NUMB = NUMB + 10 
100   CONTINUE
900   RETURN
      END 
      END$
FTN4,L
      SUBROUTINE FWORD
      IMPLICIT INTEGER (A-Z)
      LOGICAL ISEQL,FLAG,PARMS
      COMMON/IO/INPT,OUTP 
      COMMON/RBUF/RBUF(33)
      COMMON/NSECTS/NSECTS
      COMMON/RTE/SYTYPE 
      COMMON/SNDAT/NENTS,NLIBS,LWABG,FWABG
      COMMON/SYSTM/SYSTM(9),SYERR,DCBSY(144),RECSY(128) 
      COMMON/TERM/LU
      DIMENSION MBUF (66) 
      DIMENSION WORDS (3),OBUF(20)
      DATA OBUF/2H S,2HEC,2HT:,2H  ,2H  ,2H  ,2HWD,2H: ,12*2H  /
      NWORDS = 0
      FLAG = .FALSE.
      IF (.NOT.PARMS(3)) GO TO 900
  
C  IF FIRST PARM PARSED AS NUMERIC, ASSUME THE REST DID ALSO
C  AND SEE HOW MANY (UP TO 3).  OTHERWISE PICK UP 3 WORDS FROM
C  ASCII PARSE. 
  
      IF (RBUF(13).EQ.1) GO TO 10 
         WORDS (1) = RBUF (14)
         WORDS (2) = RBUF (15)
         WORDS (3) = RBUF (16)
         NWORDS = 3 
         GO TO 25 
10    NWORDS = RBUF (33) - 3
      DO 20 J=1,NWORDS
20    WORDS (J) = RBUF (J*4+10) 
  
25      IF (RBUF(2).EQ.2HDS) GO TO 500
  
        START = OCTAL (2) 
        LAST = OCTAL (3)
  
      DO 100 J = START,LAST,64
        DO 30 L = 0,65
30      CALL GETEM (J+L,MBUF(L+1),INPT) 
        IF (IFBRK(D)) 999,35
35      DO 40 L = 0,63
        IF (J+L .GT. FWABG) GO TO 40
        IF (.NOT.(ISEQL(MBUF(L+1),WORDS,NWORDS))) GO TO 40
            CALL SHOW (LU,J+L,INPT) 
            FLAG = .TRUE. 
40    CONTINUE
100   CONTINUE
      GO TO 900 
500   DISK = GPARM (1,0) + SYTYPE 
      TR = GPARM (2,0)
      DO 600 SECNO = 0, NSECTS -1 
  
      IF (IFBRK(D)) 999,505 
505    SN = 2 * (SECNO/2) 
       CALL EXEC (1,DISK,RECSY,128,TR,SN) 
         LAST = 64
       IF (IAND(SECNO,1).EQ.0) GO TO 507
            CALL MOVE (RECSY(65),RECSY,64)
            IF (SECNO.GT.NSECTS-3) GO TO 507
               LAST = 65 - NWORDS 
            CALL EXEC (1,DISK,RECSY(65),64,TR,SN+2) 
507    DO 510 K = 1, LAST 
       IF (.NOT.(ISEQL(RECSY(K),WORDS,NWORDS))) GO TO 510 
          FLAG = .TRUE. 
          CALL CNUMD (SECNO,OBUF(3))
          OBUF (3) = 2HT: 
          OBUF(9) = KCVT (K)
          CALL DIGITS (RECSY(K),8,OBUF(11)) 
          CALL DIGITS (RECSY(K),10,OBUF(15))
          OBUF(19) = ASCII (RECSY(K)) 
          CALL EXEC (2,LU,OBUF,20)
510   CONTINUE
600   CONTINUE
900   IF (.NOT.FLAG) CALL EXEC (2,LU,11H NOT FOUND!,-11)
999   FLAG = .FALSE.
      RETURN
      END 
      END$
  
FTN4,L
        SUBROUTINE FLINE (INBUF,OBUF,OSIZE) 
  
C FORMAT LINE FOR ASCII DISPLAY 
C NNNNNN NNNNNN NNNNNN NNNNNN NNNNNN NNNNNN NNNNNN NNNNNN*AAAAAAAAAAAAAAAA
C !<-------- OCTAL NUMBERS ----------------------------->!<-- ALPHA ---->!
  
        IMPLICIT INTEGER (A-Z)
        DIMENSION INBUF (8), OBUF (37), TEMP (24) 
        DATA MAXCH/77440B/
  
C NOTE: OSIZE = NUMBER OF CHARS PUT INTO OBUF. WILL BE
C       EXACTLY 74.  THEREFORE CALLING PROG SHUD DIMENSION
C       OBUF TO AT LEAST 37 WORDS 
  
        DO 70 L = 0, 7
70        CALL DIGITS (INBUF(L+1),8,TEMP(3*L+1))
        OSIZE = 0 
        CALL SETDB (OBUF,OSIZE) 
        DO 73 L = 0, 7
         CALL CPUT (1H )
73       CALL ZPUT (TEMP(3*L+1),1,6)
        CALL CPUT (1H*  ) 
        PTR = 1 
        CALL SETSB (INBUF,PTR,16) 
        DO 75 K = 1, 16 
          CHAR = KHAR (CHAR)
          IF (CHAR .LT. 1H  .OR.  CHAR .GT. MAXCH) CHAR = 1H  
75        CALL CPUT (CHAR)
      CALL CPUT (1H  )
      RETURN
      END 
      END$
FTN4,L
      SUBROUTINE DMODF
      IMPLICIT INTEGER (A-Z)
      LOGICAL FLAG,PARMS
      COMMON/DM/DM
      COMMON/RTE/SYTYPE 
      COMMON/RBUF/RBUF(33)
      DIMENSION ANSR(5),OUTPT(40) 
      COMMON/HEADR/HD1(3),DKLU(3),HD2(4),TRACK(3),HD3(4),SECTR(3) 
      COMMON/TERM/LU
      COMMON/SNAP/SNAP(9),SNERR,DCBSN(144),RECSN(128) 
      COMMON/SYSTM/SYSTM(9),SYERR,DCBSY(144),RECSY(128) 
      DIMENSION BUFR (128)
C DM,LU,TR,SECT 
C  NOTE: SYTYPE = 7700B FOR RTE-L, 177400B FOR RTE-IV 
  
      CALL CLOSE (SNAP) 
      CALL CLOSE (SYSTM)
      FLAG = .FALSE.
      IF (.NOT.PARMS(2)) GO TO 900
        DISK = GPARM (1,0)
        TR   = GPARM (2,0)
        SECT = GPARM (3,0)
  
10    SN = 2*(SECT/2) 
  
      CALL EXEC (1,DISK+SYTYPE,BUFR,128,TR,SN)
       INDX = IAND (SECT,1) 
       CALL MOVE (BUFR(1+64*INDX),RECSY(1),64)
      CALL CNUMD (DISK,DKLU)
      CALL CNUMD (TR,TRACK) 
      CALL CNUMD (SECT,SECTR) 
      CALL EXEC (2,LU,HD1,20) 
  
15    CALL EXEC (2,LU,16HTYPE ?? FOR HELP,-16)
  
20    CALL EXEC (2,LU+2000B,2H--,1) 
      CALL REIO (1,LU+400B,ANSR,-10)
      CALL ABREG (STATUS,SIZE)
      CALL PARSE (ANSR,SIZE,RBUF) 
  
      IF (RBUF.EQ.1) GO TO 25 
      IF (RBUF(2).EQ.2H/E) GO TO 200
      IF (RBUF(2).NE.2H??) GO TO 21 
          CALL HELP (2HDM,LU) 
          GO TO 20
  
21    IF (RBUF(2).NE.2HLI) GO TO 15 
  
      CALL EXEC (2,LU,1H  ,1) 
      CALL EXEC (2,LU,HD1,20) 
  
      DO 22 L = 1,57,8
         CALL FLINE (RECSY(L),OUTPT,LEN)
22       CALL EXEC (2,LU,OUTPT,-LEN)
  
      GO TO 20
  
25    INDEX = RBUF (2)
  
30    IF (INDEX .GT. 64  .OR. INDEX .LT. 1) GO TO 15
  
      CALL SHOWB (LU+2000B,INDEX,RECSY(INDEX))
  
      CALL REIO (1,LU+400B,ANSR,-10)
      CALL ABREG (STATUS,SIZE)
      CALL PARSE (ANSR,SIZE,RBUF) 
      IF (RBUF .EQ. 0) GO TO 40 
         FLAG = .TRUE.
         RECSY(INDEX) = RBUF(2) 
         CALL EXEC (2,LU+2000B,29HPATCH MADE TO SECTOR BUFFER: ,-29)
         CALL SHOWB (LU,INDEX,RECSY(INDEX)) 
40    IF (RBUF(5).NE.0) GO TO 100 
          INDEX = INDEX + 1 
          GO TO 30
  
100   IF (RBUF(6).EQ.2H/E .OR. RBUF(10).EQ.2H/E) GO TO 20 
  
200   IF (.NOT.FLAG) GO TO 900
      CALL EXEC (2,LU+2000B,15HWRITE TO DISC? ,-15) 
      CALL REIO (1,LU+400B,ANSR,-10)
      IF (ANSR.NE.2HYE) GO TO 900 
  
      CALL MOVE (RECSY,BUFR(1+64*INDX),64)
      CALL EXEC (2,DISK+SYTYPE,BUFR,128,TR,SN)
      CALL EXEC (2,LU,7H DONE !,-7) 
  
900   RETURN
      CALL FOPEN (SNAP) 
      CALL FOPEN (SYSTM)
      END 
FTN4,L
      SUBROUTINE DLIST
      IMPLICIT INTEGER (A-Z)
      LOGICAL PARMS 
      DIMENSION ANSR (5),OBUF (40), TEMP (24) 
      COMMON/HEADR/HD1(3),DKLU(3),HD2(4),TRACK(3),HD3(4),SECTR(3) 
      COMMON/TERM/LU
      COMMON/RTE/SYTYPE 
      COMMON/SYSTM/SYSTM(9),SYERR,DCBSY(144),RECSY(128) 
  
         IF (.NOT.PARMS(2)) GO TO 900 
  
10       DISK = GPARM (1,0) 
C NOTE: SYTYPE = 7700B FOR RTE-L, 177400B FOR RTE-IV
         DLU = DISK + SYTYPE
         TR = GPARM (2,0) 
         SECT = GPARM (3,0) 
         NSECTS = GPARM (4,1) 
         LIST = GPARM (5,LU)
  
      SNUM = SECT 
  
      DO 100 I=1,NSECTS 
  
        IF (IFBRK(D)) 900,20
20      SN = 2 * (SNUM/2) 
        CALL EXEC (1,DLU,RECSY,128,TR,SN) 
        IF (IAND(SNUM,1).EQ.1) CALL MOVE (RECSY(65),RECSY,64) 
        CALL CNUMD (DISK,DKLU)
        CALL CNUMD (TR,TRACK) 
        CALL CNUMD (SNUM,SECTR) 
  
        CALL EXEC (2,LIST,2H  ,1) 
  
        CALL EXEC (2,LIST,HD1,20) 
        DO 80 J = 1,57,8
        CALL FLINE (RECSY(J),OBUF,OSIZE)
80      CALL EXEC (2,LIST,OBUF,-OSIZE)
100   SNUM = SNUM + 1 
900   RETURN
      END 
      BLOCK DATA
      IMPLICIT INTEGER (A-Z)
      COMMON/HEADR/HEADR(20)
      DATA HEADR/2H  ,2HLU,2H: ,2H  ,2H  ,2H  ,2H  ,2H  , 
     .           2HTR,2H: ,2H  ,2H  ,2H  ,2H  ,2HSE,2HCT, 
     .           2H: ,2H  ,2H  ,2H  / 
  
      END 
      END$