PDP-10 Archive: decus/20-0050/tblopr.for from decuslib20-02

Trailing-Edge - PDP-10 Archives - decuslib20-02 - decus/20-0050/tblopr.for
There is 1 other file named tblopr.for in the archive. Click here to see a list.
      SUBROUTINE TBLOPR
C
C     TBLTRN ROUTINE TO IDENTIFY AND PERFORM OPERATION
C     INDICATED BY SYMBOL IN RANGE OF OPERATOR.
C
C     DONALD BARTH, CHEMISTRY DEPT., HARVARD UNIVERSITY
C
      COMMON/TBLTRN/I,IADDRS,IADJST,IBASE,IBLANK,IDGT(16),
     1IERR,IFILL,IFKNT,IKODE,ILEFT,ILINE,ILPT,ILTR,IBYTE,
     2IMASK,LMAX,NMORE,IMOST,INSERT,IOCT(13),IOPRTR,IOUT,
     3IPAREN,IPNCTN(11),IPRCN,IRADIX,IREAD,IREPT,IRIGHT,
     4ISHIFT,ISIGN,ISTAR,ISTORE(478),ITEN,ITEST,ITITLE(6),
     5ITTY,IWIDE,IWRITE,J,JADJST,JBASE,JBLANK,JERR,KPAREN,
     6JFKNT,JKODE(37),JLEFT,JMASK,JMORE,JPAREN,JRADIX,LOOP,
     7JRIGHT,JSHIFT,JSIGN,K,KADJST,KBASE,KERR,KIND,KLINE,
     8KLM,KLTR,KMASK,KNT,KNTLTR,KNTWRD,KODE,KRADIX,IDBG,
     9KREAD,KSHIFT,L,LEAST,LETTER(160),LMASK,LOCK,LSTNEW,
     1LTTR(160),M,MASK,MASTER(5000),MAX,MLEFT,MORE,MOST,
     2MRIGHT,MULT,N,NEW,NEXT,NSIGN,NTITLE(6),NUMBER,LRADIX,
     3KMAX,INLINE,JPNCTN(50),KPNCTN(50),LPNCTN,JOPRTR,NLTR,
     4JBYTE,ILOOP,ISKIP,IVALUE,INSN(6),JNSN,IMAX,JMAX,
     5KNSN,MLTR,JLTR,JLOOP,IPFX,JPFX,LSIGN,IIARG,JJARG,
     6KKARG,LLARG,JVALUE,MIN,IAC,IARG,JARG,KARG,LARG,JSTFY,
     7LENGTH(20),LNGMIN,IORDER,IRMV,KSIGN
C
C     ***********************************
C     *   SYMBOL IN RANGE OF OPERATOR   *
C     ***********************************
C
      GO TO(153,153,137,153,153,153,153,153,153,153,153,153,
     123,33,36,153,153,153,153,153,153,153,153,144,153,153,
     22,2,153,2,153,2,153,2,153,153,36,153,111,2,67,2,153,
     32,153,2,153,2,153,2,153,2,153,153,153,153,153,2,153,
     42,2,2,153,2,153,153,153,75,153,77,76,153,85,2,153,
     586,88,90,2,153,32,2,153,2,129,89,87,2,2,2,
     62,2,2,2,2,2,99,2,100,2,102,2,104,2,103,2,101,
     72,107,2,108,2,109,2,2,2,2,153,2,153,153,2,153,153,
     8153,2,153,2,112,2,124,2,143,153,153,153),IOPRTR
C
C     *************************************
C     *  OPERATORS WHICH CAN TAKE PREFIX  *
C     *************************************
C
    1 KNTWRD=KNTWRD-1
      IF(KODE.EQ.45)GO TO 155
      IF(KODE.EQ.47)GO TO 153
    2 IF(KODE.EQ.66)GO TO 13
      IF(KODE.GE.1001)GO TO 9
      IF(KODE.LE.2)GO TO 15
      IF(KODE.EQ.54)GO TO 7
      IF(KODE.EQ.55)GO TO 8
      IF(KODE.EQ.11)GO TO 155
      IF(KODE.EQ.12)GO TO 155
      IF(KODE.EQ.47)GO TO 155
      IF(KODE.EQ.125)GO TO 3
      IF(KODE.EQ.127)GO TO 155
      IF(KODE.EQ.10)GO TO 4
      IF(KODE.EQ.9)GO TO 5
      IF(KODE.EQ.38)GO TO 6
      IF(KODE.NE.124)GO TO 153
C
C     SIGNS + - IOR
      KSIGN=1
      GO TO 147
    3 KSIGN=2
      GO TO 147
    4 KSIGN=3
      GO TO 147
    5 KSIGN=4
      GO TO 147
    6 KSIGN=5
      GO TO 147
