         SYSTEM   SIG7FDP
         SYSTEM   BPM
         TITLE    'PHASE 4.2 - SUBSCRIPT SUBROUTINE'
* READ PROC                                                             APR
* LF     R---     R-,+/-HW OFFSET,INDIRECT ADDR.                        APR  1
RMCF     CNAME    1                                                     APR01
         PROC                                                           APR04
LF       BAL,L1   RDMCF             READ MCF CLUSTER
         SLS,R2   -1                BA(CLOC) TO HA
         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                SET HA(CLOC)-1
         FIN                                                            APR44
         FIN                                                            APR44
         PEND                                                           APR50
* WRITE PROC                                                            APW
* LF     W---     R-,BA(CLOC)+/-BA OFFSET,RETURN                        APW 1
WPOF     CNAME    0                                                     APW00
         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       NUM(AF(4))
         B        WRPOF             WRITE POF CLUSTER
         ELSE
         DO       NUM(AF(3))
         LI,L1     AF(3)
         B        WRPOF             WRITE POF CLUSTER                   APW841
         ELSE                                                           APW842
         BAL,L1   WRPOF             WRITE POF CLUSTER                   APW843
         FIN                                                            APW844
         FIN                                                            APW848
         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
         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
* EXTERNAL REFERENCES
         REF      BAA02             RETURN
         REF      PIA00,PIA02,PIA06,PIA08,PIA20,PIA22,PIA26,PIA28
         REF      PII00,PII02,PII20,PII22
         REF      PIL00,PIL02,PIL06,PIL20,PIL22,PIL26
         REF      PID10,PID11,PID12,PID14,PID16,PID18
         REF      PIP00,PIP02,PIP20,PIP22
         REF      PRA00,PRA01,PRA02,PRA04,PRA20,PRA21,PRA22,PRA24
         REF      PRB00,PRB02,PRB06,PRB20,PRB22,PRB26
         REF      PRE00,PRE01,PRE02,PRE20,PRE21,PRE22
         REF      PRF00,PRF02,PRF06
         REF      PRG00,PRG02,PRG06,PRG20,PRG22,PRG26
         REF      PRT00,PRT02,PRT06,PRT20,PRT22,PRT26
         REF      PDB00,PDB02,PDB06
         REF      PDD00,PDD01,PDD02,PDD03,PDD04,PDD06,PDD08
         REF      PDL10,PDL12,PDL16
         REF      PPI10,PPI12
         REF      PIY00,PIY01,PIY02,PIY03
         REF      PIY20,PIY21,PIY22,PIY23
         REF      PIY30,PIY31,PIY32,PIY33
         REF      PIZ30,PIZ32
         REF      MTL20
         REF      LRA00,LRA01,LRA02
         REF      LRR00,LRR01,LRR02
         REF      LRD00,LRD01
         REF      LRD10,LRD11,LRD20,LRD21
         REF      LRD40,LRD41,LRD42
         REF      LRD60,LRD61,LRD62,LRD80,LRD81,LRD82
         REF      LRL00,LRL01
         REF      MRR10,MRR11,MRR12
         REF      MRR40,MRR41,MRR42
         REF      MRR60,MRR61,MRR62,MRR80,MRR81,MRR82
         REF      NRR10,NRR11,NRR12
         REF      NRR40,NRR41,NRR42
         REF      NRR60,NRR61,NRR62,NRR80,NRR81,NRR82,NRR70
         REF      NRD00,NRD01,NRD02
         REF      ORR03,ORR04,ORR05,ORR06,ORR07,ORR08
         REF      ORD12,ORD22,ORD23,ORD24
         REF      ORD42,ORD44,ORD48
         REF      ODR02,ODR04
         REF      JSXR,JSSCX,JSXSX
         REF      LNKTB,LNKSZ,LNKCT
         REF      LNKR7,DIAG,LCORF
         REF      JCSXR             CSXR SAVE
         REF      WRPOF
         REF      RDMCF
         REF      PDBS              NO. OF BYTES FOR BASE 4(HALF-WORD)
         REF      PDBX              LINE NO.                            AAC063
         REF      PDBZ              DDB ADCONS
         REF      STG:UST           STRING/UNSTRING FLAG                COBOL42S
*                                             +3 = WA(DBB BASE)
*                                             +4 = NO. OF DDB'S,
*                                                  WA(DBINDX)
         REF      GTMP              TEMP STG
         REF      GADNO             ADCON NO.
