         SYSTEM   SIG7FDP
         SYSTEM   BPM
         TITLE    'PHASE 4.2 - STORE-2'
* 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
* CHECK CLASS,BRANCH
CLAS     CNAME
         PROC
* LF     CLAS,CF(2),CF(3) AF(1),AF(2),AF(3),AF(4),AF(5),AF(6)            4
*             REG   BC-   CLASS  BGE  EXU/C   BG   BE    B               5
         CI,CF(2) AF(1)             CHECK -FLD CLASS                     6
         DO       NUM(CF(3))                                             7
         GEN,8,24 CF(3),AF(2)       CHECK-FLD CLASS
*        ABOVE REPLACES
*        CF(3)    AF(2)
*        WHICH CAUSES SEVERITY LEVEL 7 IN OBJECT MODULE     6/4/70
         DO       NUM(AF(3))                                             9
         EXU      AF(3)-AF(1),CF(2) EXECUTE ON -FLD CLASS               10
         FIN
         ELSE                                                           12
         BGE      AF(2)-AF(1),CF(2) >/=                                 13
         DO       NUM(AF(4))
LF       CI,CF(2) AF(3)             CHECK -FLD CLASS                    15
         BG       AF(4)             >
         DO       NUM(AF(5))
         BE       AF(5)             =
         FIN
         DO       NUM(AF(6))
         B        AF(6)             <
         FIN
         ELSE                                                           24
         DO       NUM(AF(3))
         B        AF(3)                                                 26
         FIN                                                            27
         FIN                                                            29
         FIN
         PEND
* 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      PIX02,PIX06,OIX02
         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,PPI11,PPI12
         REF      PIY00,PIY01,PIY02,PIY03
         REF      PIY20,PIY21,PIY22,PIY23
         REF      PIY30,PIY31,PIY32,PIY33
         REF      PIZ30,PIZ32
         REF      LRA00,LRA01,LRA02
         REF      LRA92
         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      NRR16
         REF      NRR40,NRR41,NRR42
         REF      NRR60,NRR61,NRR62
         REF      NRR70,NRR71,NRR72
         REF      NRR80,NRR81,NRR82
         REF      NRD00,NRD01,NRD02
         REF      ORR03,ORR04,ORR05,ORR06,ORR07,ORR08
         REF      ORD12,ORD22,ORD23,ORD24
         REF      ORD42,ORD44,ORD48
         REF      OII00,OII01,OII02
         REF      MTL20
         REF      NDF00,NDF02,NDF04 ZERO,*,SPACE FILL
         REF      SSB00,SSB01,SSB02
         REF      SSL00,SSL01,SSL02
         REF      SSS00,SSS01,SSS02
         REF      JDECP,JDSIZ
         REF      WRPOF
         REF      RDMCF
         REF      PDBP              SPECIAL NAME FLAG
         REF      PDBS              NO. OF BYTES FOR BASE 4(HALF-WORD)
         REF      PDBX              LINE NO.                            AAC063
         REF      PDBZ              DDB ADCONS
         REF      LNKSF
         REF      GTMP              TEMP STG
         REF      GADNO             ADCON NO.
         REF      VPP00,VPP10,LITF
         REF      VPP30,NOVF,VBIDX
         REF      RFLDF,VPP50
         REF      VARF
* 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
RFL      EQU      V0                FLP
RF       EQU      V2                FILE CNTL
RS       EQU      V1                SIGN - EDIT
RC       EQU      L1                %
P1       EQU      V2                PREG 1
SR1      EQU      8                 SR1
SR3      EQU      X'A'              SR3
* BA(D-)
CBD0     EQU      X'30'
CBD1     EQU      X'34'                                                 CBD1
CBD2     EQU      X'38'                                                 CBD2
CBD3     EQU      X'3C'
* 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'
CIBC     EQU      RB-4              CONVERT BIN
CIFC     EQU      RFL-4             CONVERT FLP
* R REGISTERS
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
CRFL     EQU      CRV0              FLP
CRS      EQU      CRV1              SIGN-EDIT
CRF      EQU      CRV2              FILE CNTL
CRC      EQU      CRL1              %
CP1      EQU      CRV2              PREG 1
CSR1     EQU      X'80'             SR1                                 CR3
CSR3     EQU      X'A0'             SR3                                 CR3
* OP CODES
CCAL1    EQU      X'0400'           CAL1
CLD      EQU      X'1200'                                               C12
CSTD     EQU      X'1500'
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'
CLW      EQU      X'3200'                                               C32
CMTW     EQU      X'3300'
CSTW     EQU      X'3500'
CSW      EQU      X'3800'           SW
CLCW     EQU      X'3A00'           LCW
CSTS     EQU      X'4700'           STS                                 C47
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
CAND     EQU      X'4B00'
CMTH     EQU      X'5300'
CLAH     EQU      X'5B00'
CMBS     EQU      X'6100'
CBDR     EQU      X'6400'                                               C64
CAWM     EQU      X'6600'
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
CBNE     EQU      X'6930'           BNE,BNEZ
CLCI     EQU      X'0220'
CBAL     EQU      X'6AB0'           BAL,L1
CLB      EQU      X'7200'                                               C72
CMTB     EQU      X'7300'
CSTB     EQU      X'7500'                                               C75
CPACK    EQU      X'7600'                                               C76
CUNPK    EQU      X'7700'
CDSA     EQU      X'7C00'
CDL      EQU      X'7E00'                                               C795
CDST     EQU      X'7F00'
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
DARG     EQU      X'0414'           GLOBAL LITERALS
DARL     EQU      X'0418'           LOCAL LITERALS
DART     EQU      X'0416'           TMP STG
* 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
* REGISTER SAVE LEVELS
DSS      EQU      1                 SUBSCRIPT
DSL      EQU      2                 STORE
DSG      EQU      4                 GENERATOR
* RESET REGISTER SAVE LEVEL VALUES
DSAR     EQU      X'F'
DSLR     EQU      X'E'
DSSR     EQU      X'C'
* GLOBAL LITERAL WA DISPL - BASE 4
DGZZ3    EQU      1                 GEN,24,8 0,C'0'(ZONED ZERO)
DGZZ0    EQU      2                 GEN,8,24  C'0',0
DGDZ3    EQU      3                 GEN,24,8  -,D'+0'(ZONE = X'F')
DGDZ     EQU      4                 D'+0'
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
* 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
*
* ENTRY POINTS
         DEF      LDR00,LDR20,LDR60,LDR70,LDR80
         DEF      MDR00,MDR02,MDR30,MDR40,MDR50
         DEF      MDR60,MDR64,MDR66,MDR68
         DEF      MDR80,MDR84,MDR88
         DEF      MDR70,MDR74,MDR78
         DEF      NDR00
         DEF      NDR06,NDR18
         DEF      NDR30
         DEF      NDR31,NDR32
         DEF      NDR10,NDR34
         DEF      NDR38,NDR39
         DEF      NDR40
         DEF      ODR00
         DEF      ODR02,ODR04
         DEF      ODR16
         DEF      ODR32,ODR34
         DEF      ODR40
         DEF      MDS00,MDS01
         DEF      MDE00,MDE02
         DEF      NDE00,NDE02,NDE20,NDE50
         DEF      ODE02,ODE04,ODE10,ODE16
*
* STORE REGISTER - NUMERIC ONLY
* **                     RFLD CLASS AGREES WITH SFLD CLASS
*                        R2 = HA(CLOC)
*                        R5 = HA(CLOC)-1
*                        L0 = LINK REGISTER
LDR00    RES      0
         LH,R7    0,R2              LOAD,MASK RFLD CLASS
         AND,R7   K30F
LDR01    RES      0
         BAL,L1   LDR91             SAVE REGISTERS, SET PARAMETERS
LDR02    RES      0
         CI,R6    X'C'              CHECK SFLD CLASS
         BL       LDR22             SFLD = NC
         EXU      LDR08-X'C',R6     EXECUTE ON SFLD CLASS
LDR08    RES      0
         B        LDR62             INDEX
         B        LDR62             BIN
         B        LDR72             FLS
         B        LDR82             FLL
* SFLD   NC
LDR20    RES      0
         LH,R7    0,R2              LOAD,MASK RFLD CLASS
         AND,R7   K30F
*                        R7 = RFLD CLASS
*                        R6 = SREG,SFLD CLASS
LDR21    RES      0
         BAL,L1   LDR91             SAVE REGISTERS, SET PARAMETERS
*                        V0 = SREG
*                        R6 = SFLD CLASS
LDR22    RES      0
         LW,V1    JDECP             LOAD DECPS
         LW,D0    JDSIZ             LOAD DSIZS
*                        V1 = DECPS
*                        D0 = DSIZS
LDR24    CLAS,R7  X'C',LDR28,5,MDR02,MDE02,MDR30 CHECK RFLD CLASS
* RFLD CLASS BRANCH TABLE
LDR28    RES      0
         B        MDR42             INDEX
         B        MDR42             BIN
         B        MDR52             FLS
         B        MDR52             FLL
*
* SFLD = INDEX/BIN
LDR60    RES      0
         LH,R7    0,R2              LOAD,MASK RFLD CLASS
         AND,R7   K30F                                                  3
LDR61    RES      0
         BAL,L1   LDR91             SAVE REGISTERS, SET PARAMETERS
LDR62    RES      0
         CLAS,R7  X'C',LDR68,MDR62  CHECK RFLD CLASS
LDR68    RES      0
         B        MDR64+1           INDEX
         B        MDR64+1           BIN
         B        MDR66+1           FLS
         B        MDR68+1           FLL
*                                                                       14
* SFLD = FLS
LDR70    RES      0
         LH,R7    0,R2              LOAD,MASK RFLD CLASS
         AND,R7   K30F                                                  3
LDR71    RES      0
         BAL,L1   LDR91             SAVE REGISTERS, SET PARAMETERS
LDR72    RES      0
         CLAS,R7  X'C',LDR78,MDR72  CHECK RFLD CLASS
LDR78    RES      0
         B        MDR74+1           INDEX
         B        MDR74+1           BIN
         B        MDR64+1           FLS
         B        MDR78+1           FLL
*                                                                       73
* SFLD = FLL
LDR80    RES      0
         LH,R7    0,R2              LOAD,MASK RFLD CLASS
         AND,R7   K30F                                                  3
LDR81    RES      0
         BAL,L1   MDR91             SAVE REGISTERS, SET PARAMETERS
LDR82    RES      0
         CLAS,R7  X'C',LDR88,MDR82  CHECK RFLD CLASS
LDR88    RES      0
         B        MDR84+1           INDEX
         B        MDR84+1           BIN
         B        MDR64+1           FLL
         B        MDR88+1           FLS
