         SYSTEM   SIG7FDP
         TITLE    'PHASE 4.1 - CORRESPONDING'
* READ PROC                                                             APR
* LF     R---     R-,+/-HW OFFSET,INDIRECT ADDR.                        APR  1
RCEF     CNAME    0                                                     APR00
RECF     CNAME    1                                                     APR01
RCRF     CNAME    2                                                     APR02
         PROC                                                           APR04
         DO       NAME>1                                                APR10
LF       BAL,L1   AAC00             READ CRF CLUSTER                    APR11
         ELSE                                                           APR12
         DO       NAME                                                  APR13
LF       BAL,L1   AAE00             READ ECF CLUSTER                    APR14
         ELSE                                                           APR15
LF       BAL,L1   *AF(3)            READ CRF/ECF CLUSTER                APR16
         FIN                                                            APR17
         FIN                                                            APR18
         DO       NUM(AF(1))                                            APR30
         LW,AF(1) R2                LOAD HA(CLOC)+/- HW OFFSET          APR31
         DO       NUM(AF(2))                                            APR40
         AI,AF(1) AF(2)                                                 APR41
         ELSE                                                           APR42
         AI,AF(1) 1                                                     APR43
         FIN                                                            APR44
         FIN                                                            APR44
         PEND                                                           APR50
* WRITE PROC                                                            APW
* LF     W---     R-,BA(CLOC)+/-BA OFFSET,RETURN                        APW 1
WPOF     CNAME    0                                                     APW00
WMCF     CNAME    1                                                     APW01
         PROC                                                           APW03
         DO       NUM(AF(2))                                            APW11
LF       LI,R4    AF(2)             LOAD BA(CLOC)                       APW12
         ELSE                                                           APW13
         DO       NUM(AF(1))                                            APW132
LF       LW,R4    AF(1)             LOAD,SET HA(CLOC) TO BA             APW14
         AW,R4    R4                                                    APW15
         FIN                                                            APW16
         FIN                                                            APW17
         DO       NAME                                                  APW80
         DO       NUM(AF(4))
         B        WRMCF             WRITE MCF CLUSTER
         ELSE
         DO       NUM(AF(3))
         LI,L1    AF(3)             LOAD LINK REGISTER
         B        WRMCF             TO WRITE MCF CLUSTER
         ELSE                                                           APW812
         BAL,L1   WRMCF             WRITE MCF CLUSTER                   APW813
         FIN                                                            APW814
         FIN                                                            APW818
         ELSE                                                           APW82
         DO       NUM(AF(4))
         B        WRPOF             WRITE POF CLUSTER
         ELSE
         DO       NUM(AF(3))
         LI,L1    AF(3)             LOAD LINK REGISTER
         B        WRPOF             TO WRITE POF CLUSTER
         ELSE                                                           APW842
         BAL,L1   WRPOF             WRITE POF CLUSTER                   APW843
         FIN                                                            APW844
         FIN                                                            APW848
         FIN                                                            APW85
         PEND                                                           APW90
* DIAG PROC                                                             APD
DX       CNAME                                                          APD00
         PROC                                                           APD01
* AF     DX       DIAG CODE,LINK                                        APD02
LF       LI,R1    AF(1)             LOAD DIAG CODE                      APD10
         DO       NUM(AF(3))
         B        DIAG              WRITE DMF CLUSTER
         ELSE
         DO       NUM(AF(2))
         LI,L1    AF(2)             LOAD LINK REGISTER
         B        DIAG              WRITE DMF CLUSTER                   APD242
         ELSE                                                           APD243
         BAL,L1   DIAG              WRITE DMF CLUSTER                   APD244
         FIN                                                            APD248
         FIN                                                            APD29
         PEND                                                           APD40
* LINK(OR LOAD) AND BRANCH PROC                                         APL
* LF     LAB,L/R  BRANCH ADDRESS,LINK ADDRESS(OR LOAD VALUE)            APL  1
LAB      CNAME                                                          APL01
         PROC                                                           APL04
LF       LI,CF(2) AF(2)             SET LINK REGISTER                   APL12
         B        AF(1)             BRANCH                              APL14
         PEND                                                           APL90