* 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
RE       EQU      4                 EVEN
RO       EQU      5                 ODD
RB       EQU      R6                BIN
RF       EQU      V2                FILE CNTL
RVX      EQU      RO                ALTERNATE VOLATILE INDEX REGISTER
SR1      EQU      8                 SR1
SR3      EQU      X'A'              SR3
* BA(D-)                                                                CBD
CBD0     EQU      X'30'                                                 CBD0
CBD1     EQU      X'34'                                                 CBD1
CBD2     EQU      X'38'                                                 CBD2
CBD3     EQU      X'36'                                                 CBD3
* INDEX REGISTERS                                                       CIR
CIR1     EQU      2                                                     CIR1
CIR2     EQU      4                                                     CIR2
CIR3     EQU      6                                                     CIR3
CIR4     EQU      8                                                     CIR4
CIR5     EQU      X'A'                                                  CIR5
CIR6     EQU      X'C'                                                  CIR6
CIR7     EQU      X'E'
* R REGISTERS
CIRO     EQU      CIR5              ODD
CIRVX    EQU      CIRO              ALTERNATE VOLATILE INDEX REGISTER
CRR1     EQU      X'10'                                                 CR01
CRR2     EQU      X'20'                                                 CR02
CRR3     EQU      X'30'                                                 CR03
CRR4     EQU      X'40'                                                 CR04
CRR5     EQU      X'50'                                                 CR05
CRR6     EQU      X'60'                                                 CR06
CRR7     EQU      X'70'                                                 CR07
CRV0     EQU      X'80'                                                 CR08
CRV1     EQU      X'90'                                                 CR09
CRV2     EQU      X'A0'                                                 CR10
CRL1     EQU      X'B0'                                                 CR11
CRD0     EQU      X'C0'                                                 CR12
CRD1     EQU      X'D0'                                                 CR13
CRD2     EQU      X'E0'                                                 CR14
CRD3     EQU      X'F0'                                                 CR15
CRE      EQU      X'40'             EVEN
CRO      EQU      X'50'             ODD
CRB      EQU      CRR6              BIN
CRF      EQU      CRV2              FILE CNTL
CP1      EQU      CRR7              PREG 1
CRVX     EQU      CRO               ALTERNATE VOLATILE INDEX REGISTER
CSR1     EQU      X'80'             SR1                                 CR3
CSR3     EQU      X'A0'             SR3                                 CR3
* OP CODES                                                              C0
CCAL1    EQU      X'0400'           CAL1                                C04
CLD      EQU      X'1200'                                               C12
CFAL     EQU      X'1D00'                                               C194
CAI      EQU      X'2000'                                               C20
CLI      EQU      X'2200'           LI                                  C22
CLI1     EQU      X'2210'           LI,1                                C221
CMI      EQU      X'2300'
CSF      EQU      X'2400'                                               C24
CS       EQU      X'2500'                                               C25
CAW      EQU      X'3000'
CSTW     EQU      X'3500'           STW                                 C35
CSTS     EQU      X'4700'           STS                                 C47
CLW      EQU      X'3200'                                               C32
CEOR     EQU      X'4800'           EOR                                 C48
CSAS     EQU      X'400'            RA SETING - SAS                     C484
CSDA     EQU      X'500'            RA SETTING - SAD                    C485
COR      EQU      X'4900'           OR                                  C49
CLAH     EQU      X'5B00'
CMBS     EQU      X'6100'
CBDR     EQU      X'6400'                                               C64
CEXU     EQU      X'6700'                                               C67
CBR      EQU      X'6800'           B                                   C68
CBLE     EQU      X'6820'           BLE,BLEZ                            C682
CBEZ     EQU      X'6830'           BEZ                                 C683
CBAZ     EQU      X'6840'           BAZ                                 C684
CBL      EQU      X'6910'           BL                                  C691
CBAL     EQU      X'6AB0'           BAL,L1
CLB      EQU      X'7200'                                               C72
CSTB     EQU      X'7500'                                               C75
CDL      EQU      X'7E00'                                               C795
CPACK    EQU      X'7600'                                               C76
CIND     EQU      X'8000'           INDIRECT BIT                        C900
* POF CLUSTER CLNG,CNTL
* INSTRUCTION TYPE
DAIA     EQU      X'0401'           CONSTANT
DAID     EQU      X'0609'           DATA
DAII     EQU      X'0402'           INTERNAL LABEL
DAIL     EQU      X'0406'           LOC. CNTR
DAIP     EQU      X'0404'           PAR/SEC NAME
DAIX     EQU      X'0108'           XREF
* DATA REFERENCE
DARA     EQU      X'0410'           ADCONS
DARB     EQU      X'0417'           BRANCH TABLE
DARE     EQU      X'0415'           EXIT TABLE
DARF     EQU      X'41A'            FILE LABEL
* DATA DEF
DADB     EQU      X'0621'           BINARY
DADD     EQU      X'0829'           DATA REF
DADL     EQU      X'0626'           LOC. CNTR
DADX     EQU      X'0328'           EXTERNAL NAME
* DEFINITIONS/DECLARATIONS
DAPI     EQU      X'0341'           INTERNAL LABEL
* GLOBAL LITERAL WA DISPL - BASE 4
DGDZ     EQU      4                 D'+0'
DGD1     EQU      3                 D'+1'
DGFZ     EQU      6                 FL'0.E8'
* GLOBAL LITERAL BA DISPL - BASE 4
DGZRO    EQU      0                 ZERO
DGSPC    EQU      1                 SPACE
DGQUO    EQU      2                 QUOTE
DGLV     EQU      3                 LOW-VALUE
DGHV     EQU      4                 HIGH-VALUE
DGAST    EQU      6                 ASTERISK
* REGISTER SAVE LEVELS
DSS      EQU      1                 SUBSCRIPT
DSL      EQU      2                 STORE
DSG      EQU      4                 GENERATOR
* TEMP REGISTER SAVE AREAS
DTB      EQU      9                 BIN
DTF      EQU      18                FLP
DTCSX    EQU      20                CORRESPONDING SXR1,SXR2
DTD1     EQU      10                DECA - SUBSCRIPT
DTD2     EQU      14                DECA - STORE
DTD4     EQU      22                DECA - GENERATORS
DTWA     EQU      28                WA TMP WORK AREA
DTBA     EQU      DTWA*4            BA TMP WORK AREA                    22
* ENTRY POINTS
         DEF      SSB00,SSB01,SSB02
         DEF      SSL00,SSL01,SSL02
         DEF      SSS00,SSS01,SSS02
         DEF      SSS10,SSS18       CORRESPONDING,GRP SWITCHES
         DEF      SUBSF,LNKSF
*
* LOAD BA(DREF)(,SUBSCRIPTS/INDICES)                                    0
SSL00    RES      0                                                     000
*                        R2 = HA(CLOC)
*                        R5 = HA(CLOC)-1
         LH,R7    0,R2              LOAD,MASK CLASS
         AND,R7   K30F
