         SYSTEM   SIG7FDP
         TITLE    'PHASE 4.1 - COND SUBROUTINE'
* READ PROC                                                             APR
* LF     R---     R-,+/-HW OFFSET,INDIRECT ADDR.                        APR  1
RCEF     CNAME    0                                                     APR00
RECF     CNAME    1                                                     APR01
RCRF     CNAME    2                                                     APR02
         PROC                                                           APR04
         DO       NAME>1                                                APR10
LF       BAL,L1   AAC00             READ CRF CLUSTER                    APR11
         ELSE                                                           APR12
         DO       NAME                                                  APR13
LF       BAL,L1   AAE00             READ ECF CLUSTER                    APR14
         ELSE                                                           APR15
LF       BAL,L1   *AF(3)            READ CRF/ECF CLUSTER                APR16
         FIN                                                            APR17
         FIN                                                            APR18
         DO       NUM(AF(1))                                            APR30
         LW,AF(1) R2                LOAD HA(CLOC)+/- HW OFFSET          APR31
         DO       NUM(AF(2))                                            APR40
         AI,AF(1) AF(2)                                                 APR41
         ELSE                                                           APR42
         AI,AF(1) 1                                                     APR43
         FIN                                                            APR44
         FIN                                                            APR44
         PEND                                                           APR50
* WRITE PROC                                                            APW
* LF     W---     R-,BA(CLOC)+/-BA OFFSET,RETURN                        APW 1
WPOF     CNAME    0                                                     APW00
WMCF     CNAME    1                                                     APW01
         PROC                                                           APW03
         DO       NUM(AF(2))                                            APW11
LF       LI,R4    AF(2)             LOAD BA(CLOC)                       APW12
         ELSE                                                           APW13
         DO       NUM(AF(1))                                            APW132
LF       LW,R4    AF(1)             LOAD,SET HA(CLOC) TO BA             APW14
         AW,R4    R4                                                    APW15
         FIN                                                            APW16
         FIN                                                            APW17
         DO       NAME                                                  APW80
         DO       NUM(AF(4))
         B        WRMCF             WRITE MCF CLUSTER
         ELSE
         DO       NUM(AF(3))
         LI,L1    AF(3)             LOAD LINK REGISTER
         B        WRMCF             TO WRITE MCF CLUSTER
         ELSE                                                           APW812
         BAL,L1   WRMCF             WRITE MCF CLUSTER                   APW813
         FIN                                                            APW814
         FIN                                                            APW818
         ELSE                                                           APW82
         DO       NUM(AF(4))
         B        WRPOF             WRITE POF CLUSTER
         ELSE
         DO       NUM(AF(3))
         LI,L1    AF(3)             LOAD LINK REGISTER
         B        WRPOF             TO WRITE POF CLUSTER
         ELSE                                                           APW842
         BAL,L1   WRPOF             WRITE POF CLUSTER                   APW843
         FIN                                                            APW844
         FIN                                                            APW848
         FIN                                                            APW85
         PEND                                                           APW90
* DIAG PROC                                                             APD
DX       CNAME                                                          APD00
         PROC                                                           APD01
* AF     DX       DIAG CODE,LINK                                        APD02
LF       LI,R1    AF(1)             LOAD DIAG CODE                      APD10
         DO       NUM(AF(3))
         B        DIAG              WRITE DMF CLUSTER
         ELSE
         DO       NUM(AF(2))
         LI,L1    AF(2)             LOAD LINK REGISTER
         B        DIAG              WRITE DMF CLUSTER                   APD242
         ELSE                                                           APD243
         BAL,L1   DIAG              WRITE DMF CLUSTER                   APD244
         FIN                                                            APD248
         FIN                                                            APD29
         PEND                                                           APD40
* LINK(OR LOAD) AND BRANCH PROC                                         APL
* LF     LAB,L/R  BRANCH ADDRESS,LINK ADDRESS(OR LOAD VALUE)            APL  1
LAB      CNAME                                                          APL01
         PROC                                                           APL04
LF       LI,CF(2) AF(2)             SET LINK REGISTER                   APL12
         B        AF(1)             BRANCH                              APL14
         PEND                                                           APL90
* LOAD,BRANCH AND LINK                                                  PRL
LBAL     CNAME    0                                                     PRL01
         PROC                                                           PRL02
* LF     LBAL,L-  BRANCH,LOAD VALUE,V-                                  PRL09
         DO       NUM(AF(3))                                            PRL20
         LI,AF(3) AF(2)             LOAD VALUE                          PRL22
         ELSE                                                           PRL23
         LI,V0    AF(2)             LOAD VALUE                          PRL24
         FIN                                                            PRL28
         DO       NUM(CF(2))                                            PRL40
         DO       NUM(AF(1))
         BAL,CF(2) AF(1)            BRANCH                              PRL42
         ELSE
         BAL,CF(2) ADI00
         FIN
         ELSE                                                           PRL43
         DO       NUM(AF(1))
         BAL,L1   AF(1)             BRANCH                              PRL44
         ELSE
         BAL,L1   ADI00
         FIN
         FIN                                                            PRL48
         PEND                                                           PRL99
         PAGE
* EXTERNAL REFERENCES
         REF      WRMCF
         REF      WRPOF
         REF      DIAG
         REF      AAC00             READ
         REF      AA01,AA02,AA03    M.C. RETURNS
         REF      ADE00             ARITHMETIC EXPRESSIONS
         REF      ADI00,ADI02
         REF      GTMP              TEMP STG
         REF      GADNO             ADCON NO.
         REF      JAKON,JADAT,JASAV,JAMOD
         REF      STBAS             DATA STACK
         REF      MCBUF             MCF CLUSTER BUF
         REF      JDCSAV
         REF      MDBUF
         REF      PPI32
         REF      PII22
         REF      EXPOUT
         REF      ADEX2
         REF      ADV00
         REF      PIL06,PIA06,PRA24,PII20
         REF      PRA22
         REF      GNBISRH
         REF      ATENDFLG
         REF      SSTBS
         REF      SRHTDB
         REF      ALL
         REF      BINSRD
         REF      OP1                                                   COBOL41L
         REF      PH41E
* REGISTER EQUIVALENCES
R0       EQU      0
R1       EQU      1
R2       EQU      2
R3       EQU      3
R4       EQU      4
R5       EQU      5
R6       EQU      6                                                     117
R7       EQU      7                                                     116
V0       EQU      8
V1       EQU      9
V2       EQU      10
L0       EQU      V2                                                    1212
L1       EQU      11                LINK REGISTER
D0       EQU      12                DECA
D1       EQU      13
D2       EQU      14
D3       EQU      15
* DIAG CODE BASE EQUIVALENCES
XCS      EQU                        S CONDITION EXPRESSION DIAG CODE BAS
*                                                                       AA0
CISAV    EQU      X'80000'          SAVE REF FLAG                       ADI455
CLOP     EQU      X'80'           A LAST OPERAND                        A
* DATA CLUSTER CLNG,CNTL EQUIVALENCES
CJIDM    EQU      X'00980'          NC CLNG,CNTL ADJ.                   ADI6314
CJINE    EQU      X'D85'          M NE  - NUMERIC EDITED                ADI511
CJICM    EQU      X'10980'          ND CLNG,CNTL ADJ.                   ADI5604
CJIC2    EQU      X'2088F'        M FPL - COMPUTATIONAL-2               ADI745
CJIC1    EQU      X'3088E'        M FPS - COMPUTATIONAL-1               ADI751
CJIB     EQU      X'4088D'        M BIN - COMPUTATIONAL                 ADI761
CJIX     EQU      X'5088C'        M INDX - INDEX                        ADI263
CJIFZ    EQU      X'70394'        M FIGCON - ZERO
CJILZ    EQU      X'70695'        M LITERAL ZERO - AN
CJINL    EQU      X'60296'          N LIT CNTL
CJLIT    EQU      X'60000'          LIT REF FLAG                        ADF041
CJZFM    EQU      X'200'          M NC ZERO FILL CNTL ADJ.              ADI622
CJIMN    EQU      X'C049F'          MNEMONIC NAME
IDCS     EQU      X'49046'          CONDITION NAME REF CNTL
ADCSUBZ  EQU      X'C9004'          SUBJECT OR 'ZERO'
ADCGRP   EQU      X'C2000'
ADCFIG   EQU   X'C9020'                                                 COBOL41L
ADCG30   EQU      X'C5220'
ADCLE30  EQU     X'C5020'
ADCND    EQU   X'C5404'                                                 COBOL41L
ADCNC    EQU      X'C0044'
ADCBIN   EQU      X'C0044'
ADCFLP   EQU      X'C0044'
* SFLD TYPES                                                            ADG 0
CJANL    EQU      -3                ANLIT/FIGCON                        ADG 01
CJAG     EQU      -2                GRP                                 ADG 02
CJAN     EQU      -1                AN/ANE                              ADG 03
CJAC     EQU      0                 NC/NE                               ADG 10
CJAD     EQU      1                 ND                                  ADG 11
CJAFL    EQU      2                 FLL                                 ADG 12
CJAFS    EQU      3                 FLS                                 ADG 13
CJAB     EQU      4                 BIN                                 ADG 14
CJAX     EQU      5                 INDEX                               ADG 15
CJAL     EQU      6                 NLIT                                ADG 16
CJAZ     EQU      7                 ZERO                                ADG 17
*ENTRY POINTS
         DEF      ADC00
         DEF      WHENFLG
         DEF      METHKY
         DEF      DIRECT
         DEF      TDBKYODR
         DEF      KEYORDER
         DEF      KEYPRIOT
* CONDITIONAL EXPRESSIONS          "CEXP"                               ADC
ADC00    RES      0
         STW,R3   ADCR3             SAVE STKTOP
         LCI      X'A'              SAVE R6
         STM,R6   ADCRSAV               THRU R3
ADC01    BAL,L1   ADC222            CHECK CLUSTER AT R2
         CI,V1    X'38'             LEGAL SUBJECT
         BAZ      ADC60             NO- DELETE STATEMENT
         LW,7     WHENFLG           IF WHEN CLAUSE ?
         BLEZ     ADC02             NO, PASS THROUGH
         CI,V1    X'20'
         BE       ADC011
         LH,7     3,R2              GET TDB & KEY
         STH,7    JTDB
         BAL,11   KEYINFOR
         LW,7     CMPLMENT          CHECK CMPLMENT FLAG
         BEZ      %+2
         STW,7    CMPLFLG           SET CMPLFLG
ADC011   LW,7     ATENDFLG
         BEZ      ADC02
         LI,7     0
         STW,7    ATENDFLG          CLEAR ATENDFLG
         BAL,L1   GNBISRH           TO GENERATE BIN SEARCH