*
         DEF      AEC00             CORRESPONDING  MOVE
         DEF      AEG00             CORRESPONDING  ADD
         DEF      AEH00             CORRESPONDING  SUBTRACT
         DEF      AEC40,AEC50
         REF      WRMCF
         REF      DIAG
         REF      AAC00             READ CRF
         REF      AAE00             READ ECF
         REF      AA01,AA02,AA03    M.C. RETURNS
         REF      AA09,AA092        DIAG RETURNS
         REF      ADI00,ADI02
         REF      ADJ06
         REF      ABC00
         REF      ABG01
         REF      PIA22,PRT26
         REF      PIA26
         REF      JMCRD,JMCER,JRDF  CORRES. SWITCHES
         REF      JMCSX,JMCSI       SUBSCRIPT ERROR, INVS SWITCH
         REF      JAMOD
         REF      JAKON,JADAT,JASAV
         REF      STBAS             DATA STACK
         REF      ECFRF,CORRF
* 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
*
IBCC     EQU      X'2000'           REF CNTL
CBGSUB   EQU      1                 SUBTRACT
CBGOSE   EQU      2                 OSE
CEGOP    EQU      X'8000'           ADD/SUBTRACT FLAG
CECOM    EQU      X'8007'           CORRESPONDING MCF OPTION MASK
CLOP     EQU      X'80'           A LAST OPERAND                        A
DTSE     EQU      26                OSE FLAG
*
* CORRESPONDING  MOVE               TYPE = X'76'                        AEC
AEC00    RES      0                                                     AEC00
         LI,D1    0                 LOAD MOVE CORRESPONDING OPTION
         LI,L1    ABC00             SET LINK REGISTER
*                        D1 = CORRESPONDING OPTION
*                        L1 = NORMAL RETURN
AEC02    RES      0
         STW,L1   JECST
         MTW,15   JMCRD             SET NORMAL RETURN SWITCH
         MTW,14   JMCER             SET ERROR RETURN SWITCH
         MTW,15   JMCSI             SET SUBSCRIPT INVS SWITCH
         MTW,1    CORRF             SET CORR FLAG
* GRP A
         LI,V2    IBCC              LOAD REF CNTL
         BAL,L1   ADI00             CHECK REF GRP
         B        AEC68             INVALID CORRESPONDING GRP A
* *** IF FIRST GROUP INVALID, NO ECF CLUSTERS *****
*                        V0 = 0(=DECP)
         STW,V0   JECRF             INITIALIZE ECF CLOC
         LH,V1    1,R4              LOAD, CHECK SUBSCRIPT IND.
         BLE      AEC04             NO. SUBSCRIPTS
* GRP A SUBSCRIPTED
         LI,V0    X'20'             LOAD CSXR1
         AI,D1    X'100'            RAISE CSXR1 FLAG
AEC04    RES      0
         STW,V0   JECSXR            STORE CSXR1/0
         STH,D1   MAEC+1            STORE OPTION
         WMCF     ,BA(MAEC)+2       WRITE CORRESPONDING CNTL
         AI,D1    X'2000'           RAISE INTERMEDIATE CORRESPONDING FLA
         CI,D1    X'100'            CHECK CSXR1 FLAG
         BAZ      AEC10             DOWN. GRP NOT SUBSCRIPTED
* GRP A SUBSCRIPTED
         WMCF     ,BA(STBAS)+2      WRITE GRP A CLUSTER
* GRP B
*                        V2 = GRP REF CNTL
*                        D1 = CORRESPONDING OPTION
AEC10    RES      0
         LI,R3    HA(STBAS)         RESET HA(STKTOP)
         BAL,L1   ADI00             CHECK GRP B
         B        AEC62             INVALID GRP B
*                        V0 = 0(=DECP)
         STW,V0   JECAB             INITIALIZE A(1),B(1) FLAG
         LH,V1    1,R4              LOAD,CHECK SUBSCRIPT IND.
         BLE      AEC14             NO SUBSCRIPTS