C
C     PARENTHESIS
    7 LSIGN=1+KSIGN
      GO TO 147
    8 IF(LSIGN.EQ.0)GO TO 153
      NUMBER=JVALUE
      GO TO 22
C
C     SINGLE ENTRY CONSTANT
    9 IF(KIND.NE.2)GO TO 11
      IF(IOPRTR.EQ.15)GO TO 10
      IF(IOPRTR.EQ.37)GO TO 10
      IRADIX=KRADIX
      GO TO 18
   10 IRADIX=JRADIX
      GO TO 18
   11 IF(IPFX.LT.0)GO TO 12
      IF(IPFX.EQ.0)GO TO 18
      IF(IPFX.NE.(KODE-1000))GO TO 15
      GO TO 18
   12 NUMBER=KODE-1000
      GO TO 18
C
C     MULTIPLE ENTRY CONSTANT
   13 NUMBER=-NUMBER-1
      IF(IPFX.LT.0)GO TO 16
      IF(IPFX.EQ.0)GO TO 17
      I=MASTER(NUMBER+2)
   14 IF(IPFX.EQ.MASTER(NUMBER))GO TO 17
      IF(IPFX.GT.MASTER(NUMBER))GO TO 15
      NUMBER=NUMBER-2
      IF(NUMBER.GT.I)GO TO 14
   15 NUMBER=0
      GO TO 18
   16 NUMBER=MASTER(NUMBER)
      GO TO 18
   17 NUMBER=MASTER(NUMBER-1)
C
C     PROCESS UNLESS UNBALANCED PARENTHESES
   18 IF(LSIGN.EQ.0)GO TO 21
      KSIGN=KSIGN-1
      IF(KSIGN.GE.0)GO TO 19
      KSIGN=2
      IF(IBASE.EQ.2)KSIGN=4
   19 JVALUE=ITBPUT(JVALUE,NUMBER,KSIGN,0,2)
      KSIGN=LSIGN-1
      IF(IOPRTR.EQ.15)GO TO 20
      IF(IOPRTR.NE.37)GO TO 147
   20 IF(KNTWRD.NE.3)GO TO 147
      MASTER(IADDRS)=JOPRTR+1
      MASTER(IADDRS-1)=JVALUE
      GO TO 147
   21 IF(KSIGN.EQ.4)NUMBER=-NUMBER
      IF(KSIGN.EQ.2)NUMBER=0
   22 IF(IOPRTR.EQ.15)GO TO 39
      IF(IOPRTR.EQ.37)GO TO 39
      IF(IOPRTR.EQ.27)GO TO 79
      IF(IOPRTR.EQ.60)GO TO 80
      IF(IOPRTR.EQ.28)GO TO 81
      IF(IOPRTR.EQ.82)GO TO 82
      IF(IOPRTR.EQ.61)GO TO 83
      IF(IOPRTR.EQ.84)GO TO 84
      IF(IOPRTR.EQ.89)GO TO 93
      IF(IOPRTR.EQ.91)GO TO 94
      IF(IOPRTR.EQ.115)GO TO 95
      IF(IOPRTR.EQ.93)GO TO 96
      IF(IOPRTR.EQ.117)GO TO 97
      IF(IOPRTR.EQ.95)GO TO 98
      KODE=IOPRTR+1
      IOPRTR=0
      GO TO 155
C
C     ************************************
C     *  ADDRESS FOLLOWING LOC OPERATOR  *
C     ************************************
C
   23 KNT=1
      IOPRTR=0
      I=MOST+NEXT
      IF(IBASE.EQ.2)GO TO 24
      IF(ISIGN.LT.0)ISIGN=2
      GO TO 25
   24 IF(ISIGN.LT.0)ISIGN=4
   25 IF(MORE.LE.NEXT)GO TO 26
      NEXT=NEXT+1
      I=I+1
      IF(I.GE.LEAST)GO TO 154
      MASTER(I)=0
      GO TO 24
   26 INSERT=MULT+NEXT
      IMOST=MOST
      IF(KODE.EQ.16)GO TO 30
      IF(KODE.EQ.2)GO TO 29
      IF(KODE.EQ.1)GO TO 27
      IF(KODE.NE.0)GO TO 153
      MASTER(NEW)=1
   27 IF(IBASE.GT.17)GO TO 62
C     REMOVE FOLLOWING TEST IF UNKNOWN ADDRESS LABEL
C     REFERENCE INFORMATION IS NOT TO BE STORED
C     WITHIN THE ASSEMBLED TABLE.
      IF(LOCK.EQ.0)GO TO 28
C
C     UNKNOWN ADDRESS IN ENTRY WITH OTHER CONTENTS
      LOCK=2
      GO TO 148
C
C     INITIAL CONTENT OF TABLE ENTRY IS UNKNOWN ADDRESS
   28 IADDRS=NEW
      JSIGN=ISIGN
      JBASE=IBASE
      JSHIFT=ISHIFT
      JMORE=MORE
      LOCK=1
      GO TO 146