*        OPERAND IN - EITHER SUBJECT,COND NAME, OR MNEMONIC NAME
ADC02    LI,V1    0                 INITIALIZE
         STH,V1   ADCSUBJA             SUBJECT ANCHOR
         STH,V1   ADCIJCT              IMPLIED JTJF COUNT
         LI,V2    ADCSUBZ           REF CNTL
         AI,R3    1                 TO FORCE STKTOP > 0
         BAL,L1   ADI00             GO TO REF ROUTINE            **REF**
         B        ADC60             INVALID
         B        ADC10             DATA REF- MUST BE SUBJECT
*        RETURN 3     MNEMONIC/CONDITION NAME
         TITLE    'MNEMONIC NAME PROCESSOR'
ADC04    RES      0
         STD,R4   ADCR4             SAVE R4 AND R5
         BAL,L0   ADC44             PUT OUT CONDITION IN STACK IF ANY
         LD,R4    ADCR4             RESTORE R4 AND R5
         LH,D1    0,R4              IS IT CONDITION NAME
         CI,D1    X'049F'               OR MNEMONIC NAME
         BNE      ADC88             88
*        M N E M O N I C   N A M E  *
         LH,V1    1,R4              CATEGORY AND SWITCH NUMBER
         STH,V1   MDBUF+1
         LH,V1    R6                FORCE MNEMONIC-NAME
         STH,D1    R6                 TO FAIL EXPRESSION TEST
         B        %+2                 AT ADC05 BELOW
ADC07    LH,V1    R6                SUBJECT TYPE
         STW,V1   MDBUF
         LI,V1    X'04CC'           LENGTH AND CTL
         STH,V1   MDBUF
         LI,R4    BA(MDBUF)         OUTPUT MASTER CLUSTER
         BAL,L1   WRMCF
*
*        AT THIS POINT THE CLUSTER AT SUBJA MUST BE PUT OUT AS IS
*        AND THEN A BE/BNE OUTPUT BASED ON THE JTJF AT R2
*        THIS ROUTINE IS SHARED BY CLASS/SIGN TEST TYPES 23-27
*
ADC05    RES      0
         LW,R4    R5                R4
         AI,R4    1                   TO BA
         LH,R1    R6                IS SUBJECT
         CI,R1    -4                   AN EXPRESSION
         BG       %+3
         BAL,L1   EXPOUT             GO TO EXPRESSION OUTPUT ROUTINE
         B        ADC08             PROCESS INTERNAL LABEL
         AW,R4    R4                OF SUBJECT CLUSTER
         BAL,L1   ADV00             RESOLVE VAR REC PARAM               COBOL41L
         BAL,L1   WRMCF             PUT ON MCF
*        NOW CHECK CLUSTER AT R2
ADC08    BAL,L1   ADC222
         CI,V1    X'C0'             IS IT AN INTL
         BAZ      ADC60             NO- DELETE STATEMENT
         LW,R1    R2                PICK UP
         AI,R1    1                     OPTIONS
         LH,V1    0,R1
         AI,R1    1                 INTERNAL LABEL NUMBER
         LH,D3    0,R1              TO D3
         LI,V0    CBE               BE OPCODE TO V0
         CI,V1    X'100'            IS IT JT/JF
         BANZ     %+2               JUMP TRUE
         AI,V0    X'100'            JF- CHANGE TO BNE
         BAL,L1   PII22             WRITE BCS/BCR ON MCF IN POF FORMAT
ADC06    MTH,1    ADCS4S            TURN ON FORCE SUBJECT FLAG
         LI,V1    0                 INITIALIZE
         STH,V1   ADCSUBJA              SUBJA
         B        ADC50             READ AND CHECK NEXT CLUSTER
KEYINFOR LCI      2                 SAVE
         STM,7    TEMPSAV             R7, R8
         LH,V0    SSTBS+1
         CI,V0    1
         BAZ      REBACK            NOT SEARCH ALL GO BACK
         LW,7     TDBKYODR          IS IT EMPTY
         BNEZ     MUTSUBJ           TO MULTIPLE SUBJECT CHECK
         STW,7    CMPLMENT          CLEAR CMPLMENT FLAG
         STW,7    CNFCTFLG          CLEAR CNFCT FLAG
         STW,7    KEYORDER          CLEAR
         LH,7     JTDB              LOAD TDB#
         BEZ      REBACK            NOT A KEY GO BACK
         LH,7     SRHTDB            LOAD TDB# OF SEARCH
         AND,7    L(X'0000FF00')
         STH,7    TDBKYODR          SAVE TDB#
         LH,7     JTDB              LOAD TDB#
         STB,7    KEYORDER          STORE KEY ORDER
         AND,7    L(X'0000FF00')    GET TDB#
*        THE FOLLOWING TWO INST WERE DELETED FOR SIDR 9412              COBOL41L
*        CH,7     TDBKYODR                                              COBOL41L
*        BNE      ADC60                                                 COBOL41L
         STW,7    CMPLMENT          SET CMPLMENT GLAG
         LH,7     KEYORDER          LOAD IN KEYORDER & PRIOT
         BEZ      REBACK            = 0  GO BACK
         BGZ      %+3               > 0  TO ASCENDING KEY
         AND,7    L(X'0000FF00')    ONLY WANT KEY ORDER & PRIOT
         AI,7     -X'8000'          SUBTRACT BASE OF DESENTING
         SAS,7    -8                SHIFT TO LOWEST BYTE
         STB,7    KEYPRIOT          STORE PRIORITY#
         B        REBACK            RETURN
TEMPSAV  RES      2
TDBKYODR RES      1
KEYORDER RES      1
KEYPRIOT RES      1
MUTSUBJ  LH,7     JTDB              LOAD TDB#
         LH,V0    SSTBS+1
         CI,V0    1
         BAZ      REBACK            NOT SEARCH ALL GO BACK
         LI,8     0                 CLEAR R8
         STB,7    8                 STORE KEYORDER
         AI,8     0
         BEZ      REBACK            = 0  GO BACK
         AND,7    L(X'0000FF00')    GET TDB#
         CH,7     TDBKYODR          COMPR TDB#
         BNE      ADC60             TO DIAG ILLEGAL SUBJECT
         STW,7    CMPLMENT          SET CMPLMENT FLAG
         LH,7     8                 LOAD IN KEYORDR
         MTW,0    CNFCTFLG          CHECK CONFLICT
         BNEZ     CNFCTODR          TO CONFLICT
         AI,7     0                 CHECK CC
         BLEZ     DEORDR            TO DESCENTING ORDER
         LH,8     KEYORDER          LOAD KEYORDER OF PREVIOUS SUBJECT
         BLEZ     CNFCTODR          TO CONFLICT
         SAS,7    -8                MOVE TO LOWEST BYTE
         LH,8     KEYPRIOT
         SAS,8    -8
         CW,7     8                 CHECK KEY ORDER
         BL       ADC60             PRIORITY NOT IN ORDER
         STB,7    KEYORDER          STORE NEW KEYORDER
         STB,7    KEYPRIOT          STORE NEW KEYPRIORITY
         B        REBACK            RETURN
DEORDR   LH,8     KEYORDER          LOAD KEYORDER OF PREVIOUS SUBJECT
         BGEZ     CNFCTODR          NOT <0 ,TO CNFCTORDER
         SAS,7    -8                MOVE TO LOWEST BYTE
         STB,7    KEYORDER
         AND,7    L(X'0000007F')
         LH,8     KEYPRIOT
         SAS,8    -8
         CW,7     8                 CHECK KEY ORDER
         BL       ADC60             PRIORITY NOT IN ORDER
         STB,7    KEYPRIOT          STORE NEW PRIORITY#
         B        REBACK            RETURN
CNFCTODR AI,7     0
         BGEZ     %+3
         AND,7    L(X'0000FF00')
         AI,7     -X'8000'          GET KEY PRIORITY #
         SAS,7    -8
         STB,7    KEYPRIOT          STORE KEYPRIOT
         LI,7     0
         STW,7    KEYDIRCT          SET CONFLICT FLAG
         AI,7     1
         STW,7    CNFCTFLG          SET CNFLICT FLAG
REBACK   LCI      2                 RELOAD
         LM,7     TEMPSAV                R7, R8
         B        *11               RETURN
CNFCTFLG DATA     0
         TITLE    'PROCESS SUBJECT OF RELATIONS'
ADC10    RES      0
         LH,V1    ADCIJCT           IJFLAG ON
         BEZ      ADC11             NO- OK
         LI,V1    0                 CLEAR
         STH,V1   ADCIJCT             IJFLAG
         DX       X'B9'             DIAG 185 - ILLEGAL IMPLICATION
*
*        GOOD SUBJECT IN
*
ADC11    BAL,L0   ADC44             TEST IF RELATION PENDING
         LI,R1    BA(ADCSUBJA)      INITIALIZE
         BAL,L1   ADCZ0             WORK AREA
         LI,R1    BA(MDBUF)+2       INITIALIZE
         BAL,L1   ADCZ0             WORK BUFFER
ADC12    BAL,L1   ADC222            CHECK CLUSTER AT (C2)
         CI,V1    1                 ARITHMETIC OPERATOR
         BANZ     ADC13             YES-
         CI,V1    X'38'
         BAZ      ADC14
*        CHECK CLASS FOR NUMERIC- OTHERWISE INVALID STATEMENT
         CI,V1    X'10'             DATA REF ?
         BNE      ADC13-2           NO
         MTW,0    WHENFLG           WHEN CLAUSE
         BLEZ     %+7               NO, PASS THROUGH
         LH,7     3,R2              GET TDB & KEY
         STH,7    JTDB
         BAL,L1   KEYINFOR
         LW,7     CMPLMENT          CHECK CMPLMENT FLAG
         BEZ      %+2
         STW,7    CMPLFLG           SET CMPLFLG
         LH,V1    R6                CLASS NUMERIC
         BLZ      ADC60             NO-DELETE STATEMENT
ADC13    LI,V1    1
         SLS,V1   31
         STW,V1   JDECP
         STW,V2   SAVV2            SAVE V2 FOR POSSIBLE USE IN ADI00    COBOL41L
         BAL,L1   ADEX2             GO TO EXPRESSIONS
         B        ADC60             BAD EXPRESSION-DELETE STATEMENT
*        EXPRESSION GOOD- NOW IN STACK
*        SET UP SUBJA/LINK AND CHECK NEXT
         LW,V2    SAVV2           RESTORE V2 INCASE 41M DESTROYED IT    COBOL41L
         AI,R6    X'80000'          TURN ON EXPRESSION TYPE BIT
         BAL,L1   ADC222            SET UP V1 FOR NEXT
         TITLE    'RELATIONAL OPERATOR PROCESSING'