* GRP B SUBSCRIPTED
         LI,V0    X'30'             LOAD CSXR2
         AI,D1    X'200'            RAISE CSXR2 FLAG
AEC14    RES      0
         STH,V0   JECSXR            STORE CSXR2/0
         CI,R2    0                 CHECK NLOC
         BNEZ     AEC17             NOT= 0, NEXT CLUSTER READ
AEC16    RES      0
         RCRF                       READ NEXT CLUSTER
AEC17    RES      0
         LH,R1    0,R2              LOAD, CHECK CLNG,CNTL
         CI,R1    X'80'
         BANZ     AEC19             NEXT STMT
         AI,R2    1                 HA(NLOC) = HA(NLOC)+1
         LH,R1    0,R2              LOAD, CHECK OPTION
         BLZ      AEC18             NOT OPTION ONLY
* OPTION ONLY - ROUNDED
         AI,D1    4                 RAISE MCF ROUND FLAG
         B        AEC16
AEC18    RES      0
         AI,R2    -1                HA(NLOC) = HA(NLOC)-1
AEC19    RES      0
         STH,D1   MAEC+1            STORE CORRESPONDING OPTIONS
         WMCF     ,BA(MAEC)+2       WRITE CORRESPONDING CNTL
         CI,D1    X'200'            CHECK CSXR2 FLAG
         BAZ      AEC20             DOWN. GRP B NOT SUBSCRIPTED
* GRP B SUBSCRIPTED
         WMCF     ,BA(STBAS)+2      WRITE GOP B CLUSTER
         LI,R3    HA(STBAS)         RESET HA(STKTOP)
*
AEC20    RES      0
         CI,R7    CLOP              CHECK LAST OP FLAG
         BAZ      AEC22             DOWN. NOT LAST GRP
* LAST GRP
         AI,D1    X'4000'           RAISE E-O-CORRESPONDING FLAG
         STH,D1   MAEC+1
AEC22    RES      0
         MTW,15   JRDF              SET READ ECF SWITCH
         MTW,15   JMCSX             SET SUBSCRIPT ERROR SWITCH
         XW,R2    JECRF             EXCHANGE ECF,CRF NLOC
         BNEZ     AEC24             ECF NLOC NOT= 0
* ECF NLOC = 0, READ
         RECF                       READ NEXT CLUSTER
AEC24    RES      0
         LW,V0    JECAB             LOAD,CHECK A(I),B(I) FLAG
         BGEZ     *JECST            CORRESPONDING ENTRIES PRESENT
* NO CORRESPONDING ENTRIES
         B        AEC60
* CORRESPONDING SUBSCRIPT ERROR RETURN
AEC40    RES      0
         LW,R2    JECAB             LOAD  A(I),B(I) FLAG
         LH,R2    JECSXR,R2         LOAD,CHECK CSXR(A/B)
* GROUP SUBSCRIPTED
         SLS,R2   8                 POSITION CSXR(A/B)
         B        ADJ06+1
* *** IF NDIM NOT= NSUB, DIAGNOSTIC GIVEN AT GRP LEVEL*****
*
*
* CORRESPONDING STMT RETURN
AEC50    RES      0
         CI,R2    0                 CHECK HA(NLOC)
         BNEZ     AEC52             NOT = 0, NEXT CLUSTER READ
* NLOC = 0, NEXT CLUSTER NOT READ
         RECF                       READ NEXT CLUSTER
* NLOC NOT= 0, NEXT CLUSTER READ
AEC52    RES      0
         LH,D1    MAEC+1            LOAD CORRESPONDING FLAG
         CI,D1    X'400'            CHECK ERROR FLAG
         BAZ      AEC54             DOWN. NORMAL RETURN
* ERROR RETURN
         CI,D1    CBGOSE            CHECK OSE FLAG
         BAZ      AEC54             DOWN.
* OSE
         MTW,15   JINTL             INTL NO. = INTL NO.-1
         LW,V0    JECAB             LOAD,CHECK A(I),B(I) FLAG
         BLZ      AEC60             < 0, E-O-GRP B