*
* RFLD = NC/ND
MDR00    RES      0
         LH,R7    0,R2              LOAD,MASK RFLD CLASS
         AND,R7   K30F                                                  3
MDR01    RES      0
         BAL,L1   MDR91             SAVE REGISTERS, SET PARAMETERS
         LW,V1    JDECP             LOAD DECPS
         LW,D0    JDSIZ             LOAD DSIZS
MDR02    RES      0
         STW,L0   MDRLNK            SAVE LINK REGISTER
*                        V1 = SFLD DECP(DECPS)
*                        D0 = SFLD DSIZ(DSIZS)
         BAL,L1   ODR00             CHECK,ALIGN DECA, ADJUST DSIZS
*                        D0 = DSIZS(ADJUSTED FOR ALIGNMENT)
MDR04    RES      0
         MTH,DSL  JSAVD             RAISE SAVE DECA FLAG
         LH,V1    3,R5              LOAD DSIZR
         CI,R7    8                 CHECK RFLD CLASS
         BANZ     MDR22             RFLD = NC, DIRECT DST                3
* RFLD = ND                                                              4
MDR05    RES      0
         CI,V1    1                 CHECK DSIZR
         BANZ     MDR08             ODD. DIRECT UNPK
* DSIZR EVEN
         LBAL     SSS02-1,CRO       CHECK SUBSCRIPTS
         AI,V0    X'F0000'          RAISE SUBSCRIPT FLAG
         MTH,-DSL JSAVD             LOWER SAVE DECA FLAG
MDR06    RES      0
         CI,R7    6                 CHECK RFLD CLASS                    10
         BE       MDR07             RFLD = NDS
* RFLD = NDU
         BAL,L0   NDR12-1           WRITE ADCON BSIZR-1,BA(RFLD)        14
*                                   ****  LW/AW,RO ADCON                15
         BAL,L0   NDR16-1           WRITE UNPK,BSIZR/2+1 UNPKA+1        16
*                                   ****  LI,RE BA(UNPKA+1)+1           17
*                                   ****  MBS,RE  0                     18
         BAL,L0   NDR18             ZONE LAST DIGIT
         B        *MDRLNK           RETURN                              28
* RFLD = NDS                                                            30
MDR07    RES      0
         BAL,L0   NDR12             WRITE ADCON BSIZR,BA(RFLD)
*                                   ****  LW/AW,RO ADCON                34
         BAL,L0   NDR16             WRITE UNPK,BSIZR/2+1 UNPKA+1        35
*                                   ****  LI,RE BA(UNPKA+1)+1           36
*                                   ****  MBS,RE  0                     37
         B        *MDRLNK           RETURN                              36
* DSIZR ODD
MDR08    RES      0                                                     32
         BAL,L1   SSB01             CHECK SUBSCRIPTS
         MTH,-DSL JSAVD             LOWER SAVE DECA FLAG
         BAL,L1   RFLDV
         AI,V0    CUNPK             FORM UNPK,- -(,SXR)                 45
         LW,L1    LNKSF             SAVE LNK FLAG
         STW,L1   ZLNKF
         BAL,L1   ORD12+1           WRITE UNPK,DSIZ/2+1  RFLD(,SXR)
         CI,R7    6                 CHECK RFLD CLASS                    47
         BE       *L0               RFLD = NDS. RETURN                  48
* RFLD = NDU, FORCE ZONE                                                49
*                        V0 = UNPK,L -(,SXR)                            50
*                        D3 = RFLD BASE,DISPL
MDR09    RES      0
         LW,L0    ZLNKF
         STW,L0   LNKSF             RECOVER LNK FLAG
         BAL,L0   NDR06             SET ZONE OP, ADJUST SXR
         MTW,1    NOVF
         BAL,L0   NDR09             ZONE LAST DIGIT
         B        *MDRLNK           RETURN
* RFLD = AN/ANJR                                                         1
* *** ENTRY THRU MDR30 *************
MDR10    RES      0
         BAZ      MDR14             RFLD = AN
* RFLD = ANJR                                                            4
         SW,V1    D0                PAD SIZE(PSIZ) = DSIZS-DSIZR
         BLEZ     MDR04+1           PSIZ </= 0 (DSIZS >/= DSIZR),NO PAD
* PAD REQUIRED
         LI,V0    CRR1              LOAD RO                              8
         CI,D0    1                 CHECK DSIZS                          9
         STW,D0   DSIZR%                                                COBOL42N
         BANZ     MDR13             DSIZS ODD
* DSIZS EVEN                                                            11
         BDR,V1   MDR11             PSIZ = PSIZ-1
* PSIZ = 0, BSIZR ODD(=DSIZS+1)                                         13
         LW,V1    D0                LOAD DSIZS                          14
         LBAL,L0  MDR08,6,R7        CHECK SUBSCRIPTS
*                                   WRITE UNPK,BSIZR/2+1 RFLD(,SXR)     16
         BAL,L1   PIA06             WRITE                               17
         LI,V2    C' '              ****     LOAD PAD                   18
         LW,V1    V0                SAVE UNPK,BSIZ/2+1 -(,SXR)          19
         AND,V0   K30E              MASK SXR                            20
         AI,V0    CSTB+CRV2         FORM STB,V2 -(,SXR)                 21
         BAL,L1   PID12             WRITE STB,V2 RFLD(,SXR)             22
         LW,V0    V1                LOAD UNPK,BSIZ/2+1 -(,SXR)          23
         B        MDR09             ZONE LAST DIGIT
* PSIZ NOT= 0
MDR11    RES      0
         BAL,L0   NDR32             CHECK SUBSCRIPTS
*                                   WRITE ADCON PSIZ,BA(RFLD)
*                                   ****  LW/AW,R1 ADCON
         BAL,L0   BLVAR
         BAL,L0   NDF04             SPACE FILL
         BAL,L1   ODR11             WRITE UNPK,BSIZS/2+1 0,R1
         BAL,L1   PIA06             WRITE
         LI,V2    C' '              ****     LOAD PAD
         BAL,L1   PIY31             WRITE
         STB,V2   0,R1              ****     STORE PAD
MDR12    RES      0
         MTH,-DSL JSAVD             LOWER SAVE DECA FLAG
         LW,D3    DSIZR%                                                COBOL42N
         CI,D3    1                 IS IT ODD
         BAZ      MDR12:A           BRANCH IF NOT
         AI,D3    -1                DECREMENT COUNT BY ONE
         BEZ      MDR12:B           DONT NEED THE **AI
MDR12:A  RES      0
         LI,V0    CAI+CRR1                                              COBOL42N
         BAL,L1   PIA22             WRITE *** AI,R1 DSIZR               COBOL42N
MDR12:B  RES      0
         BAL,L1   PIA06             WRITE                               COBOL42N
         LB,V2    0,1               *** LB,V2 0,1                       COBOL42N
         BAL,L1   PRG06             WRITE
         OR,V2    DGZZ3             ****  OR,V2 ZONE MASK
         BAL,L1   PIA06             WRITE                               COBOL42N
         STB,V2   0,1               *** STB,10 0,1                      COBOL42N
         B        *MDRLNK           RETURN
* DSIZS ODD
MDR13    RES      0
         BAL,L0   NDR32             CHECK SUBSCRIPTS
*                                   WRITE ADCON PSIZ,BA(RFLD)
*                                   **** LW/AW,R1 ADCON
         BAL,L0   BLVAR
         BAL,L0   NDF04             SPACE FILL
         LAB,L1   ODR11,MDR12       WRITE UNPK,BSIZS/2+1 0,R1
BLVAR    STW,V0   TMPV0
         STW,L0   TMPL1
         LI,V0    R1
         BAL,L0   VPP00             RESOLVE VAR REC
         LW,V0    TMPV0
         B        *TMPL1
* RFLD = AN
MDR14    RES      0
         CW,V1    D0                COMPARE BSIZR,DSIZS                  1
         BE       MDR05             BSIZR = DSIZS,NUMBERIC MOVE          2
         BG       MDR15             BSIZR > DSIZS                        3
* BSIZR < DSIZS                                                          4
         LBAL,L0  NDR32,CRO         CHECK SUBSCRIPT                      5
*                                   WRITE ADCON BSIZR,BA(RFLD)           6
*                                   ****  LW/AW,RO ADCON                 7
         MTH,-DSL JSAVD             LOWER SAVE DECA FLAG
         LW,L0    MDRLNK            LOAD LINK REGISTER                   8
         LW,V1    D0                LOAD DSIZS                           9
         CI,D0    1                 CHECK DSIZS                         10
* *** DSIZS CHECK FOR LEFT JUSTIFIED RFLD ***
         BAZ      NDR16             DSIZS EVEN                          11
* DSIZS ODD                                                             12
         LAB,L1   ODR16,NDR16+2     WRITE UNPK,DSIZS/2+1 UNPKA+1        13
* BSIZR > DSIZS                                                         20
MDR15    RES      0                                                     21
         SW,V1    D0                PSIZ = BSIZR-DSIZS                  22
         STW,V1   JDSIZR            SAVE PSIZ                           23
         LW,V1    D0                LOAD DSIZS                          24
         CI,V1    1                 CHECK DSIZS                         25
         BANZ     MDR16             DSIZS ODD                           26
* DSIZS EVEN                                                            27
         LBAL     SSS02-1,CRO       CHECK SUBSCRIPTS                    28
         AI,V0    X'F0000'          RAISE SUBSCRIPT FLAG                29
         MTH,-DSL JSAVD             LOWER SAVE DECA FLAG
         BAL,L0   NDR12-1           WRITE ADCON BSIZR-1,BA(RFLD)        14
*                                   ****  LW/AW,RO ADCON
         BAL,L0   NDR16-1           WRITE UNPK,BSIZR/2+1 UNPKA+1        1
*                                   ****  LI,RE BA(UNPKA+1)+1
*                                   ****  MBS,RE  0
         BAL,L0   NDR18
         BAL,L1   PIA06             WRITE
         LW,R1    RO                ****     LOAD MBS,0 RO              31
         BAL,L1   PIY31             WRITE                               32
         AI,R1    1                 ****     POSITION TO PAD CHAR.      33
         LW,V1    JDSIZR            LOAD PSIZ                           34
         BAL,L0   NDR30             OBTAIN L,RPTCNT                     35
*                                   WRITE LI,V2 L                       36
         BAL,L1   PIA06             WRITE                               36
         STB,V2   R1                ****     L TO MBS,0 RO              37
         BAL,L0   NDF04             BLANK PAD                           38
         B        *MDRLNK           RETURN                              39
* DSIZS ODD
MDR16    RES      0
         LBAL,L0  MDR08,6,R7        CHECK SUBSCRIPTS                    41