ADC14    RES      0
         LH,R1    R6                SUBJECT TYPE
         STW,R1   MDBUF             INTO MASTER CLUSTER
         CI,R1    -4                IS THIS AN EXPRESSION
         BG       %+2               NO
         AI,R1    8                 CLEAR SIGN EXTENSION
         EXU      ADC700,R1         SET UP REF CNTL IN V2
ADC702   CI,V1    6
         BAZ      ADC60             NO- DELETE STATEMENT
         CI,V1    2                 RELATION
         BAZ      ADC17             NO- CLASS/SIGN TEST
ADC15    LI,L1    %+2               SET RETURN FROM SUBR.
         EXU      ADC600,R1         ESTABLISH CLASS WEIGHT
         STW,V1   ADCWGHT           SAVE ASSIGNED PRIORITY
         BAL,L1   ADC100            SET UP SUBJA AND ELAT
ADC16    LI,R2    0
         LW,7     WHENFLG           WHEN CLAUSE ?
         BLEZ     %+5
         LH,V0    SSTBS+1
         CI,V0    1
         BAZ      %+2
         STW,R2   JTDB              CLEAR JTDB
         BAL,L1   ADI00                                          **REF**
         B        ADC60             INVALID
         B        ADC20             DATA REF
         B        ADC04             MN.NAME/88
*        CLASS/SIGN TEST
*        CONSTRUCT MASTER- THEN OUTPUT SUBJECT AND BE/BNE
ADC17    STH,D1   MDBUF+1
         RCRF                       READ NEXT
         LH,V1    MDBUF+1                                               COBOL41L
         CI,V1    X'2300'                                               COBOL41L
         BL       ADC07             NOT CLASS/SIGN TEST                 COBOL41L
         CI,V1    X'2600'                                               COBOL41L
         BL       ADC07             SIGN TEST                           COBOL41L
         BG       ADC18             IF ALPHANUMERIC                     COBOL41L
         LH,V1    R6                SUBJECT TYPE                        COBOL41L
         CI,V1    1                                                     COBOL41L
         BLE      ADC07             DISPLAY                             COBOL41L
         B        ADC19                                                 COBOL41L
ADC18    LH,V1    R6                SUBJECT TYPE                        COBOL41L
         BLZ      ADC07             ALPHA                               COBOL41L
ADC19    RES      0                                                     COBOL41L
         DX       X'11F'            DIAG - ILLEGAL DATA USAGE           COBOL41L
         B        ADC07
         TITLE    'CONDITIONAL SUBROUTINES'
*        ROUTINE TO HANDLE NEW SUBJECT/STATEMENT
ADC100   LW,V1    R5                OFFSET
         STW,R5   ADCANCH             TO ANCHOR
         SW,V1    KHASTK            CALCULATE
         STW,V1   ADCSUBJA          ORIGINAL SUBJECT POINTER
         STH,V1   ADCSUBJA              SUBJECT POINTER
         STH,D1   ADCRLOP           RELATION CODE
         STW,R3   ADCOR3            SAVE R3
         B        *L1               RETURN
*
*        ROUTINE TO MAINTAIN LINKAGE IN STACK
ADC200   RES      0
*        ADCANCH  MAY IN SOME CASES OF EXPRESSIONS NOT BE POINTING      COBOL41L
*        TO THE CORRECT STACK ENTRY.  IT MAY BE NECESSARY TO USE THE    COBOL41L
*        PREVIOUS ENTRY TO CHANGE ITS LINK--THIS IS WHY ADCANCH IS      COBOL41L
*        STORED IN EXPANCH BEFORE IT IS CHANGED                         COBOL41L
         LW,D3    ADCANCH                                               COBOL41L
         STW,D3   EXPANCH           SAVE PRIOR ANCHOR FOR EXPROSSIONS   COBOL41L
         LI,V1    HA(STBAS+392)     SEE IF WITHIN LAST 8 WORDS          COBOL41L
         CW,R5    V1                   LIMIT                            COBOL41L
         BLE      ADC201            OK                                  COBOL41L
         DX       X'3D'             DIAG  61                            COBOL41L
         DX       X'77'             DIAG 119 (ABORTS JOB)               COBOL41L
         B        PH41E             EXIT
ADC201   RES      0                                                     COBOL41L
         CW,R5    ADCANCH           LINKAGE OK
         BE       *L1                  YES
         LW,V1    R5                INITIALIZE
         LI,D3    0                 NEXT
         STH,D3   0,R5              LINK
         LI,D3    HA(STBAS)         CALCULATE
         SW,V1    D3                CURRENT
         LW,R1    ADCANCH           ANCHOR
         STH,V1   0,R1              ADDRESS
         STW,R5   ADCANCH
         B        *L1               RETURN
         PAGE
*        ROUTINE TO EXAMINE CLUSTER IN INPUT BUFFER
ADC222   LW,R1    R2                PICK UP
         AI,R1    1                   OPTIONS
         LH,R7    0,R1                FIELD
         BLZ      ADC225            9 THRU E
         LW,D1    R7                SAVE OPTIONS
         SLS,R7   -12               OPERAND TYPE TO LOW ORDER
         EXU      ADC224,R7         SET V1 FOR TYPES 0 TO 3
ADC223   STW,V1   ADCNXT            SAVE V1 CODE
         B        *L1               RETURN
ADC224   LI,V1    X'10000'          SYNTAX ONLY
         LI,V1    1                 ARITHMETIC OPERATOR
         B        ADC227            RELAT- WHAT KIND
         LI,V1    8                 FIGCON   =    8
ADC225   AI,R7    X'8000'           GET RID OF HIGH BITS
         LW,D1    R7                SAVE OPTIONS
         SLS,R7   -12               OPER TYPE TO LOW ORDER
         EXU      ADC226,R7         SET V1
         B        ADC223            RETURN
ADC226   LI,V1    X'10'             UNDEFINED- REF WILL RETURN INVALID
         LI,V1    X'10'             REF =    10
         LI,V1    0                 NO TYPE 'A'
         LI,V1    X'20'             STRING   =    20
         LI,V1    X'20'             NUMBER   =    20
         LI,V1    0                 NO  INTEGERS
         B        ADC229            WHAT KIND OF LABEL
ADC227   SLS,D1   -8                CHECK
         CI,D1    X'23'               RELATIONAL
         BL       ADC230            OPERATOR                            COBOL41L
         CI,D1    X'27'               FOR
         BG       ADC228              CLASS/SIGN TEST
         LI,V1    4                 CLASS/SIGN TEST
         SLS,D1   8                 SET UP D1 FOR MDBUF+1
         B        ADC223            RETURN
ADC230   STW,D1   RELOPB            SAVE RELATIONAL OPERATOR            COBOL41L
ADC228   LI,V1    2                 RELATION =    2
         B        ADC223            RETURN
ADC229   LI,V1    X'40'             CHECK
         CI,D1    X'800'                IF DEFINITION
         BAZ      ADC223            NO- JTJF =    40
         AI,V1    X'40'             DEF-     =    80
         B        ADC223            RETURN
         PAGE
*        ROUTINE  TO SET OBJECT TYPE/KEEP TYPE COUNT/UP OBJECT COUNT
ADC35    LCH,R1   R6                CLASS TYPE
         CI,R1    4                                                     COBOL41L
         BL       %+2               NOT EXPRESSION                      COBOL41L
         AI,R1    -8                                                    COBOL41L
         LI,V1    X'10000'          BIT
         SLS,V1   12,R1                 TO PROPER TYPE POSITION
         LW,R1    V1                SAVE BIT
         AND,V1   MDBUF+1           IF BIT ALREADY ON
         BNE      %+3               YES
         AWM,R1   MDBUF+1           TURN ON  TYPE BIT
         MTH,1    MDBUF+1           INCREMENT NO. OF TYPES
         MTW,1    MDBUF+1           INCREMENT OBJECT COUNT
ADC32    LH,R1    R6                INCREMENT
         CI,R1    -4                                                    COBOL41L
         BG       %+2               NOT EXPRESSION                      COBOL41L
         AI,R1    8                                                     COBOL41L
         MTH,1    MDBUF+4,R1          COUNT FOR THIS CLASS
         CI,R1    0                 NC
         BNE      *L1               NO- RETURN
         LH,V1    4,R5              IS DECP >
         CH,V1    MDBUF+2           MAXD
         BLE      *L1               NO
         STH,V1   MDBUF+2           NEW MAXD
         B        *L1               RETURN
*        ROUTINE TO MOVE CLUSTERS TO STACK
*        R3 CONTAINS NEXTLOC IN STACK
*        D0 CONTAINS BA OF CLUSTER TO BE MOVED
*        D2 CONTAINS NO BYTES O BE MOVED
*        ROUTINE TAKES CARE OF ALL ANCHOR AND LINKAGE ADJUSTMENT
ADCMOV   RES      0
         LW,R5    R3                LINK ADDR TO R3
         STW,L1   ADCANCX           SAVE RETURN
         BAL,L1   ADC200            MAINTAIN LINKAGE
         AI,R3    1
         LW,D1    R3                NEXT ADDRESS
         AW,D1    D1                  IN BYTES
         STB,D2   D1
         MBS,D0   0                 MOVE CLUSTER
         SLS,D1   -1                HA
         STW,D1   R3                NEW ADDR TO R3
         LW,R5    R3                AND R5
         BAL,L1   ADC200            MAINTAIN LINKAGE
         B        *ADCANCX          RETURN
         TITLE    'CONDITIONAL OPERAND PROCESSING'
ADC20    RES      0
         LH,V1    1,R5              OPTIONS FIELD
         CI,V1    X'10'             IS SFLAG SET
         BANZ     ADC10             YES - MUST BE A SUBJECT
         LH,V1    ADCSUBJA          HAS SUBJA BEEN RESET
         BEZ      ADC10             YES- MUST BE SUBJECT
         LW,7     WHENFLG           WHEN CLAUSE ?
         BLEZ     %+2               NO, SKIP 1 INST
         BAL,L1   KEYINFOR          TO GET KEY INFOR
         LH,V1    ADCIJCT           HAS IJFLG BEEN FORCED
         BEZ      %+2               NO
         MTH,-1   ADCIJCT           DECREMENT IT
         LH,V1    ADCRLOP           RELATIONAL OPERATOR
         STH,V1   1,R5                  INTO OPTIONS FIELD OF OPERAND
         BAL,L1   ADC222            CHECK NEXT CLUSTER (R2)
         CI,V1    1                 ARITHMETIC OPERATOR
         BANZ     ADC21             YES- PROCESS AS EXPRESSION
         CI,V1    X'38'             ANOTHER OPERAND
         BANZ     REST+4            YES, TO CONTINUE
         LW,7     WHENFLG           WHEN CLAUSE ?
         BLEZ     REST+2            NO
         LH,V0    SSTBS+1
         CI,V0    1
         BAZ      REST+2            NOT SEARCH ALL
         LI,11    REST+2