C
C     LABEL OF KNOWN ADDRESS
   29 IF(NUMBER.GE.0)GO TO 31
      NUMBER=-NUMBER-1
      NUMBER=MASTER(NUMBER)
      GO TO 31
   30 NUMBER=MOST+MORE
   31 I=MOST+MORE
      MASTER(I)=ITBPUT(MASTER(I),NUMBER,ISIGN,ISHIFT,
     1IBASE)
      GO TO 145
C
C     ******************************************
C     *  SYMBOL FOLLOWING XSY OR XAD OPERATOR  *
C     ******************************************
C
C     XAD OPERATOR
   32 IF(NEW.EQ.0)GO TO 147
      IF(KODE.EQ.1)GO TO 153
      IF(KODE.EQ.2)GO TO 34
      GO TO 147
C     XSY OPERATOR
   33 IF(NEW.EQ.0)GO TO 147
      IF(KODE.LE.2)GO TO 147
      IF(KODE.EQ.29)GO TO 34
      IF(KODE.EQ.66)GO TO 34
      IF(KODE.NE.8)GO TO 35
   34 IF(NUMBER.GE.0)GO TO 35
      NUMBER=-NUMBER
      IF(IARG.EQ.NUMBER)IARG=0
      IF(IIARG.EQ.NUMBER)IIARG=0
      IF(IMASK.EQ.NUMBER)IMASK=0
      MASTER(NUMBER)=0
      IF(NUMBER.GT.KSIGN)KSIGN=NUMBER+1
   35 MASTER(NEW)=0
      IF(NEW.GT.KSIGN)KSIGN=NEW+1
      GO TO 147
C
C     ****************************************
C     *  SYMBOL FOLLOWING = OR == OPERATORS  *
C     ****************************************
C
   36 IF(KODE.GT.2)GO TO 37
      IF(KODE.NE.0)GO TO 153
      IF(NEW.NE.IKODE)GO TO 153
      IF(JOPRTR.NE.0)GO TO 18
      KODE=1001
      KIND=2
C
C     TEST FOR OPERATOR WHICH HAS FOLLOWING CONSTANT
   37 IF(JOPRTR.NE.0)GO TO 1
      IF(NUMBER.NE.0)GO TO 40
      I=0
   38 I=I+1
      IF(JKODE(I).EQ.0)GO TO 40
      IF(JKODE(I).NE.KODE)GO TO 38
      JOPRTR=KODE
      KSIGN=0
      LSIGN=0
      JVALUE=0
      GO TO 42
C
C     SYMBOL RIGHT OF OPERATORS WHICH CAN TAKE INTEGER
C     PREFIX IN RANGE OF = OR ==
   39 KODE=JOPRTR+1
      JOPRTR=0
C
C     TEST FOR SYMBOLS THAT CAN BE IN BYTE PATTERN
C     DEFINITIONS
C     KODE= 9, -
C         =10, +
C         =11, OCT
C         =12, DEC
C         =16, . (SINGLE PERIOD)
C         =29, ANOTHER BYTE PATTERN
C         =31, LFT WITH PREFIX
C         =33, RIT WITH PREFIX
C         =35, SIZ WITH PREFIX
C         =38, IOR
C         =45, SRX WITH PREFIX
C         =59, WRD WITH PREFIX
C         =67, ARG
C         =127, PFX WITH PREFIX
C         =124, XOR
C         =125, AND
   40 IF(MASTER(IADDRS).NE.29)GO TO 42
      IF(KPAREN.LT.0)GO TO 46
      IF(KODE.EQ.9)GO TO 155
      IF(KODE.EQ.10)GO TO 155
      IF(KODE.EQ.11)GO TO 155
      IF(KODE.EQ.12)GO TO 155
      IF(KODE.EQ.38)GO TO 155
      IF(KODE.EQ.45)GO TO 155
      IF(KODE.EQ.127)GO TO 155
      IF(KODE.EQ.124)GO TO 155
      IF(KODE.EQ.125)GO TO 155
C     FOLLOWING CAN'T BE IN PHRASE AFTER ARG
   41 IF(KODE.EQ.16)GO TO 58
      IF(KODE.EQ.29)GO TO 45
      IF(KODE.EQ.31)GO TO 60
      IF(KODE.EQ.33)GO TO 59
      IF(KODE.EQ.35)GO TO 155
      IF(KODE.EQ.59)GO TO 155
      IF(KODE.EQ.67)GO TO 64
      LSTNEW=IADDRS
      LEAST=MASTER(IADDRS+1)
      MASTER(LEAST)=0
      MASTER(IADDRS)=1001
      MASTER(IADDRS-1)=0