*                                   WRITE UNPK,DSIZS/2+1 RFLD(,SXR)     42
         BAL,L0   NDR06             SET ZONE OP,ADJUST SXR
         BAL,L0   NDR09             ZONE LAST DIGIT                     44
*                        D3 = BASE,PAD DISPL-1(3)                       46
         LW,V1    JDSIZR            LOAD PSIZ                           48
         AI,D3    1                 PAD DISPL-1(/3) = PAD DISPL(-2)     49
         LI,D1    X'E'              MASK,CHECK SXR
         AND,D1   V0                                                    55
         BEZ      MDR17             = 0, NO SUBSCRIPTS
* SXR NOT= 0.                                                           53
         SLS,D1   -1                POSITION SXR                        56
         LBAL     PIA02,CLW+CRR1    WRITE LW,R1 SXR                     57
         LAB,V0   MDR18,CAW-CLW+CRR1 SET AW(-LW),R1                     58
* SXR = 0                                                               69
MDR17    RES      0                                                     72
         LI,V0    CRR1              LOAD RREG                           73
MDR18    RES      0                                                     74
         BAL,L0   NDR32+2           OBTAIN L,RPTCNT                     75
*                                   WRITE ADCON L,RPT CNT               76
*                                   ****  LW/AW,R1 ADCNN                77
         BAL,L0   NDF04             BLANK PAD                           75
         B        *MDRLNK           RETURN                              76
* RFLD = NC
MDR22    RES      0
         BAL,L1   SSB01             CHECK SUBSCRIPTS
         MTH,-DSL JSAVD             LOWER SAVE DECA FLAG
         STW,V1   JDSIZR            SAVE DSIZR                          81
         AI,V0    CDST              FORM DST,-  -(,SXR)                 82
         BAL,L1   RFLDV             RESOLVE VAR REC
         MTW,1    NOVF
         LW,L1    LNKSF             SAVE LINKAGE FLAG                   COBOL42N
         STW,L1   ZLNKF                                                 COBOL42N
         BAL,L1   ORD12+1           WRITE DST,DSIZ/2+1 RFLD(,SXR)       83
         LW,V1    JDSIZR            LOAD DSIZR
         CI,V1    1                 CHECK DSIZR
         BANZ     MDR24             DSIZR ODD                           86
* DSIZR EVEN
         CW,D0    V1                COMPARE DSIZS,DSIZR
         BLE      MDR24             DSIZS </= DSIZR, FILL UNNECESSARY
* DSIZR < DSIZS, ZERO FILL FIRST DIGIT
         LW,V1    V0                SAVE DST,L -(,SXR)
*                        R4,D1,D2,D3 SET FOR DST,L  RFLD(,SXR)
         AND,V0   K30E              MASK SXR
         AI,V0    CLB+CRV2          FORM LB,V2 -(,SXR)
         BAL,L1   PIY02             WRITE LB,V2 RFLD(,SXR)
         BAL,L1   PRG06             WRITE
         AND,V2   DGDZ3             ****  AND,V2 X'F'
         AI,V0    CSTB-CLB          FORM STB,V2 -(,SXR)
         BAL,L1   NDR10             WRITE STB,V2 0/RFLD(,SXR)
         LW,V0    V1                RESTORE DST,L -(,SXR)
MDR24    RES      0
         CI,R7    8                 CHECK RFLD CLASS                    84
         BE       *L0               RFLD = NCS                          85
* RFLD = NCU                                                            86
         CH,R7    JUNSD             CHECK UNSIGNED FLAG
         BANZ     *L0               UP. UNSIGNED SFLD
* SIGNED SFLD
*                        V0 = DST,L -(,SXR)
         AI,V0    -X'10'            L = L-1
         LI,R4    X'F0'             MASK,POSITION L-1
         AND,R4   V0
         SLS,R4   -4
         AND,D3   K301S             MASK BA,HA BITS
         AW,D3    R4                DISPL = DISPL+(L-1)
         AND,R4   K303              MASK,CHECK BA,HA BITS
         BEZ      MDR26             = 0, WA ALIGNED
* NOT= 0, NOT WA ALIGNED
         AND,V0   K30E              MASK,CHECK SXR
         BEZ      MDR26+1           = 0, NOT SUBSCRIPTED
* SUBSCRIPTED
         BAL,L1   ODR06             WRITE AI,SXR BA,HA BITS
*                        V0 PRESERVED
         LI,R4    0                 LOWER BA,HA DISPL FLAG
MDR26    RES      0
         AND,V0   K30E              MASK SXR
         LW,L1    ZLNKF             RESTORE LINKAGE FLAG                COBOL42N
         STW,L1   LNKSF                                                 COBOL42N
         EXU      MDR28,R4          EXU ON BA/HA DISPL
*                        V0 = MT-,2 OR AWM,V2
MDR265   RES      0                                                     COBOL42N
         B        NDR10-1           WRITE MT-,2 OR AWM,V2 RFLD/0,SXR
* BA,HA DISPL = 2
MDR27    RES      0
         BAL,L1   PIA06             WRITE
         LI,V2    X'200'            ****     LOAD REG TO FORCE +
         LAB,V0   MDR265,CAWM+CRV2        WRITE AWM,V2 RFLD             COBOL42N
* RFLD = NCU - BA,HA DISPL
MDR28    RES      0
         AI,V0    CMTB+X'20'        = 0
         LI,V0    CMTH+X'20'        = 1
         B        MDR27             = 2
         LI,V0    CMTW+X'20'        = 3
*
* RFLD = AN/ANE
MDR30    RES      0
         STW,L0   MDRLNK            SAVE LINK REGISTER
         BAL,L1   ODR00             CHECK,ALIGN DECA, ADJUST DSIZS
*                        D0 = ADJUSTED DSIZ                             45
         LH,V1    3,R5              LOAD DSIZR
         MTH,DSL  JSAVD             RAISE SAVE DECA FLAG
         CI,R7    2                 CHECK RFLD CLASS                    46
         BLE      MDR10             RFLD = AN/ANJR
* RFLD = ANE/ANEJR
         BAZ      MDR31             RFLD ANEJR
* RFLD = ANE                                                             7
         LCW,D0   D0                DSIZS = -DSIZS                       8
         B        MDR32
* RFLD = ANEJR
MDR31    RES      0
         CW,D0    V1                COMPARE DSIZS,DSIZR
         BLE      MDR32             DSIZS </= DSIZR, USE DSIZS
* DSIZS > DSIZR
         LW,D0    V1                DSIZS = DSIZR
MDR32    RES      0
         STW,D0   JDSIZR            SAVE UNPK DSIZS
         BAL,L0   NDR31             WRITE ADCON BSIZR,BA(RFLD)
*                                   ****  LW/AW,RO ADCON
*                                   WRITE ADCON BSIZR,BA(ANE FLD)
         BAL,L0   NDR40             WRITE LI,RE BA(MASK)
*                                   ****  MBS,RE 0
         MTH,-DSL JSAVD             LOWER SAVE DECA FLAG
         BAL,L1   ODR34             CHECK DSIZS,R, SET -BSIZR            1
*                        R1 = EGRPCNT(J)
*                        R5 = EMDLOC(I)
*                        V1 = DSIZR(ADJUSTED)
*                        D0 = 0 - NO SFLD TRUNCATION
*                           > 0 - LEFT TRUNCATION OF SFLD
*                           < 0 - RIGHT TRUNCATION OF SFLD
*                        D1 = -BSIZR(ADJUSTED)
* **                     RO = BA(RFLD)+BSIZR
         CI,R1    1                 CHECK EGRPCNT(J)
         BL       *MDRLNK           < 1, NO XGRPS                        3
* J > 0                                                                  4
         LAW,V1   JDSIZR            LOAD UNPK DSIZS                      5
         BAL,L1   ODR16             WRITE UNPK,DSIZR/2+1 UNPKA+1
*                        D3 = UNPKA+1 BASE,DISPL
         LW,D0    JPSIZ             LOAD,CHECK PSIZ
         BL       MDR34             RIGHT PAD, ZONING UNNECESSARY.      22
* NO PAD/LEFT PAD ONLY - ZONING REQUIRED                                23
*                        V0 = UNPK,L                                    24
         BAL,L0   NDR06             SET ZONE OP, ADJUST DISPL
*                        V0 = STS,V2                                    26
         BAL,L1   PID11             WRITE STS,V2 UNPKA(+OFFSET)         27
         LW,D3    KUNPK4            LOAD UNPKA+1 BASE DISPL             27
MDR34    RES      0                                                     39
         LW,V1    JDSIZR            LOAD,CHECK UNPK DSIZS               40
         CI,V1    1                                                     41
         BANZ     MDR35             ODD DSIZS                           42
* EVEN DSIZR
         AI,D3    1                 UNPKA+1 DISPL = UNPKA+1 DISPL+1
MDR35    RES      0                                                     50
         BAL,L0   NDR38             MOVE TO EDIT GRPS                   51
         B        *MDRLNK                                               52
*
* SFLD = NC
* RFLD = INDEX/BIN
MDR40    RES      0
         LH,R7    0,R2              LOAD,MASK RFLD CLASS
         AND,R7   K30F                                                  3
MDR41    RES      0
         BAL,L1   MDR91             SAVE REGISTERS, SET PARAMETERS
MDR42    RES      0
         STW,L0   MDRLNK            SAVE LINK REGISTER
* **                     RB ASSUMED TO BE AVAILABLE
         LI,V0    CLI+CP1+CIBC      LOAD LI,P1 RB,-
MDR44    RES      0
         LW,D3    JDECP             LOAD DECPS
         BAL,L1   PIA22             WRITE LI,P1 RB,DECPS
         LW,V0    KCVTD-X'C',R7     LOAD C:C-D NAME
         BAL,L1   PIX02+1           WRITE BAL,L1 C:C-D
         EXU      MDR48-X'C',R7     EXECUTE ON RFLD CLASS
         B        MDR65             WRITE STW,RB/RFL RFLD
*
MDR48    RES      0
         LI,V1    CRB               INDEX
         LI,V1    CRB               BIN
         LI,V1    CRFL              FLS
         B        MDR54             FLL
*
* RFLD = FLP
MDR50    RES      0
         LH,R7    0,R2              LOAD,MASK RFLD CLASS
         AND,R7   K30F                                                  3
MDR51    RES      0
         BAL,L1   MDR91             SAVE REGISTERS, SET PARAMETERS
MDR52    RES      0
         STW,L0   MDRLNK            SAVE LINK REGISTER
         LI,V0    CLI+CP1+CIFC      LOAD LI,P1 RFL,-
         B        MDR44             WRITE LI,P1 RFL,DECPS
