*CREATED 01/05/71 PC 3122
*UPDATED 01/15/71 PC #3122
*UPDATED 1/19/71 PC #3122
         SYSTEM   SIG7
* CREATED 2/4/71 P.CRISMAN FOR A01
*        UPDATED MAY '71, J. SLAYBAUGH, FOR FILE DATES PHASE 2 (P2)
SIM      SET      0
         SYSTEM   BPM
         TITLE    '** ENVIRONMENT-EQU, REF/DEF, PROC **'
FILLSEC  CSECT    1
**
**                DEFINE STANDARD REGISTERS AND CONDITION CODES
R0       EQU      0
R1       EQU      1
R2       EQU      2
R3       EQU      3
R4       EQU      4
R5       EQU      5
R6       EQU      6
R7       EQU      7
SR1      EQU      8
SR2      EQU      9
SR3      EQU      10
SR4      EQU      11
D1       EQU      12
D2       EQU      13
D3       EQU      14
D4       EQU      15
**  DISPLACEMENT VALUES FOR DCB
ORG      EQU      5                 FILE ORGANIZATION LEFT BYTE 3
KBUF     EQU      10
RWS      EQU      13                ACTUAL NUMBER OF BYTES READ
KEYM     EQU      12
INSNN    EQU      X'30'             DISPLACEMENT IN F:EO FOR INSN
BLABSZ   EQU      250
VPT:SIZ  EQU      112
         REF      DO:TIME
         REF      DO:TABLES:ADS
         DEF      COMPDAT
         REF      BSR1
         REF      PURGE
         REF      SLP:FPT
         PAGE
MOVE:FLD CNAME
         PROC
         LOCAL    P,LUP,LI,LW
LI       SET     X'22'
LW       SET      X'32'
P        DO       2
         GEN,8,4,20  LI*(AFA(P)=0)+LW*(AFA(P)),3+P,AF(P)  DOES LW/LI FOR
*                 R4/R5 WITH/WITHOUT ASTERISK
         FIN
LUP      LB,3    *4,3               NAW
         LB,2    *4,1               LEI
         AI,3     1
         STB,3    5                 SET BYTE COUNT AS WORDS
         SLD,4    2                 R4,R5 TO BA
         MBS,4    0
         SLD,4    -2                BACK TO WA
         LI,3     3                 RESTORE CONSTANT
         CI,2     0                 CHECK FOR LEI
         BE       LUP               GO DO ANOTHER VLP
         LI,2     2                 RESTORE CONSTANT
         PEND
         PAGE
FILLDATA CSECT    0
         DEF      FILL
         DEF      LB2
         REF      FREI:CMN
         DO       SIM
         SPACE    5                 *********************
*        ************************************************
*        FOR SIMULATION
         REF      F%BREC,F%TI,F%SEL,F%BACK,F%USR
F:BREC   EQU      F%BREC
F:TI     EQU      F%TI
F:SEL    EQU      F%SEL
F:BACK   EQU      F%BACK
F:USR    EQU      F%USR
*        **********************************************
         SPACE    5                 ***************************
         ELSE
         REF      F:BREC,F:TI,F:SEL,F:BACK,F:USR
         FIN
FL:TAPE  EQU      F:TI
FUSRACCT EQU      F:USR+32
         DEF      ERBCK,USRABN,USRERR
         REF      RELEASE
         REF      MAGICWRD
         REF      MAGIC
         REF      GET:CM
         REF      NMPG,BUFSZ,BUF
         REF      SAV:ACC
         REF      KEYLOC
         REF      BLABL
         REF      MAILBOX
         REF      J:JIT
         REF      SETSQ
         REF      SPECFLG
         REF      LOCCODE1
         REF      LASTREEL,LASTREELX,REELTMP
         DEF      SEL:COM,SEL:COM:BUF
         DEF      FIND:STRG,SK:BL
         DEF      SELKEY,ECB
         REF      DATEAD,DATE1AD,TIMEAD
         TITLE    '**  DATA  **'
*                 THE FOLLOWING MUST BE CONTIGUOUS & IN ORDER
FILL:TEXTC TEXTC  'FILL'
         TEXTC    '='
         TEXTC    '('
RTPAREN  TEXTC    ')'
         TEXTC    ','
         TEXTC    '('
         TEXTC    'REEL'
         TEXTC    '='
         TEXTC    ')'
*                 UP TO THIS POINT.
*
*                 THESE STRINGS ARE FOR LEGAL RANGES OF VALUES IN
*                  REEL NUMBERS (DDLD).  NEGATIVE INDEXING IS USED
         TEXT     '00AA'
LOW      EQU      %
         TEXT     '99Z9'
HI       EQU      %
SELKEY   TEXTC    'SEL:FIL'
         BOUND    8
MBS:T:SB DATA     TACT0,16**22+1
MBS:SB:SB1 DATA   0,16**24+16
CBS:ACT1 DATA     BA(BLABL+4),8**24+BA(FUSRACCT)
CBS:ACT2 DATA     BA(BLABL+4),8**24+BA(ZAPACCT)
MLBXNM   TEXT     ' MAILBOX'
*
*                 TPY SELFIL ENTRY
TACT0    DATA     0
TACT1    DATA     0
TFIDPTR  DATA     0
TSN      DATA     0
*                 TPY ENTRY FOR FID FOR SELFIL
TFID     DATA     0,0,0,0,0,0,0,0
NO:FILL:MESS TEXTC  'UNFILLED REQUEST - FID'
NO:FILL:FID EQU  %
         DO1      8
         DATA     C'    '
*                 BAD SELFIL COMMAND BUFFER
BAD:COM:MESS TEXTC  'BAD SEL:FIL INPUT  '
SEL:COM:BUF EQU   %
         DO1      20
         DATA     '    '
SEL:COM  EQU      %                 LABEL FOR PRECEEDING 20 WORD BUFFER
ERR:RET  PZE      BAD:SEL:COM
ERR:RET1 DATA     0
         DEF      ERR:RET1,ERR:RET
SEL:BUF  DATA     0
SELFID:PTR DATA   0
SELECT   DATA     0                 1=SELECTIVE FILL
SPBYCT   RES      1
SAV:SYM  DATA     0
TMP      DATA     0
SR1X     DATA     0
TMP1     DATA     0
R47      DATA     0,0,0,0
MAILPAR  PZE      NOMSG
         PZE      MAIL:AC
MAIL:AC  DATA     0,0
MAILSUC  PZE      SUCCESS
         PZE      MAIL:AC
NO:FILL:PAR  DATA NO:FILL:MESS
         DATA     MAIL:AC
SUCCESS TEXTC     'FILLED                   '
         RES      9
NOMSG    TEXTC    'ERROR      FAILED TO RECOVER                  '
         RES      9
KADR     TEXTC    'BACKUP'
OPERMSG  TEXTC    'ARE THERE MORE SETS OF BACKUP TAPES(Y/N)'
BADSEQ   TEXTC    'FILE OUT OF SEQUENCE-QUIT OR CONTINUE(Q/C)'
BADFIL   TEXTC    'BAD FILE ENCOUNTERED'
FILLONO  TEXTC    'REQUEST FILL, NOFILL, OR INSTANT SQUIRREL(F,N,S)'
SAVREC TEXTC 'FILL RESTARTED-REMEMBER OR IGNORE PREVIOUS RUNS(R/I)'
NTRREEL  TEXTC    'FILL REEL NUMBER='
STARTFILE TEXTC   'SKIP TO FILE'
NOMSG:FAIL TEXT   'FAILED TO RECOVER'
NOMSG:FOLL TEXT   'FOLLOWING FILE   '
FILCNT   DATA     0
ZAPFLAG  EQU      %                 IF NON-ZERO,FILE DELETEION SUPPRESSED
YES      PZE
FID:ACCT EQU      %                 INPUT BUFFER--FID & ACCT
         DO1      11
         DATA     0
START:ACCT  DATA  0,0               STARTING ACCT FOR FILL
ECB      PZE
         BOUND    8
TIME     RES      2
         TITLE    '**  FPT  **'
*F:USR
*                 OPEN USER OR TEST USER (DISK)
USER:FIL:RES GEN,8,7,17  X'14',0,F:USR      RESTORE USER:FIL
USER:FIL GEN,8,7,17 X'14',,F:USR    PARAMETER LIST TO OPEN USR FILE
         DATA     X'C728DA3C'
         PZE      USRERR
         PZE      USRABN
USER:ORG DATA     0
USER:ACC DATA     0
USER:MOD DATA     2                 OUTPUT MODE
         DATA     USER:FPAR
KEYMAX   DATA     0
USER:NEWX DATA    0
USER:SPARE DATA   0
URSTORE  DATA     0
BLUNK    EQU      %
         GEN,8,24    X'03',0       ERASE PREVIOUS SETTINGS IN DCB
         GEN,8,24  X'04',0
         DATA     X'05000202'       READ ACCOUNTS
         TEXT     'ALL     '
         DATA     X'06000202'       WRITE ACCOUNTS
         TEXT     'NONE    '
         GEN,8,24  X'0B',0
USER:VPT RES      VPT:SIZ
USER:FPAR RES     VPT:SIZ
         SPACE    5