C
C     DEFINE AS EQUAL FIRST SYMBOL IN DEFINITION
   42 IF(KNTWRD.NE.3)GO TO 43
      MASTER(IADDRS)=KODE
      MASTER(IADDRS-1)=NUMBER
      IF(KODE.EQ.29)MASTER(IADDRS-1)=0
      IF(KODE.EQ.66)MASTER(IADDRS-1)=0
C
C     TEST FOR SYMBOLS THAT CAN BE IN PHRASES
C     KODE= 9, -
C         =10, +
C         =11, OCT
C         =12, DEC
C         =29, BYTE PATTERN
C         =31, LFT WITH PREFIX
C         =33, RIT WITH PREFIX
C         =35, SIZ WITH PREFIX
C         =38, IOR
C         =45, SRX WITH PREFIX
C         =54, ( OR ((
C         =55, )
C         =56, ))
C         =57, NUL
C         =59, WRD WITH PREFIX
C         =127, PFX WITH PREFIX
C         =124, XOR
C         =125, AND
   43 IF(KODE.EQ.9)GO TO 155
      IF(KODE.EQ.10)GO TO 155
      IF(KODE.EQ.11)GO TO 155
      IF(KODE.EQ.12)GO TO 155
      IF(KODE.EQ.29)GO TO 45
      IF(KODE.EQ.31)GO TO 155
      IF(KODE.EQ.33)GO TO 155
      IF(KODE.EQ.35)GO TO 155
      IF(KODE.EQ.38)GO TO 155
      IF(KODE.EQ.45)GO TO 155
      IF(KODE.EQ.54)GO TO 155
      IF(KODE.EQ.55)GO TO 155
      IF(KODE.EQ.56)GO TO 155
      IF(KODE.EQ.57)GO TO 155
      IF(KODE.EQ.59)GO TO 155
      IF(KODE.EQ.66)GO TO 155
      IF(KODE.EQ.127)GO TO 155
      IF(KODE.EQ.124)GO TO 155
      IF(KODE.EQ.125)GO TO 155
      IF(KODE.GT.1000)GO TO 44
      IF(JOPRTR.NE.0)GO TO 147
      IF(KNTWRD.NE.3)GO TO 153
      IERR=-1
      GO TO 147
   44 IF(KIND.NE.2)GO TO 155
      IF(NEW.EQ.0)GO TO 155
      IF(IRADIX.NE.JRADIX)GO TO 153
      MORE=1
      GO TO 155
   45 KODE=16
      GO TO 155
C
C     TEST FOR SYMBOLS WHICH CAN FOLLOW ARG OPERATOR
C     KODE= 9, -
C     KODE=10, +
C         =11, OCT
C         =12, DEC
C         =38, IOR
C         =45, SRX WITH PREFIX
C         =54, ( OR ((
C         =55, )
C         =56, ))
C         =57, NUL SIMULATED AS ZERO
C         =66 OR 1001 OR GREATER, CONSTANT
C         =127, PFX WITH PREFIX
C         =124, XOR
C         =125, AND
   46 IF(KODE.EQ.9)GO TO 50
      IF(KODE.EQ.10)GO TO 49
      IF(KODE.EQ.11)GO TO 155
      IF(KODE.EQ.12)GO TO 155
      IF(KODE.EQ.38)GO TO 51
      IF(KODE.EQ.45)GO TO 155
      IF(KODE.EQ.54)GO TO 52
      IF(KODE.EQ.55)GO TO 55
      IF(KODE.EQ.56)GO TO 55
      IF(KODE.EQ.57)GO TO 56
      IF(KODE.EQ.66)GO TO 53
      IF(KODE.EQ.127)GO TO 155
      IF(KODE.EQ.124)GO TO 47
      IF(KODE.EQ.125)GO TO 48
      IF(KODE.GT.1000)GO TO 54
      IF(KPAREN.LE.-2)GO TO 153
      KPAREN=0
      GO TO 41
   47 IF(KPAREN.EQ.-1)IPAREN=0
      GO TO 155
   48 IF(KPAREN.EQ.-1)IPAREN=1
      GO TO 155
   49 IF(KPAREN.EQ.-1)IPAREN=2
      GO TO 155
   50 IF(KPAREN.EQ.-1)IPAREN=3
      GO TO 155
   51 IF(KPAREN.EQ.-1)IPAREN=4
      GO TO 155
   52 IF(KPAREN.EQ.-1)KPAREN=-2
      GO TO 147
   53 ISIGN=MASTER(NEW-1)
      GO TO 57
   54 ISIGN=-NEW
      IF(KIND.NE.2)GO TO 57
      IF(NEW.EQ.0)IRADIX=JRADIX
      GO TO 56
   55 IF(KPAREN.EQ.-1)GO TO 153
      I=KPAREN
      KPAREN=0
      IF(I.EQ.-3)GO TO 146
   56 ISIGN=-MAX
   57 IF(IRADIX.NE.JRADIX)GO TO 153
      IF(KPAREN.EQ.-2)KPAREN=-3
      GO TO 66