TEMINFOR LW,7     CNFCTFLG          CHECK CONFLICT
         BNEZ     NOTCM+2
         LW,7     KEYORDER
         BNEZ     %+3
         LW,7     BINSRD            USE TABLE DIRECT
         STW,7    KEYORDER
         LW,7     CMPLFLG
         BGZ      NOTCM             NO CMPLMENT SUBJ
         LCW,7    KEYORDER          COMPLEMENT
         B        NOTCM+1
NOTCM    LW,7     KEYORDER
         STW,7    KEYDIRCT           SET KEY DIRECTION
         LI,7     0
         STW,7    TDBKYODR          CLEAR TDBKYODR
         STW,R7   CMPLMENT                                              COBOL41L
REST     STW,7    CMPLFLG           CLEAR CMPLFLG
         B        *11
         BAL,L1   ADC200            MAINTAIN LINKAGE
         B        ADC25             GOOD COMPERAND HERE
         LW,7     WHENFLG           WHEN CLAUSE ?
         BLEZ     %+2               NO, SKIP ONE INST
         BAL,L1   KEYINFOR          TO GET KEY INFOR
         LH,V1    R6                IS CLASS NUMERIC
         BLZ      ADC23             NO- DELETE OPERAND
ADC21    LI,V1    1
         SLS,V1   31
         STW,V1   JDECP
         STW,V2   SAVV2            SAVE V2 FOR POSSIBLE USE IN ADI00    COBOL41L
         BAL,L1   ADEX2             GO TO EXPRESSIONS
         B        ADC23             INVALID EXPRESSION- DROP IT
         AI,R6    X'80000'          GOOD EXPRESSION AS COMPERAND
         LW,V2    SAVV2           RESTORE V2 INCASE 41M DESTROYED IT    COBOL41L
*       NOTE IF ADCANCH HAS BEEN SAVED PRIOR TO GOING TO THE           COBOL41L
*        EXPRESSION ROUTINE, IT WILL BE RESTORED BEFORE GOING TO       COBOL41L
*        ADC200 WHICH HANDLES THE LINKS                                COBOL41L
         LW,D3    OP1              SEE IF EXPRESSION ROUTINE            COBOL41L
         AI,D3    -1               POINTER IS THE SAME AS ADANCH        COBOL41L
         CW,D3    ADCANCH                                               COBOL41L
         BNE      ADC22                                                 COBOL41L
         MTW,0    EXPANCH           WAS ANCHOR STORED                   COBOL41L
         BEZ      ADC22A            NO                                  COBOL41L
         LW,D3    EXPANCH           YES                                 COBOL41L
         STW,D3   ADCANCH           EXCHANGE                            COBOL41L
ADC22    RES      0                                                     COBOL41L
         LI,D3    0                 CLEAR FOR NEXT TIME                 COBOL41L
         STW,D3   EXPANCH                                               COBOL41L
ADC22A   RES      0                                                     COBOL41L
         BAL,L1   ADC222            SET UP NXT
         CI,V1    6                 NEXT CLUSTER RELATIONAL OPERATOR?
         BANZ     ADC10             THIS MUST BE A NEW SUBJECT
         BAL,L1   ADC200            COMPERAND- MAINTAIN LINKAGE
         B        ADC25             PROCESS MASTER CLUSTER INFORMATION
ADC23    BAL,L0   ADB90             SKIP 'EXPRESSION'
ADC24    DX       X'B7'             DUAGNOSTIC 183
         B        ADC61             READ NEXT - NO SAVE                 COBOL41L
         TITLE    'CONDITIONS- BUILD MASTER CLUSTER'
ADC25    RES      0
         LI,R7    HA(MDBUF)+1       2ND HW MDBUF
         LI,R4    1                 CHECK IF ONE, TWO
         LH,V1    ADCOBJC,R4          OR MORE OBJECTS
         BEZ      ADC30             FIRST OBJECT
         CI,V1    1
         BE       ADC31             SECOND OBJECT- REPLACE OBJECT TYPE
*        MULTIPLE OBJECTS- MDBUF+1 ALREADY CONTAINS TYPE AND COUNTS
*        INCREMENT COUNT OF THIS CLASS
         B         ADC36         CHECK SUBJECT                          COBOL41L
*        FIRST COMPERAND
ADC30    RES      0
         LH,R4    R6                TYPE INTO
         STH,R4   MDBUF+1             OBJECT TYPE FIELD OF M.C.
         CI,R4    -4                AN EXPRESSION RESULT
         BG       ADC30A                                                COBOL41L
         AI,R4    8                 CLEAR SIGN EXTENSION
         LW,V1    ADCWGHT           SUBJECT WEIGHT                      COBOL41L
         CW,V1    ADCW22            IS IT ALPHANUM                      COBOL41L
         BNE      ADC30A            NO                                  COBOL41L
         MTH,1    ADCFLG3           SUBJECT = AN OBJECT = EXPRESSION    COBOL41L
ADC30A   RES      0                                                     COBOL41L
         LI,L1    %+2               SET RETURN
         EXU      ADC600,R4         DETERMINE PRIORITY
         CW,V1    ADCWGHT           HIGHER PRIORITY THAN SUBJECT
         BLE       ADC40                                                COBOL41L
         MTH,1    ADCFLG            SET SWAP FLAG
         LW,V1    ADCWGHT                  TEST WEIGHT OF SUBJECT       COBOL41L
         CW,V1     ADCW22               IS IT EQUAL TO ALPHANUMERIC     COBOL41L
         BNE      ADC40                                                 COBOL41L
         LI,R1    3                                                     COBOL41L
         LB,R4    R6,R1             PICK UP CONTROL BYTE OBJECT         COBOL41L
         CI,R4    X'91'             IS THIS ALPHANUM LIT                COBOL41L
         BE       ADC40             YES
         CI,R4    X'90'             FIGCON (NOT ZERO)
         BE       ADC30B
         CI,R4    X'94'             FIGCON ZERO
         BE       ADC30B
         CI,R4    X'95'             ZERO VALUE NUM LIT
         BE       ADC30B
         CI,R4    X'92'             ALL '1 CHAR'
         BNE      ADC40
ADC30B   RES      0
         MTH,1    ADCFLG2           FLIP FLAG FOR COMPLEX CONDITIONALS  COBOL41L
         B        ADC40             PROCESS NEXT CLUSTER
*        SECOND COMPERAND
ADC31    RES      0
         LW,R4    R6                SAVE THIS OBJECT TYPE
         LW,R6    MDBUF+1           FIRST OBJECT TYPE
         LI,V1    0                 INITIALIZE
         STH,V1   MDBUF+1             TYPES FIELD
         STH,V1   ADCFLG            RESET SWAP FLAG
         BAL,L1   ADC35             SET TYPE BITS AND BUMP TYPE COUNT
         LW,R6    R4                NOW TAKE CARE OF THIS OBJECT
ADC36    LI,V1   0                                                      COBOL41L
         STH,V1  ADCFLG2                   CLEAR FLAG                   COBOL41L
         LH,R4   R6                TYPE  OF OPERAND                     COBOL41L
         LI,L1     %+2                                                  COBOL41L
         EXU    ADC600,R4                 GET WEIGHT OF OPERAND         COBOL41L
         CW,V1    ADCWGHT                   COMPARE WITH SUBJECT WEIGHT COBOL41L
         BLE      ADC37                                                 COBOL41L
         LW,V1   ADCWGHT                                                COBOL41L
         CW,V1     ADCW22              IS SUBJECT ALPHANUMERIC          COBOL41L
         BNE      ADC37             NO--DO SET FLAG                     COBOL41L
         LI,R1    3                                                     COBOL41L
         LB,R4    R6,R1             PICK UP CONTROL BYTE OBJECT         COBOL41L
         CI,R4    X'91'             IS THIS ALPHANUM LIT                COBOL41L
         BE       ADC37             YES
         CI,R4    X'90'             FIGCON (NOT ZERO)
         BE       ADC36A
         CI,R4    X'94'             FIGCON ZERO
         BE       ADC36A
         CI,R4    X'95'             ZERO VALUE NUM LIT
         BE       ADC36A
         CI,R4    X'92'             ALL '1 CHAR'
         BNE      ADC37
ADC36A   RES      0
         MTH,1   ADCFLG2                 YES---SET COMPLEX FLAG         COBOL41L
ADC37    RES      0                                                     COBOL41L
         BAL,L1   ADC35             SET TYPE AND COUNT
         TITLE    'CONDITIONS- PROCESS INTERNAL LABELS'
ADC40    RES      0
         MTW,1    ADCOBJC
         LW,V1    ADCNXT            NEXT CLUSTER CODE
         CI,V1    X'C0'             IS IT INTERNAL LABEL
         BANZ     ADC41             IT BETTER BE
         DX       X'B9'             IT'S NOT - - DIAGNOSTIC 185
         B        ADC60             DELETE
ADC411   LH,V1    ADCSUBJA          STACKER EMPTY?
         BNEZ     ADC413            NO- PUT IN STACK
         LH,D3    1,R2              INTERNAL LABEL NUMBER
         LW,V1    D3
         BAL,L1   PPI32             PUT OUT DEFENITION
         B        ADC50             RESD NEXT CLUSTER
ADC412   LH,V1    ADCSUBJA          STACKER EMPTY?
         BNEZ     ADC413            NO- PUT IN STACK
         LH,D3    1,R2              INTERNAL LABEL NUMBER
         LI,V0    CBR               OP CODE
         BAL,L1   PII22             PUT OUT BRANCH
         B        ADC50             RESD NEXT CLUSTER
ADC41    LW,R1    R2                GET
         AI,R1    1                   OPTIONS
         LH,V1    0,R1                FIELD
         CI,V1    X'800'            INTERNAL DEF?
         BANZ     ADC411            YES
         CI,V1    X'F00'            UNCONDITIONAL BRANCH?
         BAZ      ADC412            YES
         CI,V1    1                 IJFLAG ON
         BAZ      %+3                   NO
         LI,D1    2
         STH,D1   ADCIJCT           FORCE FLAG
         LH,D1    ADCRLOP           RELATION CODE
         AW,R1    R1                   NOW
         AI,R1    1                     COMBINED
         LH,V1   ADCFLG2               IS COMPLEX COND FLIP FLG SET     COBOL41L
         BEZ      ADC41A
         CI,D1    X'20'             OP CODE BE
         BE       ADC41A
         CI,D1    X'28'             IS OP CODE BNE
         BE       ADC41A
         EOR,D1   FLPFLG              FLAG WAS SET SO FLIP OPERAND      COBOL41L
