         SYSTEM   SIG7FDP
         SYSTEM   BPM
         TITLE    'PHASE 4.1 - ARITHMETIC'
* 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
*                                                                       AA0
         DEF      ABG01
         DEF      ABG00             ADD
         DEF      ABK00             COMPUTE
         DEF      ABJ00             DIVIDE
         DEF      ABI00             MULTIPLY
         DEF      ABH00             SUBTRACT
         DEF      COMPFLG
         DEF      MTPLRST
         DEF      RDECP
         DEF      STMTYP
         REF      PRIMODE
         REF      WRMCF
         REF      WRPOF
         REF      DIAG
         REF      AAC00             READ
         REF      AA01,AA02,AA03    M.C. RETURNS
         REF      AAE00             READ
         REF      JMCRD,JMCER,JRDF  CORRES. SWITCHES
         REF      ADE00             ARITHMETIC EXPRESSIONS
         REF      ADF00,ADG00,ADH00 STACK,UNSTACK
         REF      ADI00,ADI02
         REF      GADNO             ADCON NO.
         REF      JAKON,JADAT,JASAV,JAMOD
         REF      STBAS             DATA STACK
         REF      MCBUF,MDBUF
         REF      AA14
         REF      EXPOUT            EXPRESSION OUTPUT ROUTINE
         REF      ADV00
* 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
XAS      EQU      182
XAW      EQU      185
* MCF CLUSTER CLNG,CNTL
*
CISAV    EQU      X'80000'          SAVE REF FLAG                       ADI455
IBGO     EQU      X'8'
IBGR     EQU      X'18'
CLOP     EQU      X'80'           A LAST OPERAND                        A
* REF DATA TYPE CONTROL SETTINGS
* MCF CLUSTER CLNG,CNTL
* 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
CJINL    EQU      X'602A1'          N LITERAL CNTL                      ADI887
CJIFZ    EQU      X'70390'        M FIGCON - ZERO                       ADI821
CJILZ    EQU      X'70696'        M LITERAL ZERO - AN                   ADI863
CJLIT    EQU      X'60000'          LIT REF FLAG                        ADF041
CJZFM    EQU      X'200'          M NC ZERO FILL CNTL ADJ.              ADI622
* 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
* RFLD TYPES                                                            ADG 2
DJAX     EQU      -2                INDEX                               ADG 21
DJAD     EQU      -1                NC/NE/ND - DESCENDING               ADG 22
DJAC     EQU      0                 NC/NE/ND - ASCENDING                ADG 23
DJAFL    EQU      1                 FLL                                 ADG 31
DJAFS    EQU      2                 FLS                                 ADG 32
DJAB     EQU      3                 BIN                                 ADG 33
DJAN     EQU      4                 AN/ANE                              ADG 34
DJAG     EQU      5                 GRP                                 ADG 35
DJZF     EQU      6                 ZERO/BLANK FILL                     ADG 36
DGFZ      EQU     6                 FLOATING ZERO
DGFTZ    EQU      10                TRUE FLOATING ZERO GLOBAL
OTCB      EQU     4                 OBJ TIME CONSTANT BASE
AFLZ     EQU      DGFTZ*4           BA TRUE FL ZERO OBJ TIME
*        STACKER  OUTPUT
*        JNREF    (BYTE) WORD ALIGNED
*        -1 DESC
*        JSIZM    HW WORD ALIGNED
*        JDECP    FW WORD ALIGNED
*        JTYPB    HW WORD ALIGNED
*        JNTYP    BYTE WORD ALIGNED
*        -1 DESC
*        JDMAX    HW WORD
*        JDMIN    HW
*        SPECIAL FOR CHECKOUT
ABG00    RES      0                 ADD
         B        %+1
         B        ABG00A
ABH00    RES      0                 SUBTRACT
         B        %+1
         B        ABH00A
ABI00    RES      0                 MULTIPLY
         B        ABM00
ABJ00    RES      0                 DIVIDE
         LI,V2    0
         STW,V2   RDECP             INITIALIZE RDECP
         B        ABD00
*
*
*        CORRESPONDING ENTRY ADD/SUBTRACT
ABG01    OR,V2    ASCONT            OPTIONS
         STW,V2   MCBUF
         LI,D0    0
         STW,D0   MCBUF+1
         CW,V2    SZEBIT
         BAZ      ABG03
         STW,V0   MCBUF+1           OSEO
         STH,V1   MCBUF+1           NSTAG
*   INTERNAL LABEL COUNT HAS BEEN INCREMENTED  AND WILL BE              COBOL41F
*    INCREMENTED AGAIN SO WE WILL ADJUST BY DECREMENTING                COBOL41F
         MTW,-1   JINTL                                                 COBOL41F
ABG03    RES      0
         AND,V2   RNDBIT
         STW,V2   COROUND
         B        ABA05
*        SUBTRACT
ABH00A   RES      0
         LI,V2    1
         STW,V2   STMTYP           STATEMENT IS SUBTRACT                COBOL41F
         B        ABA00
*        ADD
ABG00A   RES      0
         LI,V2    0
         STW,V2   STMTYP           STATEMENT IS ADD                     COBOL41F
*        ADD/SUBTRACT
ABA00    RES      0
ABA02    RES      0
         BAL,L1   AHB00
*                                   AND INITIALIZE MCBUF
ABA05    RES      0
         BAL,L1   ZMC00
*        SET UP LINKAGE TO ADF00 (STACKER)
ABA06    RES      0
         LI,D0    WA(KBA01)         EXU TABLE
         LI,D1    ABGTIC
*
         BAL,L1   ADF00             STACKER
         STW,R1   ASOPT
*
         CI,R4    0
         BE       ABA065
*        SET LAST OP BIT
         LH,D0    1,R5
         OR,D0    ABGLOP
         OR,D0    COROUND
         STH,D0   1,R5
         LI,D0    0
         STW,D0   COROUND           ZERO OUT
*        COMPUTE REC FIELD INDEX IF NO TO, GIV.
         LH,D0    0,R4
         AND,D0   K30F
         AI,D0    -X'D'
         BGEZ     ABA062            0,1,2  BIN, FLS, FLL
         LI,D0    3                 DECIMAL
ABA062   RES      0
         STW,D0   OPNDX             0,1,2,3
*
ABA065   RES      0
         BAL,L1   CRM00             RESULT MODE
         LI,R1    HA(MCBUF)
         BAL,L0   ACL00             PARTIAL CLUSTER CONSTRUCTION
ABA067   RES      0
         LW,D0    JDECP
         STW,D0   MCBUF+2           MAX DP
         LH,D0    JSIZM             ASCENDING
         STH,D0   MCBUF+2           MAX SIZE
         BAL,L1   SCD00
*
ABA07    CI,R7    0
         BE       ABA20             MORE OPS - TO / GIVING
*        LAST OPERAND
         CI,R4    0
         BE       *JMCER            LAST IN ERROR - QUIT
         LB,R1    JNREF             NO. OF OPERANDS
         CI,R1    1
         BLE      *JMCER            LESS THAN 2 OPS - QUIT
*
ABA10    RES      0
         LW,D0    OPNDX             0,1,2,3
         STH,D0   MCBUF+3           B,FS,FL,DEC
         LW,D0    MCBUF+1
         BEZ      ABA11
*        SIZE ERROR INC LINE NO.
         MTW,1    JINTL