C
C     ORIGIN INCREMENT COMMAND IN MASK DEFINITION
   58 ISIGN=-1
      GO TO 66
C
C     SHIFT IN MASK DEFINITION
   59 NUMBER=-NUMBER
   60 IF(NUMBER.EQ.0)GO TO 61
      IF(JBASE.GT.17)GO TO 62
   61 ISHIFT=NUMBER*JADJST
      KSHIFT=NUMBER
      GO TO 147
   62 WRITE(ITTY,63)
   63 FORMAT(1X,28HBYTE SPECIFICATION TOO LARGE)
      GO TO 153
C
C     ARGUMENT SPECIFICATION IN MASK DEFINITION
   64 KPAREN=-1
      IBASE=JBASE
      IADJST=JADJST
      IF(NSIGN.GE.0)GO TO 65
      ISIGN=4
      IF(IBASE.NE.2)ISIGN=2
   65 IPAREN=ISIGN
      JPAREN=NMORE
      IF(JPAREN.EQ.0)JPAREN=1
   66 NEW=IADDRS
      GO TO 148
C
C     **************************************
C     *  ADDRESS IN RANGE OF BIT OPERATOR  *
C     **************************************
C
   67 IOPRTR=0
      IF(IRADIX.NE.KRADIX)GO TO 153
      IF(KPAREN.GT.0)GO TO 68
      IF(MASK.NE.0)MASK=MASK+2
C
C     ADJUST ISHIFT AND MORE FOR MULTIPLE PRECISION
C     OR REVERSE (LEFT TO RIGHT) BIT NUMBERING
   68 MORE=NMORE
      IF(MORE.EQ.0)MORE=1
      I=IPRCN
      IF(IPRCN.GT.0)GO TO 70
      IF(IPRCN.EQ.0)GO TO 153
   69 I=I-IPRCN
      ISHIFT=ISHIFT+IPRCN
      IF(ISHIFT.GT.0)GO TO 69
      ISHIFT=I-ISHIFT+1
      I=-IPRCN
   70 IF(ISHIFT.LE.I)GO TO 71
      MORE=MORE+1
      ISHIFT=ISHIFT-I
      GO TO 70
   71 ISHIFT=JBYTE*(ISHIFT-1)
      IF(KODE.NE.16)GO TO 74
C
C     DEPOSIT BIT IN PRESENT ENTRY
      I=MOST+NEXT
   72 IF(MORE.LE.NEXT)GO TO 73
      NEXT=NEXT+1
      I=I+1
      IF(I.GE.LEAST)GO TO 154
      MASTER(I)=0
      GO TO 72
   73 INSERT=MULT+NEXT
      IMOST=MOST
      I=MOST+MORE
      J=4
      IF(IBYTE.NE.2)J=2
      IF(JBYTE.NE.1)J=2
      MASTER(I)=ITBPUT(MASTER(I),1,J,ISHIFT,IBYTE)
      GO TO 145
C
C     CALL TBLCEL TO DEPOSIT BIT IN KNOWN ENTRY
   74 IF(KODE.EQ.2)GO TO 149
C
C     CALL TBLCEL TO DEPOSIT BIT IN UNKNOWN ENTRY
      IF(KODE.GT.2)GO TO 153
      ISIGN=-1
      MASTER(NEW)=1
      GO TO 148
C
C     **************************************************
C     *  ADDRESS IN RANGE OF LOA ADR OR HIA OPERATORS  *
C     **************************************************
C
   75 MORE=1
      GO TO 78
   76 MORE=-MULT+1
      GO TO 78
   77 MORE=NEXT
      IF(MORE.EQ.0)MORE=1
   78 IOPRTR=0
      MORE=MORE+NMORE-1
      IF(NMORE.EQ.0)MORE=MORE+1
      IF(KODE.LE.2)GO TO 151
      GO TO 153
C
C     *******************************************
C     *  SYMBOL IN RANGE OF IF CLASS OPERATORS  *
C     *******************************************
C
   79 IF(NUMBER.EQ.0)GO TO 92
      GO TO 91
   80 IF(NUMBER.NE.0)GO TO 92
      GO TO 91
   81 IF(NUMBER.EQ.0)GO TO 92
   82 IF(NUMBER.LT.0)GO TO 92
      GO TO 91
   83 IF(NUMBER.EQ.0)GO TO 92
   84 IF(NUMBER.GT.0)GO TO 92
      GO TO 91
   85 IF(KODE.NE.0)GO TO 92
      GO TO 91
   86 IF(KODE.EQ.0)GO TO 92
      GO TO 91
   87 IF(KODE.EQ.0)GO TO 92
   88 IF(KODE.EQ.1)GO TO 92
      IF(KODE.EQ.2)GO TO 92
      GO TO 91
   89 IF(KODE.EQ.0)GO TO 92
   90 IF(KODE.GT.2)GO TO 92
   91 IFKNT=1
   92 JFKNT=JFKNT+1
      IOPRTR=0
      GO TO 150