*                        R7 = CLASS
SSL01    RES      0
         LW,V0    JSXR              LOAD,POSITION SXR
         SLS,V0   4
         LH,D1    1,R2              LOAD SUBSCRIPT INFO.
*                        V0 = SXR
*                        D1 = SUBSCRIPT INFO
SSL02    RES      0
         STW,L1   SSBSAV            SAVE LINK REGISTER
         BAL,L1   SSS02             CHECK EVALUATE SUBSCRIPTS
         AI,V0    CAI-CLI           SUBSCRIPTED, FORM AI(-LI),SR
         AI,V0    CLI               FORM LI/AI,SXR
         STW,D2   SSSD0+2           SAVE D2
         MTW,0    LNKSF
         BNEZ     %+2               IN LINKAGE SECTION
         BAL,L1   PID10             WRITE LI/AI,R-BA(DREF)(+BYTE OFFSET)008
         LI,D1    0                 CLEAR SUBSCRIPT INFO.
         LW,D2    SSSD0+2           RESTORE D2
         AND,V0   K3F0              MASK -,R
         B        SSB06
* * * V0 ALWAYS SET TO INDICATE SUBSCRIPTING(=R-)                       009
*
* LOAD SUBSCRIPTS,/BYTE OFFSET                                          1
*                        R2 = HA(CLOC)
*                        R5 = HA(CLOC)-1
SSB00    RES      0                                                     100
         LH,R7    0,R2              LOAD,MASK CLASS
         AND,R7   K30F
*                        R7 = CLASS
SSB01    RES      0
         LW,V0    JSXR              LOAD,POSITION SXR
         SLS,V0   4
         LH,D1    1,R2              LOAD SUBSCRIPT INFO.
*                        V0 = SXR
*                        D1 = SUBSCRIPT INFO
SSB02    RES      0
         STW,L1   SSBSAV            SAVE LINK REGISTER
         BAL,L1   SSS02             CHECK EVALUATE SUBSCRIPTS
         B        SSB08             SUBSCRIPTED
* NOT SUBSCRIPTED
         CI,D1    0                 CHECK FOR BA/HA BITS
         BNEZ     SSB10             BA/HA BITS
* NO SUBSCRIPTS OR BA/HA BITS
         LI,V0    0                 CLEAR XR
SSB06    RES      0
         STW,V0   SSSV0+1           SAVE NO SUBSCR./R-/SXR IND.
         B        *SSBSAV           RETURN
* SUBSCRIPTED
SSB08    RES      0
         MTW,0    LNKSF
         BNEZ     SSB12             IN LINKAGE SECTION
         CI,D1    0                 CHECK FOR BA/HA BITS ALSO
         BEZ      SSB12             NO. SUBSCRIPT ONLY
* SUBSCRIPTS AND BA/HA BITS
         AI,V0    CAI-CLI           SET FOR AI,SXR
* BYTE OFFSET ONLY                                                      115
SSB10    RES      0                                                     116
         STD,D0   SSSD0             SAVE REGISTERS
         AI,V0    CLI               FORM OP CODE - LI,R-                117
         BAL,L1   PIA02             WRITE LI,R- BYTE OFFSET             118
         LD,D0    SSSD0             RESTORE REGISTERS
SSB12    RES      0
         AND,V0   K3F0              MASK XR
         SLS,V0   -3                POSITION XR
         B        SSB06
*
* SUBSCRIPTS
*                        R2 = HA(CLOC)
*                        R5 = HA(CLOC)+1
SSS00    RES      0                                                     300
         LH,R7    0,R2              LOAD,MASK CLASS
         AND,R7   K30F
SSS01    RES      0
         LW,V0    JSXR
         SLS,V0   4
         LH,D1    1,R2              LOAD SUBSCRIPT INFO.
*                        V0 = SXR
*                        D1 = SUBSCRIPT INFO
SSS02    RES      0
         STW,V0   SAVV02            SAVE V0                             COBOL42S
         MTW,1    SUBSF
         LH,D3    2,R2              LOAD BASE NO.,DISPL                 301
         LH,R1    2,R5                                                  302
         STH,R1   D3                                                    303
         LI,R1    3                 MASK,CLEAR BA/HA BITS
         AND,R1   D3
         STW,L0   SAVL0
         LH,L0    0,R2
         STW,L0   LCLAS
         BAL,L0   SSK00             CHECK FOR LINKAGE SECTION
         LW,L0    SAVL0
         CI,D1    0                 CHECK SUBSCR. INDICATOR             305
         BNEZ     SSS04             SUBSCRIPTED
* NOT SUBSCRIPTED
         LW,D1    R1                .. HA/BA BITS
         MTW,0    LCORF+1
         BLEZ     SSS03             NOT LINKAGE GRP
         MTW,0    LNKSF
         BEZ      SSS05             NOT LINKAGE GROUP
         LCI      14
         STM,R2   SSSAV
         LW,R1    D1TEMP            SET UP R1                           COBOL425
         B        SSC00
SSS05    LW,R1    LNKCF
         STW,R1   LNKSF
SSS03    LI,R1    0
         STW,R1   SUBSF
         STW,R1   LSVSF
         MTW,0    LNKSF
         BNEZ     *L1               IN LINKAGE SECTION
         LI,R1    1                 LOAD RETURN INDEX                   309
         B        *L1,R1            RETURN                              309
* SUBSCRIPTED
SSS04    RES      0
         XW,R1    D1                EXCHANGE BA/HA BITS,SUBSCR. INFO
         LCI      14                SAVE REGISTERS
         STM,R2   SSSAV
         EXU      JSSCX             = B SSS10/SSS10-1
