         SYSTEM   SIG7FDP
         TITLE    'PHASE 4.1 - MOVE'
* 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
RI       EQU      R7                INDEX
CRI      EQU      RI*16             INDEX
*                                                                       AA0
         DEF      ABC00             MOVE
         DEF      ABE00             SET
         DEF      ACP00             PERFORM VARYING
         DEF      ACP16             VARYING FROM
         DEF      ACW00             WHEN
         REF      WRMCF
         REF      DIAG
         REF      AA00
         REF      AA01,AA02,AA03    M.C. RETURNS
         REF      AA14              BWZ/*WZ INTL RESERVE
         REF      AAC00             READ
         REF      AAZ00
         REF      ABP60
         REF      ADC00
         REF      ADI00,ADI02
         REF      ADF00,ADG00,ADH00 STACK,UNSTACK
         REF      PIA02
         REF      PID11,PID14,PID16
         REF      PII20
         REF      PPI30,PPI32
         REF      JMCRD,JMCER,JRDF  CORRES. SWITCHES
         REF      JAKON,JADAT,JASAV
         REF      JAMOD
         REF      STBAS             DATA STACK
         REF      SSTBS             SEARCH BUFFER
         REF      MCBUF             MCF CLUSTER BUF
         REF      ADV00
* 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
         BAL,CF(2) AF(1)            BRANCH                              PRL42
         ELSE                                                           PRL43
         BAL,L1   AF(1)             BRANCH                              PRL44
         FIN                                                            PRL48
         PEND                                                           PRL99
* MCF CLUSTER CLNG,CNTL
DABC     EQU      X'4C4'            MOVE
*
CBYT     EQU      X'FF'             BYTE MASK
CGMXD    EQU      31                A MAX. NO. OF DIGITS(DISPLAY)       COBOL41D
CIANO    EQU      X'200'          A AN ONLY                             ADI561
CIANX    EQU      X'400'          A AN USAGE ERROR - ALLOWED            ADI406
CLOP     EQU      X'80'           A LAST OPERAND                        A
CITC     EQU      X'10000'          TRUNCATION
CISAV    EQU      X'80000'          SAVE REF FLAG                       ADI455
* DATA CLUSTER CLNG,CNTL EQUIVALENCES
CJIFZ    EQU      X'70394'        M FIGCON - ZERO                       ADI821
CJINT    EQU      X'60B9D'          INTEGER                             57
CJIX     EQU      X'5098C'          INDEX
CANC     EQU      7                 NREF,ANCHOR OFFSET
CPI      EQU      -3                VARYING SWITCH SETTING               1
CLI      EQU      X'2200'
* DIAG CODE BASE EQUIVALENCES
XCS      EQU      145               DX CODE
* REF DATA TYPE CONTROL SETTINGS
IBCS     EQU      X'9000'           MOVE SFLD                           ABC001
IBCG     EQU      X'2000'                GROUP                          ABC032
IBCAG    EQU      X'8A00'                AN/GRP ONLY                    ABC033
IBCAND   EQU      X'48C0'                AN/ND ONLY                     ABC021
IBCN     EQU      X'4450'           MOVE NC/ND/NLIT/BIN/FLP             ABC0361
IBCZ     EQU      X'8810'                ZERO                           ABC071
IBER     EQU      X'2C'             SET RFLDS
IBEXN    EQU      X'2C'             INDEX NAME
IBEX     EQU      X'2E'             INDEX NAME,DATA
IBEXD    EQU      X'2A'             DATA,INDEX
IBEUD    EQU      X'29'             UP/DOWN BY
* 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
CJAO     EQU      9                 UP/DOWN BY 1
* 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
* WRITE STACK CONTROL                                                   ABC6  0
DWCA     EQU      X'629CA'          AN         - 6 1 2 3 4 5            314E5
DWCN     EQU      X'239CA'          NC/ND/NLIT - 2 1 6 3 4 5            0A72E
DWCFL    EQU      X'394AC'          FLL        - 3 4 5 1 2 6            1CA56
DWCFS    EQU      X'474AC'          FLS        - 4 3 5 1 2 6            23A56
DWCB     EQU      X'570AC'          BIN        - 5 3 4 1 2 6            2B856
DWIN     EQU      X'17280'          NC/ND/NLIT - 1 3 4 5 8
DWIFL    EQU      X'4A0A0'          FLL        - 4 5 8 1 2
DWIFS    EQU      X'3A0A0'          FLS        - 3 5 8 1 2
DWIB     EQU      X'380A0'          BIN/INDEX  - 3 4 0 1 2
*                                                                       ABC6
* MOVE                              TYPE = X'5E'                        ABC
ABC00    RES      0                                                     ABC00
         STW,R3   JBPFA             SAVE HA(SFLD)-1                      2
         LI,V2    IBCS+CISAV        LOAD SOURCE FLD(SFLD) REF CONTROL
         BAL,L1   ADI02             CHECK, SAVE SFLD                    ABC002
* S*****INVALID MOVE FIELD**********                                    ABC004
         B        *JMCER            ERROR RETURN                        ABC005
ABC01    RES      0                                                     ABC010
         STW,R6   JSFLD             SAVE SFLD TYPE,CLNG,CNTL            ABC011
         STD,V0   JDECP                       DECP,DSIZ                 ABC012
         LI,R1    DABC              LOAD MOVE CLNG,CNTL
         LH,R7    R6                LOAD,BRANCH ON RFLD TYPE            ABC013
         STW,R7   MCBUF             STORE SFLD TYPE
         STH,R1   MCBUF             STORE MOVE CLNG,CNTL
         BGEZ     ABC04             NUMERIC SFLD                        ABC014
         LI,D0    ABC81+2           LOAD AN STACK CONTROL LOC
         EXU      ABC03+3,R7        EXU TO LOAD REF CONTROL             ABC015
         B        ABC09                                                 ABC018
* NON-NUMERIC SFLD                                                      ABC02
ABC02    RES      0                                                     ABC020
         LI,V2    IBCAND+CITC       LOAD AN ONLY REF CONTROL            ABC021
         CI,V1    CGMXD             CHECK SIZC                          ABC022
         BLE      *L1               < MAX DISPLAY SIZE                  ABC023
         AI,V2    CIANO             SET AN ONLY REF CONTROL             ABC024
         B        *L1                                                   ABC025
*
         BAL,L1   ABE03             VARYING
ABC03    RES      0                                                     ABC030
         BAL,L1   ABC08             AN LIT/FIGCON                       ABC031
         LI,V2    IBCG+CITC         GRP - GRP ONLY REF CONTROL
         BAL,L1   ABC02             AN                                  ABC033
         BAL,L1   ABC05             NC
         BAL,L1   ABC05             ND                                  ABC035
         LI,V2    IBCN              FLL                                 ABC0361
         LI,V2    IBCN              FLS                                 ABC0362
         LI,V2    IBCN+CITC+CIANX   BIN
         BAL,L1   ABE04             INDEX
         BAL,L1   ABC05             NLIT                                ABC038
         BAL,L1   ABC07             ZERO
* NUMERIC SFLD                                                          ABC04
ABC04    RES      0                                                     ABC040
         LI,D0    ABC84+2           LOAD N STACK CNTL LOC.
         EXU      ABC03+3,R7        EXU TO LOAD REF/STACK CONTROL       ABC041
         B        ABC09                                                 ABC043
* ND/NLIT SFLD                                                          ABC05
ABC05    RES      0                                                     ABC050
         LI,V2    IBCN+CITC         LOAD ND/NLIT SFLD REF CONTROL
         CI,V0    0                 CHECK DECP                          ABC052
         BNEZ     ABC02+1           DECP NOT= 0, NON-INTEGER            ABC053
         AI,V2    CIANX             SET INTEGER REF CONTROL             ABC054
         B        ABC02+1           TO CHECK SIZC                       ABC055
* NC SFLD                                                               ABC06
ABC06    RES      0                                                     ABC060
         LI,V2    IBCN+CITC         LOAD NC SFLD REF CONTROL
         B        ABC02+1                                               ABC062
* ZERO SFLD                                                             ABC07
ABC07    RES      0                                                     ABC070
         LI,V2    IBCZ              LOAD ZERO SFLD REF CONTROL          ABC071
         LI,D0    ABC80+2           *             STACK CONTROL
         CI,R6    CJIFZ             CHECK FOR FIGCON ZERO               ABC073
         BE       *L1               YES. FIGCON ZERO
         LI,V2    IBCN+CIANX        LOAD ND/NLIT SFLD REF CONTROL       AB
         B        *L1
* AN LIT/FIGCON                                                         ABC08
ABC08    RES      0                                                     ABC080
         LI,V2    IBCAG             LOAD AN/GRP ONLY REF CONTROL        ABC081
         CI,R6    1                 CHECK FOR (ALL) 'LITERAL'
         BAZ      *L1               NOT (ALL) 'LITERAL'                 ABC084
         LI,V2    IBCAG+CITC        LOAD AN/GRP ONLY,TRUNCATION
         CI,R6    2                 CHECK FOR AN LIT
         BAZ      ABC02             ANLIT
         LI,D0    ABC96+2           LOAD (ALL) 'LITERAL' STACK CONTROL
         B        *L1
*                                                                       ABC09
ABC09    RES      0                                                     ABC090
         LI,R5    1                 SET HA(CLOC)+1                      ABC094
         AW,R5    R2                                                    ABC095
         LH,V1    0,R5              CHECK LAST OP FLAG                  ABC096
         CI,V1    CLOP                                                  ABC097
         BAZ      ABC20             LAST OP FLAG = 0,MULTIPLE RFLDS     ABC098
* SINGLE RFLD                                                           ABC10
         BAL,L1   ADI02             CHECK RFLD                          ABC102
         B        *JMCER            INVALID RFLD, ERROR RETURN          ABC103
         LH,R3    R6                LOAD TYPE IND.                      ABC104
         EXU      *D0,R3            EXU FOR RFLD TYPE CHECK             ABC105
* MOVE A TO B.                                                          ABC12
ABC12    RES      0                                                     ABC120
         STH,R3   MCBUF+1           STORE RFLD TYPE                     ABC121
*                        R3 = I(=RFLD TYPE IND.)                        ABC1213
         LW,R7    R4                SAVE HA(RFLD)                       ABC122
         BAL,L1   AA14              CHECK,WRITE BWZ/WZ INTL RESERVE
         WMCF     ,BA(MCBUF)        WRITE MOVE CLUSTER                  ABC123
         CI,R3    DJZF              CHECK FOR ZERO/BLANK FILL           ABC124
         BGE      ABC15             ZERO/BLANK FILL                     ABC125
         LW,R4    JBPFA             LOAD HA(SFLD)-1                      4
         LH,R1    JSFLD             CHECK SFLD TYPE                     ABC126
         CI,R1    CJAD
         BLE      ABC14             SFLD NOT= BIN/FLP/NLIT
* SFLD = BIN/FLP/NLIT
         CI,R1    CJAX                                                   1
         BGE      ABC14             SFLD NOT= BIN/FLP                    2
* SFLD = BIN/FLP                                                         3
*                        V0 = DECPR
         STH,V0   4,R4              STORE DECPR                          7
ABC14    RES      0                                                     ABC140
         AI,R4    1                 HA(CLOC)-1 = BA(CLOC)               11
         AW,R4    R4                                                    12
         BAL,L1   ADV00             RESOLVE VAR PARAM
         BAL,L1   WRMCF             WRITE SFLD CLUSTER                  13
ABC15    RES      0                                                     ABC150
         LW,R4    R7
         AW,R4    R4
         BAL,L1   ADV00             RESOLVE VAR PARAM
         BAL,L1   WRMCF             WRITE RFLD CLUSTER
         B        *JMCRD            NORMAL RETURN                       ABC152
* MULTIPLE RFLDS
ABC20    RES      0                                                     ABC200
         AI,V2    CISAV             RAISE SAVE FLAG
         LI,D1    X'78000'          LOAD IGNORE OPTION,NO. OF TYPES     ABC203
         LI,R1    MCBUF+2           LOAD WA(NREF),WA(ANCHOR) BASE       ABC204
         BAL,L1   ADF00             STACK RFLDS                         ABC206
* VALID RFLDS                                                           ABC211
         LB,R3    JNREF             LOAD,CHECK NREF                     ABC212
         BDR,R3   ABC22             NREF > 1, MULTIPLE RFLDS            ABC213
         BEZ      *JMCER            NO VALID RFLDS
* SINGLE RFLD                                                           ABC214
ABC21    RES      0
         LH,R3    JLSTI             RELOAD RFLD TYPE                    ABC215
         LD,R4    JDGSAV+2          *           HA(CLOC)                 2
         LH,V0    4,R5              *           DECPR                    3
         B        ABC12             TO COMPLETE                         ABC216
* MULTIPLE RFLDS                                                        ABC22
*                        R3 = NREF-1                                    ABC22 3
ABC22    RES      0                                                     ABC220
         LH,R1    JSFLD             LOAD SFLD TYPE
* **                     R1 NOT VOLATILE
         LH,V1    JTYPB             LOAD RFLD TYPE BITS                 ABC221
         CI,V1    CBYT              CHECK FOR ZERO/BLANK FILL RFLDS     ABC222
         BAZ      ABC26             NO ZERO/BLANK FILL RFLDS            ABC223
* ZERO/BLANK FILL
         AND,V1   K2FF00            MASK REMAINING RFLD TYPES
         LI,V0    DABC+X'300'       LOAD,STORE ZERO/BLNK FILL CLNG,CNTL ABC224
         XW,V0    MCBUF+4             (SAVE NREF(4),NREF(5)             ABC225
         WMCF     ,BA(MCBUF)+18     WRITE ZERO/BLANK FILL CLUSTER(CLNG=7)
         STW,V0   MCBUF+4           RESTORE NREF(4),NREF(5)
         LI,R6    6                 LOAD TYPE                           ABC231
         LI,R7    5                 LOAD NO. OF TYPES
         BAL,L1   ADH00+2           WRITE RFLD CLUSTERS                 ABC233
         CI,R3    0                 CHECK NREF-1                        ABC235
         BG       ABC26             > D, MULTIPLE RFLDS REMAIN          ABC236
         BNEZ     AA01              <0. ZERO/BLANK FILL ONLY
* SINGLE RFLD REMAINS                                                   ABC238
         LI,R3    7                 SET I = GRD(I)+2                    ABC239
ABC24    RES      0                                                     ABC240
         LH,R4    MCBUF+1,R3        LOAD,CHECK NREF(I)
         BNEZ     ABC25             NREF(I) NOT= 0, RFLD FOUND          ABC242
         BDR,R3   ABC24             I = I-1, CONTINUE SEARCH            ABC243
*                        R3 = I+2                                       ABC25 3
*                        R4 = HA(CLOC)-(HA(STBAS)-1)                    ABC25 4
ABC25    RES      0                                                     ABC250
         LH,R4    MCBUF+8,R3        LOAD ANCHOR(F)
         AI,R4    HA(STBAS)+2       SET HA(CLOC)+1                       6
         AI,R3    -2                I + 2 = I                           ABC252
         LH,V0    3,R4              LOAD DECPR                           8
         BDR,R4   ABC12             HA(CLOC)+1 = HA(CLOC)                9
* MULTIPLE RFLDS                                                        ABC26
*                        V1 = TYPE BITS
ABC26    RES      0                                                     ABC260
         BAL,L1   AA14              CHECK,WRITE BWZ/WZ INTL RESERVE
         LB,V0    JNTYP             COMBINE REF TYPE BITS,NTYP
         AW,V0    V1                                                    ABC263
         LI,R4    BA(MCBUF)         PRESET BA(CLOC) MOVE CLUSTER        ABC264
*                        R1 = SFLD TYPE(MAY NOT= SFLD TYPE IN CLUSTER)
         EXU      ABC60+3,R1        EXU ON SFLD TYPE
         LI,D0    1                 SET WRITE STACK COUNT(WCNT) = 1     ABC266
ABC261   BAL,L1   WRMCF             WRITE MOVE CLUSTER
         LI,R4    BA(STBAS)+2
         BAL,L1   ADV00             RESOLVE VAR PARAM
         BAL,L1   WRMCF             WRITE SFLD CLUSTER
*                        R6 = RFLD TYPE
*                        R7 = NRTYP
*                        D0 = WCNT
ABC27    RES      0                                                     ABC270
         BAL,L1   ADH00+2           WRITE RFLD CLUSTERS                 ABC271
         BDR,D0   ABC28             WCNT = WCNT-1                       ABC272
* WCNT = 0, ALL RFLDS WRITTEN                                           ABC273
         B        AA01              RETURN                              ABC274
* WCNT NOT= 0, REPEATED WRITE                                           ABC28
*                        R7 = 0                                         ABC28 7
*                        D1 = 3-BIT RFLD TYPE(I)                        ABC28 8
ABC28    RES      0                                                     ABC280
         LH,R6    D1                LOAD I                              ABC281
         BNEZ     ABC29             NOT= 0, NOT INDEX
* INDEX
         AI,R6    8                 I = 8
ABC29    RES      0
         STH,R7   D1                POSITION NEXT I                     ABC282
         SLS,D1   3                                                     ABC283
         LI,R7    1                 SET NRTYP = 1                       ABC284
         B        ABC27             TO WRITE NREF(I)                    ABC285
ABC60    RES      0                                                     ABC600
         BAL,L1   ABC61             ANLIT                               ABC6001
         BAL,L1   ABC62             GRP                                 ABC6002
         BAL,L1   ABC63             AN                                  ABC6003
         BAL,L1   ABC64             NC                                  ABC6010
         BAL,L1   ABC64             ND                                  ABC6011
         BAL,L1   ABC68             FLL                                 ABC6012
         BAL,L1   ABC69             FLS                                 ABC6013
         BAL,L1   ABC71             BIN                                 59
         BAL,L1   ABC71             INDEX(=BIN)
         BAL,L1   ABC70             NLIT                                61
         BAL,L1   ABC72             ZERO                                62
         BAL,L1    ABE26            SET TO
         BAL,L1   ABE14             SET TO ZERO
         BAL,L1   ABC71             SET UP/DOWN BY 1
* AN LIT/ FIGCON - GROUP/AN RFLDS ONLY                                  ABC61
ABC61    RES      0                                                     ABC610
         LW,R6    JSFLD             FIGCON
         CI,R6    1
         BAZ      ABC612            YES
         CI,R6    2                 ALL 'ANLIT'
         BAZ      ABC63             NO
ABC612   RES      0
         LI,R6    DJAN              LOAD TYPE(I)                        ABC611
         LI,R7    2                      NO. OF RFLD TYPES(NRTYP)       ABC612
         LW,V1    MCBUF+4           LOAD,STORE NREF(GRP)                ABC613
         STH,V1   MCBUF+2                                               ABC614
         SLD,V0   16                POSITION STORE REF TYPE BITS,NTYP,  ABC615
         STW,V0   MCBUF+1           *              NREF(AN/ANE)         ABC616
         MTB,2    MCBUF             CLNG = 6                            ABC617
         B        *L1                                                   ABC619
* GROUP - GROUP RFLDS ONLY                                              ABC62
ABC62    RES      0                                                     ABC620
         LI,R6    DJAG              LOAD TYPE(I)                        ABC621
         LI,R7    1                 *    NRTYP                          ABC622
         LW,V1    MCBUF+4           NREF(GRP) TO MOVE CLUSTER           ABC623
         STW,V1   MCBUF+1                                               ABC624
         MTB,1    MCBUF             CLNG = 5                            ABC625
         B        *L1                                                   ABC626
* AN - ALL RFLD TYPES MAY BE PRESENT                                    ABC63
ABC63    RES      0                                                     ABC630
         LI,D1    DWCA              LOAD WRITE STACK CONTROL            ABC631
         B        ABC64+1                                               ABC632
* NC/ND/N LIT - ALL RFLD TYPES MAY BE PRESENT                           ABC64
ABC64    RES      0                                                     ABC640
         LI,D1    DWCN              LOAD WRITE STACK CONTROL            ABC641
         LI,R1    X'6000'           CHECK FOR BOTH A AND D
         AND,R1   V0
         CI,R1    X'6000'
         BL       ABC66             NOT BOTH A AND D                    ABC643
         LI,R1    -1                SET INDEX FOR D PARAMETERS          ABC644
         LH,V1    JSIZM,R1          MAX SIZE = SIZE MAX(D)              ABC645
         AH,V1    JDMAX             *          + DECP MAX(A)            ABC646
         SH,V1    JDMAX,R1          *          - DECP MAX(D)            ABC647
         CI,V1    CGMXD             CHECK FOR SIGNIFICANCE LOSS         COBOL41D
         BG       ABC66             YES, RETAIN BOTH A AND D            ABC649
* NO SIGNIFICANCE LOSS, LINK A AND D CHAINS                             ABC65
         AI,V0    -X'4001'          CLEAR D TYPE BIT,NREG = NREF-1      65
         LH,V1    *JDREF,R1         NREF(A) = NREF(A)+NREF(D)           ABC652
         AH,V1    *JDREF                                                ABC653
         STH,V1   *JDREF                                                ABC654
         LI,V1    0                 NREF(D) = 0                         ABC655
         STH,V1   *JDREF,R1                                             ABC656
         LH,V1    *JDANC,R1         LOAD ANCHOR(D)                      ABC657
         LH,R1    JLNKT             *    LNKT(A)                        ABC658
         STH,V1   STBAS,R1          ANCHOR(D) TO TYPLNK(LNKT(A))        ABC659
ABC66    RES      0                                                     ABC660
         STH,V0   MCBUF+1           STORE REF TYPE BITS,NTYP            ABC661
         LI,R6    DJAG+2            LOAD FIRST TYPE(I)                  ABC662
         LI,D0    7                      WCNT                           ABC664
ABC67    RES      0                                                     ABC670
         LI,R7    1                 LOAD NRTYP                          ABC663
         MTW,15   JDREF             DECREMENT NREF(I),ANCHOR(I) BASE    ABC665
         MTW,15   JDANC                                                 ABC666
         MTB,7    MCBUF             CLNG = 11
         B        *L1,R7            RETURN                              ABC667
* FLL - ALL RFLD TYPES MAY BE PRESENT                                   ABC67
ABC68    RES      0                                                     ABC680
         LI,D1    DWCFL             LOAD WRITE STACK CONTROL            ABC671
         B        ABC69+1
* FLS - ALL RFLD TYPES MAY BE PRESENT                                   ABC68
ABC69    RES      0                                                     ABC690
         LI,D1    DWCFS             LOAD WRITE STACK CONTROL            ABC681
         LW,V1    JDMAX-1           DECP MAX(D) TO DECPS
         STH,V1   STBAS+4
         B        ABC66                                                 ABC682
* NLIT                                                                  91
ABC70    RES      0
         LW,R6    JSFLD             LOAD,CHECK LIT TYPE                 93
         CI,R6    CJINT                                                 94
         BNE      ABC64             NOT= INTEGER
* BIN - ALL RFLD TYPES MAY BE PRESENT                                   ABC69
ABC71    RES      0                                                     97
         LI,D1    DWCB              LOAD WRITE STACK CONTROL            ABC691
         B        ABC64+1                                               ABC692
* ZERO - ALL TYPES MAY BE PRESENT                                       ABC70
ABC72    RES      0                                                     99
         STH,V0   MCBUF+2           STORE TYPE                          ABC701
         LI,V0    DABC+X'400'       LOAD STORE ZERO MOVE CLNG,CNTL
         STH,V0   MCBUF+1                                               ABC703
         AI,R4    4                 SET BA(CLOC) ZERO MOVE CLUSTER      ABC704
         LI,R6    DJZF-5            LOAD TYPE(I)                        ABC705
         LI,R7    5                 *    NRTYP                          ABC706
         B        *L1                                                   ABC707
* ZERO MOVE STACK CONTROL                                               ABC80
ABC80    RES      0                                                     ABC800
         LI,R3    1               I=1 GRP
         LI,R3    1                 1 AN/ANE
         LI,R3    2                 2 NC/NE
         LI,R3    2                 2 ND
         LI,R3    3                 3 FLL
         LI,R3    4                 4 FLS
         LI,R3    4                 4 BIN
* AN MOVE STACK CONTROL                                                 ABC81
ABC81    RES      0                                                     ABC810
         LI,R3    DJAG            I=5   GRP                             ABC811
         LI,R3    DJAN              4   AN/ANE                          ABC812
         BAL,L1   ABC82             0/-1  NC/NE                         ABC813
         BAL,L1   ABC82-1           0/-1  ND                            ABC814
         LI,R3    DJAFL             1   FLL                             ABC815
         LI,R3    DJAFS             2   FLS                             ABC816
         LI,R3    DJAB              3   BIN                             ABC817
* ND RFLD                                                               ABC818
         LI,R3    DJAC              ND, SET I FOR ASCENDING             ABC819
* AN SFLD, NC/NE/ND RFLD                                                ABC82
ABC82    RES      0                                                     ABC820
*                        R3 = I(ASCENDING)                              ABC8203
         CI,V0    0                 CHECK DECPC                         ABC821
         BE       ABC89             = 0, INTEGER
         BG       ABC83             > 0, NON-INTEGER                    ABC823
* < 0, TRAILING P                                                       ABC824
         LI,R3    DJAD              SET I FOR DECREASING                ABC825
         LW,R1    V0                LOAD DECPC FOR SIGNIFICANCE CHECK   ABC826
         B        ABC87                                                 ABC827
* DECPC > 0, NON-INTEGER                                                ABC83
ABC83    RES      0                                                     ABC830
         CW,V0    V1                COMPARE DECPC,SIZC                  ABC831
         BL       ABC89             DECPC < SIZC, SIGNIFICANCE
* DECPC >/= SIZC,NO SIGNIFICANCE                                        ABC833
         LH,R3    R6                SET I FOR ZERO FILL                 ABC834
         AI,R3    DJZF                                                  ABC835
         B        *L1               TO LINK TO ZERO FILL CHAINS         ABC836
* NUMERIC MOVE STACK CONTROL                                            ABC84
ABC84    RES      0                                                     ABC840
         LI,R3    DJAG            I=5   GRP                             ABC841
         BAL,L1   ABC93             4   AN/ANE                          ABC842
         BAL,L1   ABC85             0/-1  NC/NE                         ABC843
         BAL,L1   ABC85-1           0/-1  ND                            ABC844
         LI,R3    DJAFL             1   FLL                             ABC845
         LI,R3    DJAFS             2   FLS                             ABC846
         BAL,L1   ABC90             3   BIN                             ABC847
         BAL,L1   ABC90-1           4 INDEX
* ND RFLD                                                               ABC848
         LI,R3    DJAC              ND, SET I FOR ASCENDING             ABC849
* NC/NE/ND RFLD                                                         ABC85
ABC85    RES      0                                                     ABC850
         CW,V0    JDECP             COMPARE DECPC,DECP                  ABC851
         BE       ABC89             =, ALIGNED
         BG       ABC86             > 0, ASCENDING CHAIN                ABC853
* DECPC < DECP, DESCENDING CHAIN                                        ABC8534
         LI,R3    DJAD              SET I FOR DESCENDING                ABC854
         LCW,R1   JDECP             LOAD,CHECK -DECP                    ABC855
         CI,R1    -X'7FFF'                                              ABC856
         BE       ABC89             -DECP = -MAX DECP, FLP SFLD
         AW,R1    V0                SIGNIFICANCE = -DECP+DECPC          ABC858
         AW,R1    JDSIZ             *              +DSIZ
         B        ABC87             TO COMPLETE SIGNIFICANCE CHECK      ABC859
* DECPC > DECP, ASCENDING CHAIN                                         ABC86
ABC86    RES      0                                                     ABC860
         LW,R1    JDECP             SIGNIFICANCE = +DECP                ABC861
         SW,R1    V0                               -DECPC               ABC862
         AW,R1    V1                *              +DSIZC
* COMPLETE SIGNIFICANCE CHECK                                           ABC87
ABC87    RES      0                                                     ABC870
         BGZ      ABC89             SIGNIFICANCE > 0
* SIGNIFICANCE </= 0, ZERO FILL                                         ABC88
ABC88    RES      0                                                     ABC880
         LH,R3    R6                LOAD NC/ND TYPE IND.(I)             ABC881
         AI,R3    DJZF              SET I FOR ZERO/BLANK FILL           ABC882
         B        *L1                                                   ABC883
* SIGNIFICANCE
ABC89    RES      0
         CI,R6    X'A'              CHECK RFLD CLASS
         BANZ     *L1               RFLD NOT NE
* NE RFLD
         LH,R1    5,R5              LOAD,CHECK EDIT OPTION(TE-TI)
         CI,R1    X'800'
         BAZ      *L1               BWZ/*WZ FLAG DOWN.
* BWZ/*WZ
         MTW,1    JINTE             UPDATE BWZ/*WZ INTL NO. RESERVE
         B        *L1
* INDEX
         LI,R3    DJAX-DJAB+CJAB    SET I FOR INDEX
* BIN RFLD                                                              ABC90
ABC90    RES      0                                                     ABC900
         AI,R3    DJAB-CJAB         SET I FOR BIN(/INDEX)
         LW,R1    JDECP             LOAD,CHECK DECP
         BEZ      *L1               DECP = 0, INTEGER                   ABC903
         BGZ      ABC92             DECP > 0, NON-INTEGER               ABC904
* DECP < 0, TRAILING P                                                  ABC91
         AW,R1    V1                SIGNIFICANCE = DECP-SIZC            ABC911
         BGZ      *L1               SIZC > -DECP, SIGNIFICANCE          ABC912
* SIZE  </= (-)DECP
ABC91    RES      0
         AI,R3    DJZF-1            SET I FOR ZERO/BLANK FILL
         CI,R3    DJZF              CHECK I
         BG       *L1               I = FILL CODE
         LI,R3    DJZF+DJAB-1       SET I FOR BIN ZERO FILL
         B        *L1                                                   19
* DECP > 0, NON-INTEGER                                                 ABC92
ABC92    RES      0                                                     ABC920
         CI,R1    X'7FFF'           COMPARE DECP,MAX DECP               ABC921
         BE       *L1               DECP = MAX DECP, FLP SFLD           ABC922
         CW,R1    JDSIZ             COMPARE DECP,SIZE                   ABC923
         BL       *L1               DECP < SIZE, SIGNIFICANCE           ABC924
         B        ABC91             SIZE  </= DECP
* AN RFLD                                                               ABC93
ABC93    RES      0                                                     ABC930
         LI,R3    DJAN              SET I FOR AN/ANE                    ABC931
         B        ABC90+1           TO CHECK SIGNIFICANCE               ABC932
* ALL 'LITERAL'STACK CONTROL
ABC96    RES      0                                                     ABC960
         LI,R3    DJAG            I=5 GRP
         BAL,L1   ABC97           I=4   AN/ANE                          ABC962
* AN/ANE RFLD
ABC97    RES      0                                                     ABC970
*                        V1 = SIZC                                      ABC9709
         AI,R3    DJAN+1            SET I FOR AN/GRP                    ABC971
         CI,R6    6                 CHECK RFLD CLASS
         BAZ      *L1               RFLD AN(=1)
         CI,R6    5
         BAZ      *L1               RFLD ANJR(=2)
* ANE RFLD
         CH,V1    STBAS+3           COMPARE SIZC,DSIZ
         BLE      *L1               SIZC </= MAX SIZE
         STH,V1   STBAS+3           DSIZ = SIZC
         B        *L1                                                   ABC975
         TITLE    'PHASE 4.1 - SET'
* SET                               TYPE = X'67'                        ABE
ABE00    RES      0                                                     ABE00
         STW,R3   JBPFA             SAVE HA(TO/UP/DOWN BY CLOC)-1       41
         AI,R3    24                HA(STKTOP) = HA(STKTOP)+24
* *** RESERVE FOR TO/UP/DOWN BY*****                                     2
         LI,R6    CJIX              SFLD TYPE = INDEX                   5
ABE02    RES      0
         STW,R6   JIGNL             RAISE IGNORE LIT FLAG
         LI,V0    0                 DECP = 0                            4
         STH,V0   JDMAX-1           SUBF MAX,MIN TO MINIMUM VALUE(=0)    3
         STH,V0   JDMIN-1                                                4
         LI,V1    10                DSIZ=10
         B        ABC01             INITIALIZE                          7
* PERFORM VARYING
ABE03    RES      0
         LI,D0    ABC84+2           LOAD N STACK CNTL LOC.
         LI,V2    IBER+CISAV
         B        %+2
ABE04    RES      0                                                     8
         LI,V2    IBER+CISAV+X'10'   ALLOW EDITED
         LI,D1    X'70000'          LOAD NO. OF TYPES, IGNORE OPTION    10
         LI,R1    MCBUF+2
         BAL,L1   ADF00             STACK SET FLDS                      12
         LI,L1    0                 LOWER IGNORE LIT FLAG
         STW,L1   JIGNL
         LB,D0    JNREF             LOAD,CHECK NREF                     13
         BEZ      AA00              = 0, NO VALID SET FLDS              11
* VALID SET FIELDS                                                      15
*                        R1 = NEXT STMT OPT                             43
         STW,R6   JDLST-1           SAVE RFLD TYPE,CLASS,DECP           13
         STH,V0   JDLST                                                 14
         CI,R1    7                 CHECK TO/UP/DOWN BY BITS
         BAZ      ACP14             DOWN. (VARYING) FROM
* SET TO/UP/DOWN BY                                                     47
         LI,R3    HA(STBAS)         RESET HA(STKTOP) FOR TO/UP/DOWN BY   5
         CI,R1    1                 CHECK TO FLAG                       48
         BAZ      ABE30             SET... UP/DOWN BY                   24
* SET....TO                                                             25
         LH,V1    JTYPB             LOAD RFLD TYPE BITS                 26
         BGEZ     ABE07             INDEX NAME/DATA FLAG DOWN            1
* INDEX NAME/DATA FLDS                                                  28
ABE05    RES      0                                                     481
         LI,V2    IBEXN+CISAV       SET REF CNTL FOR INDEX NAME ONLY
         LH,V0    JDMIN-1           LOAD,CHECK SUBF MIN                 30
         BNEZ     ABE06             > 0, INDEX NAME ONLY                31
         LI,V2    IBEX+CISAV        SET REF CNTL FOR INDEX NAME/DATA
ABE06    RES      0                                                     33
         CI,V1    X'7F00'           CHECK FOR DATA                      34
         BAZ      ABE08             NO. INDEX NAME/DATA ONLY             2
* DATA NAME                                                             36
ABE07    RES      0                                                      3
         LI,V2    IBEXD+CISAV       SET REF CNTL FOR INDEX/DATA
*                        V2 = REF CNTL                                  39
ABE08    RES      0                                                     37
         BAL,L1   ADI00             CHECK TO FLD                        41
         B        AA00              INVALID TO FLD
* VALID TO FLD                                                          43
         LI,L0    ABC21             SET LINK REGISTER                   48
ABE09    RES      0                                                     49
         LH,V1    R6                SET SFLD TYPE                       48
         AI,V1    -CJAX                                                 49
         AWM,V1   MCBUF                                                 50
         STW,R6   JSFLD             SAVE SFLD TYPE CNTL                 44
         STW,R3   JBPSAV            SAVE HA(STKTOP)
         LH,V0    JTYPB             LOAD RFLD TYPE BITS
         LH,R1    JSFLD             LOAD,CHECK SFLD TYPE
         AI,R1    -CJAZ                                                  5
         BNEZ     ABE20             SFLD NOT= ZERO                       6
* SFLD = ZERO
ABE10    RES      0                                                     54
         CI,V0    X'8000'           CHECK INDEX FLAG                    55
         BAZ      ABE11-2           DOWN. NO INDEX RFLDS                56
* S*****SET ... TO OR UP/DOWN BY ZERO***                                19
         DX       XCS               WRITE DMF CLUSTER                   21
         CI,R7    6                 CHECK OPTION                        22
         BANZ     AA01              UP/DOWN BY. NOP.                    23
* SET TO, MOVE ZERO                                                     24
ABE11    RES      0                                                     59
         LH,R1    R6                ADJUST SFLD TYPE                    60
         SH,R1    JSFLD                                                 61
         AWM,R1   MCBUF                                                 62
         STW,R6   JSFLD             TYPE,CLASS = ZERO                   63
         STH,R6   0,R4                                                  64
         CI,R6     X'80000'         CHECK OPTION
         BANZ      ABE24            UP/DOWN BY OR VARYING BY 1
*                        DO = NREF                                      25
*                        L0 = LINK REGISTER                             65
ABE12    RES      0                                                     57
         CI,D0    1                 CHECK NREF                          27
         BG       ABE13             NREF > 1
* NREF = 1
         AI,L0    1                 SET ZERO MOVE LINK
         LH,R3    JLSTI             LOAD,CHECK ZERO MOVE RFLD TYPE
         EXU      ABC80+3,R3
         CI,R3    1
         BG       *L0               > 1, NOT INDEX                      67
         LAB,R3   *L0,4             LOAD BIN RFLD TYPE                  68
* NREF > 1                                                              29
ABE13    RES      0
         LW,R3    D0                LOAD NREF                           30
         LI,R1    CJAX+4            LOAD SET ZERO CODE                  31
         BDR,R3   ABC22+1           FORMAT MOVE CLUSTER                 32
*                        V0 = TYPE BITS,NTYP
*                        L1 = LINK REGISTER
ABE14    RES      0
         LW,V1    MCBUF+2           LOAD NREF (A,FLL)                    3
         LW,V2    MCBUF+1           LOAD NREF (INDEX(,D))                4
         CI,V0    X'4000'           CHECK D TYPE BIT                     5
         BAZ      ABE15             = 0, NO D.                           6
* D PRESENT                                                              7
         AH,V2    V1                NREF(A) = NREF(A)+NREF(B)
         STH,V2   V1
         AND,V2   K0FFFF            MASK NREF (INDEX)                   10
         AI,V0    -X'4001'          RESET D TYPE BIT, NREF = NREF-1     11
         CI,V0    X'2000'           CHECK A TYPE BIT                    11
         BANZ     ABE15             NOT= 0. A PRESENT                   12
* A NOT PRESENT                                                         13
         AI,V0    X'2001'           SET A TYPE BIT, NREF = NREF+1       14
ABE15    RES      0                                                     15
         LI,R7    DABC+X'400'       LOAD ZERO MOVE CLNG,CNTL             1
         AW,R7    V2                COMBINE NREF INDEX CNTL
         CI,V0    X'8C00'           CHECK INDEX,BIN,FLS TYPE BITS
         BAZ      ABE18             = 0, NO INDEX/BIN/FLS
*INDEX/BIN/FLS PRESENT
         AW,V2    MCBUF+3           COMBINE NREF(INDEX,BIN(,FLS))       19
         AH,V2    V2                                                    20
         CI,V0    X'400'            CHECK BIN TYPE BIT                  16
         BAZ      ABE16             = 0, NO BIN.                        17
* BIN PRESENT                                                           18
         AI,V0    -X'401'           RESET BIN TYPE BIT, NREF = NREF-1   30
ABE16    RES      0                                                     31
         CI,V0    X'800'            CHECK FLS TYPE BIT                  32
         BANZ     ABE17             NOT = 0, FLS PRESENT
* FLS NOT PRESENT
         AI,V0    X'801'            SET BIN TYPE BIT, NREF = NREF+1
ABE17    RES      0                                                     36
         CI,V0    X'8000'           CHECK INDEX TYPE BIT                38
         BAZ      ABE18             = 0, NO INDEX.
* INDEX PRESENT
         AI,V0    X'8000'-1         RESET INDEX FLAG, NREF = NREF-1
         LH,R4    MCBUF+1+CANC      MOVE ANCHOR(INDEX)
         STH,R4   MCBUF+4+CANC
ABE18    RES      0                                                     41
         STH,V1   V2                STORE NREF(FLL)
         SLS,V1  -16                POSITION NREF(A), NFEF(AN) = 0
         LCI      4                 MOVE CLUSTER TO BUFFER              41
         STM,R7   MCBUF+4                                               42
         LI,R4    BA(MCBUF)+18      LOAD BA(MOVE CLUSTER)                0
         LI,R6    DJAD              LOAD TYPE(I)
         LI,R7    6                 *    NRTYP
         B        *L1
*                                                                       45
* SFLD NOT= ZERO                                                        60
*                        R1 = SFLD TYPE-ZERO TYPE CODE                  45
ABE20    RES      0                                                     63
         BIR,R1   ABE24             SFLD TYPE-ZERO TYPE CODE+1 < 0      46
* = 0, SFLD TYPE = NLIT
         CI,V0    X'8000'           CHECK RFLD TYPE BITS                71
         BAZ      ABE24             INDEX NAME/DATA FLAG DOWN
* INDEX NAME/DATA FLDS                                                  28
         CI,R6     CJINT            CHECK LIT TYPE
         BNE      ABE24             NC                                  COBOL41D
* BIN (INTEGER) LIT
ABE21    RES      0
         LH,V1    5,R5              LOAD INTEGER VALUE
         LH,R1    4,R4
         STH,R1   V1
         BDR,V1   ABE23             > 1                                 51
* </= 1
ABE22    RES      0
         LI,R6    CJIFZ             FORM ZERO CLUSTER                   53
         CI,V1    0                 CHECK INTEGER VALUE                 76
         BL       ABE10+2           < 0(ORIGINALLY </=0)                77
* = 0(ORIGINALLY 1)                                                     78
         CI,R7    X'16'             CHECK OPTION                        79
         BAZ      ABE11             SET TO/(VARYING) FROM               791
         AI,R6     X'30000'         RAISE UP/DOWN BY 1 FLAG
         B         ABE11
* SET TO INTEGER (>1)
ABE23    RES      0
*        SIDR  4147                                                     COBOL41D
*        THE FOLLOWING FIXES CHANGE THE SET UP/DOUN BY VALUE BY ONE     COBOL41D
*        TO CONFORM TO THE TRUE INDEX VALUES.                           COBOL41D
         CI,R7    1                 CHECK UP/DOWN BY OPTION             COBOL41D
         BANZ     ABE231            TO OR VARYING OPTION                COBOL41D
         AI,V1    1                 RAISE INDEX VALUE BY 1              COBOL41D
ABE231   RES      0                                                     COBOL41D
         STH,V1   5,R5              RESTORE INTEGER VALUE
         LH,R1    V1
         STH,R1   4,R4
         MTH,15   0,R4              SET CLASS = INDEX
         MTH,1    4,R5              *   SUBF = 1
*
*                        D0 = NREF                                      45
ABE24    RES      0                                                     76
         BDR,D0   ABE25             NREF > 1
* NREF = 1                                                              47
         B        *L0                                                   82
* NREF > 1                                                              56
ABE25    RES       0
         LW,R3    D0                LOAD NREF-1
         LI,R1    CJAX+3            LOAD SET CODE
         B        ABC22+1
*                        R4 = BA(MCBUF)                                 73
*                        V0 = TYPE BITS,NTYP                            74
*                        L1 = LINK REGISTER                             75
ABE26    RES      0                                                     81
         LH,R1    JSFLD             LOAD SFLD TYPE
         CI,V0    X'8000'           CHECK INDEX FLAG
         BANZ     ABE27             UP. SET INDEX NAME/DATA             79
* NO INDEX NAME/DATA
         AI,L1    -1                SET LINK REGISTER
         B        *L1
* INDEX NAME/DATA
ABE27    RES       0
         LH,D1    MCBUF+1           MOVE NREF,ANCHOR(INDEX
         STH,D1   MCBUF+5
         LH,D1    MCBUF+1+CANC
         STH,D1   MCBUF+5+CANC
         MTB,1    MCBUF             CLNG = CLNG+1                        3
         EXU      ABC60+3,R1        EXECUTE ON SFLD CLASS
         B        AA01  **************
         LH,R6    D1                LOAD WRITE STACK CNTL I
         EXU      ABE28-2,R6        EXU FOR WRITE STACK CNTL ADJ.
         BDR,D0   ABC261            TO WRITE STACK
*WRITE STACK CNTL ADJ.
ABE28    RES      0
         LI,D1    DWIN              NC/ND/NLIT
         LI,D1    DWIFL             FLL
         LI,D1    DWIFS             FLS
         LI,D1    DWIB              BIN/INDEX
* UP/DOWN BY
ABE30    RES      0
         LH,V1    JTYPB             LOAD TYPE BITS                      86
* UP/DOWN BY                                                            89
         CI,V1    X'7FFF'           CHECK TYPE BITS
         BAZ      ABE32
* S*****SET NON-INDEX FLD UP/DOWN BY***
         DX       XCS+1             WRITE DMF CLUSTER
ABE32    RES      0
         LI,V2    IBEUD+CISAV       LOAD UP/DOWN BY REF CNTL            17
         BAL,L1   ADI00             CHECK UP/DOWN BY FLD
         B        AA00              INVALID UP/DOWN BY REF CNTL         19
* VALID UP/DOWN BY FLD
*                        D0 = NREF                                      21
         LH,V1    R6                LOAD SFLD TYPE                      22
         BDR,D0   ABE36             NREF > 1                            23
* NREF = 1                                                              24
         BEZ      ABE34             SFLD = NC                           25
         CI,V1    CJAL                                                  26
         BNE      ABE36             SFLD NOT= NLIT                      27
* SFLD = NC/NLIT                                                        28
ABE34    RES      0                                                     29
         LH,R1    JDLST-1           LOAD,CHECK RFLD TYPE                37
         BDR,R1   ABE36             RFLD NOT=  NC/ND                    38
* RFLD = NC/ND                                                          39
         BNEZ     ABE35             RFLD = ND,  REVERSE.                40
* RFLD = NC                                                             41
         CH,V0    JDLST             COMPARE DECPS,DECPR                 42
         BLE      ABE36             DECPS </= DECPR                     43
* DECPS > DECPR, REVERSE                                                44
ABE35    RES      0                                                     45
         STH,R1   1,R5              RAISE REVERSE FLAG                  46
*                        REVERSE FLAG = -1  ALIGN NC RFLD               47
*                                     = 0   PACK ND RFLD                48
*                                     > 0  NO REVERSE                   49
ABE36    RES      0                                                     50
         AI,D0    1                 NREF = NREF+1                       51
         MTH,5    MCBUF             FORM SET UP/DOWN BY CNTL            20
         CI,R7    2                 CHECK OPTION                        21
         BANZ     ABE09-1           UP BY FLAG UP                       53
         CI,R7    4                                                     54
         BAZ      ACP21             DOWN BY FLAG DOWN, (VARYING) BY.    55
* DOWN BY                                                               23
         AI,V1    X'100'-CJAX       SFLD TYPE = SFLD TYPE X'100'
         LAB,L0   ABE09+2,ABC21                                         58
*
* UNTIL/VARYING OPTIONS
*                        V2 = STMT OPTION
ACP00    RES      0                                                      2
         CI,V2    2                 CHECK UNTIL FLAG
         BAZ      ACP10             DOWN. VARYING.
* UNTIL                                                                  8
         LI,R7    0                 VCNT = 0
         STB,R7   JBPVC
         STW,R7   JBPBA             CLEAR BY ANCHOR
         B        ACP26             WRITE INTL DEF.
*                                   PROCESS CONDITIONAL                  3
*                                   WRITE PERFORM LINKAGE                4
*                                   ****     TRUE POINT DEFS             7
*                                                                        8
* VARYING
ACP10    RES      0                                                      6
         MTW,CPI  JMCRD             SET VARYING RETURN SWITCH            7
         LB,R7    JBPVC             LOAD VCNT
*                        R3 = HA(STKTOP)                                 8
* (VARYING) FROM                                                        25
*                        R7 = NO. OF VARYING LEVELS(VCNT)                5
ACP12    RES      0                                                      9
         STB,R7   JBPCV             SAVE VARYING LEVEL
         LAB,R6   ABE02,CJIX-X'90000' INIT    E SET CLUSTER
*                        R1 = NEXT OPTION                               11
*                        R2 = HA(NLOC)                                  12
*                        R3 = HA(STKTOP)                                13
*                        R4 = HA(CLOC)                                  14
*                        R5 = HA(CLOC)-1                                15
*                        R6 = VARYING FLD                               16
ACP14    RES      0                                                     32
         SW,R4    KHASTK            HA(CLOC) = STACK OFFSET(LNKV)
         STH,R4   0,R3              SAVE LNKV
         LB,R7    JBPCV             LOAD CURRENT VARYING LEVEL(V)       81
         STW,R3   JBPFA,R7          SAVE FROM ANCHOR(V)                 37
         STW,R3   JBPFA             SAVE HA(FROM CLOC)-1                36
         CB,R7    JBPVC             CHECK V                              6
         BANZ     ACP15             VCNT = 1/3
* LAST LEVEL                                                            29
         BAL,L1   PPI30             WRITE INTL DEF                      30
         STW,D3   JBPID+1,R7        SAVE INTL(V+1)
ACP15    RES      0
         LI,V1    X'F0009'          RESET SET CLUSTER
         AWM,V1   MCBUF
         LH,V1    JTYPB             LOAD,CHECK RFLD TYPE BITS           47
         BLZ      ABE05             VARYING INDEX NAME/DATA             48
         LAB,V2   ABE08,IBER+CISAV  VARYING DATA                        49
* VARYING FROM(SET TO) WRITTEN                                          50
ACP16    RES      0                                                     52
         LB,R7    JBPCV             LOAD V                              53
         LD,D0    MCBUF             SAVE SET CLUSTER                    54
ACP17    RES      0
         STD,D0   STBAS,R7                                              55
* *** ANALYZE ***
* BY                                                                    69
ACP20    RES      0                                                     80
         LW,R3    JBPSAV            RESTORE HA(STKTOP)                  80
         STW,R3   JBPBA,R7          SAVE BY ANCHOR(V)                   81
         LI,D0    1                 NREF = 1
         B        ABE32             CHECK (VARYING)  BY FLD             62
*                        V1 = SFLD TYPE                                 63
ACP21    RES      0                                                     64
         CI,V1    CJAFL             CHECK SFLD TYPE                     65
         BAZ      ACP22             SFLD NOT= FLP/NLIT                  66
         CI,V1    CJAL                                                  67
         BE       ACP22             SFLD = NLIT                         68
* SFLD = FLP                                                            69
         LH,V0    JDLST             DECPS = DECPR                       70
         STH,V0   4,R5                                                  71
ACP22    RES      0                                                     72
         SH,V1    JSFLD             ADJUST SFLD TYPE                    75
         BAL,L0   ABE09+2           FORMAT SET UP BY CLUSTER            88
         B        ACP24             SET UP PARTIALLY FORMED             90
* (VARYING) BY ZERO
*                        V0 = TYPE BITS
         CI,V0    X'8000'           CHECK TYPE BITS
         BANZ     ACP23             INDEX RFLD. DX WRITTEN
* S****(VARYING) BY ZERO ***********                                    91
         DX       XCS               WRITE DMF CLUSTER                   21
ACP23    RES      0
         LB,R7    JBPCV             LOAD V
         LI,R3    0                 CLEAR BY ANCHOR(V)
         STW,R3   JBPBA,R7
ACP24    RES      0                                                     96
         LH,R3    JLSTI             LOAD RFLD TYPE
         STH,R3   MCBUF+1           STORE RFLD TYPE                     97
         LB,R7    JBPCV             LOAD V                              98
         LD,D0    MCBUF             SAVE SET UP BY CLUSTER
ACP25    RES      0
         STD,D0   STBAS+6,R7                                            99
* *** ANALYZE ***
         LW,R3    JBPSAV            RESTORE HA(STKTOP)                   3
         BDR,R7   ACP12             V = V-1                              1
* E-O-VARYING FLDS                                                       2
         LB,R7    JBPVC             LOAD VCNT                            4
         CI,R7    2                 CHECK VCNT
         BE       ACP27             = 2, INTL DEF(V) WRITTEN
ACP26    RES      0                                                      5
         BAL,L1   PPI30             WRITE INTL DEF                       8
*                        D3 = INTL(V)
         STW,D3   JBPID,R7          SAVE INTL(V)
ACP27    RES      0
         BAL,L1   ADC00             PROCESS CONDITIONAL                 11
         LW,R3    JBPSAV            RESTORE HA(STKTOP)
         BDR,R7   ACP26             V = V-1                             12
* LAST VARYING LEVEL                                                     0
*                        R7 = V
         AI,R7    1                 V = V+1
         STB,R7   JBPCV             SAVE V
         BAL,L0   ABP60             GENERATE PERFORM LINKAGE
         LB,R7    JBPCV             LOAD V                              53
* E-O-CONDITIONALS                                                      13
*                        R7 = V                                         17
ACP30    RES      0                                                     11
         LW,R4    JBPBA,R7          LOAD,CHECK BY ANCHOR
         BEZ      ACP34+1           = 0, (VARYING) BY ZERO
         LI,L0    ACP34             SET LINK REGISTER                    6
         ANLZ,R4  ACP25             OBTAIN DA(SET UP BY(V))
*WRITE SET UP BY(V)                                                      8
*                        R4 = DA(BY/FROM)
*                        R7 = V                                          9
*                        L0=LINK REGISTER
ACP32    RES      0                                                     18
         SLS,R4   3                 DA(SET UP BY(V)) TO BA              13
         BAL,L1   ADV00             RESOLVE VAR PARAM
         BAL,L1   WRMCF             WRITE SET UP BY(V)                  14
         EXU      *L0               LOAD HA(BY/FROM(V))                 15
*                        R4 = HA(BY/FROM(V))-1
         AI,R4    1
         AW,R4    R4                HA(BY/FROM(V)) TO BA                19
         BAL,L1   ADV00             RESOLVE VAR PARAM
         BAL,L1   WRMCF             WRITE BY/FROM(V)                    20
         LW,R4    JBPFA,R7          LOAD HA(FROM(V))                    21
         LH,R4    0,R4              LOAD VARYING(V) STACK OFFSET
         AI,R4    HA(STBAS)         FORM BA(VARYING(V))                 23
         AW,R4    R4                                                    24
         BAL,L1   ADV00             RESOLVE VAR PARAM
         BAL,L1   WRMCF             WRITE VARYING(V)                    25
         AI,L0    1                 SET LINK REGISTER                   26
         B        *L0               RETURN                              27
ACP34    RES      0                                                     30
         LW,R4    JBPBA,R7          LOAD HA(BY(V))                      31
* SET UP WRITTEN
         LW,D3    JBPID,R7          LOAD INTL(V)                        32
         BAL,L1   PII20             WRITE B INTL(V)
* WRITE  TRUE POINT DEFINITIONS
         LI,L0    ACP38             SET LINK REGISTER
         LI,D2    X'FE800'          LOAD OPTION
ACP36    RES      0
         RCRF     R5                READ NEXT CLUSTER                   35
         CH,D2    0,R5              CHECK OPTION
         BNE      *L0               NOT= TRUE POINT
         LH,D3    1,R2              LOAD TRUE POINT LABEL(V)
         LAB,L1   PPI32,ACP36       WRITE TRUE POINT(V) DEF
*                                                                       34
ACP38    RES      0
         CB,R7    JBPVC             CHECK V                             37
         BE       AA00              V = VCNT, E-O-PERFORM               39
* PROCESS NEXT VARYING LEVEL                                            39
         BAZ      ACP40             V = 1(VCNT = 2)                     40
         ANLZ,R4  ACP17             OBTAIN DA(SET TO FROM(V))
         BAL,L0   ACP32             WRITE SET TO FROM(V)                42
         LW,R4    JBPFA,R7          LOAD HA(FROM(V))                    43
ACP40    RES      0                                                     44
         AI,R7    1                 V = V+1                              1
         B        ACP30                                                 46
*
* E-O-SEARCH - N.S. INTL DEF
*                        R7 = INTL NO.
ACW00    RES      0
         LH,D1    SSTBS+4           LOAD SUBF
         LW,D3    SSTBS+2           LOAD INDEX BASE,DISPL
         LH,V1    SSTBS+1           LOAD, CHECK OPTION
         CI,V1    1
         BANZ     ACW11             SEARCH 'ALL'
ACW04    RES      0
         LBAL     PIA02,CLI+CRI     WRITE LI,R1 SUBF
ACW05    RES      0
         BAL,L1   PID16             WRITE
         AWM,RI   2                 ****  AWM,RI INDEX
         LH,V1    SSTBS+1           LOAD,CHECK OPTION
         BGEZ     ACW10             VARYING FLAG DOWN
* VARYING OPTION
         LH,R3    SSTBS+5           LOAD,CHECK VARYING TYPE
         CI,R3    CJAX
         BNE      ACW08             NOT= INDEX
* VARYING INDEX
         LH,D1    SSTBS+9           LOAD,CHECK SUBFV
         BEZ      ACW08A              0 = INDEX DATA                    COBOL41D
* INDEX NAME
         LW,D3    SSTBS+7           LOAD VARYING BASE,DISPL
         STB,R3   SSTBS+1           LOWER VARYING FLAG
         CH,D1    SSTBS+4           COMPARE SUFBV,SUBF
         BE       ACW05             SUBFV = SUBF
         B        ACW04             WRITE LI,RI SUBFV
*                                   ****  AWM,RI VARYING INDEX
* NOT= INDEX NAME, SET UP BY 1
ACW08    RES      0
         LI,V0    0                 DECPS = 0
         LI,V1    1                 DSIZS = 1
         STD,V0   JDECP
         LW,R6    SSTBS+5           LOAD TYPE,CLNG,CNTL
         LH,V0    SSTBS+9           *    DECPR
         LH,V1    SSTBS+8           *    DSIZR
         EXU      ABC84+2,R3        EXECUTE ON VARYING TYPE
         CI,R3    DJZF              CHECK SIGNIFICANCE
         BGE      ACW10             NO SIGNIFICANCE
         LI,D1    DABC+5            LOAD SET UP CLNG,CNTL
         LW,D2    R3                LOAD RFLD TYPE
*                                                                       COBOL41D
* THE FOLLOWING 3 INSTRUCTIONS CAUSE THE IDENTIFIER TO BE INCREMENTED   COBOL41D
* BY THE SAME AMOUNT AS THE INDEX-NAME.                                 COBOL41D
* PREVIOUSLY THE IDENTIFIER WAS INCREMENTED BY 1 (I. E., SET UP BY 1),  COBOL41D
* REGARDLESS OF THE SIZE OF THE TABLE ENTRY, BY THE FOLLOWING INSTRUCTN:COBOL41D
         LBAL     PID14,CJAO           WRITE SET UP BY 1                COBOL41D
         WMCF     ,BA(SSTBS)+22        WRITE VARYING  FLD               COBOL41D
         B         ACW10                                                COBOL41D
ACW08A   RES      0                                                     COBOL41D
         LW,D3    SSTBS+7           BASE AND DISPLACEMENT OF IDENTIFIER COBOL41D
         BAL,L1   PID16             WRITE **** AWM,RI                   COBOL41D
         AWM,RI   2                                                     COBOL41D
ACW10    RES      0
         LI,D3    0                 LOWER SEARCH FLAG
         XW,D3    JSTDL             LOAD INTL NO.
         BAL,L1   PII20             WRITE B INTL
         LW,D3    R7                LOAD INTL NO.
         LAB,L1   PPI32,AA02        WRITE INTL DEF
ACW11    LI,D3    0                 LOWER SEARCH FLAG
         XW,D3    JSTDL
         LW,D3    R7                LOAD INTL NO.
         LAB,L1   PPI32,AA02        WRITE INTL DEF
*
K2FF00   RES      0
         GEN,8,24 X'FF',X'FF00'
K303     EQU       JAKON+5
K0FFFF   EQU      JAKON+7
KHASTK   EQU      JAKON+32
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
JLNKT    EQU      JADAT+14          *         LNKT
JSIZM    EQU      JADAT+15          SIZE MAX
JTYPB    EQU      JADAT+24          TYPE BITS
JDREF    EQU      JADAT+25          WA(NREF)
JLSTI    EQU      JADAT+27          LAST REF(I)
JNREF    EQU      JADAT+28          TOTAL NO. OF DATA REFS
JDANC    EQU      JADAT+29          WA(ANCHOR)
JNTYP    EQU      JASAV+1           NO. OF TYPES
JDGSAV   EQU      JASAV+2           R2-R7
JINTE    EQU      JAMOD+X'E'        BWZ/*WZ INTL NO. RESERVE
JBPVC    EQU      JADAT+X'1F'       VARYING
JBPPI    EQU      JADAT+X'20'       PERFORM PROC. INFO.
*        RES      4
JBPID    EQU      JADAT+X'26'       INTL NO.
*        RES      3
JBPFA    EQU      JADAT+X'29'       FROM ANCHOR
*        RES      3
JBPBA    EQU      JBPFA+3           BY ANCHOR
*        RES      3
JBPCV    EQU      JADAT+X'30'       CURRENT VARYING LEVEL
JSTDB    EQU      JADAT+X'31'       SEARCH WA(TDB)
JSTDL    EQU      JADAT+X'31'       INTL NO.
JIGNL    EQU      JADAT+X'32'
JBPSAV   EQU      JASAV+25
         END
