         SYSTEM   SIG7FDP
R0       EQU      0
R1       EQU      1
R2       EQU      2
R3       EQU      3
R4       EQU      4
R5       EQU      5
R6       EQU      6
R7       EQU      7
R8       EQU      8
R9       EQU      9
R10      EQU      10
R11      EQU      11
R12      EQU      12
R13      EQU      13
R14      EQU      14
R15      EQU      15
SR1      EQU      8
SR2      EQU      10
         DEF      C:ERD
         DEF      C:BBF
         DEF      C:ABF
         DEF      C:BEF
         DEF      C:AEF
         DEF      C:BBR
         DEF      C:ABR
         DEF      C:BER
         DEF      C:AER
         DEF      C:OPD
         DEF      C:TLBL
         DEF      C:CLD
         DEF      C:RLD
         DEF      C:WLD
         REF      OPEN
         REF      CLOSE,CVOL,READ
         REF      C:OPN
         REF      C:CLS
         REF      C:RLR
         REF      C:WLR
         REF      C:WOB
DECLERD  DATA     0                *THESE NINE WORDS MUST STAY
DECLBBF  DATA     0                *TOGETHER  AND  DECLERD MUST
DECLABF  DATA     0                *BE THE  FIRST  WORD
DECLBEF  DATA     0                *
DECLAEF  DATA     0                *
DECLBBR  DATA     0                *
DECLABR  DATA     0                *
DECLBER  DATA     0                *
DECLAER  DATA     0                *
C:ERD    STW,R11  DECLERD
         B        DEXIT
C:BBF    STW,R11  DECLBBF
         B        DEXIT
C:ABF    STW,R11  DECLABF
         B        DEXIT
C:BEF    STW,R11  DECLBEF
         B        DEXIT
C:AEF    STW,R11  DECLAEF
         B        DEXIT
C:BBR    STW,R11  DECLBBR
         B        DEXIT
C:ABR    STW,R11  DECLABR
         B        DEXIT
C:BER    STW,R11  DECLBER
         B        DEXIT
C:AER    STW,R11  DECLAER
DEXIT    AI,R11   2
         B        *R11
C:CLD    RES      0
         PSW,R15  *R0
         PSW,R11  *R0
         CI,R14   X'220'            DO WE HAVE  CLOSE REEL
         BE       CLREEL            YES
         LW,R5    *R6
         LI,R4    1
         LW,R12   *R5,R4
         CI,R12   X'40000'          IS DCB OPEN  OUTPUT
         BAZ      CLINPT            NO
         LW,R12   DECLBEF           DO WE HAVE BEF
         BEZ      %+2               NO
         BAL,R13  LINKBCK           YES  EXECUTE IT
         LW,R12   DECLAEF           DO WE HAVE  AEF
         BEZ      %+2               NO
         BAL,R13  LINKBCK           YES  EXECUTE IT
         LW,R12   L(X'00200000')    DO WE HAVE LABEL RECORDS
         CW,R12   1,R6
         BAZ      CLOUTX            NO
         BAL,R13  SETLNGTH
         LW,R13   L(X'40000000')    SET TLABEL FLAG IN FPT
         STS,R13  CLOSE+1
         LI,R12   C:LABEL           SET UP  BUFFER  ADDRESS
         STW,R12  CLOSE+3
CLOUTX   BAL,R11  C:CLS             DO   CLOSE
         B        %+2
         B        ERRDECLX
         LW,R5    CLOSE+1           REMOVE TLABEL FLAG IN FPT OF CLOSE
         AND,R5   L(X'BFFFFFFF')
         STW,R5   CLOSE+1
         B        BIGEXIT
CLINPT   LW,R12   DECLBEF           DO WE HAVE  BEF
         BEZ      %+2               NO
         BAL,R13  LINKBCK
         BAL,R13  MVFRBUF           MOVE LABEL TO USER AREA
         LW,R12   DECLAEF           DO WE  HAVE  AEF
         BEZ      %+2               NO
         BAL,R13  LINKBCK
         BAL,R11  C:CLS             DO  CLOSE
         B        %+2
         B        ERRDECLX
         B        BIGEXIT
CLREEL   RES      0
         LW,R5    *R6
         LI,R4    1
         LW,R12   *R5,R4
         CI,R12   X'40000'          IS DCB OPEN OUTPUT
         BAZ      RDDECL            NO  BRANCH
         AI,R6    X'20000'          SET OUTPUT FLAG FOR WOB
         BAL,R11  C:WOB             GO WRITE  LAST BLOCK
         B        WRCLDEC
         LI,R12   X'1C'
         CB,R12   SR2
         BNE      ERRDECLX
WRCLDEC  RES      0
         AI,R6    X'E0000'          RESET OUTPUT FLAG
         LI,R15   C:CLS
         B        WRDECL