ADC41A   RES      0
         STB,D1   0,R1              WITH LABEL TYPE
         B        %+3                                                   COBOL41L
ADC413   AW,R1    R1                 OBTAIN BYTE ADDRESS (SIDR 1965)    COBOL41L
         AI,R1    1                                                     COBOL41L
         LW,D0    R2                 ADDRESS OF                         COBOL41L
         AW,D0    D0                CLUSTER TO D0
         AI,R1    -1
         LB,V1    0,R1
         CI,V1    X'E6'
         BNE      %+5
         AI,R1    -2
         LB,D2    0,R1
         AW,D2    D2
         B        %+2
         LI,D2    6                 MOVE 6 BYTES
         BAL,L1   ADCMOV            VIA MOV
         TITLE    'COMPLEX CONDITIONAL HANDLING'
ADC50    RES      0
         RCRF                       READ NEXT CLUSTER
         LH,V1    0,R2              DOES NEW STATEMENT
         CI,V1    X'80'                FOLLOW
         BAZ      ADC58             NO- MORE COMING
ADC54    LI,V1    0                 INITIALIZE
         STH,V1   ADCWARN              WARNING FLAG
         BAL,L0   ADC44             WRITE OUT STACK
         B        ADC99             RETURN TO MASTER CONTROL
ADC58    BAL,L1   ADC222            CHECK INPUT BUFFER
         CI,V1    X'80'             IS TI AN INTERNAL DEF
         BANZ     ADC41              PUT INTO STACK (SIDR 1965)         COBOL41L
         CI,V1    X'10000'          SYNTAX ONLY? (FLAG IN PERFORM)
         BANZ     ADC54             YES- END OF CONDITION
         CI,V1    X'38'             OPERAND
         BANZ     ADC51             YES- TEST IF SUBJECT
         CI,V1    2                 RELATIONAL OPERATOR
         BAZ      ADC40+1           ILLEGAL - CATCH
         STH,D1   ADCRLOP           NEW
         B        ADC16             PROCESS NEW OPERATOR
ADC51    LW,R1    R2                ACCESS
         AI,R1    1                     NEXT
         LH,V1    0,R1                  OPTIONS FIELD
         CI,V1    X'10'             SUBJA FLAG ON
         BAZ      ADC52             NO- CHECK IF FORCED BY SPECIAL CASE
         LI,11    ADC53-3
TOTERMI  STW,11   RETURN
         LW,7     TDBKYODR          TERMINATE KEYINFOR ?
         BEZ      %+2
         BAL,11   TEMINFOR          TO DECIDE KEY INFORMATION
         CH,V1    L(X'B0000000')
         BGE      ADC53-3           NOT DATA REF
         LW,7     WHENFLG           CHECK WHEN FLAG
         BLEZ     %+7               NO, PASS THROUGH
         LH,7     3,R2              GET TDB & KEY
         STH,7    JTDB
         BAL,L1   KEYINFOR          TO GET KEYINFORMATION
         LW,7     CMPLMENT          CHECK CMPLMENT FLAG
         BEZ      %+2
         STW,7    CMPLFLG           SET CMPLFLG
         B        *RETURN
         LI,V1    0                 INITIALIZE
         STH,V1   ADCWARN              WARNING FLAG
         BAL,L0   ADC44             WRITE OUT CURRENT RELATION
ADC53    LW,R3    ADCR3             RESET STACK TO TOP
         B        ADC02             PROCESS NEW RELATION
*        IF CLUSTER PRECEDING LAST INT. LABEL WAS A MNEMONIC NAME,
*        CONDITION NAME, OR CLASS/SIGN TEST THEN THIS OPERAND
*        MAY ONLY BE A SUBJECT.     (NOT LEGAL STATEMENT)
ADC52    CB,V1    L(X'20000000')    CONDITION NAME
         BAZ      %+2               NO
         BAL,11   TOTERMI           TERMINATE KEY INFOR
         LH,V1    ADCS4S            FORCED SUBJECT FLAG
         BEZ      ADC57             OFF- CHECK IF WARNING FLAG ON
         LI,V1    0                 TURN OFF FLAG
         STH,V1   ADCS4S
         B        ADC53             RESET STACK TOP
*        IF WARNING FLAG IS ON THE LAST SUBJECT MUST BE RELOADED
*        OUTPUT THE STACK AND BUILD NEW CONDITION WITH CURRENT SUBJECT
ADC57    LH,V1    ADCWARN           IS WARNING FLAG ON
         BEZ      ADC16+1           NO- SAVE AND READ
         LI,V1    0                 TURN OFF
         STH,V1   ADCWARN              WARNING FLAG
         BAL,L0   ADC44             WRITE OUT STACK
         LI,R1    1                 PUT ORIGINAL SUBJA
         LH,V1    ADCSUBJA,R1          INTO CURRENT
         STH,V1   ADCSUBJA             SUBJA
         AI,V1    HA(STBAS)         RESET ANCHOR
         STW,V1   ADCANCH
         LW,R3    ADCOR3            RESET R3 FOR REF
         LI,V1    0                 INITIALIZE
         STH,V1   ADCOBJC,R1           OBJECT COUNT
         STH,V1   ADCFLG            RESET SWAP FLAG IF ON
         LI,R1    BA(MDBUF+1)       INITIALIZE
         BAL,L1   ADCZ0                OBJECT INFO IN M.C.
         LI,V2    ADCSUBZ           RESET REF CONTROL            140
         B        ADC16+1           SAVE AND READ
         TITLE    'CONDITIONAL ERROR HANDLING'
ADC60    RES      0
         DX       X'B8'             DIAGNOSTIC 184
ADC61    RCRF                       READ NEXT
         LH,V1    0,R2              NEW STATEMENT
         CI,V1    X'80'                IN
         BANZ     ADC99             YES- RETURN TO MASTER CONTROL
         LW,R1    R2                ACCESS
         AI,R1    1                     STATEMENT
         LH,V1    0,R1                  OPTIONS
         CI,V1    X'10'             SUBJECT FLAG ON
         BANZ     ADC53             YES- PROCESS NEXT RELATION
         B        ADC61             LOOP
*        RETURN TO MASTER CONTROL
ADC99    LCI      X'A'              RESTORE
         LM,R6    ADCRSAV               REGISTERS
         B        *L1               RETURN
         TITLE    'CONDITIONAL OUTPUT ROUTINE'
ADC44    RES      0
         LH,V1    ADCSUBJA          SUBJECT LINK SET
         BEZ      *L0               NO- RETURN
*        WRITE MASTER CLUSTER
         LW,D3    R5                SAVE R5
         LI,D1    X'11CB'           CLNG CNTL COMPLEX RELATION
         LI,R1    1                 HOW MANY
         LH,D2    ADCOBJC,R1          OBJECTS
         CI,D2    1                 ONLY ONE
         BE       ADC444            SIMPLE RELATION                     COBOL41L
         BG       ADC44A            COMPLEX                             COBOL41L
         DX       X'B6'       INVALID  DIAG  182                        COBOL41L
         B        *L0               RETURN                              COBOL41L
ADC44A   EQU      %                                                     COBOL41L
         LI,R4    BA(MDBUF)         WRITE OUT 'CB'
         STH,D1   MDBUF             CLNG & CTL INTO MDBUF
         BAL,L1   WRMCF             MASTER CLUSTER
         LH,R6    MDBUF,R1          SUBJECT TYPE
         CI,R6    2                 FLL
         BE       ADC442            YES
         CI,R6    3                 FLS
         BNE      ADC440            NO
ADC442   LH,V1    MDBUF+2           MAXD
         LH,R1    ADCSUBJA          ADDRESS
         AI,R1    HA(STBAS)+8          OF SUBJECT DECP
         STH,V1   0,R1              MAXD TO DECP
         PAGE
*
*        ROUTINE TO WRITE OUT THE STACK
*
ADC440   LH,R1    ADCSUBJA          PICK UP ANCHOR
ADC441   LW,R4    R1                NEXT
         LH,R1    STBAS,R1          LINK
         BEZ      ADC449            END OF STACK
ADC443   AI,R4    HA(STBAS)+1
         LH,V1    0,R4
         LI,D1    X'F8'             IS THIS
         AND,V1   D1                   AN EXPRESSION
         CI,V1    X'B8'                  RESULT CLUSTER
         BNE      ADC447            NO
         LW,7     WHENFLG
         BLEZ     %+5
         LH,7     SSTBS+1
         CI,7     1
         BAZ      %+2               SEARCH ALL ?
         STW,V1   EXPRESS           SET EXPRESSION FLAG
         LW,R5    R4                SET R5
         AI,R5    -1                TO CLOC-1
         STH,R1   ADCSUBJA          SAVE R1
         STW,L0   ADCR10            SAVE L0
         BAL,L1   EXPOUT            WRITE OUT EXPRESSION
         LW,L0    ADCR10            RESTORE L0
         B        ADC440            PICK UP R1 AND GET NEXT ENTRY
ADC447   LW,R7    R4
         AI,R7    1
         LH,R7    0,R7              OPTIONS FIELD
         BGEZ     %+4
         AI,R7    X'10000'          CLEAR SIGN BITS
         CI,R7    X'E000'           IS IT AN INTERNAL LABEL
         BGE      ADC68             YES- FORMAT POF CLUSTER
ADC445   LW,7     CKDCDGT           SHOULD CHECK DEC DIGIT
         BEZ      NOCHCK
         LI,7     6                 LIT ?
         CW,7     OBJTYPE
         BNE      TS0               TO TEST PACKED
         LI,7     0
         CW,7     SUBTYPE           PACKED ?
         BE       CHECK             CHECK DEC DIGIT
         LI,7     1
         CW,7     SUBTYPE           ND ?
         BE       CHECK
         BNE      NOCHCK
TS0      LI,7     0
         CW,7     OBJTYPE           PACKED OBJ
         BNE      NOCHCK
         CW,7     SUBTYPE           PACKED SUBJ
         BNE      CHCKSUB           TO CHECK SUBJ
CHECK    LW,7     4
         AI,7     7
         LH,7     0,7
         CW,7     DCDGLNG           COMPARE PREVIOUS DEC DIGIT LENG
         BGE      CHCKSUB-2
         LI,7     1                 SET DCDGFLG
         STW,7    DCDGFLG           SET COMPLEMENT FLAG
         B        NOCHCK            THROUGH
         STW,7    DCDGLNG           GET DEC DIGIT
         B        NOCHCK            THROUGH