*                                   ****  BAL,L1 C:CDE/F
* RFLD = FLL
MDR54    RES      0
         LI,V0    CRFL              SREG
         B        MDR88+2           WRITE STD,RFL RFLD
*
* SFLD = INDEX/BIN
* RFLD = NC/ND/NE
MDR60    RES      0
         LH,R7    0,R2              LOAD,MASK RFLD CLASS
         AND,R7   K30F                                                  3
         BAL,L1   MDR91             SAVE REGISTERS, SET PARAMETERS
MDR62    RES      0
         STW,L0   MDRLNK            SAVE LINK REGISTER
*                        R6 = SFLD CLASS
*                        R7 = RFLD CLASS
*                        V0 = SREG
         LI,D0    10                DSIZS = 10
         AH,D0    4,R5              DSIZS = DSIZS+DECPR
MDR63    RES      0
         LH,D3    4,R5              LOAD DECPR
         XW,R7    R6                EXCHANGE RFLD,SFLD CLASS
         BAL,L0   NRR16+2           WRITE LI,P1  SREG-4,DECPR
         XW,R7    R6                RESTORE RFLD,SFLD CLASS
*                                   ****  BAL,L1 C:C-D
         LH,D3    4,R5              LOAD DECPS
         B        MDR04             STORE NC/ND
*
* RFLD = INDEX/BIN
*                        V0 = SREG
MDR64    RES      0
         BAL,L1   MDR91             SAVE REGISTERS, SET PARAMETERS
         STW,L0   MDRLNK            SAVE LINK REGISTER
         LW,V1    V0                SAVE SREG
MDR65    RES      0
         BAL,L1   SSB01             CHECK SUBSCRIPTS
*                        V0 = SXR/0
*                        V1 = SREG
*                        D3 = RFLD BASE,DISPL
         AW,V0    V1                FORM STW,SREG  -(,SXR)
         AI,V0    CSTW
         MTW,2    VBIDX
         B        MDR90             WRITE STW,SREG WA(RFLD),(SXR)
* RFLD = FLS/FLL
MDR66    RES      0
MDR68    RES      0
         BAL,L1   MDR91             SAVE REGISTERS, SET PARAMETERS
         STW,L0   MDRLNK            SAVE LINK REGISTER
         LW,D1    V0                SET SREG
         LBAL,L0  NRR42,CRFL        CONVERT BIN TO FLP
* ** USE STANDARD FLP REGISTER ***
         LI,V1    CRFL              SREG = RFL
         CI,R7    X'F'              CHECK RFLD CLASS
         BNE      MDR65             RFLD = FLS
         B        MDR89             RFLD = FLL
*
* SFLD = FLS/FLL
* RFLD = NC/ND/NE
MDR70    RES      0
MDR80    RES      0
         LH,R7    0,R2              LOAD,MASK RFLD CLASS
         AND,R7   K30F                                                  3
         BAL,L1   MDR91             SAVE REGISTERS, SET PARAMETERS
MDR72    RES      0
MDR82    RES      0
         STW,L0   MDRLNK            SAVE LINK REGISTER
         LI,D0    31                DSIZS = STANDARD FLP
         B        MDR63             CONVERT TO NC
* SFLD = FLS
* RFLD = INDEX/BIN
MDR74    RES      0
         BAL,L1   MDR91             SAVE REGISTERS, SET PARAMETERS
         STW,L0   MDRLNK            SAVE LINK REGISTER
         LW,D1    V0                SET SREG
         LBAL,L0  NRR62,CRB         CONVERT FLS TO BIN
         LAB,V1   MDR65,CRB         WRITE STW,RB RFLD
* RFLD = FLL
MDR78    RES      0
         BAL,L1   MDR91             SAVE REGISTERS, SET PARAMETERS
         LW,D1    V0                SET SREG
         LBAL     ORR06,CRFL        WRITE LW,RFL SREG
         BAL,L1   ORR03             WRITE LI,RFL+1 0
         LAB,V0   MDR88+1,CRFL      WRITE STD,RFL RFLD
* SFLD = FLL
* RFLD = INDEX/BIN
MDR84    RES      0
         BAL,L1   MDR91             SAVE REGISTERS, SET PARAMETERS
         STW,L0   MDRLNK            SAVE LINK REGISTER
         LW,D1    V0                SET SREG
         LBAL,L0  NRR82,CRB         CONVERT FLL TO BIN
         LAB,V1   MDR65,CRB         WRITE STW,RB RFLD
* RFLD = FLL
MDR88    RES      0
         BAL,L1   MDR91             SAVE REGISTERS, SET PARAMETERS
         STW,L0   MDRLNK            SAVE LINK REGISTER
         LW,V1    V0                SAVE SREG
MDR89    RES      0
         BAL,L1   SSB01             CHECK SUBSCRIPTS
*                        V0 = SXR/0
*                        V1 = SREG
*                        D3 = RFLD BASE,DISPL
         AW,V0    V1                FORM STD,SREG  -(,SXR)
         AI,V0    CSTD
         MTW,3    VBIDX
MDR90    BAL,L1   RFLDV             RESOLVE VAR REC
         MTW,0    LNKSF
         BNEZ     MDR92             IN LINKAGE SECTION
         BAL,L1   PID11             WRITE STD,SREG WA(RFLD)(,SXR)
         B        *MDRLNK           RETURN
MDR92    LI,D3    0
         BAL,L1   PIA22             *** WRITE LW/LD 0,SXR
         B        *MDRLNK           RETURN
*
* SPECIAL DECA STORE
* **                     DECA ALIGNED
MDS00    RES      0
         LH,R7    0,R2              LOAD MASK RFLD CLASS
         AND,R7   K30F
         LH,V1    3,R5              LOAD DSIZR
         B        MDS01+2
MDS01    RES      0
         LW,R7    JRFLD             LOAD RFLD CLASS
         LW,V1    JDSIZ             LOAD DSIZ(=DSIZS)
         BAL,L1   MDR91             SAVE REGISTERS, SET PARAMETERS
* **                     DSIZR=DSIZS
MDS02    RES      0
         STW,L0   MDRLNK            SAVE LINK REGISTER
         LW,D3    JSFLD             LOAD RFLD BASE,DISPL
         LW,V0    JSFLDS            LOAD RFLD SXR
         CI,V0    X'F0'             CHECK RSXR
         BAZ      MDS12             = 0, DIRECT DST/UNPK,- RFLD(,SXR)
* RSXR NOT= 0
         AI,V0    X'10'             SET RSXR ODD
         BGZ      MDR06             > 0, NOT SUBSCRIPTED
* SUBSCRIPTED                                                            1
         BAL,L1   PIA06             WRITE                                2
         LW,RO    RE                ****     SUBSCRIPT VALUE TO RO       3
         LI,L1    0
         STW,L1   RFLDF
         LB,R4    D3                SAVE BASE NO.                        4
         SW,D3    V1                DISPL=DISPL-DSIZS
         CB,R4    D3                CHECK BASE NO.                       6
         BE       MDR06             =. DISPL ADJUSTED
* DISPL NOT PROPERLY ADJUSTED                                            8
         AW,D3    V1                RESTORE DISPL
         LCW,D1   V1                LOAD-DSIZS
         AI,V0    CAI+X'F'          FORM AI,RO -                        11
         BAL,L1   PIA02             WRITE AI,RO-MBSCNT                  12
         AI,V0    -CAI-X'F'          RESTORE RSXR
         B        MDR06
* DIRECT DST/UNPK,- RFLD(,SXR)
MDS12    RES      0
         CI,R7    8                 CHECK RFLD CLASS
         BANZ     MDR22+2           RFLD = NC
         B        MDR08+2           RFLD = ND
*
* CHECK,ALIGN DECA  - ADJUST DSIZS
*                        D0 = DSIZS
*                        V1 = DECPS
*                        D2,D3 VOLATILE
NDR00    RES      0
         CH,V1    4,R5              COMPARE DECPS,DECPR
         BGE      *L0               DECPS >/= DECPR
* DECPS < DECPR
         BAL,L1   ODR00             ALIGN DECA, ADJU0T D0IZ0
         LW,V1    JDECP             LOAD ADJUSTED DECPS
*                        V1 = ADJUSTED DECPS
*                        D0 = ADJUSTED DSIZS
* **                     DECA VALUE ALIGNED
         B        *L0
*
* SET ZONE OP, ADJUST SXR
*                        V0 = -,L  -(,SXR)
*                        D3 = BASE,DISPL/OFFSET
NDR06    RES      0
         AI,V0    -X'10'            L = L-1
         LI,D0    X'F0'             MASK,POSITION (L-1)*2(=BSIZ-1)
         AND,D0   V0
         SLS,D0   -3
         AND,D3   K301S             MASK BA,HA BITS
         AW,D3    D0                RFLD DISPL = RFLD DISPL+BSIZ-1
         AND,V0   K30E              MASK,CHECK SXR
         BEZ      NDR07             = 0, NOT SUBSCRIPTED
* SUBSCRIPTED
         AI,V0    CLB+CRV2          FORM LB,V2 -,SXR
         STW,D0   DSIZR%                                                COBOL42N
         AND,D0   K303              MASK,CHECK HA BIT
         BEZ      *L0               = 0, WA ALIGNED
* HA BIT NOT= 0.
         AI,D3    -2                RESET HA BIT
         LI,R4    2                 LOAD HA BIT
         BAL,L1   ODR06             WRITE AI,SXR BA,HA BITS
*                        V0 PRESERVED
         B        *L0               RETURN
* *** DSIZR ODD - EITHER WA ALIGNED/HA BIT POSSIBLE ***
NDR07    RES      0
         LI,V0    CSTS+CRL1         LOAD STS,L1
         AND,D0   K303              MASK,CHECK HA,BA BITS
         BEZ      NDR08             = 0, WA ALIGNED
         BAL,L1   PIA06             WRITE
         LI,L1    X'F000'           ****     LOAD STS MASK
         B        *L0               RETURN
NDR08    RES      0
         BAL,L1   PRG06             WRITE
         LW,L1    DGZZ0             ****  LW,L1 =X'F000000' STS MASK
         B        *L0               RETURN
*
* ZONE LAST DIGIT                                                       90
*                        V0 = STS,L1/LB,V2 -(,SXR)
*                        D3 = BASE,DISPL                                92
NDR09    RES      0                                                     93
         BAL,L1   RFLDV             RESOLVE VAR REC
         BAL,L1   NDR10
         CI,V0    X'F'              CHECK SXR
         BAZ      *L0               = 0, NOT SUBSCRIPTED STS,L1 WRITEN
         BAL,L1   PRG06             WRITE
         OR,V2    DGZZ3             ****     ZONE DIGIT
         AI,V0    CSTB-CLB          FORM STB,V2 -,SXR
         LW,L1    L0                RETURN ADDR