*        OUTPUT CLUSTER AND OPS
ABA11    RES      0
         BAL,L1   ACA00
*        FINAL RETURN
ABA12    RES      0
         B        *JMCRD
*
ABA20    RES      0
         LW,D0    RESMOD
         CI,D0    X'D'
         BL       ABA21             DEC RESULT JDECP SET
         BE       ABA205            BINARY RESULT
*        FLOATING RESULT
         LI,D0    X'7FFF'           32767
         STW,D0   JDECP
         B        ABA21
ABA205   LI,D0    0
         STW,D0   JDECP
*
ABA21    RES      0
         LW,D0    ASOPT
         CI,D0    1
         BANZ     ABA25             FROM/TO
*        GIVING
         CI,R4    0
         BNE      ABA22
*
         STW,R3   ABAD
*
*
ABA22    RES      0
         LB,D0    JNREF
         CI,D0    1
         BG       ABA23
         STW,R3   ABAD
ABA23    RES      0
         BAL,L1   SGB00
         B        ABA30
*        FROM/TO
ABA25    RES      0
         BAL,L1   SFBB00
         LB,D0    JNREF
         BNEZ     ABA26
         STW,R3   ABAD
ABA26    RES      0
*        NO EDITED
         LI,V2    IBGO+CISAV
         LH,D0    1,R5              REMOVE
         SW,D0    ABGLOP            LAST
         STH,D0   1,R5              OP
*
ABA30    LI,D0    WA(KBA02)
*        STACKER
         BAL,L1   ADF00
ABA33    RES      0
*
*        EXIT IF BAD ELSE UPDATE JINTL
         BAL,L1   ABM50
*        MD CLUSTER
         BAL,L0   MDCL00
*
*
*
ABA40    RES      0
*        PUT OUT ORIGINAL ADD OPS
         BAL,L1   ACA00
*        PUT OUT GIVING/TO CLUSTER AND OPS
         BAL,L1   GT00
*
         B        *JMCRD
*
*        ABH00    CHECKS FOR OSE OPTION IN +-*/ COMPUTE
*                 SETS UP MCBUF - MCBUF+1
*        BAL,L0   ADH00
*        INPUT V2 WITH STATEMENT TYPE
AHB00    RES      0
         LI,D0    0
         STW,D0   MCBUF+1
         AND,R6   K2FF
         CW,R6    K2E5
         BNE      ABH10             NO SIZE ERROR OPTION
*        SIZE ERROR OPTION IN STATEMENT
         OR,V2    SZEBIT
ABH06    RES      0
         LH,V1    1,R2              NEXT STMT LABEL
         LI,R2    0                 CAUSE STACKER TO READ INITIALLY
         LW,V0    JINTL
         STW,V0   MCBUF+1
         STH,V1   MCBUF+1           NEXT STMT / INT LINE NO.
         MTW,1    MCBUF+1
*        NOT HERE                   INCREMENT INT LINE NO.
*        INITIALIZE MCBUF
ABH10    OR,V2    ASCONT
         STW,V2   MCBUF
         B        *L1
*        ADD/SUB OPERANDS
KBA01    RES      0
         BAL,L1   KBA016            NUM COMP / EDITED
         BAL,L1   KBA016            NUM DISPLAY
         BAL,L1   KBA013            FLOATING LONG
         BAL,L1   KBA012            FLOATING SHORT
         BAL,L1   KBA014            BINARY
         BAL,L1   KBA014            INDEX
         BAL,L1   KBA0160           NUM LIT                             COBOL41F
         BAL,L1   KBAZRO
KBAZRO   RES      0
         BAL,D3   ZROLIT                                                COBOL41F
         B        *L1
KBA012   RES      0
         LI,R3    2                 FLS
         B        KBA0135
KBA013   RES      0
         LI,R3    3                 FLL
KBA0135  RES      0
         STW,R3   FLOPFL            FLOATING OF FLAG
         B        *L1
KBA014   RES      0
         LI,R3    1                 BINARY
         B        KBA018
KBA0160  RES      0                                                     COBOL41F
         CI,V0    0                 IS LIT  AN INTEGER                  COB0L41F
         BNE      KBA016
         CI,V1    9                IS LIT OVER 9 DIGITS
         BG       KBA016
         LI,R3    4                 YES CLASSIFY AS  AN                 COB0L41F
         B        %+2                                                   COB0L41F
KBA016   RES      0
         LI,R3    0
KBA018   RES      0
         CW,V0    JDECP             V0 IS OP DECP
         BLE      KBA019
         STW,V0   JDECP             MAX DECP
KBA019   RES      0
         LW,D0    JDECP
         STW,D0   KDECP             FOR ROUNDING DX
         BAL,D3   ARDX              ROUND DX TEST
         B        *L1
*        ADD TO - SUB FROM A,B,C.   GIVE
KBA02    RES      0
         BAL,L1   KBA0215           NUM COMP, EDITED
         BAL,L1   KBA022            NUM DISPLAY
         LI,R3    3                 FL LONG
         LI,R3    2                 FL SHORT
         BAL,L1   KBA0212           BINARY
         BAL,L1   KBA0212           INDEX
         BAL,L1   ILL00             NUM LIT ILLEGAL
         BAL,L1   ILL00             ZERO
KBA0212  RES      0
         LI,R3    1                 BINARY
         B        KBA023
KBA0215  RES      0
         BAL,D3   BWZ00
KBA022   LI,R3    -1                DESCEND
KBA0221  LH,D0    4,R5              DECP
         CW,D0    JDECP
         BLE      KBA023
         LI,R3    0                 ASCENDING
KBA023   RES      0
         BAL,D3   ARDX              ROUND DX TEST
         B        *L1
*
*
*
*        BAL,D3   BWZ00
*
*
BWZ00    RES      0
         CI,R6    X'A'              1010
         BANZ     *D3
BWZ05    RES      0
         LH,D0    5,R5
         CI,D0    BWZBIT
         BAZ      BWZ10
         MTW,1    JINTE
BWZ10    RES      0
         B        *D3
*        R1 = HA(BUF)
*        BAL,L0
ACL00    RES      0
*        REFS, TYPEB, NTYPS, MODE FROM STACKER
*
         LH,D0    6,R1              NO. ASC.DEC.
         STH,D0   8,R1              NUMBER DECIMAL
         LB,V0    JNREF
         STH,V0   4,R1
         STW,V0   MTPLRST
         LH,V0    JTYPB
         STH,V0   5,R1
         AI,R1    1
         LB,V0    JNTYP
         STH,V0   4,R1
         LW,V0    RESMOD
         STH,V0   3,R1
         LW,V0    R1
         AI,V0    6
         STW,V0   SAVRMOD
*        NUMBER DECIMAL
         LH,D0    5,R1              NUMBER DESC. DEC.
         AI,R1    -1
         AH,D0    8,R1
         STH,D0   8,R1              TOT NO DECIMAL
         B        *L0
*
*        MDBUF PARTIAL CONSTRUCTION AFTER STACKER TO  GIVING
*        BAL,L0
MDCL00   RES      0
*        IF SINGLE REC FIELD SET BIT IN MCBUF
         LB,V0    JNREF
         CI,V0    1
         BNE      MDCL10
*
         LI,V0    ESNGREC
         OR,V0    MCBUF
         STW,V0   MCBUF