AEC54    RES      0
         LI,R3    HA(STBAS)         LOAD HA(STKTOP)
         LW,V0    JECAB             LOAD  A(I),B(I) FLAG
         BGZ      *JECST            >0, A(I+1) READ
         BLZ      AEC60             <0, E-O-GRP B
* = 0, B(I) READ
         LI,R2    0                 NLOC = 0
         B        *JECST
*
* E-O-CORRESPONDING GROUP
AEC60    RES      0
         LI,R2    0
         XW,R2    JECRF             EXCHANGE ECF,CRF NLOC
         MTW,1    JRDF              RESET SWITCHES - READ
         MTW,1    JMCSX             *              - SUBSCRIPT ERROR
         CI,D1    X'4000'           CHECK LAST GRP FLAG
         BANZ     AEC64             UP.  E-O-CORRESPONDING GRPS.
* NEW CORRESPONDING GROUP - MOVE ONLY
         AND,D1   KECOM             MASK OPTIONS
         LI,V2    IBCC              LOAD REF CNTL
         B        AEC10             PROCESS NEXT GRP B
* INVALID GRP B
AEC62    RES      0
         CI,R7    CLOP              CHECK LAST OP FLAG
         BAZ      AEC10+1           DOWN. ANOTHER GRP FOLLOWS
* INVALID LAST GRP B
         AI,D1    X'4000'           RAISE E-O-CORRESPONDING FLAG
         STH,D1   MAEC+1
* E-O-CORRESPONDING
AEC64    RES      0
         WMCF     ,BA(MAEC)+2       WRITE E-O-CORRESPONDING CLUSTER
AEC68    RES      0
         MTW,1    JMCRD             RESET SWITCHES - NORMAL RETURN
         MTW,2    JMCER             *              - ERROR RETURN
         MTW,1    JMCSI             *              - SUBSCRIPT INVS
         LI,R4    0
         STW,R4   CORRF             RESET CORR FFLAG
         B        AA01              RETURN
* CORRESPONDING  ADD                TYPE = X'74'                        AEG
AEG00    RES      0                                                     AEG00
         LI,D1    CEGOP             LOAD CORRESPONDING OPTION
         CI,R6    X'6000'           CHECK FOR OSE
         BAZ      AEG02             NO.
* OSE OPTION
         BAL,L1   PIA26             WRITE
         LCFI     0                 ****     CLEAR CC                   15
         BAL,L1   PRT26             WRITE                               16
         STCF     DTSE              ****     LOWER OSE FLAG
         AI,D1    CBGOSE            RAISE OSE FLAG
*                        R7 = NS INTL NO.
         STW,R7   JEGNS             SAVE NS INTL NO.
         LI,R2    0                 CLEAR CLOC
*
AEG02    RES      0
         BAL,L1   AEC02             INITIALIZE ECF PROCESSING
* ADD/SUBTRACT ECF ELEMENTARY ITEMS
         LI,V2    CECOM             MASK MCF OPTION
         AND,V2   D1
         CI,D1    CBGOSE            CHECK OSE FLG
         BAZ      ABG01             DOWN.
* OSE
         MTW,1    JINTL             INTL NO. = INTL NO.+1
         LW,V0    JINTL             LOAD INTL NO.
         LI,V1    0                 CLEAR N.S. INTL NO.
         B        ABG01             OSE ENTRU
* CORRESPONDING  SUBTRACT           TYPE = X'75'                        AEH
AEH00    RES      0                                                     AEH00
         LI,D1    CEGOP+CBGSUB      LOAD CORRESPONDING OPTION
         B        AEG00+1
*
KECOM    DATA     CECOM+X'20FC'     GRP B MASK
*
JECAB    EQU      JADAT+X'1F'       A(I),B(I) FLAG
JECSXR   EQU      JECAB+1           CSXR
JECRF    EQU      JECAB+2           ECF,CRF CLOC
JECST    EQU      JECAB+3           STMT LINK REGISTER
JINTL    EQU      JAMOD+13          INTL DEF,NO.
MAEC     EQU      JAMOD+X'15'       CORRESPONDING CLUSTER
JEGNS    EQU      MAEC+1            N.S INTL NO.
         END