* SUBSCRIPT FIELD CLASS BRANCH TABLE
SSS08    RES      0
         B        SSS92             INVS
         B        SSS22             ND
         B        SSS32             NC
         BDR,R5   SSS42             INDEX - HA(SLOC)=HA(SLOC)-1
         AI,V0    CLW               BIN - FORM OP CODE - LW,XREG/VREG
         B        SSS62             FLS
         B        SSS82             FLL
         CI,R7    X'C'              CORRESPONDING - CHECK CLASS
* GRP SUBSCRIPT EXECUTE TABLE
SSS09    RES      0
         B        SSS90             INVS
         LI,R1    2                 ND
         LI,R1    3                 NC
         BDR,R5   SSS40             INDEX - HA(SLOC)= HA(SLOC)-1
         LI,R1    5                                                     COBOL42S
         LI,R1    6                                                     COBOL42S
         LI,R1    7                                                     COBOL42S
         B        SSS17             CORRESPONDING
*
* SUBSCRIPTED
* CORRESPONDING SUBSCRIPT SWITCH
         B        SSC00             CORRESPONDING SXR
SSS10    RES      0                                                     310
         AW,R5    R1                HA(SLOC) = HA(CLOC)-1+SLOC OFFSET
         LH,R3    0,R5              LOAD SUBSCR CNTL
         AI,R3    -X'8000'          MARK FIRST ENTRY
         STH,R3   R3
         LI,R6    X'D'              SET RFLD CLASS = BIN
         CI,V0    X'10'             CHECK FOR ODD XREG
         BANZ     SSS14             XREG ODD.  USE.
SSS12    RES      0
         LI,V0    CRL1              EVEN. USE VOLATILE REGISTER(VREG)
SSS14    RES      0
         SCS,R3   4                 POSITION SUBSCR.CLASS
         LH,D3    1,R5              LOAD DISPL/INVS
         AI,R5    1                 HA(SLOC) = HA(SLOC)+1
         LH,V1    0,R5              LOAD,COMBINE BASE,DISPL/INVS
         STH,V1   D3
         LH,R2    1,R5              LOAD SUBF
         AI,R5    2                 HA(SLOC) = HA(SLOC)+2
         LI,R1    7                 MASK SUBSCR FLD(=SFLD) CLASS
         AND,R1   R3
         BEZ      SSS16             END OF SUBSCRIPT/INDEX
         AI,R1    8
         STW,R1   LCLAS             CLASS FOR LINKAGE SECTION
         AI,R1    -8
         B        *JSXSX            SUBSCRIPT/INDEX/INVS
* E-O-SUBSCRIPTS/INDICES
SSS16    RES      0
         LBAL     ODR04,DSS,D3      CHECK, RESTORE DECA
SSS17    RES      0
         LI,R2    0
         STW,R2   SUBSF
         STW,R2   LSVSF
         STW,R2   SAVV02            CLEAR FLAG                          COBOL42S
         LCI      14                RESTORE REGISTERS
         LM,R2    SSSAV                                                 312
         B        *L1               RETURN                              213
*                        D3 = BASE,DISPL
*
*                        R1 = SUBSCRIPT TYPE
*                        R2 = SUBF(I)
*                        R5 = HA(SLOC)
*                        R7 = CLASS
*
* GRP SUBSCRIPT SWITCH
         EXU      SSS09-1,R1        EXECUTE ON SFLD TYPE
*
SSS18    RES      0
         EXU      SSS08-1,R1        EXECUTE ON SFLD TYPE
* BIN SUBSCRIPT
         BAL,L1   SSI00             CHECK LINKAGE SECTION
         MTW,0    LNKCF
         BEZ      SSS19             NOT IN LINKAGE SECTION
         LW,L1    SAVV02                                                COBOL42S
         CI,L1    CRR1                                                  COBOL42S
         BNE      SSS18A                                                COBOL42S
         BAL,L1   PIA06                                                 COBOL42S
         LW,L1    0,R5              *** WRITE LW,L1  0,R5               COBOL42S
         B        SSS18B
SSS18A   RES      0                                                     COBOL42S
         BAL,L1   PIA06
         LW,L1    0,R1              *** WRITE LW,L1  0,R1               COBOL42S
SSS18B   RES      0                                                     COBOL42S
         LI,V0    CRL1              USE L1
         B        SSS20
SSS19    RES      0
         MTW,0    LNKSF             CK LINKAGE                          COBOL42S
         BEZ      SSS191                                                COBOL42S
         LI,V0    CLW+CRL1          IN LINKAGE                          COBOL42S
SSS191   RES      0
         BAL,L1   PID11             WRITE LW,XREG/VREG  BIN DREF
*                        R2 = SUBF(I)
*                        V0 = XREG/VREG(ODD)
* **                     XREG/VREG = BINARY VALUE
SSS20    RES      0
         AND,V0   K3F0              MASK XREG/VREG
         AI,V0    CMI               FORM OP CODE - CMI,XREG/RREG
SSS21    RES      0
         LW,D1    R2                LOAD SUBF(I)
         BAL,L1   PIA02             WRITE MI,XREG/RREG  BIN VALUE
* **                     XREG/VREG = BIN SUBSCR. VALUE
         CI,V0    X'80'             CHECK REGISTER USAGE
         BAZ      SSS12             XREG USED - FIRST ENTRY ONLY
* VREG USED
         LI,L1    SSS12             SET LINK REGISTER
         LI,D1    X'F0'             MASK LOAD VREG(=SREG)
         AND,D1   V0
         OR,D1    K310              FORCE ODD
         LW,V0    SSSV0             LOAD XREG
         MTW,0    LNKSF
         BNEZ     SSS23             IN LINKAGE SECTION
         CI,R3    X'8'              CHECK FIRST ENTRY MARK
         BAZ      ORR06             SET. WRITE LW,XREG  VREG
* FIRST ENTRY MARK NOT SET
SSS23    AI,V0    CAW
         B        ORR07             WRITE AW,XREG  VREG