*
MDCL10   RES      0
         LW,8     STMTYP
         CI,8     3                 DIVIDE STMT ?
         BNE      X+5               NO
         LW,8     RESMOD
         CI,8     X'D'              BIN RESULT MODE ?
         BNE      XX                CHECK DEC RESULT MODE
         LW,8     PRIMODE           CHECK PRIORITY OF RESULTS
         CI,8     2                 DEC ?
         BGE      %+3               NO
         LI,8     8                 SET DEC OPERATION
         B        X
         CI,8     4                 BIN ?
         BGE      X+3               YES
         LI,8     X'F'              SET COMP-2 RESULT MODE
X        LW,1     SAVRMOD
         STH,8    0,1               UPDATE RESULT MODE
         STW,8    RESMOD
         LI,1     4
         STW,1    PRIMODE
         LI,R1    HA(MDBUF)
         B        ACL00
XX       CI,8     X'8'              DEC RESULT MODE
         BNE      X+3               SKIP
         LW,8     PRIMODE           CHECK PRIORITY MODE
         CI,8     4                 BIN ?
         BGE      X+3               YES, SKIP
         CI,8     2                 DEC RESULT MODE ?
         BL       X+3               YES, SKIP
         LI,8     ESMPLOP           LOAD NUM FIRST
         OR,8     MCBUF
         STW,8    MCBUF
         B        X-1               SET FLOAT RESULT MODE
*
*
*        PUT OUT MCBUF AND ORIGINAL ADD OPS
ACA00    RES      0
         STW,L1   ACARET
         BAL,L1   AA14              BLANK WHEN ZERO
         WMCF     ,BA(MCBUF)
*
         LI,R6    1                 BIN, FLS, FLL, ZERO
         LI,R7    3                 NO ZEROS
         LI,D0    WA(MCBUF)+6
         LI,D1    WA(MCBUF)+10
         BAL,L1   ADH00
         LI,R6    0
         LI,R7    1
         BAL,L1   ADH00+2
         B        *ACARET
*
GT00     RES      0
         STW,L1   GTRET
*
GT10     RES      0
*
*        MDCL00 ALREADY EXECUTED
         LW,D3    GT81              DEC
         LW,R1    RESMOD            8,D,E,F
         CI,R1    X'D'
         BL       GT20              DEC RESULT DECP, SIZE OK
*        BINARY OR FLOATING RESULT
         AI,R1    -X'D'
         LH,D0    JTYPB
         CI,D0    X'2000'
         BAZ      GT12
         LH,D0    JDMAX             ASCEND MAX DP
         B        GT13
GT12     LW,D0    JDMAX-1           DESC MAX DP
GT13     STW,D0   MDBUF+2
GT15     LW,D3    GT80,R1
GT20     RES      0
         MTW,0    REMBIT
         BEZ      GT21              NO REMAINDER
         LW,D0    RDECP
         STH,D0   MDBUF+5           SET DECP TO L
         MTW,-1   REMBIT
GT21     RES      0
         WMCF     ,BA(MDBUF)
GT22     RES      0
         LH,R6    D3
         BEZ      GT25
         LI,R7    1
         LI,D0    WA(MDBUF)+5
         LI,D1    WA(MDBUF)+9
         BAL,L1   ADH00
         STH,R7   D3
         SLS,D3   4
         B        GT22
GT25     B        *GTRET
GT80     RES
         DATA     X'35421'          BIN
         DATA     X'45321'          FLS
         DATA     X'54321'          FLL
GT81     DATA     X'21543'          DECIMAL
*        PUT OUT MULTIPLY MASTER CLUSTER
*
*
ACAM00   RES      0
         STW,L1   ACARET
         BAL,L1   AA14
         WMCF     ,BA(MCBUF)
         LW,D3    ACAM81
         LW,R1    RESMOD
         CI,R1    X'D'
         BL       ACAM20            DEC RESULT
         AI,R1    -X'D'             0,1,2
         LW,D3    ACAM80,R1
*
ACAM20   RES      0
         LH,R6    D3
         BEZ      ACAM25
         LI,R7    1
         LI,D0    WA(MCBUF)+5
         LI,D1    WA(MCBUF)+9
         BAL,L1   ADH00
         STH,R7   D3
         SLS,D3   4
         B        ACAM20
*
ACAM25   RES      0
         B        *ACARET
*
ACAM80   RES      0
         DATA     X'12453'          BIN
         DATA     X'12354'          FLS
         DATA     X'12345'          FLL
ACAM81   RES      0
         DATA     X'31452'          DEC
*  THIS CODE DECIDES WHICH TYPE NUMERIC LITERAL INTERGERS WILL BE       COB0L41F
*  GENERATED IN  AND LINKS  THEM TO THE  APPR0PREIATE TYPE.             COB0L41F
*  THEY ARE STACKED TEMPORARLY AS ALPHANUMERIC                          COB0L41F
*  SIDR  SIG7-0703                                                      COB0L41F
INTLINK  RES      0                                                     COB0L41F
         LCI      4                                                     COB0L41F
         STM,R2   LNKSAV                                                COB0L41F
         EOR,R1   L(X'200')         TURN OFF LIT BIT                    COB0L41F
         LI,R2    4                 SET R2 T0 4  (INT LIT) INDEX        COB0L41F
         CI,R1    X'2000'                                               COB0L41F
         BANZ     LNKDEC            DECIMAL                             COB0L41F
         CI,R1    X'1000'                                               COB0L41F
         BANZ     LNKBIN            BINARY                              COB0L41F
         CI,R1    X'0800'                                               COB0L41F
         BANZ     LNKFLS            FLOATING SHORT                      COB0L41F
         CI,R1    X'0400'                                               COB0L41F
         BANZ     LNKFLL            FLOATING LONG                       COB0L41F
         LH,R4    *JDANC,R2         GET  ANCHOR                         COB0L41F
         STH,R4   *JDANC            STORE IN DEC ASSENDING              COB0L41F
         LH,R4    JLNKL,R2          GET LINK TO LAST ITEM IN STACK      COB0L41F
         STH,R4   JLNKL             STORE IN DEC ASSENDING              COB0L41F
         OR,R1    L(X'2000')        SET DEC ASSENDING TYPE BIT 0N       COB0L41F
         LH,R4    *JDREF,R2         GET COUNT OFF 0PERANDS              COB0L41F
         STH,R4   *JDREF            STORE IN DEC ASSENDING              COB0L41F
         B        LNKEXT                                                COB0L41F
LNKBIN   LI,R3    1                 SET INDEX FOR BINARY                C0B0L41F
         B        LNKBFFD                                               C0B0L41F
LNKFLL   LI,R3    3                 SET INDEX FOR FLOATING LONG         C0B0L41F
         B        LNKBFFD                                               C0B0L41F
LNKFLS   LI,R3    2                 SET INDEX FOR FLOATING SHORT        C0B0L41F
         B        LNKBFFD                                               C0B0L41F