NDR10    MTW,0    LNKSF
         BEZ      PID12             WRITE STS/STB/LB,LB/V2 RFLD(,SXR)
         LW,D3    DSIZR%                                                COBOL42N
         SLS,D3   -2                TO WORD DISP                        COBOL42N
         B        PIA22             WRITE STS/STB/LB,LB/V2 0,SXR
*
* ADCON(=BSIZR,BA(RFLD)), LW/AW,RO ADCON
*                        V0 = RO(,SXR(=RO))
*                        V1 = BSIZR
*                        D3 = RFLD BASE,DISPL
         AI,V1    -1                BSIZR = BSIZR-1                     13
NDR12    RES      0
         LI,D2    0                 SET BA ADDR, RES.(=0)
         STB,V1   D2                BSIZR TO CONSTANT PORTION
         MTW,0    LNKSF
         BNEZ     NDR14             IN LINKAGE SECTION
         LBAL     PDD04,DADD,D0     WRITE ADCON BSIZR,BA(RFLD)
         AI,V0    CLW               FORM LW,RO
         BGZ      NDR13             NOT SUBSCRIPTED
* SUBSCRIPTED
         AI,V0    CAW-CLW           FORM AW,RO(=SXR)
NDR13    RES      0
*                        D1 = BA(ADCON)
         BAL,L1   PRA01             WRITE LW/AW,RO WA(ADCON)
         B        *L0               RETURN
NDR14    RES      0
         LBAL     PDD04,DADB,D0     WRITE ADCON
         AI,V0    COR               FORM OR,SXR ADCON
         B        NDR13
* UNPACK,MBS
*                        V1 = BSIZR
         AI,V1    1                 BSIZR = BSIZR+1                     16
NDR16    RES      0
         BAL,L1   ODR16             WRITE UNPK,BSIZR/2+1 UNPKA+1
*                        R4 = BA(D1)+2
*                        D1 = DREF CLNG,CNTL
*                        D3 = UNPKA+1 BASE,DISPL
         AI,D3    1                 DISPL = DISPL+1
* *** ENTRY FROM MDR14 *************
         BAL,L1   PIY32             WRITE
         LI,RE    0                 WRITE LI,RE  BA(UNPKA+1) +1
         MTW,0    RFLDF
         BGEZ     NDR17             NO VAR ADDR
         LI,V0    X'A'
         BAL,L1   RFLDV
         B        NDR171
NDR17    MTW,1    LITF
         BAL,L1   VDR01
         MTW,-1   LITF
NDR171   RES      0
* **                     RO = BSIZR,BA(RFLD)
         BAL,L1   PIA06             WRITE
         MBS,RE   0                 ****  MBS,RE  0
         B        *L0               RETURN
* **                     RE = BA(LAST UNPK DIGIT)                       20
* **                     RO = BA(LAST RFLD DIGIT)                       21
NDR18    RES      0
         BAL,L1   PIA06             WRITE                               22
         LB,V2    0,RE              ****     LOAD LAST UNPK DIGIT       23
         BAL,L1   PRG06             WRITE                               24
         OR,V2    DGZZ3             ****  OR,V2 C'---0'  FORCE ZONE     25
         BAL,L1   PIA06             WRITE                               26
         STB,V2   0,RO              **** STORE ZONED LAST DIGIT         27
         B        *L0               RETURN
*                                                                       06
* LOAD L,SET RPTCNT                                                     07
*                        V1 = BSIZ/PSIZ                                 08
NDR30    RES      0
         LI,V0    CLI+CRV2          LOAD LI,V2                          10
         BAL,L1   ODR32             OBTAIN L,RPTCNT                     11
*                        V0 = -,L                                       12
*                        V1 = RPTCNT,ORIGINAL V0(LOWER HALF)            13
         XW,V0    V1                EXCHANGE -,L AND RPTCNT             15
         LI,R1    2                 LOAD L                              16
         LB,D1    V1,R1                                                 17
         LW,R1    D0                SAVE DSIZS
         LAB,L1   PIA02,NDR33       WRITE (LI,V2) L
*
* CHECK SUBSCRIPTS,WRITE ADCON BSIZ,BA(DREF)
*                        V0 = SXR
*                        R2 = HA(CLOC)
NDR31    RES      0
         LI,V0    CRO               LOAD ODD REGISTER
         LH,V1    3,R2              LOAD BSIZ
         AND,V1   K2FFFF            MASK HALF-WORD
*                        V1 = BSIZR/PSIZ
*                        D0 = DSIZS - PRESERVED
NDR32    RES      0
         BAL,L1   SSS02-1           CHECK SUBSCRIPTS
         B        NDR36             SUBSCRIPTED, FORM AW(-LW),SXR
* *** ENTRY POINT FROM MBS26 *******
         MTW,0    LNKSF
         BEZ      NDR34             NOT LINKAGE SECTION
NDR37    AI,V0    COR-CLW           FORM OR,SXR ADCON
NDR34    BAL,L1   ODR32             SET L,RPTCNT
*                        V0 = -,L
*                        V1 = RPTCNT,SXR/0
         LW,R1    D0                SAVE DSIZS
         LI,L1    NDR35             RETURN POINT
         MTW,0    LNKSF
         BEZ      PDD00             WRITE ADCON BSIZR/PSIZR,BA(RFLD)
         LI,D2    0
         LAB,D0   PDD03,DADB        WRITE ADCON BSIZR/PSIZR,0
NDR35    XW,V0    V1                RESTORE SXR, SAVE BSIZR/PSIZ
         AI,V0    CLW               FORM LW/AW,SR
*  GET RID OF OVERFLOW BITS                                             COBOL42N
         AND,V0   L(X'FF00FFFF')                                        COBOL42N
*                        D1 = BA(ADCON)
         BAL,L1   PRA01             WRITE LW/AW,SXR ADCON
* LOAD RPTCNT,RESET BSIZR/PSIZ                                          24
*                        V0 = RPTCNT,-                                  25
*                        V1 = -,L                                       26
NDR33    RES      0                                                     09
         LW,D0    R1                RESTORE DSIZS
         LB,R1    V0                LOAD RPTCNT
         SH,V1    V0                READJUST BSIZR/PSIZ
         SLS,V1   -8                REPOSITION  BSIZR/PSIZ
         B        *L0               RETURN
NDR36    MTW,0    LNKSF
         BNEZ     NDR37             IN LINKAGE SECTION
         AI,V0    CAW-CLW           FORM AW,SXR ADCON
         B        NDR34
*                        R1 = RPTCNT                                    02
*                        V0 = LW/AW,RREG                                03
*                        V1 = BSIZR/PSIZ                                04
*                        D0 = DSIZS(PRESERVED)                          05
*                                                                       21
* MOVE TO ANE
*                        D0 = DSIZR(ADJUSTED)
*                        R1 = EGRPCNT(J)
*                        R5 = EMDLOC(I)
*                        V1 = DSIZR(ADJUSTED)
*                        D1 = -BSIZR(ADJUSTED)
* **                     RO = BA(RFLD)+BSIZR
NDR38    RES      0
         BAL,L1   PID16             WRITE
         LI,RE    0                 ****  LI,RE BA(UNPKA+1)(+1)
* ANE CHAR. MOVE
NDR39    RES      0
         LB,D1    5,R5              LOAD XCNT(I)
         LBAL     PIA02,CLI+CRV2    WRITE LI,R1 XCNT(I)
         BAL,L1   PIY31             WRITE
         STB,V2   RO                ****     MBS XCNT(I) TO RO
         BAL,L1   PIY31             WRITE
         MBS,RE   0                          MBS XCNT(I) DIGITS
         AI,R1    -1                J = J-1
         BLEZ     *L0               J = 0, E-O-ANE MOVE
         AI,R5    1                 I = I+1
         LB,D1    5,R5              LOAD ECNT(I)
         LBAL     PIY01,CAI+CRO     WRITE AI,RO ECNT(I)
         AI,R5    1                 I = I+1
         BDR,R1   NDR39             J = J-1, CONTINUE ANE MOVE
* ** NORMALLY NO FALL THRU SINCE I = ODD NO. - FORCED BY MDR32***
         B        *L0               SPECIAL RETURN
* ****** NOT USED ******************
* MOVE EDIT MASK
*                        R2 = HA(CLOC)
* **                     RO = BSIZR,BA(RFLD)
NDR40    RES      0
         LH,D3    4,R2              LOAD MASK DISPL
         AW,D3    K4BAS             FORM MASK BASE(=4),DISPL
         BAL,L1   PID16             WRITE
         LI,RE    0
         MTW,1    LITF
         BEZ      NDR41
         BAL,L1   VDR01
         MTW,-1   LITF
NDR41    RES      0
         BAL,L1   PIA26             WRITE
         MBS,RE   0                 ****     MOVE MASK TO EDITED FLD
         B        *L0
VDR00    MTW,0    NOVF
         BNEZ     VDR02
         BAL,L0   VPP30             RESOLVE VAR REC
VDR02    LI,L0    0
         STW,L0   VBIDX             RESET VBIDX
         STW,L0   NOVF
         B        VDR03
VDR01    STD,L0   VRSAV
         STW,V0   TMPV0
         MTW,0    LITF
         BNEZ     VDR05             LIT SFLD
         LI,V0    R4
         BAL,L0   VPP10             VAR REC ADDR
VDR05    LI,V0    R5
         BAL,L0   VPP00             VAR REC LNTH,ADDR
         LW,V0    TMPV0
VDR03    LD,L0    VRSAV
         B        *L1
RFLDV    STD,L0   VRSAV
         MTW,0    RFLDF
         BGEZ     VDR00             FOR MOVE
         BAL,L0   VPP50             RESOLVE VAR REC
         B        VDR03
*                        D0 PRESERVED
*
* CHECK,ALIGN DECA  - ADJUST DSIZS
*                        D0 = DSIZS
*                        V1 = DECPS
*                        D2,D3 VOLATILE
* **  DECA NOT SAVED IF ALIGNMENT NECESSARY ***
ODR00    RES      0
         SH,V1    4,R5              DECPS = DECPS-RFLD DECP(DECPR)
         BEZ      *L1               = 0, ALIGNED
ODR01    RES      0
         SW,D0    V1                DSIZS = DSIZS-(DECPS-DECPR)
         STW,D0   JDSIZ             DSIZS = DSIZS-(DECPS-DECPR)
         LCW,D3   V1                SHIFT CNT = -(DECPS-DECPR)
* *** +4 ENTRY FROM BCE06 **********
         AWM,D3   JDECP             DECPS = DECPS-(DECPS-DECPR)
         LAB,V0   PIA22,CDSA        WRITE DSA SHIFT CNT