*
* ND SUBSCRIPT
SSS22    RES      0
         LW,R7    V0                SAVE XREG/VREG
         AI,R5    1                 HA(SLOC) = HA(SLOC)+1
         LH,V1    0,R5              LOAD BSIZ
         CI,V1    1                 CHECK FOR ODD BSIZ
         BAZ      SSS24             NO. EVEN BSIZ
* ODD BSIZ
         BAL,L1   SSI00             CHECK LINKAGE SECTION
         LAB,L0   SSS33,ORD12       UNPACK
* EVEN BSIZ
SSS24    RES      0
         STW,V0   SAVV0
         LI,V0    CRV2              V2 - SENDING
         BAL,L1   SSI01             CHECK LINKAGE SECTION
         MTW,0    LNKCF
         BNEZ     SSS25             IN LINKAGE SECTION
         LBAL     PID10,CLI+CRV2    WRITE  LI,V2 BA(ND)
SSS25    RES      0
         LBAL     ODR02,DSS,D3      CHECK,SAVE DECA
         BAL,L1   SSK10             SAVE ORIGINAL LNKSF
         LI,V0    CRV2
         LI,D3    0                 LOWER SUBSCRIPT FLAG
         STB,D3   JZREG             LOWER DECA=0 FLAG
         LAB,L0   NRD02,SSS36       WRITE LW,RO =BSIZ,BA(UNPKA)
*                                   ****   MBS,RE  0
*                                   ****  PACK,BSIZ/2+1  UNPKA
* NC SUBSCRIPT
SSS32    RES      0
         BAL,L1   SSI00             CHECK LINKAGE SECTION
         LW,R7    V0                SAVE XREG/VREG
         AI,R5    1                 HA(SLOC) = HA(SLOC)+1
         LH,V1    0,R5              LOAD BSIZ
         LI,L0    ORD23             SET DL LINK REGISTER
SSS33    RES      0
         LW,D1    D3                SAVE BASE,DISPL
         LBAL     ODR02,DSS,D3      CHECK,SAVE DECA
         LW,D3    D1                RESTORE BASE,DISPL
         LI,V0    0                 CLEAR BYTE OFFSET XR IND.
         STB,V0   JZREG             LOWER DECA=0 FLAG
         BAL,L1   SSK10             SAVE ORIGINAL LNKSF
         BEZ      SSS31             NOT IN LINKAGE SECTION
         LI,V0    CIR5              USE R5
         LI,R7    CRL1                  AND SET VREG
         B        SSS35
SSS31    AND,D1   K303
         BEZ      SSS35             = 0, NO BYTE OFFSET
* BYTE OFFSET
         LI,V0    CRR1              LOAD BYTE OFFSET XR
         CW,V0    SSSV0             CHECK SXR
         BNE      SSS34             SXR NOT= R1
* SXR = R1, USE ALTERNATE VOLATILE INDEX REGISTER(RVX)
         LI,V0    CRVX              LOAD RVX
SSS34    RES      0
         AI,V0    CLI               FORM LI,R1/RVX
         BAL,L1   PIA02             WRITE LI,R1/RVX BYTE OFFSET
         AI,V0    -CLI              MASK,POSITION R1/RVX TO XR
         SLS,V0   -3
*                        V0 = 0/BYTE OFFSET INDEX(R1/RVX)
*                        L0 = DL/UNPK  LINK REGISTER
SSS35    RES      0
         BAL,L1   *L0               WRITE DL/UNPK,L NC/ND(,R1/RVX)
*                        R7 = XREG/VREG
SSS36    RES      0
         BAL,L1   SSK10             RESTORE LNKSF
         LW,V0    R7                RESTORE XREG/VREG
         LH,D3    0,R5              LOAD,POSITION DECP
         SLS,D3   -8
         BAL,L0   NRR12+1           WRITE LI,P1 XREG/VREG,DECP
*                                   ****   BAL,L1 C:CDB
         LW,V0    R7                RESTORE XREG/VREG
         B        SSS20+1
*
* GRP SUBSCRIPT SWITCH - INDEX
SSS40    RES      0
         LI,V1    0                 SET DREF CLASS = GRP
         B        SSS42+1
* INDEX
SSS42    RES      0
         LW,V1    SSSV0-1           LOAD DREF CLASS                      2
         CI,R3    8                 CHECK FIRST ENTRY MARK
         BANZ     SSS52             NOT SET. NOT FIRST ENTRY
* FIRST ENTRY
         LI,V0    CLW               LOAD OP CODE - LW
         MTW,0    LNKCF             SEE IF IN LINKAGE SECTION           COBOL42S
         BEZ      SSS44             NO                                  COBOL42S
         LI,V0    CAW               LOAD OP CODE - AW                   COBOL42S
SSS44    RES      0
         AW,V0    SSSV0             FORM OP CODE - LW/AW,XREG
         LI,L0    SSS12             SET LINK REGISTER                    4
* CHECK FOR CONSECUTIVE INDEX NAME/DATA                                  5
*                        V0 = LW/AW,XREG/VREG                            6
*                        D3 = INDEX BASE,DISPL                           7
*                        L0 = LINK REGISTER                              8
SSS45    RES      0                                                      9
         BAL,L1   PID11             WRITE LW/AW,XREG/VREG INDEX         10
         LI,R1    X'7000'           MASK,CHECK NEXT SFLD                11
         AND,R1   R3                                                    12
         CI,R1    X'4000'                                               13
         BNE      SSS46             NEXT SFLD NOT= INDEX                14