C:OPD    RES      0
         PSW,R15  *R0
         PSW,R11  *R0
         LW,R5    =X'80000'         SET DECLARATIVES FLAG
         STS,R5   0,R6              IN I: AREA
         LW,R5    L(X'00200000')    NAME OPTION
         CW,R5    1,R6             IS IT ON
         BAZ      NOHEADR              NO
         BAL,R13  SETLNGTH
         LW,R5    L(X'00100000')     GET TLAB BIT
         STS,R5   OPEN+1          SET OPEN FPT
         LI,R5    C:LABEL
         STW,R5   OPEN+6            SET ULABL ADDR
NOHEADR  RES      0
         CI,R14   2                 CHECK FOR OUTPUT
         BAZ      OPINPT            BRANCH  WE HAVE INPUT OR I/O
         LW,R12   DECLBBF           DO WE HAVE  BBF
         BEZ      %+2               NO
         BAL,R13  LINKBCK           YES EXUCUTE  IT
         LW,R12   DECLABF           DO WE HAVE  AEF
         BEZ      %+2               NO
         BAL,R13  LINKBCK           YES EXUCUTE  IT
OPNOUTD  BAL,R11  C:OPN             DO  OPEN
         B        %+2
         B        ERRDECLX
         LW,R5    OPEN+1
         AND,R5   L(X'FFEFFFFF')     RESET OPEN FPT
         STW,R5   OPEN+1
         B        BIGEXIT
OPINPT   LW,R12   DECLBBF           DO WE HAVE BBF
         BEZ      %+2               NO
         BAL,R13  LINKBCK           YES  EXECUTE IT
         BAL,R11  C:OPN             DO  THE  OPEN
         B        %+2
         B        ERRDECLX          ERROR
         LW,R5    OPEN+1
         AND,R5   L(X'FFEFFFFF')     RESET OPEN FPT
         STW,R5   OPEN+1
         LW,R12   DECLABF           DO  WE  HAVE  ABF
         BEZ      %+2               NO
         BAL,R13  LINKBCK           YES  EXECUTE IT
         B        BIGEXIT
C:WLD    RES      0
         PSW,R15  *R0
         PSW,R11  *R0
         BAL,R11  C:WLR             GO DO WRITE
         B        BIGEXIT           NORMAL RETURN
         LI,R13   X'13'             INVALID KEY
         CB,R13   SR2
         BE       INVADKY
         LI,R13   X'16'             INVALID KEY
         CB,R13   SR2
         BE       INVADKY
         LI,R13   X'42'             INVALID KEY
         CB,R13   SR2
         BE       INVADKY
         LI,R13   X'1C'             IS  ABN  CODE  END  OF TAPE
         CB,R13   SR2
         BNE      ERRDECLX          NO-- GO TRY  ERROR DECLARATIVES
WRDECL   LW,R12   DECLBER           DO WE HAVE  BER
         BEZ      %+2               NO
         BAL,R13  LINKBCK           YES--EXECUTE  IT
         LW,R12   DECLAER           DO WE HAVE  AER
         BEZ      %+2
         BAL,R13  LINKBCK           YES--EXECUTE  IT
         LW,R5    L(X'00200000')    DATA NAME  OPTION BIT
         CW,R5    1,R6              IS IT ON
         BAZ      WRDECLC
         BAL,R13  SETLNGTH
WRDECLC  RES      0
         BAL,R13  MVTOBUF           MOVE FROM LABEL AREA TO BUFFER
         LW,R12   DECLBBR           DO WE HAVE  BBR
         BEZ      %+2               NO
         BAL,R13  LINKBCK           YES-EXECUTE IT
         LW,R12   DECLABR           DO WE HAVE  ABR
         BEZ      %+2               NO
         BAL,R13  LINKBCK           YES--EXECUTE IT
         LW,R5    L(X'00200000')    DATA NAME  OPTION BIT
         CW,R5    1,R6              IS IT ON
         BAZ      WRCVOL
         BAL,R13  SETLNGTH
         LW,R5    L(X'40000000')
         STW,R5   CVOL+1
         LI,5     C:TRLR            GET BUF ADDR
         STW,R5   CVOL+2
WRCVOL   BAL,R11  *R15
         B        %+2
         B        ERRDECLX
         LI,R5    0
         STW,R5   CVOL+1
         B        BIGEXIT
INVADKY  RES      0
         LW,R4    *R0                GET TOP OF STACK POINTER
         MTW,1    *R4                INCREMENT IT
         LW,R11   R15
         B        BIGEXIT
C:RLD    RES      0
         PSW,R15  *R0
         PSW,R11  *R0