*                        V1 = 0 - ALIGNED
*                           < 0 - DECPR > DECPS, LEFT SHIFT
*                           > 0 - DECPR < DECPS, RIGHT SHIFT
*                        D0 = ADJUSTED DSIZS
* **                     DECA VALUE ALIGNED
*
* CHECK DECA SAVE FLAG, SAVE
*                        L1 = LINK REGISTER
*                        D2,D3 VOLATILE
         LI,D3    DSL               LOAD SAVE LEVEL
*                        D3 = SAVE LEVEL
ODR02    RES      0
         CH,D3    JSAVD             CHECK DECA SAVE FLAG
         BGE      *L1               SAVE FLAG DOWN
* SAVE
         CW,D3    JSAVD             CHECK SAVED FLAG
         BANZ     *L1               UP. ALREADY SAVED
* SAVE DECA
         AWM,D3   JSAVD             RAISE SAVED FLAG
         LI,D2    CDST              LOAD DST,0
ODR03    RES      0
         SLS,D3   2                 SAVE LEVEL = SAVE LEVEL *4
         STH,D2   D3                STORE DL/DST,0
         AI,D3    6                 SAVE LEVEL*4+6 = TMP DISPL
         LAB,D2   PRA24+1,DART      WRITE DST/DL,0 TMP DISPL
* CHECK DECA RESTORE FLAG, RESTORE
         LI,D3    DSL               LOAD SAVE LEVEL
*                        D3 = SAVE LEVEL
ODR04    RES      0
         CW,D3    JSAVD             CHECK SAVED FLAG
         BAZ      *L1               DOWN. NOT SAVED
* SAVED
         LI,D2    CDL               LOAD DL,0
         STS,D2   JSAVD             LOWER SAVED FLAG
         B        ODR03
* ADJUST SXR FOR BA,HA BITS
*                        R4 = BA,HA BITS
*                        V0 = 0   0,SXR
*                        D0,D1 VOLATILE
ODR06    RES      0
         LI,D1    X'E'              MASK SXR
         AND,D1   V0
         AI,D1    CAI/8             FORM AI,SXR
         SCS,D1   -13               POSITION AI,SXR
         AW,D1    R4                LOAD BA,HA BITS
         LAB,D0   PRA04+1,DAIA      WRITE AI,SXR BA,HA BITS
* FORMAT,WRITE -,L 0,SXR
*                        V1 = OP,0 -,SXR
*                        D0 = BSIZS
ODR11    RES      0
         LI,V0    CUNPK+CIR1        LOAD UNPACK,0 0,1                   COBOL42N
         SLS,D0   3                 BSIZ = BSIZ/2+1
         AI,D0    X'10'
         AND,D0   K3F0
         AW,V0    D0                FORM OP,BSIZ/2+1 -,SXR
         STW,L1   TMPL1
         BAL,L1   RFLDV
         LW,L1    TMPL1
         LAB,D3   PIA22,0           WRITE OP,BSIZ/2+1 0,SXR
* UNPK INTO UNPKA+1
ODR16    RES      0
         MTW,1    NOVF
         LI,V0    0
         STW,V0   LNKSF             CLEAR LINKAGE FLAG
         LI,V0    CUNPK             LOAD UNPK,-
         LW,D3    KUNPK4            LOAD UNPKA+1 BASE,DISPL
         B        ORD12+1           WRITE UNPK,BSIZR/2+1 UNPKA+1
*
* OBTAIN MBS COUNT(L), REPEAT COUNT(RPTCNT)
*                        V1 = BSIZ
*                        V0 = SXR/0 - PRESERVED IN V1
*                        D2 VOLATILE
ODR32    RES      0
         XW,V1    V0                EXCHANGE SXR/0,DSIZR/PSIZ(=L)
         SLS,V0   8                 POSITION L
         LH,D2    V0                LOAD,SAVE,CHECK L-MOD(256,L)
         STH,D2   V1
         BEZ      *L1               = 0, L</= 255
* BSIZR/PSIZ > 255
         SLS,D2   8                 POSITION,STORE L-MOD(Z56,L))=RPTCNT)
         STH,D2   V1
         AW,V0    D2                L = L+ RPTCNT
         LH,D2    V0                CHECK RPTCNT
         CB,D2    V1
         BE       *L1               UNCHANGED NO CARRY
* CARRY
         AI,V0    X'100'            L = L+1
         STB,D2   V1                UPDATE RPTCNT
         B        *L1
*                        V1 = RPTCNT,SXR/0
*                        V0 = L
*
* CHECK DSIZS,R, SET -BSIZR FOR LEFT PAD(OR SKIP) ANE
*                        V1 = BSIZR
*                         D0 = DSIZS - RFLD = ANEJR
*                           = -DSIZS - RFLD = ANE
*                           = 0 - SFLD = FIGCON(OR ALL '1CHAR' ANLIT)
ODR34    RES      0
         LCW,D1   V1                LOAD -BSIZR
         LH,V1    3,R5              LOAD DSIZR
         AW,R5    R5                HA(CLOC)-1 TO BA
         LB,R1    5,R5              LOAD EDIT GRP CNT(EGRPCNT)
         AI,R5    1                 BA(CLOC)-2=BA(CLOC)-1
         LB,R4    5,R5              LOAD,CHECK XCNT(1)
         BNEZ     ODR35             XCNT(1)  NOT= 0
* XCNT(I) = 0
         AI,R5    1                 BA(CLOC) = BA(CLOC)+1
         LB,R4    5,R5              LOAD ECNT(1)
         AW,D1    R4                -BSIZR =-BSIZR+ECNT(1)
         AI,R5    1                 BA(CLOC) = BA(CLOC)+1
         AI,R1    -2                L=GRPCNT = EGRPCNT-2
ODR35    RES      0
         SW,D0    V1                PSIZ = DSIZS-DSIZR
         BGEZ     ODR39             >/= 0, NO PAD(OR SKIP)
* PSIZ < 0, DSIZR > DSIZS
* SKIP ANE EDIT GROUPS
*                        R1 = EGRPCNT
*                        R5 = BA(EDIT MASK DESC)-20 (=EMDLOC)
*                        V1 = DSIZR
*                        D0 = PSIZ(<0)
*                        D1 = -BSIZR
*                        V0 VOLATILE
         AW,V1    D0                DSIZR = DSIZR-PSIZ
         BEZ      ODR39             = 0, SFLD = FIGCON
* *** DSIZS ORIGINALLY = 0,...(SEE FIGCON TO ANE MOVE)
         BL       ODR40             < 0, SFLD NOT JUSTIFIED
* > 0, RFLD JUSTIFIED, DSIZR > BSIZR - LEFT PAD
         SW,D1    D0                -BSIZR = -(DSIZR-PSIZ)
ODR36    RES      0
         LB,V0    5,R5              LOAD XCNT(I)
         AW,D0    V0                PSIZ = PSIZ+XCNT(I)
         BGZ      ODR38             PSIZ > 0, E-O-SKIP.
         AI,R1    -2                EGRPCNT = EGRPCNT-2
         BEZ      *L1               RETURN - NO XGRPS
* EGRPCNT > 0
         AI,R5    1                 EMDLOC = EMDLOC+1
         LB,V0    5,R5              LOAD ECNT(I)
         AW,D1    V0                -BSIZR = -BSIZR+ECNT(I)
         AI,R5    1                 EMDLOC = EMDLOC+1
         B        ODR36
* DSIZS </= 0
ODR37    RES      0
         AW,D0    V0                XCNT(I) = PSIZ+XCNT(I)
         STB,D0   5,R4
         B        ODR38+1
* PSIZ < 0
ODR38    RES      0
         STB,D0   5,R5              ECNT(I) = PSIZ(=XCNT(I)+PSIZ)
         LI,D0    0                 CLEAR PSIZ
* **                     RO = BA(RFLD)+BSIZR
ODR39    RES      0
*                        D1 = -BSIZR(ADJUSTED)
         STW,D0   JPSIZ             SAVE PSIZ
         LAB,V0   PIA02,CAI+CRO+X'F'  WRITE AI,RO -BSIZR(ADJUSTED)
*                        R1 = UPDATED EGRPCNT
*                        R5 = UPDATED EMDLOC
*                        V1 = DSIZR(ADJUSTED)
*                           = 0 IF SFLD = FIGCON(BSIZS = 0 ON ENTRY)
*                        D0 = 0 - NO SFLD TRUNCATION
*                           > 0 - LEFT TRUNCATION OF SFLD
*                           < 0 - RIGHT TRUNCATION OF SFLD
*                           = -DSIZR IF V1 = 0(SFLD=FIGCON)
*                        D1 = -BSIZR
*
* SKIP ANE EDIT GROUPS - RIGHT PAD                                       1
*                        R5 = EMDLOC(I)                                  2
*                        D0 =  -BSIZS-DSIZR
*                        V1 =  DSIZR+(-BSIZS-DSIZR) = -BSIZS
* DSIZR < 0, RFLD NOT JUSTIFIED
*                        R1,R4,V0,V1,D0 VOLATILE                        29
ODR40    RES      0                                                      5
         SW,V1    D0                DSIZR = -BSIZ-(-BSIZS-DSIZR)
         AW,D0    V1                -BSIZR = (-BSIZS-DSIZR)+DSIZR
         AW,D0    V1                PSIZ = -BSIZS+DSIZR
         BLEZ     ODR39             </= 0, NO PAD(OR IGNORE)
* > 0, DSIZR > BSIZS - RIGHT PAD
         SW,V1    D0                DSIZR = DSIZR-PSIZ
         LW,D0    V1                PSIZ = DSIZR
         LI,R1    1                 INITIALIZE EGRPCNT(I)               15
         LW,R4    R5                LOAD I                              16
ODR41    RES      0                                                     17
         LB,V0    5,R4              LOAD XCNT(I)                        18
         SW,D0    V0                PSIZ = PSIZ+XCNT(I)
         BLEZ     ODR37             PSIZ </= 0, E-O-IGNORE
         AI,R1    2                 J = J+2                             21
         AI,R4    2                 I = I+2                             22
         B        ODR41
*                                                                       31
*
* RFLD CLASS = NE
*                        R6 VOLATILE
MDE00    RES      0
         BAL,L1   MDR91             SAVE REGISTERS, SET PARAMETERS
         LW,V1    JDECP             LOAD DECPS
         LW,D0    JDSIZ             LOAD DSIZS
MDE02    RES      0
         STW,L0   MDRLNK            SAVE LINK REGISTER
         BAL,L1   ODR00             CHECK,ALIGN DECA, ADJUST DSIZS
         MTH,+DSL JSAVD             RAISE SAVE DECA FLAG
         BAL,L0   NDR31             CHECK SUBSCRIPTS