* CONSECUTIVE INDEX NAME/DATA                                           20
         SCS,R3   4                 POSITION SUBSCR. CLASS              21
         LH,D3    1,R5              LOAD DISPL                          22
         AI,R5    1                 HA(SLOC) = HA(SLOC)+1               23
         LH,D1    0,R5                                                  24
         STH,D1   D3                                                    25
         AI,R5    1                 HA(SLOC) = HA(SLOC)+1               26
         AND,V0   K3F0              MASK XREG/VREG                      27
         AI,V0    CAW               FORM AW,XREG/VREG                   28
         B        SSS45                                                 29
* E-O-CONSECUTIVE INDEX NAMES/DATA                                      30
*                        V1 = DREF CLASS                                31
SSS46    RES      0
         CI,V1    X'C'
         BL       *L0                                                   COBOL42S
         MTW,0    LNKCF
         BNEZ     *L0               IN LINKAGE SECTION
         LW,L1    L0                LOAD LINK REGISTER                  36
* ADJUST FOR WA/DA DREF
SSS48    RES      0                                                     41
         AND,V0   K3F0              MASK XREG/VREG                      42
         AI,V0    CS                FORM S,XREG/VREG                    43
         LI,D1    CSAS+X'7E'        SET SHIFT VALUE = -2
         CI,V1    X'F'
         BL       PIA02             WA DREF,WRITE SAS,XREG/VREG -2
* FLL -  DA DREF
         LI,D1    CSAS+X'7D'        SET SHIFT VALUE = -3
         B        PIA02             WRITE SAS,XREF/VREG  -3
* NOT FIRST ENTRY
SSS52    RES      0
         LI,V0    CAW               FORM AW,XREG/VREG                   49
         CI,V1    X'C'              CHECK DREF CLASS
         BL       SSS44             BA DREF                             51
* WA/DA DREF                                                            52
         LBAL,L0  SSS45,CLW+CRL1    WRITE LW,VREG INDEX                 53
*                                   ****  SLS,VREG -2/-3                54
         LW,V0    SSSV0             LOAD XREG
         AI,V0    CAW               FORM OP CODE - AW,XREG
         LI,D1    L1                LOAD VREG
*                        R4 = BA(D0)+2
*                        D0 = ABS VAL CLNG CNTL
         LAB,L1   PIY01,SSS12       WRITE AW,XREG VREG
* FLS SUBSCRIPT
SSS62    RES      0
         BAL,L1   PIA06             WRITE
         LI,L1    0                 ****     CLEAR ODD REGISTER
         BAL,L1   SSI00             CHECK LINKAGE SECTION
         MTW,0    LNKCF
         BEZ      SSS63             NOT IN LINKAGE
         BAL,L1   PIA06
         LW,L0    0,R5              *** WRITE LW,L0  0,R5
         B        SSS85
SSS63    RES      0
         LAB,V0   SSS83+1,CLW+CRV2  LOAD,CONVERT TO BIN
* FLL SUBSCRIPT
SSS82    RES      0
         BAL,L1   SSI00             CHECK LINKAGE SECTION
         MTW,0    LNKCF
         BEZ      SSS83             NOT IN LINKAGE
         BAL,L1   PIA06
         LD,L0    0,R5              *** WRITE LD,L0 0,R5
         B        SSS85
SSS83    RES      0
         LBAL     PID11,CLD+CRV2    WRITE LD,V2  WA(FLL FLD)
SSS85    RES      0
         LW,V1    SSSV0             LOAD, CHECK SXR
         CI,V1    CRR1
         BNE      SSS84             SXR NOT = R1
* SXR = R1, USE ALTERNATE VOLATILE INDEX REGISTER (RVX)
         BAL,L1   PIA26             WRITE
         LH,RVX   V2                ****     LOAD SIGN, CHAR'C
         LBAL,L0  PIZ30,-7,R1       WRITE
         SCS,RVX  8                 ****     POSITION SIGN, CHAR'C
         STB,RVX  V2                ****     STORE SIGN
         LAW,RVX  RVX               ****     OBTAIN ALIGNMENT SHIFT
         LH,RVX   RVX               ****
         SLS,RVX  2                 ****
         AI,RVX   -X'118'           ****
         SAD,V2   0,RVX             ****     ALIGN INTEGER
         LAB,V0   SSS21,CMI+CRV2    COMPUTE SUBSCRIPT
* SXR NOT = R1
SSS84    RES      0
         LI,V1    CRV2              LOAD VREG
         LAB,L0   NRR62+2,SSS20     CONVERT TO BIN
*
* GRP SUBSCRIPT SWITCH - INVS
SSS90    RES      0
* *** DREF TYPE = INDEX/BIN/FLS/FLL ONLY***
         SLS,D3   2                 INVS TO BA(INDEX/BIN/FLS)/HA(FLL)
         LW,R7    SSSV0-1           LOAD,CHECK DREF CLASS
         CI,R7    X'F'
         BL       SSS92             DREF CLASS = INDEX/BIN/FLS
* DREF CLASS = FLL
         AW,D3    D3                INVS(=HA) TO BA
*
* INVS
* ** NOT ONLY ENTRY
* **     BUT, CORRESPONDING GRP MAY HAVE INVS ONLY ***
SSS92    RES      0
         LW,V0    SSSV0             LOAD XREG
         AI,V0    CAI               FORM OP CODE - AI,XREG
         MTW,0    LNKSF             SEE IF IN LINKAGE SECT.             COBOL42S
         BNEZ     SSS94             YES                                 COBOL42S
         CI,R3    8                 CHECK FIRST ENTRY MARK
         BANZ     SSS94             DOWN. NOT FIRST(/ONLY) ENTRY
* INVS ONLY
         AI,V0    CLI-CAI           FORM LI,XREG
SSS94    RES      0
         CI,D3    0                 CHECK INVS VALUE
         BGE      SSS95             > 0
* INVS < 0
         AI,V0    X'F'              FORM AI/LI,XREG -(INVS)