*FL:TAPE
*                 TAPE READ
         BOUND    8
TAPEREAD GEN,8,7,17      X'10',0,FL:TAPE     READ BACKUP TAPE
         GEN,4,28 X'F',0
         PZE      TPERR
         PZE      TPABN
BUFRD    DATA     0                 BUF LOC
         DATA     0                 BUF SIZ
         SPACE    5
*F:USR
** WRITE USER FILE
         BOUND    8
USERWRIT GEN,8,7,17      X'11',0,F:USR
**                FLAG WORD 1ST BYTE OVERWRITTEM
         GEN,4,28 X'C',X'40'
         PZE      USRERR
         PZE      USRABN
BUFWRT   DATA
         DATA
KEY:GRAN DATA     KEYLOC
RANGRCT  DATA     0
BLNK:OPN GEN,8,7,17      X'14',,F:USR        BLANK  OPEN FOR SYNONYM
         DATA     X'C1000801'
         PZE      USRERR
         PZE      USRABN
         DATA     4                 UPDATE MODE
BLNK:VP  RES      40                N.A.P. AND SYN
         SPACE    10
*                 TEST FILE/ADJUST DCB FPTS
         SPACE 2
FL:TAPE:OPN EQU   %
         GEN,8,7,17 X'14',0,FL:TAPE ADJUST DCB  W/VLPS
         DATA     X'00006002'
         DATA     X'01010000'
         DATA     1                 IN
FL:VOL   DATA     0                 VOL
FL:TAPE:SN DATA,1 7,1,36,36
         DATA  '   0','   1','   2','   3','   4','   5','   6','   7'
         DATA  '   8','   9','   A','   B','   C','   D','   E','   F'
         DATA  '   G','   H','   I','   J','   K','   L','   M','   N'
         DATA  '   O','   P','   Q','   R','   S','   T','   U','   V'
         DATA  '   W','   X','   Y','   Z'
*
         SPACE    5
FPT:SPEC GEN,8,7,17  X'14',4,F:USR  TEST FILE W/FPARAM
         DATA     X'C0200000'
         DATA     SPECERR
         DATA     SPECABN
         DATA     USER:FPAR
         SPACE    5
TF:SPEC  GEN,8,7,17  X'14',4,F:USR   TEST FILE W/O FPARAM
         DATA     X'C0200400'       NXTF
         DATA     SPECERR,SPECABN,0  ERR,ABN,FPARAM
         SPACE    5
TFFDNA   GEN,8,7,17  X'14',X'44',F:USR   TEST FILENX ACCT,FILDIR
         DATA     X'C0000001'
         DATA     SPECERR,SPECABN
         DATA     X'01000101',X'01000000'
         DATA     X'02010202'
ZAPACCT  DATA     0,0
PATCH    RES      200
         DEF      PATCH
         TITLE    '**  DCB  **'
FUSR:DESC EQU     F:USR+X'60'
         TITLE    '**MAIN PROGRAM-STARTUP & OPEN TAPE**'
         USECT    FILLSEC
FILL     EQU      %
         DO       SIM=0
*                    ROUTINE TO GAIN ACCESS TO TABLES
         BAL,SR4  DO:TABLES:ADS
         M:INT    PURGEINT
         REF      PURGEINT
         LC       J:JIT             MUST BE GHOST JOB
         BCS,4    FILL1
         M:XXX
         FIN
FILL1    EQU      %
         BAL,SR4  DO:TIME           SET UP START SN FOR BACKUP
         LW,R6    REELTMP
         AI,R6    X'C000'           C'A'-1
         STW,R6   LASTREELX
         LW,R5    J:CALCNT
         REF      J:CALCNT
         CI,R5    100               IF GR, CAME FROM GHOST1
         BG       LB1               NORMAL ENTRY FROM GHOST1-OK
DOREC    EQU      %                 ASK IF :BREC TO BE ZAPPED
         M:KEYIN  (MESS,SAVREC),(REPLY,YES),(SIZE,1),(ECB,ECB)
         LW,R6    ECB
         BLZ      %-1
         LB,R6    YES,R1
         CI,R6    'R'               KEEP :BREC
         BE       LB1
         CI,R6    'I'               ZAP :BREC
         BNE      DOREC
         M:OPEN   F:BREC,(ABN,BSR1),(ERR,BSR1),(INOUT)
         M:CLOSE  F:BREC,(REL)
LB1,LB2  M:KEYIN  (MESS,FILLONO),(REPLY,YES),(SIZE,1),(ECB,ECB)
         LW,R6    ECB
         BLZ      %-1               WAIT FOR INPUT
         LB,R6    YES,R1
         CI,R6    'F'
         BE       YESFL
         CI,R6    'N'
         BE       NO:FILL
         CI,R6    'S'
         BE       SETSQ             PERFORM INSTANT SQUIRREL
         B        LB1
** ALLOCATE BUFFER FROM ALL AVAILABLE SPACE
YESFL    EQU      %
DO:SN    EQU      %                 GET STARTING REEL NO. FROM
*                    OPERATOR AND SET 8 SN'S
         M:KEYIN  (MESS,NTRREEL),(REPLY,FID:ACCT),(SIZE,5),(ECB,ECB)
         LW,R6    ECB
         BLZ      %-1               WAIT FOR INPUT
         STW,R0   ZAPACCT
         STW,R0   ZAPACCT+1
         LW,R4    FID:ACCT
         LW,R5    FID:ACCT+1
         SCD,R4   8                 4-CHAR NUMBER NOW ASSEMBLED
         LB,R5    FID:ACCT          CHECK INPUT LENGTH
         CI,R5    5                 4 CHARS + LINE FEED
         BNE      DO:SN             ILLEGAL INPUT
         LB,R5    FID:ACCT,R5
         CI,R5    X'15'             N/L
         BNE      DO:SN             5TH CHAR MUST BE LINE FEED
*                    SAVE SN OF TODAYS LAST SET
         LI,R5    X'F0000'
         CS,R4    LASTREELX
         BNE      SN:DO
         LI,R5    X'FF00'
         CS,R4    LASTREELX
         BL       SN:DO
         STW,R4   LASTREELX
SN:DO    EQU      %
         LI,R6    -36
         LI,R5    X'FFF00'
NXT:SN   EQU      %
         STS,R4   FL:TAPE:SN+37,R6
         CW,R4    FL:TAPE:SN+37,R6
         BNE      %+2
         STW,R6   FL:VOL            SAVE INDEX TO COMPUTE VOL
         BIR,R6   NXT:SN
         LI,R6    37                CONVERT NEG INDEX TO + VOL
         AW,R6    FL:VOL
         STW,R6   FL:VOL
         AI,R6    -1
         STW,R6   ZAPFLAG           0 IF 1ST VOL, NON-ZERO IF NOT
*                 CHECK FOR SKIPPING
GET:START EQU     %
         STW,R0   START:ACCT        ZAP START OF ACCT
         M:KEYIN  (MESS,STARTFILE),(REPLY,FID:ACCT),(SIZE,42),(ECB,ECB)
         LW,R6    ECB
         BLZ      %-1               WAIT FOR INPUT
         LB,R5    FID:ACCT,R1       NULL REPLY
         CI,R5    X'15'             NL
         BE       SET:SN            NULL--LEAVE ACCT=0
FID:ACCTX EQU     FID:ACCT+11       ADDR FOR NEGATIVE IX
         LI,R5    -43               MSG INPUT IX
         LI,R6    0                 FNE LENGTH
         LB,R4    FID:ACCTX,R5
         CI,R4    C'.'
         BE       MOVE:ACCT         ACCT ONLY
*                    SETUP FILE NAME
GET:FNE EQU       %
         BAL,SR4  CHK:TERM          CHK FOR TERMINATOR
         B        END:FNE
         AI,R6    1
         BIR,R5   GET:FNE
         B        GET:START         NO TERMINATOR
END:FNE  EQU      %
         CI,R4    C'.'
         BNE      GET:START         NAME TERMINATOR NOT '.'
*                    HANDLE ACCT
MOVE:ACCT EQU     %
         STB,R6   FID:ACCT          SET FNE LENGTH
         LI,R6    -8
MOVE:ACCT1 EQU    %
         BIR,R5   %+2               STEP TO NEXT INPUT CHARACTER
         B        GET:START
         BAL,SR4  CHK:TERM
         B        MOVE:ACCT2        END ACCT
MOVE:ACCT3 EQU    %
         STB,R4   START:ACCT+2,R6
         BIR,R6   MOVE:ACCT1
         STW,R3   ZAPFLAG           SKIP PRECEEDING ACCTS IN DO:FILDR
         B        SET:SN
MOVE:ACCT2 EQU    %
         LI,R4    C' '              SET BLANKS
         AI,R5    -1                FORCE REPEAT TO BLANK FILL
         B        MOVE:ACCT3
CHK:TERM EQU      %
*                 FETCHES NEXT CHARACTER FROM FID:ACCTX,R5 AND
*                   CHECKS FOR TERMINATOR    EXIT NORMAL IF DATA
*                   EXIT SKIPPING IF TERMINATOR
         LB,R4    FID:ACCTX,R5