LNKDEC   LI,R3    0                                                     C0B0L41F
LNKBFFD  RES      0                                                     C0B0L41F
         LH,R5    JLNKL,R2          GET LNK TO LAST LITERAL             C0B0L41F
         LH,R4    *JDANC,R3         GET ANCHOR                          C0B0L41F
         STH,R4   STBAS,R5          LINK LAST LIT TO FIRST VARIABLE     C0B0L41F
         LH,R4    *JDANC,R2         ANCHOR OF LIT                       C0B0L41F
         STH,R4   *JDANC,R3         ANCHOR OF VARIABLE                  C0B0L41F
         LH,R4    *JDREF,R3         COUNT OF VARIABLE                   C0B0L41F
         AH,R4    *JDREF,R2         ADD LIT COUNT
         STH,R4   *JDREF,R3         STORE IT                            C0B0L41F
         MTB,-1   JNTYP             REDUCE TYPE COUNT                   C0B0L41F
LNKEXT   STH,R1   JTYPB             RESET TYPE BITS                     C0B0L41F
         LCI      4                                                     C0B0L41F
         LM,R2    LNKSAV                                                C0B0L41F
         B        *L0
LNKSAV   RES      4                                                     C0B0L41F
*
*
*        COMPUTE RESULT MODE FROM JTYPB
*        LEFT BY STACKER
*        BAL,L1   CRM00
*        OUTPUT IN RESMOD           8,D,E,F 0 = ZERO
CRM00    RES      0
CRM10    LH,R1    JTYPB
*                          SIG7-0703                                    COB0L41F
*  THIS CODE CHECKS TO SEE IF WE HAVE ENCOUNTERED ANY INTEGED           COB0L41F
*  LITERALS IF SO A ROUTINE  TO RECLASSIFY THEM AND  LINK THEN T0       COB0L41F
*  THEIR  APPR0PREATE  STACK.  INTEGER  LITERALS HAVE BEEN STACKED      COB0L41F
*  AS ALPHA NUMERIC TYPE                                                COB0L41F
         CI,R1    X'200'            ANY ALPHA (LIT INT) FIELDS          COB0L41F
         BAZ      %+2               NO                                  COB0L41F
         BAL,L0   INTLINK           YES RE-LINK                         COB0L41F
*                    SIDR SIG7-0703                                     COB0L41F
         SLS,R1   -10
         AND,R1   K307              B,FS,FL BITS
         LH,V0    JTYPB
         AND,V0   CRMDEC
         BEZ      CRM15
*        SOME DEC FIELDS
         EXU      CRM61,R1
         B        CRM20
*        NO DEC FIELDS
CRM15    EXU      CRM60,R1
CRM20    STW,V0   RESMOD            RESULT MODE
         B        *L1
*        NO DECIMAL FIELDS IN ARITH
CRM60    RES      0
         LI,V0    X'0'              ALL ZERO
         LI,V0    X'F'              FLL
         LI,V0    X'E'              FLS
         LI,V0    X'F'              FLS,FLL = FLL
         LI,V0    X'D'              BIN
         LI,V0    X'F'              BIN,FLL = FLL
         LI,V0    X'F'              BIN,FLS = FLL
         LI,V0    X'F'              BIN,FLS,FLL = FLL
*        DECIMAL FIELDS
CRM61    RES      0
         LI,V0    X'8'              DECIMAL ONLY
         LI,V0    X'F'              FLL
         LI,V0    X'F'              DEC,FLS = FLL
         LI,V0    X'F'              FLS,FLL = FLL
         LI,V0    X'8'              BIN,DEC = DEC
         LI,V0    X'F'
         LI,V0    X'F'
         LI,V0    X'F'
*        ADD/SUB CONTROL
* MULTIPLY                          TYPE = X'5F'                        ABI
*
*        MULTIPLY
ABM00    RES      0
         LI,D0    WA(KMO00)
         STW,D0   MDEXNO
         LI,V2    2                 MULTIPLY
         STW,V2   STMTYP
         SLS,V2   13                2 MULTIPLY
ABM01    RES      0                 OSE OPTION
         BAL,L1   AHB00
         BAL,L1   ZMC00
         LW,D0    MDEXNO
         LI,D1    ABGTNI            40000
         BAL,L1   ADF00             STACKER
         STW,R1   MDOPT             OPTION BITS
*
ABM05    RES      0
         CI,R4    0
         BNE      ABM06
         STW,R3   ABAD              LAST OP BAD
*
ABM06    RES      0
         BAL,L1   CRM00
         LI,R1    HA(MCBUF)
         BAL,L0   ACL00             PARTIAL CLUSTER
ABM07    RES      0
         CI,R7    0
         BE       ABM08
*        NO MORE OPS
         B        *JMCER
ABM08    RES      0
         LW,D0    STMTYP
         CI,D0    3
         BE       ABD10             DIVIDE
*
*
*        MORE OPS  BY ... GIVING ...MULTIPLY
ABM085   RES      0
*        SIZE,DECP OF DEC RESULT IN MCBUF
         LW,D0    KDECP
         STW,D0   MCBUF+2
         LW,D0    KSIZM
         STH,D0   MCBUF+2
         LW,D0    MDOPT
*
         CI,D0    1
         BAZ      ABM30             GIVING
*        BY SERIES
*        A BY SERIES
ABM20    RES      0
         LB,D0    JNREF
         CI,D0    1
         BE       ABM21
         STW,R3   ABAD
ABM21    RES      0
         BAL,L1   SFBB00            BY BIT
         LD,D0    KSIZM
         STD,D0   KSIZMS
         LI,D1    ABGTIC
         LI,D0    WA(KMB00)
*
         BAL,L1   ADF00
*
         BAL,L1   ABM50
*
         BAL,L0   MDCL00
*
ABM23    RES      0
         BAL,L1   SCD00
*
*
         BAL,L1   ACAM00            MULT CLUSTER AND OPS
*
         BAL,L1   GT00
         B        *JMCRD
*
*        A BY B   GIVING SERIES
ABM30    RES      0
         LB,D0    JNREF
         CI,D0    2
         BE       ABM31
         STW,R3   ABAD
ABM31    RES      0
         BAL,L1   SGB00             GIVING BIT
         LW,D0    MCBUF
         OR,D0    KDUBL
         STW,D0   MCBUF
         LW,D0    MINF
         STW,D0   KDWANT
*
ABM32    RES      0
         LI,D0    WA(KMG00)
         BAL,L1   ADF00             STACKER
*
         BAL,L1   ABM50
*
         BAL,L0   MDCL00
ABM33    RES      0
         BAL,D3   MS00
*
*
         LW,R1    LDEN
         AI,R1    -1
         BAL,L1   SRS00             STORE SHIFT
*
         LW,R1    LNUM
         AI,R1    -1
         BAL,L1   SRS00
*
         LW,D0    KDECP
         STW,D0   MCBUF+2
         LW,D0    KSIZM
         STH,D0   MCBUF+2
         BAL,L1   SCD00
*
ABM34    RES      0
*
         BAL,L1   ACAM00            MULT CLUSTER AND OPS
         BAL,L1   GT00
         B        *JMCRD
*
*        BAL,L1
ABM50    RES      0
         LW,D0    ABAD
*        SIDR  4094                                                     COB0L41F
*        THE FOLLOWING FIX ISSUES A DIAG WHEN THERE ARE FEWER THAN      COB0L41F
*        TWO OPERANDS IN THE STATEMENT.                                 COB0L41F
         BNEZ     ABM51                                                 COB0L41F
         LB,D0    JNREF
         BEZ      ABM51                                                 COB0L41F
         B        IJNL00            INC JINTL