READCALL BAL,R11  C:RLR             GO DO READ
         B        OUTREAD           NORM  RETURN
         LI,R13   X'1C'             CHECK FOR END OF TAPE
         CB,R13   SR2
         BE       READEOT           YES  END  OF TAPE
         LI,R13   X'05'
         CB,R13   SR2               END OF DATA
         BE       EOFEXIT           YES
         LI,R13   X'06'
         CB,R13   SR2               END OF FILE
         BE       EOFEXIT           YES
         LI,R13   X'42'             INVALID KEY
         CB,R13   SR2
         BE       EOFEXIT
         LI,R13   X'43'             INVALID KEY
         CB,R13   SR2
         BE       EOFEXIT
         B        ERRDECLX
EOFEXIT  RES      0
         LW,R4    *R0                GET TOP OF STACK POINTER
         MTW,1    *R4                INCREMENT IT
         LW,R11   R15
         B        OUTREAD
READEOT  RES      0
         LW,R12   DECLBER           DO WE HAVE  BER  DECL
         BEZ      %+2               NO
         BAL,R13  LINKBCK           YES EXECUTE IT
         BAL,R13  MVFRBUF           MOVE TRAILER
         LW,R12   DECLAER           DO WE HAVE  AER  DECL
         BEZ      %+2               NO
         BAL,R13  LINKBCK           YES  EXECUTE IT
RDDECL   LW,R12   DECLBBR           DO WE HAVE  BBR  DECL
         BEZ      %+2               NO
         BAL,R13  LINKBCK           YES  EXECUTE IT
         BAL,R11  *R15              GO DO  CVOL (READ HDR IF ANY)
         B        %+2
         B        ERRDECLX
         LW,R12   DECLABR           DO WE HAVE  ABR  DECL
         BEZ      %+2               NO
         BAL,R13  LINKBCK           YES  EXECUTE IT
OUTREAD  RES      0
BIGEXIT  LI,R1    0
         STW,R1   DECLERD
         LW,R1    INTADCN
         MBS,R0   BA(DECLERD)
         PLW,R7   *R0
         PLW,R15  *R0
         B        *R7
ERRDECLX RES      0
         LW,R7    *R0
         LW,R11   *R7
         LW,R12   DECLERD
         BEZ      *R15
         BAL,R13  LINKBCK
         LI,R4    X'41'
         CB,R4    SR2
         BE       BIGEXIT
         B        *R15
*  THIS  ROUTINE  MOVES TRAILERS FROM  THE DATA  BUFFER  TO  THE
*  LABEL AREA.
MVFRBUF  RES      0
         LW,R5    L(X'00200000')    DATA NAME OPTION BIT
         CW,R5    1,R6              IS IT ON
         BAZ      *R13              NO -- EXIT
         LW,R4    2,R6              GET BUF ADDR
         BNEZ     %+2
         LW,R4    6,6
         AND,R4   =X'1FFFF'
         LB,R12   *R4               GET TRAILER RECORD LENGTH
         SLS,R4   2
         LI,R5    BA(C:LABEL)       ADDR OF USER AREA
         STB,R12  R5
         MBS,R4   0                 MOVE TRAILER
         B        *R13
LINKBCK  LCI      0
         PSM,R0   *R0
         LCI      9
         LM,R1    DECLERD
         LCI      9
         PSM,R1   *R0
         BAL,R11  *R12              PERFORM DECLARATIVES
         LCI      9
         PLM,R1   *R0
         LCI      9
         STM,R1   DECLERD
         LW,R7    *R0
         AI,R7    -3
         LW,R7    *R7
         EXU      *R7
         LCI      0
         PLM,R0   *R0
         B        *R13
MVTOBUF  RES      0
         LW,R5    L(X'00200000')    DATA NAME  OPTION BIT
         CW,R5    1,R6              IS IT ON
         BAZ      *R13              NO  EXIT
         LI,5     BA(C:TRLR)        GET BUF ADDR
         LB,R4    C:LABEL           GET LENGTH
         STB,R4   R5
         LI,R4    BA(C:LABEL)
         MBS,R4   0
         B        *R13
SETLNGTH RES      0
         LW,R4    *R6               GET DCB ADDR
         LW,R5    0,R4              IS THIS ANS TAPE
         AND,R5   =X'F'
         CI,R5    X'A'
         BNE      SETL%1            NO
         LI,R4    80                YES...SET LENGTH = 80
         B        SETL%2
SETL%1   RES      0
         LI,R5    3
         LW,R4    *R4,R5               GET BLK SIZE
         SLS,R4   -17
         CI,R4    255              IS IT LESS THAN 255
         BL       %+2
         LI,R4    255               NO USE 255
SETL%2   RES      0
         STB,R4   C:LABEL
         B        *R13
INTADCN  GEN,8,24 32,BA(DECLERD+1)
C:LABEL  RES      0
         DO1      65
         DATA     0
C:TLBL   EQU      BA(C:LABEL)+1     COBOL THINKS THIS IS LABEL AREA
C:TRLR   RES      65
         END