CHCKSUB  LI,7     1
         CW,7     SUBTYPE           DISPLAY SUBJ ?
         BE       CHECK
         LI,7     4
         CW,7     SUBTYPE           BIN SUBJ ?
         BE       CHECK
         LI,7     6
         CW,7     SUBTYPE
         BE       CHECK
NOCHCK   AW,R4    R4                BA
         BAL,L1   ADV00             RESOLVE VAR REC PARAM
         BAL,L1   WRMCF
         B        ADC441            GET NEXT
ADC449   LW,R5    D3                RESTORE R5
         LI,7     0
         STW,7    CKDCDGT           CLEAR
         B        *L0               RETURN
*        CHANGE MASTER CLUSTER TO TYPE 'CC'
ADC444   AI,D1    -X'CFF'           CHANGE CLNG & CTL
         LI,R7    HA(MDBUF)+1
         LH,V1    0,R7
         STW,V1   SUBTYPE
         LH,V1    MDBUF+1
         STW,V1   OBJTYPE
         LH,V1    ADCFLG            SWAP FLAG
         BNEZ     ADC446            SWAP OPERANDS AND OUTPUT
         LH,V1    MDBUF+1           OBJECT TYPE
         CI,V1    -3                FIGCON/AN LIT
         BNE      ADC446+1          NO.
         MTH,1    ADCFLG            RAISE SWAP FLAG
ADC446   BAL,L1   ADC55             SWAP SUBJECT AND OBJECT
         STH,D1   MDBUF             CLNG & CNTL
         LI,R4    BA(MDBUF)         WRITE OUT M.C.
         BAL,L1   WRMCF
         LW,7     WHENFLG           WHEN CLAUSE ?
         BLEZ     BADC440
         LH,7     SSTBS+1
         CI,7     1                 SEARCH ALL ?
         BAZ      BADC440
         STW,7    CKDCDGT           SET CHECK DEC DIGIT FLAG
BADC440  B        ADC440            WRITE OUT STACK
ADCZ0    LI,V1    X'20'             COUNT FIELD
         STB,V1   R1
         MBS,0    X'24'             MOVE ZEROS
         B        *L1               RETURN
         PAGE
ADC55    RES      0
         LH,R1    ADCSUBJA          ORIGINAL SUBJECT ANCHOR
         LH,R7    STBAS,R1          POINTER TO OBJECT
         LH,V1    STBAS,R7          POINTER TO NEXT
         STH,V1   STBAS,R1          CHANGE OBJECT POINTER
         STH,R1   STBAS,R7          CHANGE NEXT
         STH,R7   ADCSUBJA          CHANGE SUBJECT POINTER
         LI,R1    HA(MDBUF)+1       SWAP
         LW,7     WHENFLG
         BLEZ     %+5
         LH,7     SSTBS+1
         CI,7     1                 SEARCH ALL ?
         BAZ      %+2
         STW,R1   FLPSUB
         LH,V1    0,R1                SUBJECT
         LH,R7    MDBUF+1             AND
         STH,R7   0,R1                OBJECT TYPES
         STW,R7   SUBTYPE
         STH,V1   MDBUF+1           IN M.C.
         STW,V1   OBJTYPE
         B        *L1               RETURN
         TITLE    'FORMAT JT/JF TO POF CLUSTERS'
ADC68    RES      0
         LH,D3    1,R4              INTERNAL LABEL NO.
         CI,R7    X'F00'
         BANZ     %+3
         LI,V0    CBR               UNCONDITIONAL BRANCH
         B        ADC687
         CI,R7    X'800'
         BANZ     ADC682            INTERNAL DEF
         CI,R7    X'400'
         BANZ     ADC686            EXTERNAL JUMP
         CI,R7    X'100'
         BANZ     ADC681            JUMP TRUE
         AI,R7    -X'E220'          REDUCE TO PROPER BRANCH
         CI,R7    8                 TEST NEGATION BIT
         BAZ      %+2               OFF
         AI,R7    -5                REDUCE BY 5
ADC680   EXU      ADC683,R7         LOAD PROPER OP CODE
         LH,V1    ADCFLG            HAVE SUBJ & OBJ BEEN FLIPPED
         BEZ      %+4               NO
         LH,V1     ADCFLG2           HAVE OPERANDS BEEN FLIPPED         COBOL41L
         BNEZ      %+2             YES THEY HAVE                        COBOL41L
         EXU      ADC693,R7         CHANGE OP CODE IF NECESSARY
         LH,V1    ADCFLG3                                               COBOL41L
         BEZ      %+2                                                   COBOL41L
         BAL,L1   ADC694                                                COBOL41L
         LI,V1    0                 TURN OFF
         STH,V1   ADCFLG            SWAP FLAG
         STH,V1   ADCFLG2             CLEAR COMPLEX COND FLAG           COBOL41L
         STH,V1   ADCFLG3                                               COBOL41L
ADC687   BAL,L1   WHENCLAS          TO TEST & GENERATE BRANCH FOR 'WHEN'
         BAL,L1   PII22             PUT OUT BRANCH
         B        ADC441            TO NEXT ENTRY IN STACK
WHENCLAS LW,7     WHENFLG           IS THIS WHEN CLAUSE ?
         BLEZ     *11               NO, GO BACK
         LH,7     SSTBS+1
         CI,7     1
         BAZ      *11               NOT SEARCH ALL GO BACK
         AI,L1    1
         STW,L1   BACKL1            SAVE RETURN ADDR
         LW,7     FLPSUB            FLIPPED SUB & OBJ ?
         BEZ      %+5               NO
         LCW,7    KEYDIRCT          COMPLEMENT KEY DIRECTION
         STW,7    KEYDIRCT
         LI,7     0                 CLEAR   FLAG
         STW,7    FLPSUB
         STW,7    DCDGLNG
         LW,7     DCDGFLG           SUBJ HAS FEWER DEC DIGIT ?
         BEZ      %+7               NO
         LCW,7    KEYDIRCT          COMPLEMENT
         STW,7    KEYDIRCT
         LI,7     0
         STW,7    DCDGFLG           CLEAR  FLG
         B        LKD
         LW,7     EXPRESS           IS THIS EXPRESSION ?
         BEZ      %+5               NO
         LI,7     0
         STW,7    KEYDIRCT          SET CONFLICT
         STW,7    EXPRESS           CLEAR EXPRESS
         B        LKD
         LI,R7    1
         CW,R7    OBJTYPE           OBJ = 1 ?
         BNE      LKD
         CW,R7    SUBTYPE           SUB = 1 ?
         BNE      LKD-3
         LCW,R7   KEYDIRCT          COMPLEMENT KEY DIRECT
         STW,R7   KEYDIRCT
         B        LKD
         LI,R7    4
         CW,R7    SUBTYPE
         BE       %-5
LKD      LW,R7    KEYDIRCT          TEST KEY DIRECTION
         BLEZ     DSKEY             TO DESCENDING KEY ROUTINE
ASKEY    BAL,L1   PIL06             WRITE
         BCR,3    7                     BE  %+7
         BAL,L1   PIL06             WRITE
         BCS,2    4                     BG  %+4
         BAL,L1   PIA06             WRITE
         LI,4     -1                    LI,4  -1
         LW,D3    DIRECT            LOAD INTL DEF# FOR DIRECTION
         LI,V0    X'3540'           LOAD STW,R4 TO V0
         BAL,L1   PRA22             WRITE STW,4  DIRECT
         LW,D3    JSTDL             LOAD DEF OF C:BIS
         BAL,L1   PII20             WRITE   B   TO  BAL,L1   C:BIS
         BAL,L1   PIA06             WRITE
         LI,4     1                     L1,4   1
         BAL,L1   PIL06             WRITE
         BCR,0    X'FFFD'           B   %-3
         B        *BACKL1           RETURN TO BAL,WHENCLAS+2
BACKL1   RES      1                 RETURN ADDR
DSKEY    BNEZ     DSKEY1            TO DESCENDING KEY
         MTW,4    GADNO             GET AVAIL ADDR
         LW,D3    GADNO
         SLS,D3   -2
         STW,D3   TEMPCC            SAVE CC ADDR
         LI,V0    X'7400'           WRITE
         BAL,L1   PRA22                  STCF   TEMPCC
         BAL,L1   PIA06             WRITE
         LI,4     2                    LI,4   2
         LW,D3    METHKY            LOAD METHKY ADDR
         LI,V0    X'3540'           LOAD  STW,4
         BAL,L1   PRA22             WRITE  STW,4  METHKY
         LW,D3    TEMPCC            LOAD CC ADDR
         LI,V0    X'7030'           WRITE
         BAL,L1   PRA22                  LCF   TEMPCC
         LW,D3    JSTDL             LOAD INTNL DEF OF C:BIS
         LI,V0    CBNE              LOAD OP CODE
         B        ADC687+1
DSKEY1   BAL,L1   PIL06             WRITE
         BCR,3    7                    BE  %+7
         BAL,L1   PIL06             WRITE
         BCS,1    4                    BL  %+4
         B        ASKEY+4
*        JUMP TRUE CLUSTER
ADC681   RES      0
         AI,R7    -X'E11D'          REDUCE
         CI,R7    8                 NEGATION BIT ON
         BAZ      ADC680            OFF
         AI,R7    -X'B'             REDUCE BY 11
         B        ADC680
ADC682   LW,V1    D3                INT. LABEL #
         BAL,L1   PPI32             GENERATE LABEL DEF
         B        ADC441            TO NEXT IN STACK
*        JUMP FALSE TO EXTERNAL
ADC686   LW,R7    R4
         AW,R7    R7
         AI,R7    1
         LI,D2    8
         STB,D2   0,R7
         AI,R7    1
         SLS,R7   -1
         LI,V0    CBNE
         STH,V0   0,R7
         B        ADC445            WRITE IT OUT
         TITLE    'CONDITIONS- EXECUTE TABLES'
*        EXECUTE TABLES
*        WEIGHT ASSIGNMENT / CLASSES
         LI,V1    ADCW1
         LI,V1    ADCW2
         LI,V1    ADCW2
ADC600   B        ADC601
         B        ADC602
         LI,V1    ADCW8
         LI,V1    ADCW7
         LI,V1    ADCW4
         LI,V1    ADCW3
         B        ADC601
         LI,V1    ADCW1
ADC601   LH,V1    4,R5
         AI,V1    ADCW6
         B        *L1               RETURN
ADC602   LH,V1    4,R5
         AI,V1    ADCW5
         B        *L1               RETURN
*        OP CODE ASSIGNMENTS FOR BCS / BCR
ADC683   LI,V0    CBNE
         LI,V0    CBGE
         LI,V0    CBLE
         LI,V0    CBE
         LI,V0    CBL
         LI,V0    CBG
         LI,V0     CBE                                                  COBOL41L