ABM51    RES      0                                                     COB0L41F
         DX       36                ISSUE DIAG.                         COB0L41F
         B        *JMCER                                                COB0L41F
*
*        MULTIPLY OPERANDS EXU TABLE
KMO00    RES      0
         BAL,L1   KMO02             NUM. COMP / EDITED
         BAL,L1   KMO015            NUM DISPLAY
         BAL,L1   KMO001            FL LONG
         BAL,L1   KMO002            FL SHORT
         BAL,L1   KMO01             BINARY
         BAL,L1   KMO01             INDEX
         BAL,L1   KMO02             NLIT
         BAL,L1   KMOZRO
KMOZRO   RES      0
         BAL,D3   ZFLZ00
*
KMO001   RES      0                 FL LONG
         LI,R3    3
         STW,R3   FLOPFL            FLOATING OP FLAG
         B        KMO03
KMO002   LI,R3    2                 FL SHORT
         STW,R3   FLOPFL
         B        KMO03
KMO01    RES      0
         LI,R3    1
         B        KMO025
KMO015   RES      0                 DISPLAY NUMERIC
         LI,R3    -1                DESCENDING (JUST FOR ORDER)
         B        KMO025
*
KMO02    RES      0
         LI,R3    0                 ASCENDING
KMO025   RES      0
         AWM,V0   KDECP
         AWM,V1   KSIZM
         CI,V1    15
         BLE      KMO03
         LI,D0    EDUBLB            DUBL BIT (10)
         STW,D0   KDUBL
         STW,D0   KDUBLI
KMO03    RES      0
         B        SDNL00            SAVE DEN,NUM LOC (1ST ,2ND)
*        MULTIPLY SERIES
*        A BY B,C,D.
KMB00    RES      0
         BAL,L1   KMB03             NUM COMP.
         BAL,L1   KMB03             NUM DISP.
         LI,R3    3                 FLL
         LI,R3    2                 FLS
         BAL,L1   KMB02             BIN
         BAL,L1   KMB02             INDEX
         BAL,L1   ILL00             NUM LIT ILLEGAL
         BAL,L1   ILL00             ZERO
KMB02    RES      0
         LI,R3    1                 BINARY
         B        KMB035
KMB03    RES      0
         LI,R3    -1                DESCENDING
KMB035   RES      0
         LD,D0    KSIZMS
         STD,D0   KSIZM
         LH,D0    1,R5
         AND,D0   RNDBIT
         STW,D0   JDRND
         CI,V1    15
         BLE      KMB05
         LI,D0    EDUBLB            DOUBLE BIT
         STW,D0   KDUBLI
KMB05    STW,V0   KDWANT
         AWM,V0   KDECP
         AWM,V1   KSIZM
         BAL,D3   MRDX              MULT ROUND DX TEST
         BAL,D3   MS00
*
KMB10    RES      0
*        STORE SHIFT IN CLUSTER
         LW,R1    R5
         B        SRS00             L1 LOADED FOR RETURN
*
         B        *L1
*        MULTIPLY GIVING A,B,C
KMG00    RES      0
         BAL,L1   KMG03             NUM COMP
         BAL,L1   KMG03             NUM DISPLAY
         BAL,L1   KMGFL             FL LONG
         LI,R3    2                 FL SHORT
         BAL,L1   KMG02             BINARY
         BAL,L1   KMG02             INDEX
         BAL,L1   ILL00             NLIT
         BAL,L1   ILL00             ZERO
*
KMGFL    RES      0
         MTW,1    SFSRF             SET TO INDICATE FL LONG RESULT
         LI,R3    3                 FL LONG
         B        *L1
*
KMG02    RES      0
         LI,R3    1
         B        KMG05
KMG03    RES      0
         BAL,D3   BWZ00
         LI,R3    -1                DESCENDING (QUESTION)
KMG05    RES      0
         LH,D0    1,R5
         CI,D0    4                 ROUND
         BAZ      KMG055
         CW,V0    KCOMR
         BL       KMG055
         STW,V0   KCOMR             MQX DP ROUNDED
KMG055   RES      0
         CW,V0    KDWANT
         BL       KMG06
         STW,V0   KDWANT
         LH,D0    1,R5
         CI,D0    4
         BAZ      KMG06
         MTW,1    KDWANT            +1 FOR ROUNDING
KMG06    RES      0
         LW,D3    COMPFLG
         BNEZ     *L1               COMPUTE
         BAL,D3   MRDX              ROUND DX TEST
         B        *L1
*
*        MRDX
*        BAL,D3
*
ARDX     RES      0
*
MRDX     RES      0
*        V0 IS DECP OF OPERAND
         CW,V0    KDECP
         BL       *D3
MRDX3    RES      0
         LH,D0    1,R5
         CW,D0    RNDBIT
         BAZ      *D3
*        ROUNDED DIAGNOSTIC         ERROR
         LH,D0    0,R4
         AND,D0   K30F
         CI,D0    X'D'              BINARY
         BE       MRDX4             GIVE DX
         LW,D0    FLOPFL            FLOATING OP FLAG
         BNEZ     *D3               FLOATING OPS
MRDX4    RES      0
         LH,D0    1,R5              OPTOIONS
         AND,D0   NRND              TURN OFF ROUND
         STH,D0   1,R5
MRDX5    RES      0
         STW,L1   MRDL1
         STW,D3   MRDRET
         DX       126
*
         LW,L1    MRDL1
         B        *MRDRET
*
ABD00    RES      0
         LI,V2    3
         STW,V2   STMTYP
         SLS,V2   13                3 DIVIDE
         LI,D0    WA(KDO00)
         STW,D0   MDEXUO
         B        ABM01
ABD10    RES      0
         LW,D0    MDOPT
         CI,D0    X'10'
         BAZ      ABD11
         LI,D0    X'400'            SET REMAINDER BIT
         AWM,D0   MCBUF             UPDATE C OF MCF
         MTW,1    REMBIT
         B        ABD30
ABD11    LW,D0    MDOPT
         CI,D0    1
         BAZ      ABD30             GIVING
*        DIVIDE A INTO B (,C,D).
ABD20    RES      0
         LB,D0    JNREF
         CI,D0    1
         BE       ABD21
         STW,R3   ABAD
ABD21    RES      0
ABD22    RES      0
         BAL,L1   SFBB00
         LI,D0    WA(KDI00)
         BAL,L1   ADF00             STACKER
*
ABD24    RES      0
*        EXIT IF BAD ELSE INCREMENT JINTL
         BAL,L1   ABM50
         BAL,L0   MDCL00
         BAL,L1   SCD00
*
         BAL,L1   ACA00
*
         BAL,L1   GT00
*
         B        *JMCRD
*
*        A INTO B GIVING
ABD30    RES      0
         LB,D0    JNREF
         CI,D0    2
         BE       ABD31
         STW,R3   ABAD
*
ABD31    RES      0
         LW,D0    RESMOD
         CI,D0    X'D'
         BGE      ABD32             D,E,F - LOAD NUM FIRST
*        DEC RESULT
         LW,R1    LDEN
         LH,D0    0,R1
         AND,D0   K30F
         CI,D0    7
         BLE      ABD33             DEN DISPLAY
ABD32    RES      0
         LI,D0    ESMPLOP           LOAD NUM FIRST
         OR,D0    MCBUF
         STW,D0   MCBUF