CHK:TERM1 EQU     %
         CI,R4    C'.'
         BE       *SR4
         CI,R4    C' '
         BE       *SR4
         CI,R4    X'15'
         BE       *SR4
         AI,SR4   1
         B        *SR4
         TITLE    '**  MAIN PROGRAM--SELECTIVE FILL  **'
         SPACE    2
SELFILL  EQU      %   ********    SELECTIVE FILL ROUTINE
         REF      BB1
         DEF      SELFILL
*                 ENTERED FROM BACKUP IF THE SEL:FIL FILE EXISTS
*
         CAL1,8   L(X'08000001')    GET ONE DYNAMIC DATA PAGE
         BCS,8    BB1               NO PAGES AVAILABLE
         STW,SR2  SEL:BUF           SAVE START ADDRESS OF PAGE
*                 INITIALIZE SELFIL TABLE
         LI,R7    511
         STW,R0   *SEL:BUF,R7       ZERO WORDS 1-511
         BDR,R7   %-1
         LI,R7    2*4
         STW,R7   *SEL:BUF          NEXT ENTRY CTL WD
         LI,R7    512*4
         STW,R7   *SEL:BUF,R1       FIRST FID ENTRY CTL WD
*                 OPEN :BREC AND READ SEL:FIL RECORD
         M:OPEN   F:BREC,(INOUT),(DIRECT),(SAVE),;
                  (ERR,SELO),(ABN,SELO)
SEL:RD:SELR EQU   %
         M:READ   F:BREC,(KEY,SELKEY),(SIZE,512*4),(BUF,*SEL:BUF),;
                  (ABN,SEL:OPN:SELF),(ERR,SEL:OPN:SELF)
SEL:OPN:SELF EQU  %                 OPEN SEL:FIL FILE
         M:OPEN   F:SEL,(ABN,NO:SEL:FILE),(ERR,NO:SEL:FILE),(INOUT)
READ:SEL  EQU     %
         M:READ   F:SEL,(ABN,SEL:FIL:EOF),(ERR,SEL:FIL:EOF)
*                 TRANSLATE AND CHEK INPUT COMMAND,BUILDING AN ENTRY IN
*                 THE TEMPORARY TABLES
         BAL,SR4  FIND:FILL         VERIFY CHARS PRECEEDING FID
         BAL,SR4  DO:FID            HANDLES FID IF PRESENT
         BAL,SR4  DO:ACCT           HANDLES ACCT
         BAL,SR4  FIND:REEL         HANDLES REEL NBR AND OTHER CHARS
*                     CHK SEL:FIL SN = CURRENT BACKUP SN
         LW,D1    TSN
         LW,D2    L(X'FFFFFF00')
         CS,D1    LASTREELX         COMPARE IF SAME TAPE SET
         BNE      %+3
         REF      NOTAPFG
         LW,D1    NOTAPFG           & CURRENT TAPE IS IN USE
         BNEZ     BAD:SEL:COM       YES-REJECT COMMAND
*                 FINISH ENTRY IN TEMP FOR FID, IF PRESENT
         STW,R0   TFIDPTR
         LB,D1    TFID
         BEZ      NO:FID
         LI,R7    504*4             LAST FID ENTRY IN TABLE
NXT:FID  EQU      %
         LB,D1    *SEL:BUF,R7
         BEZ      MTFID             EMPTY ENTRY FOUND
         AI,R7    -32
         B        NXT:FID
SELO     EQU      %                 CREATE THE :BREC FILE
         LB,D1    SR3
         CI,D1    X'13'             RECORD DOESNT EXIST ON DELREC
         BE       SEL:MT13
         CI,D1    3                 FILE DOESNT EXIST
         BNE      SEL:OPN:SELF
         M:OPEN   F:BREC,(OUT),(SAVE),(KEYED),(DIRECT),;
                    (ABN,BSR1),(ERR,BSR1)
         M:CLOSE  F:BREC,(SAVE)
         M:OPEN   F:BREC,(INOUT),;
                    (ABN,SELO),(ERR,SELO)
         B        SEL:OPN:SELF
MTFID    EQU      %
         STW,R7   TFIDPTR           SAVE IX OF FID
         LI,R6    -32
         CW,R7    *SEL:BUF,R1
         BGE      %+2
         STW,R7   *SEL:BUF,R1       SET NEW HI WATER FOR FIDS
*                 MOVE FI//NAME INTO FID AREA OF SEL:BUF
         LB,D1    TFID+8,R6
         STB,D1   *SEL:BUF,R7
         AI,R7    1
         BIR,R6   %-3
NO:FID   EQU      %
*                 MOVE ENTRY INTO SEL:BUF
         LW,R7    *SEL:BUF
         SLS,R7   -2
         AI,R7    -1