*                                   WRITE ADCON BSIZR,BA(NE RFLD)
*                                   ****  LW/AW,RO ADCON
         MTH,-DSL JSAVD             LOWER SAVE DECA FLAG
         LH,R6    5,R5              LOAD EDIT CNTL(TE-TI)
         LH,V1    3,R5              LOAD DSIZR
         AW,R5    R5                HA(CLOC)-1 TO BA
*
         CI,R6    X'800'            CHECK FOR BWZ/*WZ
         BAZ      MDE04             NO.
         BAL,L0   NDE00             WRITE ZERO TEST, BWZ/*WZ
*   THE NEXT THREE INSTRUCTIONS RESTORE R6 (EDIT CONTROL)
         LW,R6    R2                   GET CLUSTER HW(ADDR)
         AI,R6    9                 INCR TO GET EDIT CONTROL
         LH,R6    0,R6
         BAL,L1   OII00             WRITE B INTL
MDE04    RES      0
         BAL,L1   ODE04             CHECK,CHANGE EDIT FLAGS
         B        MDE16             NO FLOATING +/-
* FLOATING +/-
         BAL,L0   NDE10             CHECK,LOAD '-'
         BAL,L1   PIL26             WRITE
         B        2                 ****  B %+2
         BAL,L1   ODE10             WRITE LI,RS C'+'/C' '
*                        V1 = DSIZR
MDE16    RES      0
         BAL,L0   NDR40             WRITE LI,RE BA(MASK)
*                                   ****  MBS,RE 0
         BAL,L1   ODE16             CHECK,ADJUST RO
         B        MDE20             NO LEADING +/-
*                                   **** AI,R6 -BSIZR(+TJ) WRITTEN
* LEADING +/-
*                        R1 = TJ
*                        D3 = -BSIZR+TJ
* **                     LEADING SIGN PRESET FOR +
         LI,V0    CAI+CRO+X'F'      LOAD AI,RO X'F----'
         SW,D3    R1                -BSIZR = (-BSIZR+TJ)-TJ
         AW,R1    D3                SAVE -BSIZR+TJ                        1
         BAL,L1   PIA22             WRITE AI,RO -BSIZR
         BAL,L0   NDE11             CHECK,LOAD '-'
         BAL,L1   PIY31             WRITE
         STB,RS   0,RO              ****     STORE LEADING SIGN
         LW,D3    R1                RESTORE -BSIZR+TJ                    2
MDE20    RES      0
         BAL,L0   NDE20             EDIT BYTE STRING
         B        MDE60             NO TRAILING SIGN,INSERTIONS
* TRAILING + AND/OR TRAILING -/DB/CR WITH TRAILING INSERTIONS
*                        D3 = %+ VALUE
         LBAL     PIL22,CBL         WRITE BLZ %+4/6
         BAL,L0   NDE50             INSERT TRAILING SIGN
MDE60    RES      0
         CI,R6    X'800'            CHECK BWZ/*WZ FLAG
         BAZ      *MDRLNK           DOWN. RETURN
* BWZ/*WZ
         BAL,L1   PPI11             WRITE INTL DEF
         B        *MDRLNK
* BWZ/*WZ
* **                     R0 = BSIZE,BA(RFLD)
* **                     R5 = BA(HA(CLOC)-1)
*                        L0 = LINKAGE REGISTER
*                        R6 = EDIT CNTL
NDE00    RES      0
         STW,L0   VRSAV
         LI,V0    R5
         BAL,L0   VPP00             RESOLVE VAR REC
         LI,L0    -1
         STW,L0   LITF              FOR NDR40
         LW,L0    VRSAV
         BAL,L1   PRG26             WRITE
         DC,1     DGDZ              ****  DC,1 =D'+0'
         BAL,L1   ODE02
         LBAL     PIL02,CBNE        WRITE BNEZ %+4/6/7
         BAL,L1   PIA06             WRITE
         LW,R1    RO                ****     BA(RFLD) TO R1(=R41)
NDE02    RES       0
         BAL,L1   PID16             WRITE
         MBS,0    0                 ****  MBS,0 BA(=' '/'*')
         CI,R6    2                 CHECK FOR '.' INSERTION
         BAZ      *L0               NO.
* '.' INSERTION
* **                     RO = BSIZR,BA(RFLD)'+SUBSCRIPTS)
         CI,R6    1                 CHECK FOR '.***---'
         BAZ      NDE04             YES.
* '****.***---'
         LB,D3    6,R5              LOAD '.' POSITION (TL)
         AI,D3    -1
         SH,D3     3,R2             TL = TL-1-BSIZR
         LBAL      PIA22,CAI+CRR1+X'F'  WRITE AI,R1  TL
NDE04    RES      0
         LI,D3    C'.'              LOAD '.'
         LW,V0    PDBP              CHECK SPECIAL NAME - '.' IS ','
         CI,V0    X'200'
         BAZ      NDE06             NO. USE '.'
         LI,D3    C','              USE ','
NDE06    RES      0
         LBAL      PIA22,CLI+CRV2   WRITE LI,V2 C'.'/C','
         BAL,L1   PIY33             WRITE
         STB,V2    0,R1             ****     INSERT  '.'/','
         B        *L0               RETURN
*
* CHECK,LOAD '-'
NDE10    RES      0
         CI,R6    X'800'            CHECK FOR BWZ/*WZ
         BANZ     NDE12             YES. CC SET
* NO BWZ/*WZ, CHECK DECA
NDE11    RES      0
         BAL,L1   PRG06             WRITE
         DC,1     DGDZ              ****  DC,1 =D'+0'
NDE12    RES      0
         BAL,L1   PIL06             WRITE
         BGEZ     3                 ****  BGEZ %+3
         LCW,D1   R1                LOAD - TJ
         BAL,L1   PIA06             WRITE
         LI,RS    C'-'              ****     LOAD SIGN
         B        *L0               RETURN
*
* EDIT BYTE STRING
*                        R2 = BA(CLOC)                                  11
* **                     R5 = BA(HA(CLOC)-1)
*                        D3 = -BSIZR+TJ(=-C)
NDE20    RES      0
         LI,R1    X'10'             CC4 = 1, FORCE SIGNIFICANCE
         CI,V1    1                 CHECK FOR ODD DSIZR
         BANZ     NDE22             YES.
* DSIZR EVEN
         AI,R1    X'40'             NO. EVEN, CC1 = 1
*                        V1 = (BSIZR-1)*2
NDE22    RES      0
         SLS,V1   -1                (BSIZR-1)*2 = BSIZR-1
         LI,D2    CBD3+3            LOAD BA(D3)+3
         SW,D2    V1                BA(SFLD) = BA(D3)+3-(BSIZR-1)
         LI,V0    X'4000'           FILL CHAR. = SPACE
         CI,R6    X'500'            CHECK SUPRESSION FLAGS
         BAZ      NDE24             DOWN. NO Z/* REPLACEMENT
* Z/* REPLACEMENT
         AI,R1    -X'10'            CC4 = 0, NO SIGNIFICANCE
         CI,R6    X'100'            CHECK FOR Z REPLACEMENT
         BANZ     NDE24             YES.
* * REPLACEMENT
         LI,V0    X'5C00'           FILL CHAR. = *
NDE24    RES      0
         BAL,L1   PDB02             WRITE ADCON FILL CHAR. BA(SFLD)
         LBAL     PRA01,CLW+CRE     WRITE LW,RE ADCON
*                        D3 = -BSIZR+TJ(=-C)
         AI,R5    3                 BA(CLOC)-2 = BA(CLOC)+1
         LB,V1    5,R5              LOAD,CHECK TRAILING INS.(TK)
         BEZ      NDE26             TK = 0
* TK NOT= 0, TRAILING INSERTIONS
         CI,R6    X'23000'          CHECK FOR TRAILING SIGN
         BAZ      NDE26             NO.
* TRAILING SIGN
         AI,R6    4                 RAISE TRAILING SIGN FLAG(TSIGN)
*                        V1 = TK(=EBS1)                                  5
NDE26    RES      0
         AI,R5    2                 BA(CLOC)+1 = BA(CLOC)+3
         CI,R6    X'5E0'            CHECK FOR FLOATING/SUPPRESSION
         BAZ      NDE30             NO.
* FLOATING/SUPPRESSION
         LB,D1    5,R5              LOAD,CHECK NO. OF INSERTIONS(TM)
         BEZ      NDE28             TM = 0, NO INSERTIONS.
* TM NOT= 0, INSERTIONS PRECEDING LEADING 9/V/.
* **                     RO = BA(RFLD)+TJ
         LB,D0    5,R2              LOAD TJ
         SW,D1    D0                TM = TM-TJ(=EBS2)
         AW,V1    D1                -EBS1 = -EBS1+EBS2                   1
         LW,D2    D1                SAVE EBS2                            2
         LBAL     PIA02,CLI+CRR1    WRITE LI,R1  TM-TJ
         AI,R6    8                 RAISE EBS2 FLAG
NDE28    RES      0
         CI,R6    X'80'             CHECK FOR FLOATING %
         BAZ      NDE30             NO.
* FLOATING %
         LB,D1    PDBP+1            LOAD CURRENCY SIGN                   8
         LBAL     PIA02,CLI+CRC     WRITE LI,RC CURRENCY SIGN            9
* GENERATE RO ADJUSTMENT ADCON                                          10
*                        R2 = BA(CLOC)                                  0002 2
*                        R5 = BA(CLOC)+3
*                        V1 = -EBS1(=TK+EBS2)                           11
*                        D2 = EBS2(=TM-TJ)                              12
*                        D3 = -BSIZR+TJ
* *** NO LEADING +/-     EBS1-1/EBS2-1,-BSIZ+TJ                         14
* *** LEADING +/-        EBS1/EBS2,TJ                                   15
NDE30    RES      0
         AW,V1    D3                -EBS1 = -EBS1+(-BSIZ+TJ)            17
         CI,R6    8                 CHECK EBS2 FLAG                     18
         BANZ     NDE31             UP. EBS2 SET.                       19
* NO EBS2                                                               19
         LCW,D2   V1                -EBS1 = EBS1                        20
NDE31    RES      0                                                     21
         SCS,D2   -8                POSITION EBS1/EBS2                  27
         CI,R6    X'14000'          CHECK LEADING +/- FLAGS             22
         BAZ      NDE32             DOWN.                               23
* LEADING +/-                                                           24
         LB,D3    5,R2              LOAD TJ                             25
NDE32    RES      0
         AW,D2    D3                FORM EBS1/EBS2,RO ADJ.              28
         LBAL     PDD04,DADB,D0     WRITE AD CON EBS1/EBS2,RO ADJ.      29
         LBAL     PRA01,CAW+CRO     WRITE AW,RO ADCON                   30
         CI,R6    8                 CHECK EBS2 FLAG                     31
         BAZ      NDE33             DOWN.                               32
* EBS2                                                                  33
         BAL,L1   PIA06             WRITE                               34
         AW,R1    RO                *--*     R1 = BA(9/V/'.')           35
NDE33    RES      0                                                     36
         LW,D1    R1                LOAD CC SETTING
         LBAL     PIA02,CLCI        WRITE LCI CC4=1/0,CC1=1/0           38
         BAL,L1   PIY31             WRITE
         EBS,RE   0                 ****     EDIT
*
         CI,R6    X'E0'             CHECK FLOATING SIGN FLAG
         BAZ      NDE36             DOWN. NO FLOATING.
* FLOATING SIGN
* **                     R1 = BA(SIGNIFICANCE START)+1
         BAL,L1   PIL26             WRITE
         BDR,R1   1                 ****  BDR,R1 %+1  SS+1 = SS
         LI,V0    CSTB+CRS+CIR1     LOAD STB,RS -,R1
         CI,R6    X'80'             CHECK FLOATING % FLAG
         BAZ      NDE34             DOWN. FLOATING +/-.
* FLOATING %
         LI,V0    CSTB+CRC+CIR1     LOAD STB,RC -,R1
NDE34    RES      0
         LBAL     PIA22,0,D3        WRITE STB,RS/RC 0,R1
NDE36    RES      0
         CI,R6    8                 CHECK EBS2 FLAG
         BAZ      NDE40             DOWN. EBS COMPLETE
* EBS  INCOMPLETE
*                        V1 = EBS2
         LCW,D3   V1                LOAD EBS2                           41
         LBAL     PIA22,CLI+CRR1+8  WRITE LI,R1 X'800(EBS2)'
* **                     CC4 SET - SIGNIFICANCE FORCED
* *** LI  DOES NOT ALTER CC 2(OR 1)***
         BAL,L1   PIY33             WRITE
         STB,R1   RO                ****     EBS2 (C) TO RO
*                        D1 = EBS,RE  0
         WPOF     ,CBD0+2           WRITE EBS,RE 0
NDE40    RES      0
         CI,R6    X'20004'          CHECK TRAILING SIGN FLAGS
         BAZ      *L0               DOWN. RETURN
* TRAILING + AND/OR TRAILING SIGN PRECEDED BY SIMPLE INSERTIONS
         AI,L0    1                 SET RETURN LINK
         LI,D3    4                 %+ VALUE = 4
         CI,R6    4                 CHECK TSIGN FLAG
         BAZ      NDE44             DOWN. TRAILING + ONLY
* TRAILING SIGN PRECEDED BY SIMPLE INSERTIONS
         AI,R5    2                 BA(CLOC)+3 = BA(CLOC)+5
         LB,D1    4,R5              LOAD TK
         LI,V0    CAI+CRO           LOAD AI,RO
         CI,R6    X'1000'           CHECK CR/DB FLAG
         BAZ      NDE46             DOWN. TRAILING +/-.
* CR/DB
         LI,D3    6                 %+ VALUE =6                         42
         BDR,D1   NDE46             TK = TK-1                           43
* TRAILING + ONLY
NDE44    RES      0
         LI,V0    CAI+CRO+X'10'     LOAD AI,RO+1                        45
*                        D1 = -,0/TM                                    46
NDE46    RES      0
         STH,V0   D1                FORM AI,RO RO ADJ.+1                48
         BDR,D1   *L0               RO ADJ.+1 = RO ADJ.                 49
*
* LOAD;STORE TRAILING +/' '
NDE50    RES      0
         LI,D3    C' '              LOAD SPACE
         CI,R6    X'20000'          CHECK TRAILING + FLAG
         BAZ      NDE52             DOWN. TRAILING -/CR/DB
* TRAILING +
         LI,D3    C'+'              LOAD +
NDE52    RES      0
         LBAL     PIA22,CLI+CRR1    WRITE LI,R1 C' '/C'+'
*                        D1 = AI,RO TK/-1
         LW,D3    D1                LOAD AI,RO TK/-1
         BAL,L1   WRPOF             WRITE AI,RO TK/-1
         BAL,L1   PIY33             WRITE
         STB,R1   0,RO              ****     STORE ' '/+
         CI,R6    X'1000'           CHECK CR/DB FLAG
         BAZ      *L0               DOWN. RETURN
* CR/DB
         BAL,L1   PIY33             WRITE
         AI,RO    1                 ****     BA(RFLD) = BA(RFLD)+1
         BAL,L1   PIY33             WRITE
         STB,R1   0,RO              ****     STORE 2ND C' '
         B        *L0               RETURN
*
* OBTAIN BNEZ %+ VALUE
* CHECK BWZ/*WZ, OBTAIN BNEZ %+ VALUE
ODE02    RES      0
         LW,D3    K4SPAC            LOAD SPACE BASE,DISPL
         LI,D1    4                 %+ VALUE = 4
         CI,R6     X'400'           CHECK * FLAG
         BAZ      *L1               DOWN. BWZ
* *WZ
         AI,R6    X'FFC01'          MOVE  *WZ FLAG
         AI,D3    DGAST-DGSPC       SET ASTERISK BASE,DISPL
         LB,V0    6,R5              LOAD,CHECK FOR '.'(TL)
         BEZ      *L1               NO.
* '.' INSERTION
         AI,D1    3                 %+ VALUE = %+ VALUE+3
         AI,R6    2                 RAISE '.' INSERTION FLAG
         B        *L1               RETURN
************************************
         BDR,V0  *L1                '.' POSITION = '.' POSITION-1
* '. ***.....'
         AI,R6    -1                LOWER '***.***---' FLAG
         BDR,D1   *L1               %+ VALUE = %+ VALUE-1
*
* CHECK,CHANGE EDIT FLAGS
ODE04    RES      0
         CI,R6    X'C000'           CHECK FOR LEADING SIGN
         BAZ      ODE05             NO.
* LEADING SIGN
         AI,R6    X'C000'           CHANGE LEADING SIGN FLAGS
ODE05    RES      0
         CI,R6    X'1000'           CHECK FOR TRAILING +/-
         BAZ      ODE06             NO.
* TRAILING +/CR/DB
         CI,R6    X'2000'           CHECK FOR TRAILING +
         BANZ     ODE06             NO.
* TRAILING +
         AI,R6    X'1F000'          CHANGE TRAILING + FLAG
ODE06    RES      0
         CI,R6    X'C0'             CHECK FOR FLOATING SIGN
         BAZ      *L1               NO.
* FLOATING +/-/%/
         AI,R6    -X'40'            CHANGE FLOATING SIGN FLAG
         CI,R6    X'80'             CHECK FOR FLOATING %
         BANZ     *L1               YES. FLOATING %.
* FLOATING +/-
         AI,R6    +X'20'            SET FLOATING +/- FLAGS
         AI,L1    1                 SET FLOATING +/-RETURN
         B        *L1               RETURN
*
*
* LOAD POSITIVE SIGN FOR FLOATING +/- OR TRAILING +
ODE10    RES      0
         LI,D1    C'+'              LOAD C'+'
         CI,R6    X'2040'           CHECK FOR FLOATING -
         BAZ      ODE12             NO. FLOATING/TRAILING +
* FLOATING -
         LI,D1    C' '              LOAD C ' '
ODE12    RES      0
         LAB,V0   PIA02,CLI+CRS     WRITE LI,RS C'+'/C' '
*
* ADJUST RO FOR EBS
ODE16    RES      0
         LCH,D3   3,R2              LOAD -BSIZR
         AW,R2    R2                HA(CLOC) TO BA
         LB,R1    5,R2              LOAD NO. LEADING INSERTIONS(TJ)
         AW,D3    R1                -BSIZR = -BSIZR+TJ
         CI,R6    X'14000'          CHECK FOR LEADING +/-
         BAZ      *L1               NO. RETURN
         AI,L1    1                 SET LEADING +/- RETURN
         B        *L1               RETURN
*
* SAVE REGISTERS,
LDR91    RES      0
         LCI      10                SAVE REGISTERS
         STM,R6   LDRSAV
         BAL,L0   LRA92             SET PARAMETERS
         LCI      10                RESTORE REGISTERS
         LM,R6    LDRSAV
         B        *L0               RETURN                              00922
MDR91    RES      0
         LCI      10                SAVE REGISTERS
         STM,R6   MDRSAV
         BAL,L0   LRA92             SET PARAMETERS
         LCI      10                RESTORE REGISTERS
         LM,R6    MDRSAV
         B        *L0               RETURN                              20922
NDR91    RES      0
         LCI      10                SAVE REGISTERS
         STM,R6   NDRSAV
         BAL,L0   LRA92             SET PARAMETERS
         LCI      10                RESTORE REGISTERS
         LM,R6    NDRSAV
         B        *L0               RETURN                              10922
         BOUND    8
VRSAV    RES      2
TMPV0    RES      1
TMPL1    RES      1
DSIZR%   DATA     0                                                     COBOL42N
ZLNKF    DATA     0
*
JSAVD    EQU      JDECP+14          SAVE DECA FLAG
JSFLD    EQU      JDSIZ+4
JSFLDS   EQU      JDSIZ+5
JRFLD    EQU      JDSIZ+18          RFLD CLASS
JUNSD    EQU      JDSIZ+21          UNSIGNED FLAG
JDSIZR   EQU      JDSIZ+22          DSIZR
JPSIZ    EQU      JDSIZ+23          ANE PSIZ
         REF      KBKON,K4BAS,K6BAS
K30E     EQU      KBKON
K3E0     EQU      KBKON+1
K30F     EQU      KBKON+2
K3F0     EQU      KBKON+3
K3FF     EQU      KBKON+4
K2FFFF   EQU      KBKON+5
K303     EQU      KBKON+9
K301S    EQU      KBKON+12
K4SPAC   EQU      K4BAS+1
K4AST    EQU      K4BAS+2
KUNPKA   EQU      K6BAS+1
KUNPK4   EQU      K6BAS+2           UNPKA+1
KMSG     EQU      K6BAS+3           MSG AREA
         REF      KCVTD             SUBROUTINE NAME
         REF      LRASAV            LOAD,STORE
LDRSAV   EQU      LRASAV            R6-D3
MDRSAV   EQU      LDRSAV+10         R6-D3
NDRSAV   EQU      MDRSAV+10         R6-D3
LDRREG   EQU      NDRSAV+10         SREG,DECPS
MDRLNK   EQU      LDRREG+5          CURRENT LINK
         END