*
ABD33    RES      0
         LW,D0    MINF
         STW,D0   KDWANT
         BAL,L1   SGB00
         LI,D0    WA(KDG00)
*        STACKER
         BAL,L1   ADF00
*
*
ABD34    RES      0
         BAL,L1   ABM50
         BAL,L0   MDCL00
*
         BAL,D3   DS00              DIVIDE SHIFT
         LW,D0    KDECP
         STW,D0   MCBUF+2
         LW,D0    KSIZM
         STH,D0   MCBUF+2
         LW,D0    KSHFT
         STH,D0   MCBUF+3
*        STORE THE SHIFT IN NUM AND DEN.
         LW,R1    LDEN
         AI,R1    -1
         BAL,L1   SRS00
         LW,R1    LNUM
         AI,R1    -1
         BAL,L1   SRS00
*
         BAL,L1   SCD00
ABD35     RES     0
*
         BAL,L1   ACAD00
*
         BAL,L1   GT00
         B        *JMCRD
*        DIVIDE GIVING OUTPUT FIRST 2 OPS
ACAD00   RES      0
         STW,L1   ACARET
         BAL,L1   AA14              BWZ LINE NOS.
         WMCF     ,BA(MCBUF)
         LW,D0    MCBUF
         CI,D0    ESMPLOP
         BAZ      ACAD10
*        SWITCH NUM FIRST THEN DEN.
         LW,D0    LDEN
         XW,D0    LNUM
         STW,D0   LDEN
*
ACAD10   RES      0
         LW,R4    LDEN
         AW,R4    R4
         BAL,L1   ADV00             RESOLVE VAR REC PARAM
         WMCF
         LW,R4    LNUM
         AW,R4    R4
         BAL,L1   ADV00             RESOLVE VAR REC PARAM
         WMCF
         B        *ACARET
*
*        BAL,D3   DS00
DS00     RES      0
         LI,D0    0
         STW,D0   KSHFT
         LD,D0    KNMSZ
         STD,D0   KSIZE
         LW,D0    KDECP             NUM DECP
         SW,D0    KDNDP             DEN DECP
         STW,D0   KDECP             RESULT
         LW,D0    KDWANT
         CW,D0    MINF
         BE       DS15
DS01     RES      0
         SW,D0    KDECP
         BLEZ     DS05              NO SHIFT
         CI,D0    64
         BLE      DS03
         LI,D0    64
DS03     RES      0
         STW,D0   KSHFT
         AWM,D0   KSIZE
         AWM,D0   KDECP
DS05     RES      0
         LW,D0    KSIZE
         CI,D0    15
         BLE      DS10
         LI,D0    EDUBLB
         STW,D0   KDUBLI
DS10     RES      0
         B        *D3
*
*        ALL FL RESULTS
DS15     RES      0
         LI,D0    30
         SW,D0    KNMSZ
         B        DS03
*
KDO00    RES      0
         BAL,L1   KDO02             NUM COMP
         BAL,L1   KDO02             NUM EDITED
         BAL,L1   KDO006            FLL
         BAL,L1   KDO007            FLS
         BAL,L1   KDO01             BINARY
         BAL,L1   KDO01             INDEX
         BAL,L1   KDO02             NUM LIT
         BAL,L1   KDO005            ZERO
*        ZERO
KDO005   RES      0
         BAL,D3   ZFLZ00
*        FLL
KDO006   RES      0
         LI,R3    3                 FLL
         B        KDO04
*        FLS
KDO007   RES      0
         LI,R3    2
         B        KDO04
*
*
KDO01    LI,R3    1
         B        KDO03
KDO02    RES      0
         LI,R3    0                 ABSC
KDO03     RES     0
         LB,R1    JNREF             0,1
         AW,R1    R1                0,2
         AND,R1   K302              DEN S,DP  NUM S  DP
         STW,V1   KDNSZ,R1
         STW,V0   KDNDP,R1
         CI,V1    15
         BLE      KDO04
         LI,D0    EDUBLB
         STW,D0   KDUBL
KDO04    RES      0
         B        SDNL00            SAVE LOC   RETURN
*        DIVIDE INTO B,C,D.
KDI00    RES      0
         BAL,L1   KDI02             NUM COMP
         BAL,L1   KDI02             NUM DISPLAY
         BAL,L1   KDI20             FLL
         BAL,L1   KDI22             FLS
         BAL,L1   KDI01             BIN
         BAL,L1   KDI01             INDEX
         BAL,L1   ILL00             NUMLIT   (NEVER)
         BAL,L1   ILL00             ZERO
*        BINARY
KDI01    RES      0
         LI,R3    1
         B        KDI03
*
KDI02    RES      0
         LI,R3    0                 ASC
KDI03    RES      0
         STW,V0   KNMDP
         STW,V1   KNMSZ
         STW,V0   KDWANT
         CW,R7    RNDBIT
         BAZ      KDI05
         MTW,1    KDWANT
KDI05    RES      0
         BAL,D3   DS00              DIVIDE SHIFT
         LH,D0    1,R5
         AND,D0   K3FF              DECP RESULT
         OR,D0    KDUBL             + DUBL BIT
         OR,D0    KDUBLI
         LW,D1    KSHFT
         SLS,D1   8
         AW,D0    D1
         STH,D0   1,R5
KDI07    RES      0
         BAL,D3   DRDX              ROUND DX TEST
         B        *L1
*        FLL
KDI20    RES      0
         LI,R3    3
KDI21    RES      0
*
         B        *L1
*        FLS
KDI22    RES      0
         LI,R3    2
         B        KDI21
*
*
*
*
KDI80    RES      0
         DATA     0                 0
         DATA     X'1000'           1   BIN
         DATA     X'0800'           2   FLS
         DATA     X'0400'           3   FLL
*
*
KDG00    RES      0
         BAL,L1   KDG02             NUM COMP/ EDITED
         BAL,L1   KDG03             NUM DISPLAY
         LI,R3    3                 FLL
         LI,R3    2                 FLS
         BAL,L1   KDG01             BIN
         BAL,L1   KDG01             INDEX
         BAL,L1   ILL00             NUM LIT
         BAL,L1   ILL00             ZERO
*
KDG01    RES      0
         LI,R3    1
         B        KDG04
KDG02    RES      0
         BAL,D3   BWZ00
KDG03    RES      0
         LI,R3    -1                DESC
KDG04    RES      0
         CW,V0    KDWANT
         BL       KDG07
         MTW,0    REMBIT
         BEZ      KDG05             NO REMAINDER
         CI,R7    CLOP
         BCS,4    KDG06             REMAINDER OPRND
KDG05    STW,V0   KDWANT
KDG06    RES      0
         CI,R7    4
         BAZ      KDG07
         MTW,1    KDWANT
         MTW,0    REMBIT
         BEZ      KDG07             NO REMAINDER
         MTW,4    MCBUF             SET ROUND BIT
KDG07    RES      0
         BAL,D3   DRDX              ROUND DX TEST
         B        *L1
*
*        DIVIDE ROUND DX TEST
DRDX     RES      0
*        IF OP BINARY AND ROUNDED AND RESULT NOT DEC GIVE DX
         LH,D0    0,R4
         AND,D0   K30F
         CI,D0    X'D'
         BNE      *D3               NOT BINARY
         LW,D0    RESMOD
         CI,D0    8                 DECIMAL
         BE       *D3
         B        MRDX3