ADC693   NOP
         LI,V0    CBLE
         LI,V0    CBGE
         NOP
         LI,V0    CBG
         LI,V0    CBL
*      FLIP OP CODE WHEN SUBJECT = AN, OBJECT = EXPRESSION              COBOL41L
ADC694   RES      0                                                     COBOL41L
         LW,R4    V0                MOVE OP CODE TO R4                  COBOL41L
         AND,R4   L(X'00F0')        DETERMINE WHAT TYPE THIS IS         COBOL41L
         CI,R4    X'30'                                                 COBOL41L
         BE       ADC695            THIS IS (BE/BNE)                    COBOL41L
         LI,V1    X'0030'           MASK FOR (BGE/BLE/BL/BG)            COBOL41L
         B        %+2                                                   COBOL41L
ADC695   RES      0                                                     COBOL41L
         LI,V1    X'0100'           MASK FOR (BE/BNE)                   COBOL41L
         EOR,V0   V1                FLIP OP CODE                        COBOL41L
         B        *L1               RETURN                              COBOL41L
*        JUMP TABLE TO SET UP V2 BASED ON CLASS OF SUBJECT
         LI,V2    ADCFIG            -3 AN LIT/FIGCON
         LI,V2    ADCGRP            -2
         B        ADC701            -1 AN TEST IF <30
ADC700   LI,V2    ADCNC             0  NC/NE
         LI,V2    ADCND             1  ND
         LI,V2    ADCFLP            2  FLL
         LI,V2    ADCFLP            3  FLS
         LI,V2    ADCBIN            4  BIN
         LI,V2    ADCNC             5  INDEX
         LI,V2    ADCNC             6  N LIT
         LI,V2    ADCSUBZ           7  ZERO
*        CHECK SIZE OF LITERAL
ADC701   LH,V2    3,R4
         CI,V2    X'1E'             BSIZ
         BG       %+3                  >30
         LI,V2    ADCLE30           < = 30
         B        ADC702            RETURN
         LI,V2    ADCG30            >30
         B        ADC702            RETURN
         PAGE
*        C O N D I T I O N      N A M E S
         TITLE    'CONDITION NAMES PROCESSING'
ADC88    RES      0
         LI,R7    0                 CLEAR                               COBOL41L
         STW,R7   JINTLX              SAVED TRUE POINT                  COBOL41L
         BAL,L1   ADC222            CHECK NEXT CLUSTER
         CI,V1    X'40'             IS IT JTJF?
         BANZ     %+4               OK- CONTINUE
         DX       X'B9'             ILLEGAL RELATION
         B        ADC61             DELETE STATEMENT
         LW,7     WHENFLG
         BLEZ     %+5
         LH,7     SSTBS+1
         CI,7     1                 SEARCH ALL ?
         BAZ      %+2
         BAL,11   TEMINFOR          TERMINATE KEY INFOR
         LH,V1    R6                SUBJECT TYPE
         STW,V1   MDBUF                 INTO MASTER CLUSTER
         LI,V1    0                 MAKE SURE
         STH,V1   ADCRAN            RANGE FLAG DOWN
         STH,V1   4,R5              ZERO OUT DECP
         LW,R7    R4                SAVE R4- ACCESS ALL LITS/R7
         LH,D3    12,R7             FIRST LITERAL
         BLZ      ADC80             ONLY ONE LITERAL- PROCESS 'CC' TYPE
*        MORE THAN ONE LITERAL IN 88 AREA
*        SCAN THRU LITERALS AND BUILD MASTER CLUSTER
         LI,V1    X'11CB'           CLNG&CTL
         STH,V1   MDBUF                 TO MDBUF
         LI,R1    BA(MDBUF)+2       INITIALIZE
         BAL,L1   ADCZ0               M.C. BUFFER
ADC81    LI,R1    X'F00'            PICK UP
         AND,R1   D3                  CURRENT UD FIELD
         SLS,R1   -8                SET UP R6
         CI,R1    8                 FIGCON
         BAZ      %+3               NO
         LI,R6    -3                YES-TYPE = -3
         B        %+2               BYPASS EXU
         EXU      ADC801,R1           WITH APPROPRIATE TYPE CODE
         SLS,R6   16                TYPE TO HIGH HALF R6
         BAL,L1   ADC35             SET OBJECT TYPE/TYPE COUNT/OBJ CNT.
         CI,D3    X'8000'
         BANZ     ADC82
         AI,R7    2                 INCREMENT TO NEXT LITERAL
         LH,D3    12,R7             SCAN NEXT
         B        ADC81             LITERAL
ADC82    RES      0
         LI,R1    0                 CLEAR
         STH,R1   MDBUF+2              MAXD FIELD
         STD,R4   ADCR4
         LI,R4    BA(MDBUF)         PUT OUT 'CB' CLUSTER
         BAL,L1   WRMCF                 ON MCF
         LD,R4    ADCR4
*        AT THIS POINT ANOTHER SCAN IS MADE OVER LITERAL INFO
*        TO GENERATE MCF CLUSTERS IN OUTPUT STACK
         LI,R1    BA(MDBUF)         INITIALIZE
         BAL,L1   ADCZ0                 WORK AREA
         BAL,L1   ADC100            SET UP DUBJA AND ADCANCH
*        NOW ADJUST LINKAGE TO POINT BEYOND LITERAL INFORMATION
*        IN STACK BEFORE MOVING OBJECTS,ETC. TO STACK
         LH,R3    12,R5
         AI,R5    X'19'
         AW,R5    R3
         LW,R3    R5
         BAL,L1   ADC200            SET LINKAGE
*        SCAN LITERAL INFO AND GENERATE DATA/FIGCON CLUSTERS
*        AND APPROPRIATE JTJF CLUSTERS
         LW,R7    R4                R7 - CURRENT LITERAL POINTER
ADC88L   LI,R1    BA(MDBUF)         INITIALIZE
         BAL,L1   ADCZ0                MDBUF
         LH,V1    12,R7             UA-UE
         LI,R1    X'F00'            PICK UP
         AND,R1   V1                  UD
         SLS,R1   -8                TO LOW ORDER
         LI,L0    ADC83             SET RETURN ADDRESS
         CI,R1    8                 FIGCON?                 162
         BAZ      ADC880,R1         NO                      162
         CI,V1    X'FF'             ZERO TEST?              162
         BAZ      ADC818            YES                     162
         B        ADC819            PUT OUT FIGCON          162
*        EXAMINE THIS LITERAL WITH THE JTJF AND STACK JTJF/DEF
ADC83    LW,R1    R2                PICK UP
         AI,R1    2                     INT. LABEL FROM
         LH,D2    0,R1                 JTJF
         AI,R1    -1                PICK UP OPTIONS FIELD
         LH,D1    0,R1                  LEAVE R1 AT OPTIONS FIELD
         LH,V1    12,R7             UA-UE CURRENT LITERAL
         BLZ      ADC90             LAST LITERAL
         CI,V1    X'4000'
         BANZ     ADC70             FIRST OF RANGE PAIR
         LH,V1    ADCRAN            SECOND OF RANGE PAIR
         BEZ      ADC85             NO
         LI,V1    X'E222'           TO FORCE BLE
         STW,V1   MDBUF
         CI,D1    X'100'            A JUMP TRUE
         BAZ      ADC84             NO
ADC841   STH,D2   MDBUF+1           LABEL TO CLUSTER
         BAL,L0   ADC8A             MOVE JTJF TO STACK
         BAL,L0   ADC8B             BUILD INTERNAL DEF AND MOVE TO STACK
         AI,R7    2                 TO NEXT LITERAL
         MTH,-1   ADCRAN            TURN OFF RANGE FLAG
         B        ADC88L            PROCESS NEXT LITERAL
ADC84    LW,D2    JINTLX            PICK UP SAVED TRUE POINT
         B        ADC841
*        NOT LAST LITERAL - NOT IN RANGE PAIR
ADC85    LI,V1    X'E120'           TO FORCE BE
         STW,V1   MDBUF
         CI,D1    X'100'            JUMP TRUE
         BANZ     ADC87             JUMP FALSE                          COBOL41L
         MTW,0    JINTLX            SAVED TRUE POINT                    COBOL41L
         BEZ      ADC86             NO                                  COBOL41L
         LW,D2    JINTLX            YES - USE IT                        COBOL41L
ADC87    STH,D2   MDBUF+1           INTL
         BAL,L0   ADC8A             MOVE CLUSTER
         AI,R7    2                 TO NEXT LITERAL
         B        ADC88L            PROCESS IT
ADC86    LW,D2    JINTL             BE  TO NEXT
         AI,D2    1                 JINTL
         STW,D2   JINTLC            KEEP COUNT OF TRUE POINTS
         B        ADC87
*        LAST LITERAL IN STACK - NOW PROCESS FINAL BCS/BCR
ADC90    LI,R1    3
         LH,V1    ADCRAN            SECOND OF RANGE PAIR
         BEZ      ADC91             NO
         MTH,-1   ADCRAN            TURN OFF FLAG
         STH,D2   MDBUF+1
         LI,V1    X'2A'               BLE IF JT
         STB,V1   D1,R1               AND
         STW,D1   MDBUF               BG  IF JF
ADC92    BAL,L0   ADC8A             MOVE CLUSTER
         LW,V1    JINTLC            IS ANOTHER LOCAL DEF NEEDED
         CW,V1    JINTL
         BLE      ADC842            NO
         BAL,L0   ADC8B             GENERATE DEF
ADC842   LW,V1    JINTLX            IS THERE A TRUE POINT LEFT?
         BEZ      ADC843            NO
         SW,V2    V2                INITIALIZE
         STW,V2   JINTLX              SAVED INTERNAL
         BAL,L0   ADC8D             BUILD INTERNAL DEF
ADC843   LW,V1    JINTLX
         STW,V1   JINTLC
*        CONDITION NAME PROCESSED
*        READ NEXT AND CHECK FOR DEFS AND 'GO TOS' THEN WRITE OUT STACK
ADC93    RCRF
         BAL,L1   ADC222            IS NEXT
         CI,V1    X'C0'                AN INTERNAL
         BAZ      ADC94             NO- CHECK FURTHER
         LW,D0    R2                CLUSTER ADDRESS
         AW,D0    D0                   IN BYTES
         LI,D2    6                 COUNT
         BAL,L1   ADCMOV            MOVE TO STACK
         B        ADC93             READ NEXT
ADC94    BAL,L0   ADC440            WRITE OUT STACK
         LI,V1    0                 INITIALIZE
         STH,V1   ADCSUBJA              SUBJECT POINTER
         MTH,1    ADCS4S            FORCE NEXT OPERAND IF ANY- SUBJECT
         B        ADC50+1           PROCESS NEXT