C
C     **********************************************
C     *  SYMBOL IN RANGE OF DO-IF CLASS OPERATORS  *
C     **********************************************
C
   93 IF(NUMBER.EQ.0)GO TO 106
      GO TO 105
   94 IF(NUMBER.NE.0)GO TO 106
      GO TO 105
   95 IF(NUMBER.EQ.0)GO TO 106
   96 IF(NUMBER.LT.0)GO TO 106
      GO TO 105
   97 IF(NUMBER.EQ.0)GO TO 106
   98 IF(NUMBER.GT.0)GO TO 106
      GO TO 105
   99 IF(KODE.NE.0)GO TO 106
      GO TO 105
  100 IF(KODE.EQ.0)GO TO 106
      GO TO 105
  101 IF(KODE.EQ.0)GO TO 106
  102 IF(KODE.EQ.1)GO TO 106
      IF(KODE.EQ.2)GO TO 106
      GO TO 105
  103 IF(KODE.EQ.0)GO TO 106
  104 IF(KODE.GT.2)GO TO 106
  105 ISKIP=IVALUE
  106 IOPRTR=0
      GO TO 147
C
C     ***********************************************
C     *  SYMBOLS IN RANGE OF RED INC DEF OPERATORS  *
C     ***********************************************
C
  107 IF(KODE.LT.1001)GO TO 153
      IF(KIND.EQ.2)GO TO 153
      MASTER(NEW-1)=MASTER(NEW-1)-IVALUE
      GO TO 119
  108 IF(KODE.LT.1001)GO TO 153
      IF(KIND.EQ.2)GO TO 153
      MASTER(NEW-1)=MASTER(NEW-1)+IVALUE
      GO TO 119
  109 IF(KODE.LE.2)GO TO 115
      IF(KODE.EQ.66)GO TO 110
      IF(KODE.LT.1001)GO TO 153
      IF(KIND.EQ.2)GO TO 153
      GO TO 118
  110 MASTER(NEW)=1001
      MASTER(NEW-1)=IVALUE
      NUMBER=-NUMBER+1
      IOPRTR=0
      GO TO 152
C
C     ****************************************
C     *  PACKING PATTERN AFTER TON OPERATOR  *
C     ****************************************
C
  111 IF(KODE.NE.29)GO TO 153
      IMASK=1
      IOPRTR=0
      GO TO 155
C
C     *************************************
C     *  SYMBOL IN RANGE OF STK OPERATOR  *
C     *************************************
C
  112 IOPRTR=0
      IF(KODE.EQ.66)GO TO 120
      IF(KODE.LE.2)GO TO 115
      IF(KODE.LT.1001)GO TO 153
C
C     SINGLE ENTRY CONSTANT
      IF(KIND.EQ.2)GO TO 153
      IF(NUMBER.NE.0)GO TO 113
      MASTER(NEW)=KODE+1
      MASTER(NEW-1)=IVALUE
      GO TO 147
  113 J=KODE-1000
      I=J+1
  114 IF(MASTER(LSTNEW).EQ.0)LEAST=LSTNEW+1
      LSTNEW=LEAST-1
      IF((LEAST-6).LE.(MOST+NEXT))GO TO 154
      LEAST=LEAST-6
      MASTER(LSTNEW+1)=LEAST
      MASTER(LSTNEW)=-NEW+1
      MASTER(LSTNEW-1)=I
      MASTER(LSTNEW-2)=IVALUE
      MASTER(LSTNEW-3)=J
      MASTER(LSTNEW-4)=NUMBER
      MASTER(LEAST)=0
      MASTER(NEW)=66
      MASTER(NEW-1)=-LSTNEW
      GO TO 147
C
C     ADDRESS LABEL OR UNDEFINED
  115 IF(KODE.EQ.0)GO TO 117
      IF(MASTER(LSTNEW).EQ.0)LEAST=LSTNEW+1
      LSTNEW=LEAST-1
      I=LSTNEW+MASTER(NEW+1)-NEW
      IF(I.LE.(MOST+NEXT))GO TO 154
      MASTER(LEAST)=I
      MASTER(I)=0
      NEW=NEW-2
      LEAST=LEAST-3
  116 MASTER(LEAST)=MASTER(NEW)
      LEAST=LEAST-1
      NEW=NEW-1
      IF(LEAST.NE.I)GO TO 116
      NEW=LSTNEW
  117 MASTER(NEW)=1001
  118 MASTER(NEW-1)=IVALUE
  119 IOPRTR=0
      GO TO 147