*
*        STORE MC INTO MD  4 WORDS
*        BAL,L1
SCD00    RES      0
         MTW,0    REMBIT
         BEZ      SCD01             NO REMAINDER
         LW,D0    RDECP
         STH,D0   MCBUF+5          DECP TO L OF MDF
SCD01    LCI      4
         LM,D0    MCBUF
         STM,D0   MDBUF
         LH,D0    MDBUF             12C7
         AI,D0    X'30'
         STH,D0   MDBUF             12F7
         B        *L1
*
*        SIMPLE INITIALIZATION
*        BAL,L1
ZMC00    RES      0
         LW,D0    MINF              - LARGE NUMBER
         STW,D0   JDECP
         LI,D0    4
         STW,D0   PRIMODE
         LI,D0    0
         STW,D0   MCBUF+2
         STW,D0   MCBUF+3
         STW,D0   ABAD
         STW,D0   KSIZM             FOR MULTIPLY
         STW,D0   KDECP
         STW,D0   KDUBL
         STW,D0   KDUBLI
         STW,D0   MDNDX
         STW,D0   JDRND
         STW,D0   COMPFLG           COMPUTE FLAG
         STW,D0   FLOPFL            FLOATING OP FLAG
         STW,D0   RUSAG             FOR EXPRESSIONS
         AI,R3    1                 FUNNY OFFSET
         LI,R1    WA(MCBUF)+6       NREF/ANCHOR TABLE
         LI,V2    IBGO+CISAV
         B        *L1
*
*        SET FROM,BY,INTO,TO BIT
*        BAL,L1
SFBB00   RES      0
         LI,V2    IBGO+CISAV
         LW,D0    K201              BY BIT
SFBB05   RES      0
         AWM,D0   MCBUF
         AWM,D0   MDBUF
         LI,R1    WA(MDBUF)+6
         LI,D1    ABGTIC
         B        *L1
SGB00    RES      0
         LW,D0    K202              GIVING BIT
         LI,V2    IBGR+CISAV
         B        SFBB05
*
*        INCREMENT JINTL
*        BAL,L1
IJNL00   RES      0
         LB,D0    JNREF
         LW,D1    MCBUF+1
         BEZ      *L1
         AWM,D0   JINTL
         B        *L1
*
*        BAL,D3
*        KSIZM    ARE OF PRODUCT    OUTPUT ALSO
*        KDECP
*        KDWANT   IS OF B ( A BY B.)
*
*        KSHFT    OUTPUT
MS00     RES      0
         LI,D0    0
         STW,D0   KSHFT
         LW,D0    KSIZM
         CI,D0    31
         BLE      MS10              LEAVE AS IS
*
*
         LW,D0    KDWANT
         LW,D1    JDRND
         BEZ      MS03
         AI,D0    1                 DP+1 FOR ROUNDING
MS03     RES      0
         SW,D0    KDECP
         BGEZ     MS10
         CI,D0    -64
         BG       MS04
*                                   0 RESULT OF MULTIPLY
         LI,D0    -64
MS04     RES      0
*
         LCW,D1   D0                +N IN D1
         STW,D1   KSHFT             POSITIVE LEFT SHIFT !
         AWM,D0   KDECP
         AW,D0    KSIZM             -N + SIZE
         BGZ      MS06
         LI,D0    1                 EXCEPTIONAL ZERO ANSWER
MS06     RES      0
         STW,D0   KSIZM
*
MS10     RES      0
         B        *D3
*
*        BAL,D3
ZFLZ00   RES      0                 MAKE ZERO A FLOATING ZERO
         LI,D0    BA(FLZDCL)
         LW,D1    R4
         LI,R3    8
         STB,R3   D1
         AW,D1    D1
         MBS,D0   0
         MTW,5    JDGSAV+1
         LI,R3    3                 FLL
         B        *D3
*        FLOATING ZERO DATA CLUSTER
FLZDCL   RES      0
         DATA     X'098F0000'
         GEN,16,8,8  0,OTCB,0       OBJECT TIME CONSTANT BASE
         GEN,16,16 AFLZ,30
         DATA     X'87FFF'
ZROLIT   RES      0                                                     COBOL41F
         LI,D0    BA(ZRODCL)                                            COBOL41F
         LW,D1    R4                CLUSTER LOCATION                    COBOL41F
         SLS,D1   1                 HA TO BA                            COBOL41F
         LI,R3    17                SIZE FOR MOVE                       COBOL41F
         STB,R3   D1                                                    COBOL41F
         MBS,D0   0                                                     COBOL41F
         MTW,6    JDGSAV+1                                              COBOL41F
         LI,R3    4                 CLASSIFY AS AN FOR CRM00            COBOL41F
         B        *D3               RETURN                              COBOL41F
ZRODCL   DATA     X'09990000'                                           COBOL41F
         DATA     X'800'                                                COBOL41F
         DATA     1                                                     COBOL41F
         DATA     X'7E180000'                                           COBOL41F
         DATA     X'0C000000'                                           COBOL41F
*
*        STORE SHIFT IN DATA CLUSTER
*        R1 = HA(CLOC) -1/2
SRS00    RES      0
*        STORE SHIFT IN OPTIONS LEFT 8 BITS
         LW,D0    KSHFT
         SLS,D0   8
         LH,D1    1,R1
         AND,D1   K3FF
         AW,D1    D0
         OR,D1    KDUBL
         OR,D1    KDUBLI
         STH,D1   1,R1
*
         B        *L1
*
*        ILLEGAL LITERAL REC FIELD
ILL00    RES      0
         STW,L1   ABAD
         LI,R3    3
         B        *L1
*
*        BAL,L1
SDNL00   RES      0
         LW,R1    MDNDX             0,1
         AND,R1   K301
         STW,R4   LDEN,R1           DEN, NUM
         STW,R4   LNUM,R1
         MTW,1    MDNDX
         B        *L1
*
*
ABGTIC   EQU      X'48100'
ABGTNI   EQU      X'40000'
ASCONT   DATA     X'12C70000'
*        LAST OPERAND BIT
ABGLOP   DATA     X'80'
SZEBIT   DATA     X'2'
BWZBIT   EQU      X'800'
EDUBLB   EQU      X'10'
ESMPLOP   EQU     X'40'
*        DECIMAL TYPE BIT MASK FROM JTYPB
CRMDEC   DATA     X'6000'
K2FF     DATA     X'FF00'
K3FF     DATA     X'FF'
K23FFFF  DATA     X'FFFF'
K30F     DATA     X'0F'
K301     DATA     X'1'
K302     DATA     X'02'
K201     DATA     X'100'
K202     DATA     X'200'
K2E5     DATA     X'E500'
K307     DATA     X'7'
RNDBIT   DATA     4
NRND     DATA     X'FFFB'           0 ROUND BIT
MINF      DATA    X'80000000'        MINUS LARGE NUMBER
*
* COMPUTE                           TYPE = X'54'                        ABK
ABK00    RES      0                                                     ABK00
*        COMPUTE
AK00     RES      0
         LI,V2    0
         STW,V2   SFSRF             SET ZERO
         LI,V2    X'200'            GIVING BIT FOR COMPUTE
         BAL,L1   AHB00
         BAL,L1   ZMC00
         LW,D0    MINF
         STW,D0   KCOMR             MAX ROUNDED COMPUTE RESULT
         STW,D0   KDWANT
         LI,D0    X'7FFF'
         STW,D0   COMPFLG           COMPUTE FLAG
         LI,D0    WA(KMG00)
         LI,V2    IBGR+CISAV
         LI,D1    ABGTNI
         BAL,L1   ADF00             STACKER