*        LAST LITERAL - NOT IN RANGE PAIR
ADC91    LI,V1    X'20'             BE IF JT
         STB,V1   D1,R1             BNE IF JF
         STW,D1   MDBUF
         STH,D2   MDBUF+1
         CI,D1    X'100'            IS JTJF A JUMP TRUE
         BAZ      ADC92             NO- MOVE CLUSTER AND GENERATE A DEF
         BAL,L0   ADC8A             MOVE CLUSTER
         B        ADC92+2
*        FIRST OF RANGE PAIR
ADC70    LW,D3    D2                SAVE INTL
         LW,D2    JINTLX            HAS INTERNAL BEEN SAVED
         BNEZ     ADC73             YES
         MTW,1    JINTL             GRAB NEXT AVAILABLE
         LW,D2    JINTL             AND
         STW,D2   JINTLX            SAVE IT
ADC73    MTH,1    ADCRAN            TURN ON RANGE FLAG
         LW,R1    R7                ARE MORE
         AI,R1    2                 LITERALS FOLLOWING
         LH,V1    12,R1             THE RANGE PAIR
         BLZ      ADC71             NO
ADC72    LI,V1    X'E121'           FORCE A
         STW,V1   MDBUF                 BL
         B        ADC86             BL JINTL+1  GO TO NEXT LITERAL
ADC71    CI,D1    X'100'            JTJF JUMP TRUE
         BANZ     ADC72             YES
         LW,D2    D3                PICK UP INTL
         LI,V1    X'E229'           BGE  INTL
         STW,V1   MDBUF             MOVE CLUSTER
         B        ADC87             AND PROCESS NEXT LITERAL
*        ROUTINE TO SELECT OPERAND TYPE FOR '88' LITERALS
ADC801   RES      0
         LI,R6    -1                AND
         LI,R6    -1                AN
         LI,R6    0                 NC
         LI,R6    0                 NC
         LI,R6    4                 BIN
         LI,R6    3                 FLS
         LI,R6    2                 FLL
*        ROUTINE TO GENERATE DATA/FIGCON CLUSTERS FOR 88'S
ADC880   RES      0
         B        ADC810            AN
         B        ADC811            AN- ALL
         B        ADC812            NUMERIC
         B        ADC812            NC
         B        ADC814            BINARY
         B        ADC815            FLS
         B        ADC816            FLL
ADC810   LI,D1    X'0981'           CLNG & CNTL
         STH,D1   MDBUF
         LI,D2    X'FF'             PICK UP
         AND,D2   V1                     SIZE
ADC820   STW,D2   MDBUF+2           INTO DSIZ
         STH,D2   MDBUF+3                BSIZ
ADC830   LI,D2    X'400'            BASE 4
         STW,D2   MDBUF+1             TO BASE #
         AI,R7    1                 PICK UP
         LH,D1    12,R7                DISPLACEMENT
         STH,D1   MDBUF+2           INTO DISPL FIELD
         AI,R7    -1
         LI,D2    X'10'
ADC840   RES      0
         LI,D0    BA(MDBUF)         FROM MDBUF
         BAL,L1   ADCMOV            TO STACK
         B        *L0               RETURN
*        ONLY ONE LITERAL IN 88 AREA
*        FORMAT 'CC' CLUSTER - OUTPUT SUBJECT- LITERAL- JTJF
ADC80    RES      0
         LI,V1    X'04CC'           CLNG & CNTL
         STH,V1   MDBUF
         LI,R1    X'F00'
         AND,R1   D3
         SLS,R1   -8
         CI,R1    8
         BAZ      %+3
         LI,R6    -3
         B        %+2
         EXU      ADC801,R1         CHANGE R6 TO TYPE
         STH,R6   MDBUF+1
         B        ADC82             GO ON
*        AN COMPARISON WITH 'ALL' CHARACTERS
ADC811   RES      0
         LI,R1    X'0981'           CLNG & CNTL 'ALL'       162
         STH,R1   MDBUF                 INTO CLUSTER        162
*        PICK UP SIZE FROM CONDITION VARIABLE              162
         LH,D2    3,R4                                     162
         B        ADC820            FINISH CLUSTER
*        NUMERIC DISPLAY LITERAL (CHANGED TO PACKED DECIMAL)
*        PACKED DECIMAL LITERAL
ADC812   RES      0
         LI,V1    X'0988'           CLNG&CTL NC
         STH,V1   MDBUF               INTG CLUSTER
         LH,R1    ADCSUBJA          GET ADD
         AI,R1    HA(STBAS)            OF SUBJECT - 1
         LH,V1    3,R4              BSIZ
         SLS,V1   16
         STW,V1   MDBUF+3
         LH,V1    3,R1              DSIZ
         STW,V1   MDBUF+2
         B        ADC830
*        NUMERIC COMPARE WITH BINARY CONSTANT
ADC814   LI,V1    X'098D'           LNGTH&CNTL
         LI,D1    X'A'              DSIZ
         LI,D2    4                 BSIZ
ADC817   STH,V1   MDBUF
         STH,D1   MDBUF+2
         STH,D2   MDBUF+3
         B        ADC830
*        FLOATING SHORT
ADC815   LI,V1    X'098E'           CLNG & CNTL
         LI,D1    X'1E'             DSIZ
         LI,D2    8                 BSIZ
         LI,D3    X'7FFF'           DECP
         STW,D3   MDBUF+3
         B        ADC817
*        FLOATING LONG
ADC816   LI,V1    X'098F'           CLNG & CNTL
         B        ADC815+1
*        FIGCONS
*        ALPHA FIGCON- CHECK FIELD UE
ADC819   LI,D1    X'0390'           CLNG AND CNTL
         STH,D1   MDBUF
         LI,D1    X'FF'             PICK
         AND,V1   D1                   UP
         SLS,V1   8                 FIGCON DISPLACEMENT
         STH,V1   MDBUF+1           INTO FIELD D
ADC850   LI,D2    6                 NO OF BYTES
         B        ADC840            MOVE CLUSTER
*        NUMERIC WITH FIGCON ZERO
ADC818   LI,V1    X'0394'
         STH,V1   MDBUF
         B        ADC850
ADC8A    LI,V1    X'035C'
         STH,V1   MDBUF
         LI,D0    BA(MDBUF)
         LI,D2    6
         BAL,L1   ADCMOV
         B        *L0
ADC8B    MTW,1    JINTL
         LW,V1    JINTL
ADC8D    STH,V1   MDBUF+1
         LI,V1    X'E800'
         STW,V1   MDBUF
         B        ADC8A
         PAGE
*        ROUTINE TO SKIP REMAINDER OF BAD EXPRESSION
ADB90    RES      0
         RCRF                       READ NEXT CRF CLUSTER
         CI,L1    X'80'             FIRST CLUSTER BIT ON
         BANZ     *L0               YES - RETURN
         AI,R2    1                 PICK UP
         LH,L1    0,R2                  OPTUONS FIELD
         CI,L1    X'E000'           INTERNAL LABEL
         BLE      ADB90             NO- READ NEXT CLUSTER
         BDR,R2   *L0               RETURN WITH R2 SET TO HA(CLOC)
*
         BOUND    8
ADCR4    RES      2
ADCR10   RES      1
ADCWARN  DATA     0
ADCOR3   DATA     0
*
JINTLX   DATA     0
JINTLC   DATA     0
ADCFLG2    DATA     0                COMPLEX COND FLIP FLAG             COBOL41L
ADCFLG3  DATA     0                 AN SUBJ, EXPRESSION OBJ             COBOL41L
FLPFLG   DATA   3               MASK FOR FLIPPING OP CODES              COBOL41L
ADCW22      DATA   X'00060000'          WGHT OF ALPHANUMERIC FOR COMPLEXCOBOL41L
WHENFLG    DATA   0                                                     COBOL41L
METHKY   RES      1
DIRECT   RES      1
KEYDIRCT RES      1                 KEY DIRECTION
RETURN   RES      1
CMPLFLG  DATA     0                 COMPLEMENT FLAG
CMPLMENT DATA     0
TEMPCC   DATA     0
FLPSUB   DATA     0
EXPRESS  DATA     0
CKDCDGT  DATA     0
DCDGLNG  DATA     0
DCDGFLG  DATA     0
EXPANCH  DATA     0                 TEMP STOR FOR ADCANCH FOR EXPRESSIONCOBOL41L
SAVV2    DATA     0                SAVE REG 10  (V2)                    COBOL41L
RELOPB   DATA     0                 REL OP                              COBOL41L
SUBTYPE  RES      1
OBJTYPE  RES      1
KHASTK   EQU      JAKON+32          HA(STKTOP)
JINTL    EQU      JAMOD+13          INTL DEF,NO.
JTDB     EQU      JADAT+3
JDECP    EQU      JADAT+4
JSTDL    EQU      JADAT+X'31'
*        ASSIGNED PRIORITIES TO CLASSES FOR CONDITION LOADING
ADCW1    EQU      X'70000'
ADCW2    EQU      X'60000'
ADCW3    EQU      X'50000'
ADCW4    EQU      X'40000'
ADCW5    EQU      X'30000'
ADCW6    EQU      X'20000'
ADCW7    EQU      X'10000'
ADCW8    EQU      0
CBE      EQU      X'6830'
CBNE     EQU      X'6930'
CBG      EQU      X'6920'
CBL      EQU      X'6910'
CBGE     EQU      X'6810'
CBLE     EQU      X'6820'
CBR      EQU      X'6800'
*        TEMP STORES
ADCL1    EQU      JDCSAV            SAVED RETURN ADDRESS
ADCR3    EQU      JDCSAV+1          STACK TOP
ADCRSAV  EQU      JDCSAV+2
CRELTAB  EQU      JDCSAV+12
ADCSUBJA EQU      JDCSAV+12
ADCS4S   EQU      JDCSAV+13
ADCIJCT  EQU      JDCSAV+14         FORCED OBJ. COUNT (1ST)
ADCOBJC  EQU      JDCSAV+14         OBJECT COUNT (2ND)
ADCRLOP  EQU      JDCSAV+15         OPERATOR
ADCOPCT  EQU      JDCSAV+15         FLAG COUNT OF EXPECTED OBJECTS
ADCFLG   EQU      JDCSAV+16
ADCRAN   EQU      JDCSAV+16
ADCANCH  EQU      JDCSAV+17         CURRENT ANCHOR
ADCNXT   EQU      JDCSAV+18         CODE- CLUSTER IN R2-HIGH BYTE- 88
ADCANCX  EQU      JDCSAV+19
ADCWGHT  EQU      JDCSAV+20
         END