C
C     ALREADY MULTIPLE ENTRY CONSTANT
  120 NEW=-NUMBER
      IF(MASTER(NEW-2).NE.0)GO TO 121
      MASTER(NEW-1)=MASTER(NEW-1)+1
      MASTER(NEW-2)=IVALUE
      GO TO 147
  121 NUMBER=MOST+NEXT+2
      IF(NUMBER.GE.LEAST)GO TO 154
      I=MASTER(NEW+1)+1
      MASTER(NUMBER-1)=MASTER(I)
      MASTER(NUMBER)=MASTER(I+1)
  122 I=I+2
      IF(I.GE.NEW)GO TO 123
      MASTER(I-2)=MASTER(I)
      MASTER(I-1)=MASTER(I+1)
      GO TO 122
  123 MASTER(I-2)=IVALUE
      MASTER(I-1)=MASTER(I-1)+1
      GO TO 152
C
C     *************************************
C     *  SYMBOL IN RANGE OF PSH OPERATOR  *
C     *************************************
C
  124 IOPRTR=0
      IF(KODE.EQ.66)GO TO 126
      IF(KODE.LE.2)GO TO 115
      IF(KODE.LT.1001)GO TO 153
C
C     SINGLE ENTRY CONSTANT
      IF(KIND.EQ.2)GO TO 153
      IF(IVALUE.EQ.0)GO TO 125
      I=NUMBER
      NUMBER=IVALUE
      IVALUE=I
      J=1
      I=KODE-999
      GO TO 114
  125 MASTER(NEW)=KODE+1
      GO TO 147
C
C     ALREADY MULTIPLE ENTRY CONSTANT
  126 NEW=-NUMBER
      J=NEW+1
      I=MASTER(J)
  127 J=J-2
      IF(J.LE.I)GO TO 128
      MASTER(J)=MASTER(J)+1
      GO TO 127
  128 IF(IVALUE.EQ.0)GO TO 147
      NUMBER=MOST+NEXT+2
      IF(NUMBER.GE.LEAST)GO TO 154
      MASTER(NUMBER)=1
      MASTER(NUMBER-1)=IVALUE
      GO TO 152
C
C     *************************************
C     *  SYMBOL IN RANGE OF ROT OPERATOR  *
C     *************************************
C
  129 IOPRTR=0
      IF(KODE.EQ.66)GO TO 130
      IF(KODE.LE.2)GO TO 147
      IF(KODE.LT.1001)GO TO 153
C
C     SINGLE ENTRY CONSTANT
      IF(KIND.EQ.2)GO TO 153
      IF(KODE.EQ.1001)GO TO 147
      IF(NUMBER.EQ.0)GO TO 147
      IVALUE=0
      MASTER(NEW)=KODE-1
      I=KODE-1000
      J=1
      GO TO 114
C
C     MULTIPLE ENTRY CONSTANT
  130 NEW=-NUMBER
      NUMBER=MASTER(NEW+1)
      I=NEW-3
  131 MASTER(I)=MASTER(I)+1
      I=I-2
      IF(I.GT.NUMBER)GO TO 131
      IF(MASTER(NEW-2).NE.0)GO TO 134
      IF(MASTER(NEW-1).NE.MASTER(NEW-3))GO TO 147
      IF((NEW-5).EQ.NUMBER)GO TO 133
C     TOP WORD ZERO, SECOND FROM TOP NON-ZERO
C     AND AT LEAST ONE OTHER NON-ZERO WORD
      I=NEW-3
  132 MASTER(I+2)=MASTER(I)
      MASTER(I+1)=MASTER(I-1)
      I=I-2
      IF(I.GT.NUMBER)GO TO 132
      NUMBER=NUMBER+2
      MASTER(NEW+1)=NUMBER
      MASTER(NUMBER)=NUMBER-2
      GO TO 152
C     TOP WORD ZERO, SECOND FROM TOP ONLY
C     NON-ZERO WORD
  133 NUMBER=NEW+1
      NEW=-MASTER(NEW)+1
      MASTER(NEW)=1000+MASTER(NUMBER-4)
      MASTER(NEW-1)=MASTER(NUMBER-5)
      GO TO 152
  134 IF(MASTER(NEW-1).NE.MASTER(NEW-3))GO TO 136
C     ROTATE CONTENTS IF TOP 2 WORDS NON-ZERO
      I=NEW-3
      J=MASTER(NEW-1)
      J=MASTER(NEW-2)
  135 MASTER(I+2)=MASTER(I)
      MASTER(I+1)=MASTER(I-1)
      I=I-2
      IF(I.GT.NUMBER)GO TO 135
      MASTER(I+2)=1
      MASTER(I+1)=J
      GO TO 147