*
         BAL,L1   IJNL00            INCREMENT JINTL
         LI,R2    0                 SKIP =
         LB,D0    JNREF
         BNEZ     AK10
         STW,R3   ABAD
AK10     RES      0
         CI,R7    0
         BNE      *JMCER
         LI,R1    HA(MCBUF)
         BAL,L0   ACL00
         LW,D0    KDWANT
         STW,D0   JDECP
         STW,D0   KDECP             SAVE FOR NON DEC RESULT
         CW,D0    MINF
         BNE      AK15
*        FL ANSWER  BECAUSE ALL FL RESULTS
*        FORCE FL LONG RESULT NOTE SIDR REMOVED THE FOLLOWING CODE      COBOL41F
*        LI,L1     X'E'                                                 COBOL41F
*        STW,L1    RUSAG                                                COBOL41F
*        LW,L1     SFSRF                                                COBOL41F
*        BEZ       AK15                                                 COBOL41F
*        THE ABOVE CODE WAS TURNED ON AGAIN BECAUSE OF SIDR 27879       COBOL41F
         LI,L1    X'E'              FLOAT SHORT                         COBOL41F
         STW,L1   RUSAG                                                 COBOL41F
         LW,L1    SFSRF                                                 COBOL41F
         BEZ      AK15                                                  COBOL41F
         LI,L1    X'F'              FL LONG RESULT
         STW,L1   RUSAG
AK15    RES      0
         BAL,L1   ADE00             EXPRESSION SUBROUTINE
*
         B        *JMCER            ERROR IN EXPRESSION
         STD,R4   KMOR45
*        GOOD EXPRESSION
AK17     RES      0
         LH,D0    0,R4
         AND,D0   K30F              RESULT MODE  8 D E F
         STW,D0   MCBUF+3
         STW,D0   RESMOD
         LH,D0    1,R4              REGISTER R6, R7  ETC
         STH,D0   MCBUF+3
         LW,D0    RESMOD
         CI,D0    8
         BE       AK20              DECIMAL RESULT
*        RESULT BINARY  FL SHORT OR FL LONG
         LW,D0    KDECP             MAX DESC DECP
         STW,D0   JDMAX-1
         STH,D0   JDMAX
         LW,D0    RESMOD
         CI,D0    X'E'
         BGE      AK25              FLOATING RESULT
*        BINARY
         LW,D0    KCOMR
         CI,D0    0
         BL       AK25
         DX       126               ROUND DX
         B        AK25
*
*        RESULT OF EXPRESSION DECIMAL
AK20     RES      0
         LH,D0    4,R5              DECP RESULT
         STW,D0   MCBUF+2
         CW,D0    KCOMR
         BG       AK21
         DX       126               ROUND DX
AK21     RES      0
         LH,D0    3,R5              DIGIT SIZE RESULT
         STH,D0   MCBUF+2
*
AK25     RES      0
         LW,D0    MCBUF
         OR,D0    K202              GIVING BIT
         AI,D0    X'10000'
         STW,D0   MCBUF             12C8 CONTROL
*
AK30     RES      0
         BAL,L1   AA14              BLANK WHEN ZERO
         WMCF     ,BA(MCBUF)        COMPUTE CLUSTER
         LD,R4    KMOR45
         BAL,L1   EXPOUT            EXPERESSEION OUT
         BAL,L1   SCD00
*        MOVE MCBUF TO MDBUF
         LI,D0    BA(MCBUF)+4
         LI,D1    BA(MDBUF)+4
         LI,D2    60                15 WORDS
         STB,D2   D1
         MBS,D0   0
         BAL,L1   GT00
*
         B        *JMCRD
*
*        4.1 WORKING STORAGE
*        RUSAG IS A FLAG FOR EXPRESSIONS ( RESULT USAGE )
*        E,F, 0 FOR FL SHORT, FL LONG, OR ANYTHING ELSE
         DEF      RUSAG
RUSAG    DATA     0
SFSRF    DATA     0                 SPECIAL FL SHORT RESULT FLAG
ESNGREC  EQU      X'20'
OPNDX    DATA     0
SMPLOP   DATA     0
ABAD     DATA     0
RESMOD   DATA     0
RESM0D   EQU      RESMOD
ACARET   DATA     0
GTRET    DATA     0
*        4.1 TEMPS
MDOPT    DATA     0
ASOPT    EQU      MDOPT
MD0PT    EQU      MDOPT
*        CORRESPONDING ROUND BIT
COROUND  DATA     0
         BOUND    8
KMOR45   DATA     0
         DATA     0
KDNSZ    DATA     0
KDNDP    DATA     0
KNMSZ    DATA     0
KNMDP    DATA     0
KSIZM    DATA     0
KSIZE    EQU      KSIZM
KDECP    DATA     0
KSIZMS   DATA     0
KSIZPS   DATA     0
KDUBL    DATA     0
KDUBLI   DATA     0
MDEXUO   DATA     0
MDEXNO   EQU      MDEXUO
STMTYP   DATA     0
KDWANT   DATA     0
JDRND    DATA     0
KSHFT    DATA     0
KCOMR    DATA     0
COMPFLG  DATA     0                 COMPUTE FLAG
FLOPFL   DATA     0                 FLOATING OP FLAG
MRDL1    DATA     0
MRDRET   DATA     0
*
MDNDX    DATA     0                 0,1 FOR FIRST/SECOND OP
LDEN     DATA     0                 R4 FOR FIRST AND SECOND
LNUM     DATA     0                 OPERANDS
         DATA     0
MTPLRST  RES      1
SAVRMOD  DATA     0
*
RDECP    DATA     0
REMBIT   DATA     0
KHASTK   EQU      JAKON+32          HA(STKTOP)
JDECP    EQU      JADAT+4           DECP
JDSIZ    EQU      JADAT+5           DSIZ
JSFLD    EQU      JADAT+6           SFLD TYPE,CNTL
JDLST    EQU      JADAT+8           DECP/SUBF LAST
JDMAX    EQU      JADAT+10          *         MAX
JDMIN    EQU      JADAT+12          *         MIN
JLNKT    EQU      JADAT+14          *         LNKT
JSIZM    EQU      JADAT+15          SIZE MAX
JLNKL    EQU      JADAT+17          LAST LINK
JLSTI    EQU      JADAT+27          LAST REF I
JTYPB    EQU      JADAT+24          TYPE BITS
JDREF    EQU      JADAT+25          WA(NREF)
JNREF    EQU      JADAT+28
JDIGN    EQU      JADAT+26          IGNORE OPTIONS
JDEXU    EQU      JADAT+28          TYPE EXU LOC
JDANC    EQU      JADAT+29          WA(ANCHOR)
JDFSAV   EQU      JASAV             L0,L1
JNTYP    EQU      JASAV+1           NO. OF TYPES
JDGSAV   EQU      JASAV+2           R2-R7
JINTL    EQU      JAMOD+X'D'
JINTE    EQU      JINTL+1
         END