SSS95    RES      0
         LAB,L1   PIA22,SSS16       WRITE AI/LI,XREG INVS
*
* CORRESPONDING SUBSCRIPTS
SSC00    RES      0
*                        R1 = SUBSCRIPT INFO.
*                        R7 = DREF CLASS
*                        V0 = SXR
         AI,V0    CLW               FORM                                01
         LI,R6    2                 LOAD INDEX REGISTER                 02
         LB,R4    R1,R6             LOAD POSITION CSXR                  03
         SLS,R4   -4                                                    04
         LW,D1    R4                                                    05
*        SIDR 6113 CHANGED THE FOLLOWING INSTS FROM CB,V0  JCXSR,R4     COBOL42S
*                                                   BE  SSC08           COBOL42S
*        TO                 MTB,0     &     BNEZ                        COBOL42S
         MTB,0     JCSXR,R4        CHECK CSXR SAVE FLAG                 COBOL42S
         BNEZ      SSC08           UP. CSXR SAVED                       COBOL42S
* CSXR NOT SAVED                                                        09
         CB,V0    R1,R6             COMPARE SXR,CSXR                    10
         BE       SSC06             =, SAVE ONLY                        11
* SXR NOT= CSXR, SAVE UNNECESSARY                                       12
         LAB,L1   PIA02,SSC10       WRITE LW,SXR CSXR                   13
* SXR = CSXR, SAVE                                                      14
SSC06    RES      0                                                     15
*        SIDR 6113 CHANGED THE FOLLOWING INST FROM STB,V0  JCSXR,R4     COBOL42S
*        TO          MTB,1  JCSXR,R4                                    COBOL42S
         MTB,1     JCSXR,R4        RAISE CSXR SAVED FLAG                COBOL42S
         AI,V0    CSTW-CLW          FORM STW,CSXR                       19
* CSXR SAVED                                                            20
SSC08    RES      0
         AI,D1    18                OBTAIN CSXR SAVE DISPL              21
         BAL,L1   PRT02             WRITE STW/LW,SXR  CSXR SAVE         22
*                                                                       23
SSC10    RES      0                                                     24
         MTW,0    LNKSF
         BEZ      SSC11             NOT IN LINKAGE SECTION
         BAL,L1   SSK11
SSC11    RES      0
         LI,R1    8                 LOAD CORRESPONDING INDEX            25
         EXU      *JSXSX            EXECUTE NORMAL/GRP SUBSCRIPT TABLE  26
* NORMAL SUBSCRIPTING                                                   27
* ***    CI,R7    X'C'   EXECUTED **                                    28
         BL       SSS17             BA DREF
* INDEX/BIN/FLP DREF                                                    30
         LI,D1    CSAS+X'7E'        LOAD RA FOR S,- -2                  31
         CI,R7    X'F'              CHECK FOR FLL DREF                  32
         BNE      SSC12             NO. INDEX/BIN/FLS DREF              33
         LI,D1    CSAS+X'7D'        LOAD RA FOR S,- -3                  34
SSC12    RES      0                                                     35
         AND,V0   K3F0              MASK,SET SAS,SXR                    36
         AI,V0    CS                                                    COBOL42S
         LAB,L1   PIA02,SSS17       WRITE SLS,SXR -2/-3
*
*  LINKAGE SECTION DATA ADDRESS RESOLUTION
*
SSI00    STW,V0   SAVV0
         LW,V0    SAVV02                                                COBOL42S
         CI,V0    CRR1                                                  COBOL42S
         BNE      SSI00A                                                COBOL42S
         LI,V0    CRR5              USE R5                              COBOL42S
         B        SSI01                                                 COBOL42S
SSI00A   RES      0                                                     COBOL42S
         LI,V0    CRR1              USE REGISTER 1                      COBOL42S
SSI01    STW,L1   SAVL1
         STW,L0   SAVL0
         BAL,L0   SSK00
         LW,L0    SAVL0
         LW,V0    SAVV0
         B        *SAVL1
SSK00    LCI      9
         STM,R7   LNKRG             SAVE REGISTERS
         LI,V0    0
         STW,V0   LNKCF
         LB,R7    D3                BASE
         CI,R7    X'FF'
         BE       SSK01             IN LINKAGE SECTION
         MTW,0    LCORF+1
         BGEZ     SSK06
         MTW,0    LSVSF                                                 COBOL42S
         BNE      SSK07             SUBSCRIPT IT SELF                   COBOL42S
         BAL,L1   SSK12             CORR ELEMENT                        COBOL42S
         B        SSK0A                                                 COBOL42S
SSK01    LW,R7    LNKCT
         BEZ      SSK0D             BAD DATA USAGE
         MTW,1    LNKCF
         STB,V0   D3                CLEAR BASE 'FF'
SSK02    AI,R7    -1
         LW,D2    D3                SAVE DISP
SSK03    CW,D2    LNKTB,R7          CHECK LNKTB
         BL       SSK0C             NOT IN THE GROUP
         BG       SSK05             MAY BE IN THE GROUP
         LI,D3    0                 CLEAR DISPLACEMENT
SSK04    STW,D3   LKDSP             SAVE DISP
         B        SSK0N                                                 COBOL42S
SSK0E    LI,R1    0                 FORCE NO H.A./B.A. BIT              COBOL42S
SSK0A    MTW,0    LCORF                                                 COBOL42S
         BEZ      SSK0H                                                 COBOL42S
         LI,D1    X'2000'           USE R2                              COBOL42S
         B        SSK0F                                                 COBOL42S
SSK0H    LI,D1    X'3000'           USE R3                              COBOL42S
SSK0F    STW,D1   D1TEMP                                                COBOL425
         B        SSK07