C     TOP WORD NON-ZERO, SECOND FROM TOP ZERO
  136 NUMBER=MOST+NEXT+2
      IF(NUMBER.GE.LEAST)GO TO 154
      MASTER(NUMBER)=1
      MASTER(NUMBER-1)=MASTER(NEW-2)
      MASTER(NEW-2)=0
      GO TO 152
C
C     *************************************
C     *  SYMBOL IN RANGE OF POP OPERATOR  *
C     *************************************
C
  137 IOPRTR=0
      IF(KODE.EQ.66)GO TO 139
      IF(KODE.LE.2)GO TO 147
      IF(KODE.LT.1001)GO TO 153
C
C     SINGLE ENTRY CONSTANT
      IF(KIND.EQ.2)GO TO 153
      IF(KODE.NE.1001)GO TO 138
      NUMBER=NEW+1
      GO TO 152
  138 MASTER(NEW)=KODE-1
      MASTER(NEW-1)=0
      GO TO 147
C
C     MULTIPLE ENTRY CONSTANT
  139 NEW=-NUMBER
      NUMBER=MASTER(NEW+1)
      I=MASTER(NEW-1)-1
      IF(I.EQ.1)GO TO 142
      IF(I.EQ.MASTER(NEW-3))GO TO 140
C     CHANGE TOP ENTRY TO ZERO TO PRESERVE PRECISION
      MASTER(NEW-1)=I
      MASTER(NEW-2)=0
      GO TO 147
C     GET RID OF TOP ENTRY
  140 IF((NEW-5).EQ.NUMBER)GO TO 142
      I=NEW-3
  141 MASTER(I+2)=MASTER(I)
      MASTER(I+1)=MASTER(I-1)
      I=I-2
      IF(I.GT.NUMBER)GO TO 141
      NUMBER=NUMBER+2
      MASTER(NEW+1)=NUMBER
      MASTER(NUMBER)=NUMBER-2
      GO TO 152
C     CAN BECOME SINGLE ENTRY CONSTANT
  142 NUMBER=NEW+1
      NEW=-MASTER(NEW)+1
      MASTER(NEW)=1000+I
      MASTER(NEW-1)=MASTER(NUMBER-5)
      GO TO 152
C
C     *************************************
C     *  SYMBOL IN RANGE OF SFT OPERATOR  *
C     *************************************
C
  143 IOPRTR=0
      IF(KODE.LT.1001)GO TO 153
      IF(KIND.EQ.2)GO TO 153
      IVALUE=IVALUE*IADJST
      MASTER(NEW-1)=ITBPUT(0,NUMBER,4,IVALUE,IBASE)
      GO TO 147
C
C     *************************************
C     *  SYMBOL IN RANGE OF TEL OPERATOR  *
C     *************************************
C
  144 CALL TBLTEL
      GO TO 147
C
C     *********************************
C     *  INDICATE DEPOSIT INTO ENTRY  *
C     *********************************
C
  145 LOCK=2
      GO TO 146
C
C     SET SWITCH TO DETERMINE POINT TRANSFERRED TO IN
C     MAIN PROGRAM.  ONLY VALUES 3, 5, 6, 8 AND 9 HAVE
C     SIGNIFICANCE AFTER THE TRANSFER.
C
C     KODE   = 1, SET DEFAULT SHIFT AND SIGN, THEN SEARCH
C                 FOR NEXT SYMBOL.
C            = 2, SEARCH FOR NEXT SYMBOL RETAINING SHIFT
C                 AND SIGN.
C            = 4, SWAP SELECTED AND DESELECTED BUFFERS.
C            = 5, CALL TBLCEL TO STORE INFORMATION
C                 CONCERNING ADDRESS OF LABEL WHICH DOES
C                 NOT APPEAR FIRST IN STATEMENT.
C            = 6, CALL TBLCEL TO TURN BIT ON IN KNOWN
C                 ENTRY AND TO REPAIR LOC LIST FOR
C                 STATEMENTS LIKE  B LOC A,10BIT B
C            = 7, FORCE END OF STATEMENT WITHOUT DESTROYING
C                 VALUE OF IOPRTR.
C            = 8, CALL TBLCEL TO ASSIGN LOCATION TO LABEL
C                 AND INSERT VALUE WHERE PREVIOUSLY
C                 REQUESTED.
C            = 9, INSERT NEW DATA INTO CELL WITH ID AT NEW
C            = 10, A NON-FATAL ERROR HAS BEEN DETECTED.
C            = 11, A FATAL (ARRAY SPACE FULL) ERROR
C                 HAS BEEN DETECTED.
  146 KODE=-1
      GO TO 155
  147 KODE=-2
      GO TO 155
  148 KODE=-5
      GO TO 155
  149 KODE=-6
      GO TO 155
  150 KODE=-7
      GO TO 155
  151 KODE=-8
      GO TO 155
  152 KODE=-9
      GO TO 155
  153 KODE=-10
      GO TO 155
  154 KODE=-11
  155 RETURN
      END