NXT:SEL  EQU      %
         LW,D1    TSN
         CB,D1    LOW-1             ('F0')
         BL       %+4
         LI,R6    X'80'             ZERO OUT THE HIGH
         EOR,D1   R6                 ORDER BIT OF THE 'F'
         STW,D1   TSN               (MAKES #'S < LETTERS)
         CI,R7    2
         BL       ENT:FOUND         TOP OF STACK
         CW,D1    *SEL:BUF,R7
         BGE      ENT:FOUND
         AI,R7    -3
         LW,R6    R7
         AI,R6    4
         LCI      4
         LM,D1    *SEL:BUF,R7
         STM,D1   *SEL:BUF,R6
         AI,R7    -1
         B        NXT:SEL
ENT:FOUND EQU     %                 MOVE DATA INTO ENTRY
         LD,D1    MBS:T:SB
         AW,D2    R7
         AW,D2    SEL:BUF
         SLD,D1   2                 WA TO BA
         MBS,D1   0
         LI,R7    16
         AW,R7    *SEL:BUF          UPDATE ENTRY POINTER
         STW,R7   *SEL:BUF
         M:WRITE  F:BREC,(KEY,SELKEY),(SIZE,512*4),(BUF,*SEL:BUF),;
                  (ONEWKEY),(ABN,BSR1),(ERR,BSR1)
DEL:SEL  EQU      %
         M:DELREC F:SEL
         AI,R7    48                CHECK FOR FULL BUFFER
         CW,R7    *SEL:BUF,R1
         BLE      READ:SEL
*                 OUTPUT FULL--SAVE REST OF SEL:FIL FILE
         M:CLOSE  F:SEL,(SAVE)
         M:TRUNC  F:BREC
NO:SEL:FILE EQU   %
         STW,R1   SELECT            SET SELECTIVE FILL FLAG
*                 ANY SELECTIVE FILLS TO DO
         LW,R7    *SEL:BUF
         CI,R7    2*4
         BG       SEL:SET:SN
SEL:MT   EQU     %
         CAL1,9   SUPERCLOSE
         CAL1,8   L(X'09000001')    RELEASE DYNAMIC PAGE
         M:DELREC F:BREC,(KEY,SELKEY)
SEL:MT13 EQU      %
         M:CLOSE  F:BREC,(SAVE)
         B        GO:BACK
SEL:SET:SN EQU    %
*                   SETUP SN'S
         LI,R7    5
         LI,D1    X'80'
         OR,D1    *SEL:BUF,R7       RESTORE THE 'F' TO #'S
         LI,R6    -36
         LI,D2    X'FFF00'
SEL:SET:SN1 EQU   %
         STS,D1   FL:TAPE:SN+37,R6
         CW,D1    FL:TAPE:SN+37,R6   FIND WHICH SN IS START
         BNE      %+2
         STW,R6   FL:VOL            SAVE INDEX FOR VOL
         BIR,R6   SEL:SET:SN1
         LI,R6    37                CONVERT -INDEX TO +VOL
         AW,R6    FL:VOL
         STW,R6   FL:VOL
NXT:SN:ENT EQU    %
         CS,D1    *SEL:BUF,R7       ZERO REEL NBRS FOR THIS SET
         BNE      SET:SN            ALL DONE--GO
         STW,R0   *SEL:BUF,R7
         AI,R7    4
         B        NXT:SN:ENT
         SPACE 3
SEL:FIL:EOF EQU   %
         LB,SR3   SR3               IF SHORT-WILL CATCH LATER
         CI,SR3   7
         BE       *SR1
*                 HIT EOF--ZAP THE SEL:FIL FILE AND START PROCESSING
         M:WRITE  F:BREC,(KEY,SELKEY),(SIZE,512*4),(BUF,*SEL:BUF),;
                    (ABN,BSR1),(ERR,BSR1),(ONEWKEY)
         M:TRUNC  F:BREC
         M:CLOSE  F:SEL,(REL)
         B        NO:SEL:FILE
         SPACE    3
*                 BAD SEL:FIL COMMAND--LOG AND SKIP
BAD:SEL:COM EQU   %
         LB,D1    BAD:COM:MESS
         CI,D1    80
         BG       %+2
         AI,D1    80                INCLUDE COMMAND
         STB,D1   BAD:COM:MESS
         M:TYPE   (MESS,BAD:COM:MESS)
         B        DEL:SEL
         SPACE    3
SET:SN   EQU      %
         CAL1,1   FL:TAPE:OPN          ADJ.DCB TO SET SN
         STW,R0   TIME
         STW,R0   FILCNT            PRESET FOR EACH SET OF TAPES
*
*
OPN:NXT  EQU      %                 PREPARE TO OPEN NEXT TAPE FILE
         LH,R4    NMPG
         AI,R4    -20
         BLZ      GETBUF            NOT OVER 20 PAGES-PROCEED
         AI,R4    10                RELEASE DOWN TO 10
         STH,R4   FREI:CMN,R1
         CAL1,8   FREI:CMN
         SLS,R4   9
         AWM,R4   BUF
         LI,R4    10
         STH,R4   NMPG
GETBUF   BAL,SR4  PURGE
         LH,R4    NMPG
         BNEZ     GOTBUF            ALREADY HAVE ENUF PAGES
         LI,R4    10                ASK FOR 10PAGES FIRST
         STH,R4   GET:CM,R1
         CAL1,8   GET:CM
         STW,SR2  BUF
         STH,SR1  NMPG
GOTBUF   EQU      %
         LH,SR1   NMPG
         SLS,SR1  11
         AI,SR1   -4
         STW,SR1  BUFSZ
OKBUF    EQU      %
         LI,10    X'FF'
         STB,10   BLABL
         M:OPEN   FL:TAPE,(INOUT),;
                  (NXTF),;
                  (ABN,TPABN),;
                  (ERR,TPERR)
         LB,10    BLABL
         BNEZ     CUL
LAB:READ M:READ   FL:TAPE,(BUF,BLABL),(SIZE,BLABSZ*4),;
                  (ERR,SHORT),(ABN,SHORT)
**
** CONVERT USER LABEL TO OPEN FOR USER FILE
**
CUL      EQU      %
         LW,SR3   =X'0E000000'
         LD,R4    BLABL+1
         CW,R4    MAGIC             CHECK FOR END TAPE
         BNE      %+4
         LW,6     SELECT            END TAPE-CHK SEL FILL
         BNEZ     MAG:END:SEL       SEL
         B        UNLOAD            NON-SEL
         CD,R4    TIME
         BL       BADTIME
GO:ON    AWM,R1   FILCNT            FILE COUNT PER TAPE
         STD,R4   TIME
         LI,R5    3
SPTST    LW,R4    BLABL+5,R5        IS THIS A SPECIAL FILE CREATED BY
         CW,R4    SPECFLG-1,R5
         BNE      USERLAB           FILES
         BDR,5    SPTST
         TITLE    '**MAIN PROGRAM-FILE INDEX RECORD**'
         LW,R5    START:ACCT        CHK IF STILL SKIPPING
         BNEZ     SKIPPING          IGNORE INDEX IN SKIP AREA
         LW,D1    SELECT
         BEZ      DO:FILDIR         NON-SELECTIVE FILL-PROCESS LIST
*                 IN THE SELECTIVE MODE AND A FILE LIST HAS BEEN
*                   DETECTED.  IF THE ACCOUNT IS ONE THAT HAS BEEN
*                   SEARCHED FOR, THE ENTRY MUST BE ZAPPED.
         LI,R7    2
         LI,R5    0
ZAP:LUP  EQU      %
         LCI      4
         LM,D1    *SEL:BUF,R7
         CI,D4    0                 IF SN=0, IS CURRENT ENTRY
         BL       ZAP:DONE          END OF CURRENT ENTRIES
         CW,D1    BLABL+4           CHK ACCT NUMBER
         BNE      NXT:ZAP
         CW,D2    BLABL+5
         BNE      NXT:ZAP
         CW,D3    0                 ONLY ZAP ACCT REQUESTS
         BE       ZAP:DONE
NXT:ZAP  EQU      %
         AI,R7    4
         SLS,R7   2
         CW,R7    *SEL:BUF          CHK FOR END OF TABLE
         BGE      SKIPPING          END LIST
         SLS,R7   -2
         B        ZAP:LUP
ZAP:DONE EQU      %
         STW,R0   *SEL:BUF,R7
*                 SEARCH FOR ANY REMAINING ENTRIES FOR THIS TAPE.
*                 IF ANY, CONTINUE, IF NONE BUT MORE TAPES, DO
*                 END TAPE TYPE PROCESS.  IF NO MORE LIVE ENTRIES,
*                 RETURN TO SELFIL
         LW,R6    *SEL:BUF
         SLS,R6   -2
         LI,R7    2
LUK:LUP  EQU      %
         LCI      4
         LM,D1    *SEL:BUF,R7
         CI,D4    0                 CHK FOR THIS TAPE
         BL       END:SEL:TAPC
         CI,D1    0                 CHK LIVE ENTRIES THIS TAPE
         BNE      SKIPPING
         AI,R7    4                 CHK END TABLE
         CW,R7    R6
         BL       LUK:LUP
         LI,SR4   SEL:MT            REL DY, DEL SELFIL, B BACKUP
         B        REM:TAPE
END:SEL:TAPC EQU  %                 MORE, BUT NOT THIS TAPE
         LI,SR4   END:SEL:TAP
REM:TAPE EQU      %
         LW,SR3   L(X'200000')
         CW,SR3   FL:TAPE
         BANZ     REM:TAPE1         DCB OPEN
         M:OPEN   FL:TAPE,(ABN,BSR1),(ERR,BSR1),(NXTF)
REM:TAPE1 EQU     %
         M:CLOSE  FL:TAPE,(REM)
         B        *SR4
         SPACE    5
*                    PROCESS ACCT FILE LIST
DO:FILDIR EQU     %
         CAL1,1   TFFDNA            FIND NEXT ACCT
         LD,R4    CBS:ACT2
         CBS,R4   0                 BLABL+4:ZAPACCT
         BE       SPPAGREL          DONE
         LD,R4    CBS:ACT1
         CBS,R4   0                 BLABL+4:FUSRACCT
         BG       SPLSTEND1         DO NULL ACCT
         BL       SPPAGREL          DONE
         LB,R4    BLABL,R2
         BNEZ     SPLSTEND2         TRUNCATED LIST-ACCEPT ALL FILES
DO:CUR   EQU      %                 PROCESS FILDIR
         STW,R0   ZAPFLAG           ENABLE FURTHER ACCT ZAPS
         LB,R4    BLABL,R3          GET NUMBER OF DYNAMIC PAGES NEEDED
         SH,R4    NMPG              ARE THERE ENUF PAGES
         BLE      DO:FILDIR1        YES ENUF
         STH,R4   GET:CM,R1
         CAL1,8   GET:CM            GET ADDTNL PAGES NEEDED
         STW,SR2  BUF
         STH,SR1  NMPG
         BCS,1    SPPAGREL          NOT ENUF AVAILABLE
         SLS,SR1  11
         AI,SR1   -4
         STW,SR1  BUFSZ
DO:FILDIR1 EQU    %
         LW,R6    BUF               WA OF BUFFER
         SLS,R6   2                 BYTE
         LW,R4    BLABL+3           BYTE COUNT
         AW,R4    R6                LAST BYTE ADDRESS
         STW,R4   SPBYCT            TEST FOR COMPLETION
         M:READ   FL:TAPE,(BUF,*BUF),(SIZE,*BLABL+3),;
                  (ERR,TPERR),(ABN,TPABN)
         LW,R4    *BUF
         CW,R4    MAGIC
         BE       SPPAGREL
* REGISTER 6 CONTAINS BYTE ADDRESS OF SPECIAL LIST THROUGHOUT
SPNXNM   EQU      %
         STB,R0   FPT:SPEC+1,R2     NOT NXTF FOR COMP:AGE
         STW,R6   SR4               SAVE START ADDRESS OF TABLE
SPDONE   EQU      %
         LW,R6    SR4
         CAL1,1   TF:SPEC           FIND FILE IN ACCT SPECIFIED
SPCONT EQU %
         LI,R7    BA(F:USR+X'17')   FILE NAME
         LB,R4    0,R6              BYTE COUNT IN FIRST BYTE
         LB,R5    0,R7
         AI,R7    1
         CW,R5    R4
         BG       %+3
         STB,R5   R7                COMPARE SHORTER FIELD
         B        %+2
         STB,R4   R7
         CBS,6    1
         BE       SPCLSAV           IF EQUAL, SAVE THIS FILE
         BG       SPCLREL           DELETE THIS FILE
SPLSNX   EQU      %
         LW,R6    SR4
         LB,R5    0,R6              COUNT OF THIS NAME
         AW,6     R5                ADD TO TOTAL COUNT TO GET NEXT NAME
         AI,6     1                 PLUS 1 FOR COUNT BYTE
         STW,R6   SR4
         CW,6     SPBYCT            ARE WE THROUGH WITH SPECIAL LIST
         BGE      SPLSTEND          IF LIST AT END, RELEASE REMAINING
         B        SPCONT
SPCLREL  BAL,SR1  COMP:AGE
         B        SPDONE
SPCLSAV  CW,R4    R5                WERE THEY REALLY EQUAL?
         BG       SPCLREL           RELEASE-LIST IS GT FILE NAME
         BL       SPLSNX            GET NEXT LIST ENTRY
         AI,R6    1
         CW,6     SPBYCT
         BL       SPNXNM            GET NEXT FILE
         B        SPLSTEND1
SPLSTEND EQU      %
         BAL,SR1  COMP:AGE          RELEASE ALL REMAIN OLD FILES
         LB,SR1   FUSR:DESC+1,R3
         CI,SR1   2                 EOF
         BAZ      SPLSTEND1
SPLSTEND2 EQU     %
         LW,SR1   FUSRACCT          YES-MOVE ACCT NBR
         STW,SR1  ZAPACCT
         LW,SR1   FUSRACCT+1
         STW,SR1  ZAPACCT+1
         B        DO:FILDIR
SPLSTEND1 EQU     %
         MTW,0    ZAPFLAG
         BNEZ     SPLSTEND2         SKIP ACCT IF FLAG SET
         LI,SR2   X'400'            NXTF
         STS,SR2  FPT:SPEC+1
         B        SPLSTEND
         TITLE    '**MAIN PROGRAM-DATA FILE**'
USERLAB  EQU      %
         LW,R5    USER:FIL:RES      INITIALIZE FPT
         STW,R5   USER:FIL
         MOVE:FLD BLABL+4,USER:VPT
         STW,R5   D2                WORD ADDRESS OF NEXT DESTINATION
         STW,R4   TMP1
         STW,R4   D3                WORD ADDRESS OF NEXT FROM
         STW,R0   SAV:SYM           PRESET SYM FLAG
         LW,R4    L(X'0F000000')    BYTE POS--NONZERO TEST/ZERO IX
LP1      LB,R5    USER:VPT,R4       TYPE
         CI,R5    X'B'
         BE       SYNM
RET1     AI,R4    1
         LB,R5    USER:VPT,R4       END INDICATOR
         BNEZ     ENDBRN
         AI,R4    2
         LB,R5    USER:VPT,R4       WORD COUNT
         SLS,R5   2                 BYTE COUNT
         AW,R4    R5
         AI,R4    1                 NEXT TYPE
         B        LP1
SYNM     EQU      %
         STB,R1   USER:VPT,R4       CHANGE SYN TO FILE NAME - TYPE 1
         STW,R4   SAV:SYM           SAVE LOC OF SYN NAME
         B        RET1
ENDBRN   EQU      %
         STB,R0   USER:VPT,R4       ERASE END INDICATOR
         LW,R5    SAV:SYM           WAS THERE A SYN
         BEZ      NOSYN                 NO
**  MOVE N.A.P. TO BLANK OPEN
         MOVE:FLD *D3,BLNK:VP
         STW,R5   TMP               WORD ADDRESS OF NEXT DEST.
*                   CLR LEI INDICATOR
         LI,R5    BLNK:VP
FNDSYNLEI EQU     %
         LB,R4    *R5,R1
         BNEZ     CLRSYNLEI
         LB,R4    *R5,R3
         AW,R5    R4
         AI,R5    1
         B        FNDSYNLEI
CLRSYNLEI EQU     %
         STB,R0   *R5,R1
         LW,R5    SAV:SYM           BYTE DISPLACEMENT OF SYN
         AI,R5    BA(BLABL+4)
         LI,R4    X'B'              RESET TO SYNON CODE
         STB,R4   0,R5
         AI,R5    1
         STB,R1   ,R5               END INDICATOR
         SLS,R5   -2                WORD ADDRESS
         STW,R5   SAV:SYM
         MOVE:FLD *SAV:SYM,*TMP
         STB,R0   *SAV:SYM,R1       CLR LEI
         LB,R5    *D3,R3            SKIP NAME FIELD IN N.A.P.
         AW,D3    R5
         AI,D3    1
NOSYN    EQU      %
         MOVE:FLD *D3,*D2
         LW,D3    TMP1
         AI,D3    1
         LB,R6    *D3
         LB,SR2   *D3,6
         STB,SR2  NOMSG+8,R6
         BDR,R6   %-2
         LB,R6    *D3
         AI,R6    32
         STB,R6   NOMSG
         LI,D4    BLABL+4
         LI,D1    9
         BAL,R5   LOCCODE1
         NOP
         LW,R4    *D4,R1
         SCS,R4   8
         STB,R4   USER:ORG,R3
         SCS,R4   8
         STB,R4   KEYMAX,R3
         SCS,R4   5
         LW,R5    L(X'00600000')
         STS,R4   USER:FIL          SET NOSEP & CYL
         LW,R4    *D4,R2
         STB,R4   USER:SPARE,R3
         SCS,R4   -8
         STH,R4   USER:NEWX,R1
         LB,R5    USER:ORG,R3       IS FILE KEYED
         B        %+1,R5
         NOP      0                 TREAT ORG=0 LIKE SEQUEN
         B        SORG              SEQUENTIAL
         B        KORG              KEYED
*                                   RANDOM
         LI,D1    X'D'              SET RSTORE
         LI,D4    BLABL+4
         BAL,R5   LOCCODE1
         NOP      0
         LW,R5    *D4,R1
         STW,R5   URSTORE
         LW,R6    L(1**31+RANGRCT)
         STW,R6   KEY:GRAN          SET BLOCK FOR WRITE
         LI,R6    X'F1'
         B        ALLORG
KORG     EQU      %                 SET UP FOR KEYED
         LI,R6    KEYLOC
         STW,R6   KEY:GRAN
         LI,R6    X'F8'
         B        ALLORG
SORG     EQU      %                 SEQUENTIAL
         LI,R6    X'F0'             NO KEY
ALLORG   EQU      %
         STW,R0   RANGRCT
         STB,R6   USERWRIT+1,R0
** SET USER IN JIT
         LW,D3    TMP1              SAVE FID ADDRESS
         AI,D3    1
SEE1     LB,R4    *D2,R0            FIRST BYTE OF LAST TARGET
         CI,R4    2                 LOOK FOR ACCOUNT
         BE       OKACCT
         LW,SR3   =X'0F000000'
         LB,R4    *D2,R1
         BNEZ     SHORT             FOUND LEI--TRBL
         LB,R4    *D2,R3            WORD COUNT
         AW,D2    R4
         AI,D2    1
         B        SEE1
OKACCT   EQU      %
         LW,R7    SELECT
         BEZ      OKACCT1           0=NON-SELECTIVE
*                 SEARCH SELFIL TABLE FOR ACCT/FID MATCH
         LI,R7    2
         LW,R6    *SEL:BUF
         SLS,R6   -2
         STW,R0   SELFID:PTR
CHK:ACCT EQU      %
         LCI      4
         LM,SR1  *SEL:BUF,R7
         CI,SR4   0                 ENTRY FOR THIS TAPE
         BL       SKIPPING  END OF CURRENT ENTRIES
         CW,SR1   *D2,R1            ACCT 1ST WD
         BNE      CHK:NXAC
         CW,SR2   *D2,R2
         BNE      CHK:NXAC
*                 RIGHT ACCT--CHK FID
         CI,SR3   0                 IF NO FID THEN IS ALL FOR ACCT,--OK
         BE       OKSEL             OK
         LW,R5    SR3
         LB,SR1   *SEL:BUF,R5       FID LENGTH
         AI,SR1   1
         LW,SR4   SEL:BUF
         SLS,SR4  2
         AW,SR4   SR3
         STB,SR1  SR4
         LW,SR3   D3
         SLS,SR3  2
         CBS,SR3  0
         BNE      CHK:NXAC
*                 ENTRY FOUND FOR THIS FILE
         STW,R7   SELFID:PTR
OKSEL    EQU      %
         AI,R7    3
         MTW,1    *SEL:BUF,R7       COUNT FILLS FOR THIS REQUEST
         LW,R7    D2
         B        JITLP1
*                 STILL SEARCHING
CHK:NXAC EQU      %
         AI,R7    4
         CW,R7    R6
         BL       CHK:ACCT
*                 DOESNT MATCH ANYTHING--SKIP IT
         B        SKIPPING
OKACCT1  EQU      %
         LI,R7    -1
         LW,R6    START:ACCT
         BEZ      NOSKIP
         CS,R6    *D2,R1
         BL       NOSKIP            NEW ACCT >OLD,OK
         BG       SKIPPING          NOT YET THERE
         LW,R6    START:ACCT+1      CHECK 2ND WORD OF ACCT
         CS,R6    *D2,R2
         BL       NOSKIP
         BG       SKIPPING
*                 ACCT MATCHES--CHK FID
         LB,R6    FID:ACCT
         BEZ      NOSKIP            OK--NO FID TEST
         LI,D4    BA(FID:ACCT)+1
         STB,R6   D4
         SLS,D3   2
         CBS,D3   1
         BL       SKIPPING          NOT YET THERE
NOSKIP   EQU      %
*                     DON'T FILL IF EXPIRED
         STW,R0   START:ACCT        BYPASS FURTHER TESTS
         LI,D4    BLABL+4
         LI,D1    4
         BAL,R5   LOCCODE1
         B        SKIPPING
         AI,D4    1
         LW,R7    D2                SAVE FOR JITLP1
         LW,SR4   L(C'NEVE')
         CW,SR4   *D4               CHK FOR EXP='NEVER'
         BE       NEVEXP
         LW,SR4   *DATE1AD
         LH,SR3   *TIMEAD
         STH,SR3  SR4
         LW,SR3   *DATEAD
         LI,D2    SR3
         XW,D2    D4
         BAL,R5   COMPDAT
         B        SKIPPING
NEVEXP   EQU      %
         LI,R4    2
JITLP1   EQU      %
         LW,R6    *R7,R4
         STW,R6   MAIL:AC-1,R4
         BDR,R4   JITLP1
         STB,R3   BLUNK             PRESET PASSWORD CODE
         STB,0    BLUNK,R3              WITH LENGTH ZERO
OPEN:EO  EQU      %
         LI,R6    2
         STW,R6   USER:ACC+1
         LW,R5    L(X'80000')
         STS,R5   USER:FIL
         STW,R1   USER:MOD          INPUT
         CAL1,1   USER:FIL          TEST FILE
         STW,R2   USER:MOD          OUTPUT
*                 FILE EXISTS..CHK STATUS
         LB,R5    FUSR:DESC+1
         CI,R5    1
         BG       ENDFILE1          OPEN FOR MOD--SKIP
         LI,D1    X'A'
         LI,D4    USER:VPT          TAPE COPY
         BAL,R5   LOCCODE1
         NOP
         LW,D2    D4
         LI,D4    USER:FPAR         DISK COPY
         BAL,R5   LOCCODE1
         NOP
         AI,D2    1
         AI,D4    1
         BAL,R5   COMPDAT
         B        ENDFILE2          TAPE COPY NOT NEWER
         LW,R6    NOMSG+8           IS THE FILE MAILBOX
         LW,R7    NOMSG+9
         CD,R6    MLBXNM
         BNE      OPEN:USER
         LI,R6    4             YES OPEN IN UPDATE MODE
MODESET  STW,R6   USER:MOD
OPEN:USER EQU     %
         LI,R6    8                 BLOCK 03,04,05,06
         STB,R0   BLUNK
         STB,R6   BLUNK,R3
         LW,R5    L(X'FFF7FFFF')    RESET FPT TO OPEN
         AND,R5   USER:FIL
         STW,R5   USER:FIL
*
         CAL1,1   USER:FIL          OPEN FOR REAL
** READ TAPE RECORD
RD:USR   EQU      %
         LW,R4    BUF
         LW,R5    BUFSZ
         STD,R4   BUFRD
         CAL1,1   TAPEREAD
         LW,R4    BUF
         LW,R5    FL:TAPE+RWS       SIZE OF RECORD
         CI,R5    4                 ONE WORD RECORD MAY BE MAGIC
         BNE      CHECKSHT      NOT END OF FILE
EOFCHCK  EQU      %
         LW,R6    MAGIC
         CW,R6    *R4
         BE       ENDFILE
CHECKSHT AI,R5    -1                CHECK FOR SHORT RECORD
         LW,SR3   =X'0D000000'
         LI,R6    MAGICWRD          MAGIC WORD BYTE BY BYTE
         CB,R6    *R4,R5
         BNE      SHORT
         AI,R5    -1
         CB,R6    *R4,R5
         BNE      SHORT
         AI,R5    -1
         CB,R6    *R4,R5
         BNE      SHORT
         AI,R5    -1
         CB,R6    *R4,R5
         BNE      SHORT
         STD,R4   BUFWRT            BUF LOC AND SIZE TO WRITE
         LW,R4    FL:TAPE+KBUF
         LB,R5    USER:ORG,R3       IS FILE KEYED
         CI,R5    2
         BNE      NOKEY             NO
         LB,R5    *R4               IST BYTE IS CHAR COUNT
         STB,R5   KEYLOC
         LB,R6    *R4,R5            MOVE KEY FOR WRITING
         STB,R6   KEYLOC,R5
         BDR,R5   %-2
NOKEY    EQU      %
** WRITE USER RECORD
         CAL1,1   USERWRIT
         MTW,1    RANGRCT           INCREMENT BLOCK FOR RANDOM
         B        RD:USR
         SPACE 5
*                 SBR TO RELEASE FILE IF ITS MOD DATE IS OLDER
*                   THAN THE DATE ON THE TAPE
COMP:AGE EQU      %
         STW,SR1  SR1X
         CAL1,1   FPT:SPEC          TESTFILE W/FPARAM
         LCI      4
         STM,R4   R47
         LB,D1    FUSR:DESC+1
         BNEZ     FIL:SAVE          IN USE
         LB,D1    FUSR:DESC+1,R2
         CI,D1    2                 NO PURGE BIT=PO TAPE FILE
         BANZ     FIL:SAVE
         LI,D1    X'A'
         LI,D4    USER:FPAR
         BAL,R5   LOCCODE1          FIND DISK MOD DATE
         NOP
         AI,D4    1
         LI,D2    BLABL+9           TAPES DATE IN SAME FORMAT
         LH,R7    *D4,R2
         BAL,R5   COMPDAT
         BL       FIL:SAVE          DISC LATER--SAVE
         BG       FIL:REL           TAPE LATER--RELEASE
         CI,R7    X'FF2F4'          CHK FROM PO
         BE       FIL:SAVE
FIL:REL  EQU      %
         M:OPEN   F:USR,(ABN,BSR1),(ERR,BSR1)
FIL:REL1 EQU      %
         M:CLOSE  F:USR,(REL)
FIL:SAVE EQU      %
         LCI      4
         LM,R4    R47
         B        *SR1X
         TITLE    '**  SUBROUTINES  **'
COMPDAT  EQU      %
*                 COMPARES EBCDIC DATES AT D2,D4 AND RETURNS
*                  SKIPPING IF D2 DATE IS THE LATER
         LCI      2
         LM,D1    *D2
         LM,D3    *D4
         SCD,D1   -16
         SCD,D3   -16
         CD,D1    D3
         BG       1,R5
         B        *R5
         PAGE
*          THE FOLLOWING ROUTINES PROCESS THE SELECTIVE FILL CHARACTER
*                 STRINGS COMPRISING THE COMMANDS TO SELECTIVE FILL
*          LINKAGE TO PRIMARY ROUTINES IS VIA SR4 AND TO SECONDARY
*                 ROUTINES VIA SR3.  ALL ERROR EXITS ARE *ERR:RET
*          INPUTS ARE IN THE 80 BYTE BLOCK PRECEEDING SEL:COM, CHARACTERS
*                 ARE REFERENCED VIA A NEGATIVE VALUE IN R4.
*                 R7, AND D1-D4, MAY BE USED AS WORK REGS.
*                 SR2 IS USED TO POINT TO ADDITIONAL PARAMETERS,AS NEEDED
*          OUTPUT IS PLACED IN THE TEMPORARY ENTRIES AT
*                 TACT0, TACT1, TFID, TSN
*
*
         SPACE 5
SK:BL    EQU      %   ****          SKIP BLANKS
*                 FINDS THE NEXT NON-BLANK, NON-TAB, CHARACTER IN
*                 THE INPUT STREAM.  TAKES ERROR EXIT IF COL 80 OR
*                 OTHER CONTROL CHARACTER IS FOUND.
         LB,D1    SEL:COM,R4
         CI,D1    ' '
         BG       *SR3              FOUND NON-BLANK, EXIT
         BL       SK:BL:TT          CHK FOR TAB
SK:BL:T80 EQU     %
         BIR,R4   SK:BL
         B        *ERR:RET          PAST COL 80
SK:BL:TT EQU      %
         CI,D1    X'05'             CODE FOR TAB CHAR
         BE       SK:BL:T80
         B        *ERR:RET          ILLEGAL CONTROL CHAR
         SPACE    5
FIND:STRG EQU     %   ****          FIND STRING
*                 CHECKS THE NEXT N CHARACTERS FOR MATCH WITH INPUT
*                 STRING.  INPUT IS TEXTC FORMAT AT *SR2.  IF STRING
*                 MATCHES FOR LENGTH IN TEXTC, NORMAL RETURN, OTHERWISE
*                 RETURNS *ERR:RET.  SR2 IS UPDATED TO FIRST WORD AFTER
*                 THE TEXTC.
         LI,D2    BA(SEL:COM)
         AW,D2    R4
         LB,D1    *SR2
         STB,D1   D2
         LW,D1    SR2
         SLS,D1   2
         CBS,D1   1
         BNE      *ERR:RET          STRING IN ERROR
*
         AI,D1    4                 STEP TO SOMEWHERE IN NXT WORD
         SLS,D1   -2
         LW,SR2   D1                SET SR2 TO NEXT WORD
         AI,D2    -BA(SEL:COM)
         LW,R4    D2                RESTORE R4 TO NEXT CHAR
         B        *SR3
         SPACE    5
FIND:FILL EQU     %   ****          FIND FILL
*                 POSITIONS INPUT TO THE BEGINNING OF FID, OR '.'
*                 PRECEEDING ACCT IF NO FID, VERIFYING THE FIELDS
*                 'FILL', '=', AND '('.  IGNORES BLANKS IMBEDDED
*                 BETWEEN FIELDS.
*                 ERROR RETURN IS *ERR:RET
         LI,R4    -80
         BAL,SR3  SK:BL             FIND START OF FILL
         LI,SR2   FILL:TEXTC
         BAL,SR3  FIND:STRG
*                 NOW FIND =
         BAL,SR3  SK:BL
         BAL,SR3  FIND:STRG
*                 THEN FIND (
         BAL,SR3  SK:BL
         BAL,SR3  FIND:STRG
*                 THEN SKIP ANY BLANKS UP TO FID OR '.'
         BAL,SR3  SK:BL
         B        *SR4
         SPACE    5
DO:FID   EQU      %   ****          SET TFID
*                 IF THE NEXT STRING DOES NOT START WITH A '.', THE
*                 STRING OF UP TO 31 CHARACTERS IS SET INTO TFID IN
*                 TEXTC FORMAT.  IF MORE THAN 31 CHARACTERS, COL80
*                 IS ENCOUNTERED, OR NOT TERMINATED BY A PERIOD, THE
*                 ERROR EXIT IS TAKEN.  IF THE FIRST CHARACTER IS A
*                 '.', TFID IS SET TO 0, AND THE NORMAL RETURN IS MADE.
         STW,R0   TFID
DO:FID:NXT EQU    %
         LB,D1    SEL:COM,R4
         CI,D1    '.'
         BE       DO:FID:XIT
         CI,D1    ' '               CHECK FOR BLANK OR CTL CHAR
DO:FID:OK EQU     %
         BE       DO:FID:BL         BLANK AND TAB OK TERMINATORS
         BG       DO:FID:SAV
         CI,D1    X'05'             TAB
         BNE      *ERR:RET          NEITHER  IS ERROR
DO:FID:BL EQU     %
         BAL,SR3  SK:BL
         LB,D1    SEL:COM,R4
         CI,D1    '.'               MUST BE A PERIOD
         BNE      *ERR:RET
         B        DO:FID:XIT
DO:FID:SAV EQU    %
         LB,R7    TFID
         AI,R7    1
         CI,R7    31
         BG       *ERR:RET          TOO MANY CHARS
         STB,D1   TFID,R7           SAVE CHAR
         STB,R7   TFID
         BIR,R4   DO:FID:NXT
DO:FID:XIT EQU    %
         BIR,R4   DO:FID:OUT
         B        *ERR:RET          PAST END OF LINE
DO:FID:OUT EQU    %
         BAL,SR3  SK:BL             FIND START OF ACCT
         B        *SR4
         SPACE    5
DO:ACCT  EQU      %   ****          FETCH ACCOUNT
*                 THE NEXT 1-8 CHARACTERS ARE MOVED TO TACT0,TACT1
*                 AS THE ACCOUNT NUMBER.  UPDATES R4 TO FOLLOWING THE
*                 LAST CHARACTER. USES R7 AND D1
*                 EXITS *ERR:RET IF COL 80 IS PASSED
         LI,R7    -8
DO:ACCT:LUP EQU   %
         LB,D1    SEL:COM,R4
         CI,D1    C')'
         BNE      %+3
         AI,R4    -1                BLANK FILL ACCT TO 8 CHARACTERS
         LI,D1    C' '
         STB,D1   TACT0+2,R7
         BIR,R4   %+2
         B        *ERR:RET          PASSED COL 80--ERROR
         BIR,R7   DO:ACCT:LUP
         B        *SR4
         SPACE    5
FIND:REEL EQU     %   ****          FIND REEL NUMBER
*                 MOVES THE REEL NUMBER (SN) INTO TSN, AND VERIFIES
*                 ALL THE OTHER CHARACTER STRINGS FOLLOWING THE ACCT
*                 NUMBER.  USES R7 AND D1.  IF ANY CHARACTER IN THE
*                 PRESCRIBED FORMAT IS INCORRECT OR COL 80 IS PASSED
*                 THE ERROR RETURN IS TAKEN (*ERR:RET).
         BAL,SR3  SK:BL
         LI,SR2   RTPAREN
         BAL,SR3  FIND:STRG         CHK ) AFTER ACCT
         BAL,SR3  SK:BL
         BAL,SR3  FIND:STRG         CHK , BETWEEN FIELDS
         BAL,SR3  SK:BL
         BAL,SR3  FIND:STRG         ( BEFORE REEL
         BAL,SR3  SK:BL
         BAL,SR3  FIND:STRG         'REEL'
         BAL,SR3  SK:BL
         BAL,SR3  FIND:STRG         =
         BAL,SR3  SK:BL
*                 NOW MOVE 4 CHAR SN
         LI,R7    -4
FIND:REEL:LUP EQU  %
         LB,D1    SEL:COM,R4
         STB,D1   TSN+1,R7
*                 CHECK LEGAL CHARACTERS--DDLD
         CB,D1    LOW,R7
         BL       *ERR:RET
         CB,D1    HI,R7
         BG       *ERR:RET
         BIR,R4   %+2
         B        *ERR:RET          ERROR--PAST COL 80
         BIR,R7   FIND:REEL:LUP
         BAL,SR3  SK:BL
         BAL,SR3  FIND:STRG         FINAL )
         B        *SR4
         SPACE    5
         TITLE    'ERROR AND ABNORMAL ROUTINES FOR FILL'
** USER FILE ERRORS
USRABN   EQU      %
         LB,R5    SR3
         CI,R5    X'14'
         BNE      CONT1
NO:GO    EQU      %
         LCF      FL:TAPE,R1
         BCR,2    NO:OPEN           DCB NOT OPEN
         M:PFIL   FL:TAPE,(EOF)
         M:CLOSE   FL:TAPE,(SAVE)
         BAL,SR2  NO:RCV            MAILBOX
         B        OPN:NXT
NO:OPEN  EQU      %
         BAL,SR2  NO:RCV2           LOG ERROR
         B        OPN:NXT
CONT1    EQU      %
         CI,R5    X'0A'             ALREADY CLOSED
         BE       *SR1
         CI,R5    X'16'             KEY ALREADY EXISTS
         BE       *SR1
         CI,R5    X'18'             KEY DOES NOT CONFORM
         BE       SHORT
         CI,R5    X'2E'             ALREADY OPEN
         BE       *SR1
         CI,R5    X'03'             UPDATE MAILBOX DOESNT EXIST
         BNE      SHORT             ALL OTHER ABNS
         LI,R6    2                 OUTPUT MODE
         B        MODESET
         SPACE    5
**
ERBCK    EQU      %
         LB,R5    SR3
         CI,R5    X'03'             DOESNT EXIST
         BNE      *SR1
         M:OPEN   F:BACK,(OUT),(ERR,GO:BACK1),(ABN,GO:BACK1),(SAVE)
         B        GO:BACK1
         SPACE    5
** BACKUP TAPE ERRORS
TPABN    EQU      %
         LB,R5    SR3
         CI,R5    2                 END
         BNE      NXT2
ENDEND   EQU      %
         LW,D1    SELECT
         BEZ      ENDEND1           NON-SELECTIVE
         M:OPEN   FL:TAPE,(ABN,BSR1),(ERR,BSR1),(NXTF)
MAG:END:SEL EQU   %
         M:CLOSE  FL:TAPE,(REM)
END:SEL:TAP EQU   %
         LW,R7    *SEL:BUF
         SLS,R7   -2
         LI,R6    5
*                 FIND HOW MANY ENTRIES WERE FOR THE TAPE JUST
*                   COMPLETED AND DELETE THOSE ENTRIES
NXT:SEL:DEL EQU   %
         CW,R6    R7
         BG       SEL:MT            NO MORE ENTRIES--ZAP TABLE
         LW,D1    *SEL:BUF,R6
         BLZ      SEL:HAS           SN=0 MEANS IS FOR THIS TAPE
         BNEZ     NO:FILL:LOG2
NO:FILL:LOG EQU   %
         LI,D2    18
         AW,R6    SEL:BUF
         LW,R4    -1,R6
         BEZ      NO:FILL:LOG1
         LW,R5    SEL:BUF
         SLS,R5   2
         AW,R4    R5
         LB,D2    0,R4
         LI,R5    BA(NO:FILL:FID)
         STB,D2   R5
         MBS,R4   1
         AI,D2    23
NO:FILL:LOG1 EQU  %
         STB,D2   NO:FILL:MESS
         LCI      2
         LM,R4    -3,R6
         STM,R4   MAIL:AC
         SW,R6    SEL:BUF
         LI,SR3   NO:FILL:PAR
         BAL,SR4  GOMAIL
NO:FILL:LOG2 EQU  %
         AI,R6    4
         B        NXT:SEL:DEL
SEL:HAS  EQU      %
         LI,R5    2
         AI,R6    -3                ADJUST TO START OF ENTRY
SEL:HAS1 EQU      %
         LCI      4
         LM,D1    *SEL:BUF,R6       PULL UP ENTRIES OF DELETIONS
         STM,D1   *SEL:BUF,R5
         AI,R5    4
         AI,R6    4
         CW,R6    R7
         BL       SEL:HAS1
*                 FINISHED SLIDES, RESET POINTER
         SLS,R5   2                 WD IX TO BYTE IX
         STW,R5   *SEL:BUF
         M:WRITE  F:BREC,(KEY,SELKEY),(SIZE,512*4),(BUF,*SEL:BUF),;
                    (ONEWKEY),;
                    (ABN,BSR1),(ERR,BSR1)
         M:TRUNC  F:BREC
         B        SEL:OPN:SELF
ENDEND1  EQU      %
         LW,SR4   ZAPACCT
         B        ENDEND2           IGNORE GARBAGE ACCOUNTS
         LI,SR4   -1                SET MAX ACCT NBR
         STW,SR4  BLABL+4
         B        DO:FILDIR
ENDEND2  EQU      %
         STW,R0   ZAPACCT
         BAL,SR4  DO:TIME
         LW,SR4   CURRENT
         STW,SR4  LASTFIL           COMPLETION TIME OF FILL
         M:OPEN   FL:TAPE,(ERR,BSR1),(ABN,BSR1),(NXTF)
         M:OPEN   FL:TAPE,(ERR,BSR1),(ABN,BSR1),;
                      (DEVICE,'MT')
UNLOAD   M:CLOSE  FL:TAPE,(REM)
SUPERCLOSE EQU    6
         CAL1,9   SUPERCLOSE
UNLOAD1  EQU      %
         M:KEYIN  (MESS,OPERMSG),(REPLY,YES),(SIZE,1),(ECB,ECB)
         LW,R6    ECB
         BLZ      %-1               WAIT FOR INPUT
         LB,R6    YES,R1
         CI,R6    'Y'
         BE       YESFL
         CI,R6    'N'
         BNE      UNLOAD1
NO:FILL  LI,R0    0
         LI,R1    1
         M:OPEN   F:BACK,(INOUT),(ABN,ERBCK),(ERR,ERBCK)
*                   CREATE A :BACKUP FILE IF NONE EXISTS
GO:BACK1 EQU      %
         M:CLOSE  F:BACK,(SAVE)
         REF      BACKXT,ESSENCE,CURRENT,LASTFIL
         REF      BACKUP
GO:BACK  EQU      %
         LI,SR4   BACKUP
         STW,SR4  BACKXT
         B        RELEASE           OVERLAY
NXT2     EQU      %
         CI,R5    X'1C'             END OF TAPE - IMPOSSIBLE
         BE       SHORT
         CI,R5    5                 END OF DATA
         BE       SHORT
         CI,R5    6
         BE       DONE              END OF DATA, NO MAGICWORD
         CI,R5    7                 LOST DATA
         BNE      CONT
         LI,R5    32                GET MORE SPACE; BACKSPACE TAPE
         LH,SR1   NMPG              GET 32 PAGES FIRST TIME, AND
         CI,SR1   10+32
         BL       %+2
         LI,R5    128               THE WORLD TH SECOND TIME
         STH,R5   GET:CM,R1
         CAL1,8   GET:CM
         BCS,8    ANY:PAGES         NO MORE AVAILABLE
         LW,SR1   5
SOMEPAGES EQU     %
         STW,SR2  BUF               LOWEST COMMON ADDRESS FOR BUFFER
         AH,SR1   NMPG              LEFT HALF IS NUMBER OF PAGES
         STH,SR1  NMPG
         SLS,SR1  11                BYTE SIZE OF BUF
         AI,SR1   -4                LEAVE ROOM FOR MAGIC WORD
         STW,SR1  BUFSZ
         M:PRECORD FL:TAPE,(REV)
         B        RD:USR
ANY:PAGES EQU     %
         LW,SR1   SR1
         BEZ      DONE              NO PAGES--GIVE UP
         B        SOMEPAGES
CONT     CI,R5    X'14'
         BNE      CONT2
         REF      INT
         MTW,0    INT               CHK FOR ABN 14 CAUSED BY INT
         BE       SHORT
         AI,SR1   -1                YES-REPEAT M:OPEN
         B        *SR1
CONT2    CI,R5    X'0A'             ALREADY CLOSED
         BE       *SR1
         CI,R5    X'B'
         BE       NO:GO             ERROR IN SENTINEL
         REF      ERR49,ERR55
         CI,R5    X'49'
         BE       ERR49
         CI,R5    X'55'
         BE       ERR55
         CI,R5    X'41'             READ ERR
         BNE      SHORT
DONE     EQU      %
         LCF      F:USR,R1
         BCR,2    NO:GO             DCB NOT OPEN
         M:CLOSE  F:USR,(REL)
         B        NO:GO
         SPACE    3
GOMAIL   EQU      %                 SELECT MAILBX ENTRY ON TIME CHANGE
         REF      MTIME,FMAILBX
         LW,R4    *TIMEAD
         XW,R4    MTIME
         CW,R4    MTIME
         BNE      MAILBOX           NEW TIME
         B        FMAILBX           SAME TIME
         SPACE    5
TPERR    EQU      TPABN
ENDFILE  EQU      %
         M:CLOSE  F:USR,(SAVE)
ENDFILE4 EQU      %
         LI,R4    9
         LW,R6    F:USR+22,R4       TRANSFER FILENAME TO SUCCESS
         STW,R6   SUCCESS+1,4       MESSAGE
         BDR,R4   %-2
         LB,R4    F:USR+23
         AI,R4    8
         STB,R4   SUCCESS
         LI,R4    C' '
         STB,R4   SUCCESS+2
         LI,D4    0                 NO MAILBOX FILE ENTRY
         LI,SR3   MAILSUC
         BAL,SR4  GOMAIL
ENDFILE2 EQU      %
         LW,R4    SAV:SYM           IS THERE A SYN NAME
         BEZ      ENDFILE1
ENDFILE3 EQU      %
         CAL1,1   BLNK:OPN          OPEN TO ESTABLISH SYN
         M:CLOSE  F:USR,(SAVE)      CLOSE SYN
         STW,R0   SAV:SYM           CLR SWITCH
         B        ENDFILE4          DO MSG
ENDFILE1 EQU      %
         M:CLOSE  FL:TAPE,(SAVE)
*                 IF SELFIL OF SINGLE FID,ZAP ENTRY, & CHK TABLE
         LW,R6    SELECT
         BEZ      OPN:NXT
         LW,R7    SELFID:PTR
         BEZ      OPN:NXT
         B        ZAP:DONE
         SPACE    5
USRERR   EQU      %
         LB,R5    SR3
         CI,R5    X'51'
         BE       DONE
         CI,R5    X'55'
         BE       ERR55
         BG       DONE
         LI,R6    30
         STH,R6   SLP:FPT,1
         CAL1,8   SLP:FPT
         B        DONE
**
SHORT    EQU      %                 SHORT RECORD MEANS BAD TAPE FILE
** MAILBOX FAILURE TO RECOVER FILE
         BAL,SR2  NO:RCV
         M:CLOSE  F:USR,(REL)
         M:CLOSE  FL:TAPE,(SAVE)
         M:TYPE   (MESS,BADFIL)
         B        OPN:NXT
BADTIME  EQU      %
         LI,R6    BADSEQ            FILE OUT OF SEQUENCE
         STW,R6   KADR-1            TEMP
         B        BDTP
BDTP     EQU      %
         M:KEYIN  (MESS,*KADR-1),(REPLY,YES),(SIZE,1),(ECB,ECB)
         LW,R6    ECB
         BLZ      %-1               WAIT FOR ANSWER
         LB,R6    YES,R1
         CI,R6    'C'
         BE       GO:ON
         CI,R6    'Q'
         BNE      BDTP
         M:CLOSE  FL:TAPE,(SAVE)
         B        ENDEND
NO:RCV   EQU      %                 SEND NO RECOVERY TO MAILBOX
         LI,D4    1                 WRITE MAILBOX ALSO
         B        NO:RCV1
NO:RCV2  EQU      %
         LI,D4    0                 'FOLLOW' MSG--LOG ONLY
NO:RCV1  EQU      %
         LI,R7    7
         LB,SR1   SR3,R1
         SLS,SR1  15
         LB,SR4   SR3
         STB,SR4  SR1                  CODE,SUB-CODE IN 0-15
SEND:ERR1 EQU     %
         STB,R0   SR1,R3
         SCS,SR1  4
         AI,SR1   C'0'
         LB,SR4   SR1,R3
         CI,SR4   C'9'
         BLE      %+2
         AI,SR4   -X'39'            FA-39=C1, ETC
         STB,SR4  NOMSG,R7
         AI,R7    1
         CI,R7    11
         BL       SEND:ERR1
         LI,SR1   NOMSG:FOLL-1      'FOLLOW' MSG
         LW,D4    D4
         BEZ      %+2
         LI,SR1   NOMSG:FAIL-1      'FAIL' MSG
         LI,R7    5
         LW,SR4   *SR1,R7
         STW,SR4  NOMSG+2,R7
         BDR,R7   %-2
         LI,SR3   MAILPAR
         BAL,SR4  GOMAIL
         B        *SR2
SPECERR  EQU      %
SPECABN  EQU      %
         SPACE    5
         LB,R4    SR3
         CI,R4    2
         BNE      *SR1
         LB,R4    SR3,R1            SUBCODE
         CI,R4    2                 0,1=0, 2,3=1
         BL       SPLSTEND2         END THIS ACCT
         LW,SR3   BLABL+4
         CI,SR3   -1
         BE       ENDEND2
SPPAGREL EQU      %
SKIPPING EQU      %
         LW,SR3   L(X'200000')
         CW,SR3   FL:TAPE
         BAZ      OPN:NXT           DCB ALREADY CLOSED
         M:CLOSE  FL:TAPE,(SAVE)
         B        OPN:NXT
         END      FILL