SSK0N    LI,R1    0                 FORCE NO HA/BA BIT
         LW,D3    R7
         LBAL     PIA22,CLI+CRR7    *** WRITE LI,R7 PARAM DISP
         LW,D1    LNKR7             PARAM ADDR
         LW,V0    LNKRG+1           SXR
         AI,V0    CLW+CIR7+CIND
         BAL,L1   PRA01             *** WRITE LW,SXR *PARAM ADDR,R7
         MTW,0    LCORF+1                                               COBOL425
         BGZ      SSK0S                                                 COBOL425
         BAL,L1   SSK11
SSK0S    MTW,0    LSVSF
         BNEZ     SSK0T             SUBSCRIPT ITSELF
         MTW,0    LCORF+1
         BGZ      SSK09             CORR LINKAGE GROUP
         MTW,0    STG:UST           SEE IN IN STRG/UNSTRG               COBOL42S
         BNEZ     SSK08             YES--LEAVE BYTE ADDR                COBOL42S
SSK0T    LW,R7    LCLAS
         AND,R7   K30F              MASK CLASS
         CI,R7    X'C'
         BL       SSK08             NOT WA/DA ALLIGNED
         LW,V0    LNKRG+1
         AI,V0    CS
         CI,R7    X'F'
         BE       %+3               DA ALIGNED
         LI,D1    CSAS+X'7E'        SET SHIFT VALUE = -2
         B        %+2               *** WRITE SAS,XREG/VREG -2
         LI,D1    CSAS+X'7D'        SET SHIFT VALUE = -3
         BAL,L1   PIA02             *** WRITE SAS,XREG/VREG -3
SSK08    MTW,0    LCORF+1
         BGEZ     SSK06             NOT CORR ELEMENT
         MTW,0    LSVSF
         BNEZ     SSK07             SUBSCRIPT ITSELF
         BAL,L1   SSK12
         MTW,0    LNKSF
         BNEZ     SSK0E             LINKAGE GRP
         LW,L1    LNKCF             LNK ELEMT
         STW,L1   LNKSF
         B        SSK0E
SSK05    LH,V0    LNKSZ,R7
         AND,V0   K2FFFF
         AW,V0    LNKTB,R7          BA OF NEXT GROUP
         CW,D2    V0
         BGE      SSK0C             NOT IN THE GROUP
         LW,D3    D2
         SW,D3    LNKTB,R7          DISP IN THE GROUP
         B        SSK04
SSK0C    AI,R7    -1
         BGEZ     SSK03             NOT FINISHED
SSK0D    RES      0
         DX       X'5D'             BAD DATA USAGE
SSK06    MTW,0    LSVSF
         BNEZ     SSK07             FOR INDEX OR SUBSCRIPT
         LW,R7    LNKCF
         STW,R7   LNKSF             SAVE ITS LINKAGE FLAG
         MTW,1    LSVSF
SSK07    LCI      9
         LM,R7    LNKRG             RECOVER REGISTERS
         B        *L0
SSK09    LW,R7    LCORF+1
         MTW,1    LCORF+1,R7        LINKAGE FLAG FOR CORR GRP
         B        SSK06
SSK10    LW,V0    LNKSF             SAVE AND
         XW,V0    LNKCF
         STW,V0   LNKSF                SET LINKAGE FLAG
         B        *L1
SSK11    LW,D3    LKDSP             DISPLACEMENT
         BEZ      *L1               NO
         AND,V0   K3F0
         AI,V0    CAI
         B        PIA22             *** WRITE AI,SXR DISP
SSK12    LW,R7    LCORF             CHECK CORR GROUP                    COBOL42S
         LW,R7    LCORF+2,R7                                            COBOL42S
         STW,R7   LNKSF             IN LINKAGE FLAG                     COBOL42S
         MTW,1    LSVSF
         MTW,0    LCORF                                                 COBOL42S
         BEZ      SSK13                                                 COBOL42S
         LI,D1    0                 FOR 2ND ELEMENT                     COBOL42S
         STW,D1   LCORF                                                 COBOL42S
         B        *L1                                                   COBOL42S
SSK13    MTW,1    LCORF             FOR THE 1ST ELEMENT                 COBOL42S
         B        *L1                                                   COBOL42S
SAVV02   DATA     0                                                     COBOL42S
*                                                                       39
SUBSF    DATA     0
LNKSF    DATA     0                 LINKAGE SECTION FLAG
LNKCF    DATA     0                 LINKAGE FLAG
LSVSF    DATA     0                 SAVE LINKAGE FLAG
LCLAS    DATA     0                 CLASS OF DATA IN LINKAGE SECTION
LKDSP    DATA     0                 LINKAGE DISP
SAVV0    RES      1
SAVL0    RES      1                 SAVE L0
SAVL1    RES      1
LNKRG    RES      9
D1TEMP   RES      1                 SAVE  D1                            COBOL425
         REF      KBKON,K4BAS,KABA
K30E     EQU      KBKON
K3E0     EQU      KBKON+1
K30F     EQU      KBKON+2
K3F0     EQU      KBKON+3
K3FF     EQU      KBKON+4
K2FFFF   EQU      KBKON+5
K0FF     EQU      KBKON+6
K2FF     EQU      KBKON+7
K303     EQU      KBKON+9
K310     EQU      KBKON+13
K4SPAC   EQU      K4BAS+1
K4AST    EQU      K4BAS+2
K0A      EQU      K4BAS+4           LABEL BASE
K064     EQU      K4BAS+5           RECORD,DCB BASE NO. ADJ.
*
         REF      SSSAV
SSSV0    EQU      SSSAV+6
SSSD0    EQU      SSSAV+10
SSBSAV   EQU      SSSAV+14
         REF      JDECP
JZREG    EQU      JDECP+13
         END
