         SYSTEM   SIG7D
SIM      SET      0
         SYSTEM   BPM
*
*
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
         SPACE    3
         DEF      DATEAD,DATE1AD,TIMEAD
         DEF      PURGE,DOPURDEL
         DEF      INT,INPROGRAN
         REF      PURGEXIT
         REF      GRANRAD,GRANPACK,GRANMIN,GRANRESET,PURGEFLAG
         REF      GRANCYL
         DEF      PURGEFLAGAD
         REF      ECB,SEL:COM,BCK:KEY,SEL:COM:BUF
         REF      ERR:RET,ERR:RET1,BSR1
         REF      SK:BL,FIND:STRG
         REF      DATE,TIME
         REF      LOCCODE1,COMPDAT,DO:REGS4
         DO       SIM
         SPACE    5                 ****************
*        ****************************************
*        FOR SIMULATION
         REF      F%BACKUP,F%PURGE
F:BACKUP EQU      F%BACKUP
F:PURGE  EQU      F%PURGE
*        *************************************************
         SPACE    5                 ************************
         ELSE
         REF      F:BACKUP,F:PURGE
         FIN
         DEF      PURABN,PURERR,PURFPAR
SUPER:CLOSE EQU   6
PURE     CSECT    1
DATA     CSECT    0
         TITLE    'PURGE--ENVIRONMENT'
         TITLE    'DCB'
PURGEDESC EQU     F:PURGE+38
PURGEFID  EQU     F:PURGE+22
PURGEACCT EQU     F:PURGE+31
         TITLE    'WORK TABLES AND MODIFIED ITEMS'
         USECT    DATA
         SPACE    4
*        THE FOLLOWING ARE CONTROL PARAMETERS THAT MAY BE VARIED TO SUIT
*          THE INDIVIDUAL INSTALLATION
         SPACE    2
         REF      SL:THRS,SL:BKUP
THRESHOLDD DATA   SL:THRS           GRANULE LEVEL FOR AUTO PURGE
BACKUPALLD DATA   SL:BKUP       IF 1, EXPIRED FILES MUST BE BACKED UP
         SPACE    5
*                    INDIRECT ADDRESSES FOR TABLES ITEMS
INDADS   EQU      %
GRANRESETAD DATA  GRANRESET
GRANMINAD DATA    GRANMIN
PURGEFLAGAD DATA  PURGEFLAG
GRANRADAD DATA    GRANRAD
GRANPACKAD DATA   GRANPACK
GRANCYLAD DATA    GRANCYL
DATEAD   DATA     DATE
DATE1AD  DATA     DATE+1
TIMEAD   DATA     TIME
NINADS   EQU      %-INDADS
SAD:FPT  DATA     7**24+GRANRAD
         DATA     0                 ADDRESS OF VIRT PAGE FOR SAD FPT
*
*                 FOLLOWING ARE ORDINARY WORK TABLES AND ITEMS
PTYPE    DATA     0                 PURGE TYPE,A-AUTO,O-OLDER,U-UNTIL
PNUM     DATA     0                 NUMBER OF GRANS TO MAKE AVAILABLE
         BOUND    8
PDATE    DATA     0,0               DATE FOR PURGE OLDER
CDATE    DATA     0,0               CURRENT DATE FOR COMPARISON
MOVE:ACCT DATA    BA(PURGEACCT)+4,8**24+BA(PURGEMESS)+13
MOVE:FID DATA     BA(PURGEFID)+5,BA(PURGEMESS1)+19
INPROGRAN DATA    0                 GRANS IN QUEUE FOR BACKUP-PURGE
INT      DATA     0                 1=ENTRY DUE TO OPERATOR 'INT'
LOGFLAG  DATA     0                 1 SAY DON'T REPEAT 'AVAILABLE'MESS
ALLFLAG  DATA     0                 1='ALL' COMMAND
AUTOFLAG DATA     0                 HHDD OF LAST AUTOPURGE
ENDAC    DATA     0                 IF 1, LAST FILE OF ACCT
MAXABN   EQU      20                MAX UNUSUAL ABNS PER ACCT
ABNCT    DATA     MAXABN
MAXABNAC EQU      5                 MAX ACCTS WITH MAX ABNS
ABNACCT  DATA     MAXABNAC
DOPURX   DATA     0                 INDIRECT FOR DOPURGE EXIT
SR3RET   DATA     0                 INDIRECT RETURN FOR SOME SR3 SBR'S
BKQX     DATA     0                 INDIRECT RETURN FOR DOPURBKQ
BACKBUF  DATA     0                 INDIRECT FOR BACKUP TABLE
PURDYN   DATA     0                 ADDRESS OF DYNAM FAGE FOR PURGE TBL
PURDYNPRE DATA    0                 BASE ADDRESS 1 ENTRY LESS PURDYN
PURDYNIX DATA     0                 INDEX OF 1ST UNUSED WORD IN DYM PG
PURIX    DATA     0                 CURRENT PURDYN IX
PURKEYIN  DATA    0,0,0,0,0,0       KEYIN INPUT BUFFER
PURFPAR  RES,4    90                FPARAM AREA
*            ***   TPY TABLE FOR BUILDING PURGE ENTRIES
ENACS    DATA     0                 ACCESS DATE-COMPRESSED
ENDSZ    DATA     0                 DESCRIPTORS-SIZE
ENACT    DATA     0,0               ACCOUNT
ENFID    DATA     0,0,0,0,0,0,0,0   FID
*            ***   END TPY TABLE
PURGEMESS TEXTC   'PURGED ACCT-         BACKED UP-MM/DD/YY:HH MOD-'
PURGEMESS1 TEXT   'MM/DD/YY:HH:MM FNE-                              -'
PURGEMESSX EQU    %                 RESET COUNT SO ABOVE LOOKS LIKE ONE
         ORG      PURGEMESS
         DATA,1   BA(PURGEMESSX)-BA(PURGEMESS)-1
         ORG      PURGEMESSX
ENTPURGE TEXTC    'ENTER PURGE COMMAND-'
GRANSAV  TEXTC    '   ,    GRANULES AVAILABLE'
GRANSIP  TEXTC    '   ,    GRANULES IN PROGRESS'
         SPACE    5
         TITLE    'CONSTANTS'
NONETEXTC TEXTC   'NONE'
NONE     TEXT     '  NONE    '
PURGETEXTC TEXTC  'PURGE'
MINTEXTC TEXTC    'MIN'
ALLTEXTC TEXTC    'ALL'
UNTILTEXTC TEXTC  'UNTIL'
OLDERTEXTC TEXTC  'OLDER'
AUTOTEXTC TEXTC   'EXPIRED FILE PURGE INITIATED'
EXPURTXT TEXTC    'DO EXPIRED FILE PURGE (Y/N)'
NEVER    TEXT     'NEVER'
BLANKS   DATA     C'    '
TEN      DATA     10
GET:DYN1 GEN,8,24 8,1               FPT-GET 1 DYNAMIC PAGE FOR SAD
FREE:VIR  GEN,1,7,24  1,5,SAD:FPT+1  FPT-FREE LAST DYN PAGE FOR SAD
GET:DYN  GEN,8,24 8,4               FPT-GET 4 DYNAMIC PAGES
FREE:DYN GEN,8,24 9,4               FPT-FREE 4 DYNAMIC PAGES
GET:COM  GEN,8,24  X'C',1           FPT-GET 1 COMMON PAGE
FREE:COM GEN,8,24  X'D',1           FPT-FREE 1 COMMON PAGE
WAKEUP   DATA     X'06000000',C'BACK',C'UP  '  WAKEUP FPT
ACCIX    EQU      %-1               INDEX SEQUENCE FOR FETCHING AND -
         DATA,1   11,4,5,6,7,8,0,10    PACKING A DATE VLP
*                  DAYS PER MONTH USED IN DATE CALCULATIONS
DAYS:MON DATA,2   0,31,28,31,30,31,30,31,31,30,31,30,31,0
         TITLE    ' FPT '
NXACT    GEN,8,7,17, X'14',X'44',F:PURGE  TEST FILE-NXTA
         DATA     X'C0000009'
         DATA     PURERR,PURABN     ABN/ERR
         DATA     X'01000001',X'01000000'    FID=NULL
         DATA     X'02010202'                ACCT
PURACT   DATA     0,0
         SPACE    3
NXFID    GEN,8,7,17  X'14',4,F:PURGE      TEST FILE-NXTF
         DATA     X'C0000400'
         DATA     PURERR,PURABN
         SPACE    3
PURADJ   GEN,8,7,17 X'14',0,F:PURGE   ADJ DCB TO SET FNE,ACCT
         DATA     X'E001',0
PURADJFID DATA    X'01000808',0,0,0,0,0,0,0,0
         DEF     PURADJ,PURADJFID
PURADJACT DATA    X'02010202',0,0
         DATA    0,0,0,0,0            ALLOW ROOM FOR PASS,PURGE
         USECT    PURE
         TITLE    'PURGE-SUBROUTINES'
         SPACE    3
PURGESETCTR EQU   %   ****
*                  RESETS GRANMIN TO COUNT TO NEXT THRESHOLD LEVEL,AND
*                   GRANRESET TO-1/4 THRESHOLD VALUE IF GRANMIN HAS
*                   PASSED FIRST THRESHOLD. LINK=SR4
         LH,D1    AUTOFLAG          IF NO AUTO, CANT BE ANY IN PROG
         BNEZ     %+2
         STW,D1   INPROGRAN
*                   NOW DO *GRANMINAD AND *GRANRESETAD
         LI,R5    X'80000'          LARGE NEGATIVE FOR 'RESET
         LW,D1    *GRANRADAD
         AW,D1    *GRANPACKAD
         BL       *SR4              NOT YET INITIALIZED
         SW,D1    THRESHOLDD
         BGEZ     SETCTR1
*                   PAST FIRST THRESHOLD
         LCW,R5   THRESHOLDD
         SAS,R5   -2                1/4
         CI,R5    -1
         BGE      SETCTR1           SOMEBODY PLAYING GAMES
         SW,D1    R5                ADD 1/4 THRESHOLD
         BLZ      %-1
SETCTR1  EQU      %
         STW,D1   *GRANMINAD
         STW,R5   *GRANRESETAD
         B        *SR4
         SPACE    5
PURGELOG EQU      %   ****
*                 TYPES NUMBER OF GRANULES AVAILABLE AND, IF ANY,
*                   NUMBER OF GRANULES IN PROGRESS
         LI,D1    1
         XW,D1    LOGFLAG
         BNEZ     *SR4              ALREADY LOGGED
         LW,SR1   *GRANRADAD        GET GRANS AVAILABLE
         AW,SR1   *GRANPACKAD
         BAL,SR3  BINTODEC          MAKE DECIMAL DDD,DDD
         STW,D4   GRANSAV+1
         LB,D4    GRANSAV
         STW,D3   GRANSAV
         STB,D4   GRANSAV
*
         M:TYPE   (MESS,GRANSAV)
*
         LW,SR1   INPROGRAN
         BEZ      *SR4              NONE IN PROGRESS
         BAL,SR3  BINTODEC
         STW,D4   GRANSIP+1
         LB,D4    GRANSIP
         STW,D3   GRANSIP
         STB,D4   GRANSIP
*
         M:TYPE   (MESS,GRANSIP)
*
         B        *SR4
         SPACE    5
BINTODEC EQU      %   ****
*                   CONVERTS SR1 TO DECIMAL DDD,DDD IN D3-D4 WITH
*                   LEADING BLANKS
         LI,R7    7                 6 DIGITS AND COMMA
         SLD,SR1  -32
         LW,D3    BLANKS
         LW,D4    BLANKS
BINDEC1  EQU      %
         CI,R7    4
         BNE      BINDEC2
         LI,SR1   C','              INSERT COMMA
         B        BINDEC3
BINDEC2  EQU      %                 DO CONVERSION
         DW,SR1   TEN
         AI,SR1   X'F0'
BINDEC3  EQU      %                 SET CHAR
         STB,SR1  D3,R7
         CI,SR2   0
         BE       *SR3
         LI,SR1   0
         BDR,R7   BINDEC1
         B        *SR3
         SPACE    5
GET:NUM  EQU      %   ****
*                 THE DECIMAL NUMBER IN SEL:COM,IX R4, IS CONVERTED TO
*                   BINARY IN D2. R4 IS STEPPED TO NON-NUMBER. EXITS
*                   VIA ERR:RET IF END IMAGE DETECTED.
         LI,D2    0
GET:NUM1 EQU      %
         LB,D1    SEL:COM,R4
         CI,D1    C','
         BE       GET:NUM2          SKIP COMMAS
         CI,D1    X'15'             NEW LINE TERMINATES STRING
         BE       *SR4
         CI,D1    C' '              BLANK TERMINATES STRING
         BE       *SR4
         CI,D1    C'0'
         BL       *ERR:RET
         CI,D1    C'9'
         BG       *ERR:RET
         MI,D2    10
         AND,D1   L(X'F')
         AW,D2    D1
GET:NUM2 EQU      %
         BIR,R4   GET:NUM1
         B        *ERR:RET
         SPACE    5
GET:ACCESS EQU    %   ****
*                 LOADS SR2 WITH THE ACCESS DATE FOUND IN PURFPAR, IN
*                   PACKED FORM- YYMMDDHH. USES SR1,R1,LOCCODE1 REGS
         LI,D4    PURFPAR
         LI,D1    X'F'
         LI,SR2   0
         BAL,R5   LOCCODE1
         B        *SR4
         LI,R6    9
         LB,SR1   *D4,R6            GET BYTES,H,H,D,D,M,M,Y,Y
         SLD,SR1  -4
         LB,R6    ACCIX,R6
         BNEZ     %-3
         LB,R6    SR2
         AI,R6    X'FFF80'          -80 IN PACKED DECIMAL TO MAKE
         STB,R6   SR2                  NUMBER ALWAYS POSITIVE
         B        *SR4
         SPACE    5
PURGEINT EQU      %
*               RECEIVES INTERRUPT AND WAKES JOB
         MTW,1    INT
         M:TRTN
         DEF      PURGEINT
         SPACE    5
DOPURDEL EQU      %
*                 DELETES THE FILE DESCRIBED IN THE M:PURGE DCB AND
*                   LOGS ITS DESCRIPTION
         STW,SR3  SR3RET
         M:OPEN   F:PURGE,(INOUT),;
                    (ABN,PURABN),(ERR,PURERR)
         M:CLOSE  F:PURGE,(REL)
         BAL,SR4  DOPURLIST
         B        *SR3RET
         SPACE    5
DOPURLIST EQU     %
*                 PRINTS PURGE MESSAGE FOR FID.ACCT IN M:PURGE DCB
         LD,R6    MOVE:ACCT         MOVE ACCT
         MBS,R6   0
*                 MOVE FID W/ TRAILING BLANKS
         LD,R6    MOVE:FID          ADDRESSES FOR MBS
         LB,D1    PURGEFID+1
         STB,D1   R7                COUNT
         MBS,R6   0                 MOVE FID
         LI,R6    32
         SW,R6    D1
         STB,R6   R7
         LW,R1    R7
         MBS,R0   BA(BLANKS)        BLANK FILL
         LI,R1    1                 RESTORE R1
*                 MOVE BACKUP DATE
         LI,D4    PURFPAR
         LI,D1    X'10'             FIND BACKUP VLP
         LI,R7    BA(PURGEMESS)+32
         BAL,R5   LOCCODE1
         LI,D4    0                 NOT FOUND
         BAL,SR3  DATE:MESS         FORMAT & MOVE DATE INTO MESSAGE
*                 THEN MODIFICATION DATE
         LW,D1    BLANKS            INITIALIZE MINUTES
         STW,D1   PURGEMESS1+2
         STH,D1   PURGEMESS1+3
         LI,R7    BA(PURGEMESS1)
         LI,D4    PURFPAR
         LI,D1    X'0A'             FIND MOD DATE VLP
         BAL,R5   LOCCODE1
         LI,D4    0
         BAL,SR3  DATE:MESS
*                                 PRINT IT
         M:PRINT  (MESS,PURGEMESS)
         B        *SR4
         SPACE    3
DATE:MESS EQU     %
*                 THE DATE VLP AT D4 IS FORMATTED MM/DD/YY:HH:MM AND
*                  MOVED INTO THE MESSAGE AT BYTE ADDRESS R7. IF VLP
*                  HAS NO DATA,'NONE' IS MOVED, IF NOT 3 WORDS,
*                 ':MM' IS OMITTED
         LB,D1    *D4,R2
         CI,D1    2
         BGE      DATE:MESS1
NODATE   LI,R6    11
         STB,R6   R7
         LI,R6    BA(NONE)
         MBS,R6   0                NO DATA
         B        *SR3
DATE:MESS1 EQU    %                 AT LEAST 2 WORDS
         AI,D4    1
         LB,D3    *D4
         STB,D3   0,R7              M
         AI,R7    1
         LB,D3    *D4,R1
         STB,D3   0,R7              MM
         AI,R7    1
         LI,D2    '/'
         STB,D2   0,R7              MM/
         AI,R7    1
         LB,D3    *D4,R2
         STB,D3   0,R7              MM/D
         AI,R7    1
         LB,D3    *D4,R3
         STB,D3   0,R7              MM/DD
         AI,R7    1
         STB,D2   0,R7              MM/DD/
         AI,R7    1
         AI,D4    1
         LB,D3    *D4,R2
         STB,D3   0,R7              MM/DD/Y
         AI,R7    1
         LB,D3    *D4,R3
         STB,D3   0,R7              MM/DD/YY
         AI,R7    1
         LI,D2    ','
         STB,D2   0,R7              MM/DD/YY,
         AI,R7    1
         LB,D3    *D4
         STB,D3   0,R7              MM/DD/YY,H
         AI,R7    1
         LB,D3    *D4,R1
         STB,D3   0,R7              MM/DD/YY,HH
         CI,D1    2
         BLE      *SR3              NO MINUTES IN VLP
         AI,D4    1
         AI,R7    1
         LI,D2    ':'
         STB,D2   0,R7              MM/DD/YY,HH:
         AI,R7    1
         LB,D3    *D4,R2
         STB,D3   0,R7              MM/DD/YY,HH:M
         AI,R7    1
         LB,D3    *D4,R3
         STB,D3   0,R7              MM/DD/YY,HH:MM
         B        *SR3              GLAD THATS DONE, I HATE THAT KIND
*                                      OF CODE
         SPACE    5
DOPURBKQ EQU      %
*                 BUILDS A BACKUP-PURGE ENTRY AND ADDS IT TO THE FRONT
*                 END OF THE 'BACKUP' RECORD,':BACKUP' FILE. ENTRY
*                 CONSISTS OF FID VLP, ACCT VLP, AND PURGE(X'1F') VLP.
         STW,SR4  BKQX              SAVE LINK
         REF      NMPG,FREI:CMN
         LH,D1    NMPG
         BEZ      %+4
         STH,D1   FREI:CMN,R1       MUST RELEASE BACKUP'S COMMON
         CAL1,8   FREI:CMN
         STW,R0   NMPG
         CAL1,8   GET:COM           GET A COMMON PAGE FOR WORKSPACE
         BCS,8    *BKQX
         STW,SR2  BACKBUF           SAVE PAGE ADDRESS FOR INDIRECT
*                 SETUP NEW ENTRY
         LW,D1    L(X'01000808')
         STW,D1   *BACKBUF
         LI,R7    8
         LW,D1    PURGEFID,R7       FID
         STW,D1   *BACKBUF,R7
         BDR,R7   %-2
*                 MOVE IN ACCT
         LI,R7    9
         LI,R6    -3
         LW,D1    PURGEACCT+3,R6
         STW,D1   *BACKBUF,R7
         AI,R7    1
         BIR,R6   %-3
         LW,D1    L(X'1F010101')    PURGE VLP
         STW,D1   *BACKBUF,R7
         LI,D4    PURFPAR
         LI,D1    X'0D'
         LI,D2    0
         BAL,R5   LOCCODE1
         B        %+2
         LH,D2    *D4,R3
         AI,R7    1
         STW,D2   *BACKBUF,R7
*                 NOW SETUP AND READ BACKUP
         LI,SR3   0
         AW,R7    BACKBUF
         AI,R7    1
         M:OPEN   F:BACKUP,(INOUT),(DIRECT),;
                    (ABN,BSR1),(ERR,BSR1)
BCKRD    EQU      %
         M:READ   F:BACKUP,(BUF,*R7),(SIZE,498*4),(KEY,BCK:KEY),;
                    (ABN,BSR1),(ERR,BSR1)
BCKWRT   EQU      %
         LI,D1    0
         LB,D2    SR3
         BEZ      BCKWRT1          NO ERROR
         CI,D2    X'43'             NO SUCH KEY
         BE       BCKWRT2
         CI,D2    7                 LOST DATA
         BNE      BCKCLS1
*                 RECORD TOO BIG-CALL USR:BCK
         M:CLOSE  F:BACKUP,(SAVE)
         BAL,SR4  USR:BCK
         REF      USR:BCK
         B        *BKQX
BCKWRT1  LH,D1    F:BACKUP+4        ARS-ACTUAL RECORD SIZE
         SLS,D1   -1
BCKWRT2  EQU      %
         AI,D1    56                NEW RECORD SIZE
*
         M:WRITE  F:BACKUP,(BUF,*BACKBUF),(SIZE,*D1),(KEY,BCK:KEY),;
                    (ONEWKEY),;
                    (ABN,BCKCLS),(ERR,BCKCLS)
BCKCLS   EQU      %
         LW,D2    -1,R7
         AWM,D2   INPROGRAN         REFLECT GRANULES IN BACKUP-PURGE
BCKCLS1  EQU      %
         M:CLOSE  F:BACKUP,(SAVE)
         CAL1,8   FREE:COM
         B        *BKQX
         TITLE    'MAIN PROGRAM--PURGE'
*                 PURGE IS ENTERRED FROM BACKUP ON EACH EXECUTION OF
*                 THE PROGRAMAND AT VARIOUS POINTS DURING
*                 BACKUP AND FILL.
*
*                 INITIALIZE
PURGE    EQU      %
         STW,SR4   PURGEXIT
         BAL,SR4   DO:REGS4
*                   CHK IF ANY THING TO DO
PURGE1   EQU      %
         MTW,0    INT
         BG       PURGESET          ENTRY DUE TO INT ACTION
         MTW,0    *GRANMINAD
         BLE      PURGESET               REACHED THRESHOLD
         MTW,0    *GRANRESETAD           REACHED THRESHOLD RESET
         BL       PURGEX            NOTHING TO DO
PURGESET EQU      %
         BAL,SR4  PURGESETCTR
         MTW,0    INT               ENTRY DUE TO 'INTERRUPT'
         BEZ      PURGE3              NO
         BAL,SR4  PURGELOG          LOG GRANS AVAILABLE
*
         M:KEYIN  (MESS,ENTPURGE),(REPLY,SEL:COM:BUF),;
                    (SIZE,40),(ECB,ECB)
         LW,R6    ECB
         BLZ      %-1               WAIT FOR INPUT
*
         STW,R0   INT               CLEAR INTERRUPT FLAG
         LI,R4    -79               INITIALIZE INDEX FOR SCAN OF INPUT
         LI,D1    PURGEKNO          SET ERROR EXIT AND SAVE PREVIOUS
         XW,D1    ERR:RET
         STW,D1   ERR:RET1
*                   DETERMINE COMMAND
         BAL,SR3  SK:BL             FIND START OF COMMAND,D1=1ST CHAR
         CI,D1    'M'               MIN,PURGE,OR (DEFAULT) NONE
         BE       PURMIN
         LI,SR2   PURGETEXTC        ASSUME 'PURGE', SBR EXITS TO NONE
         BAL,SR3  FIND:STRG           IF NOT PURGE
         BAL,SR3  SK:BL
         STW,R0   ALLFLAG
         LI,SR2   ALLTEXTC
         CI,D1    'A'
         BNE      %+3
         BAL,SR3  FIND:STRG
         STW,R1   ALLFLAG           IS 'ALL'-SET FLAG
         BAL,SR3  SK:BL
         CI,D1    'U'
         BE       PURUNTIL
         LI,SR2   OLDERTEXTC
         BAL,SR3  FIND:STRG
         BAL,SR3  SK:BL
*                   NOW,1-4 DIGIT DAYS OR COLON 2-DIGIT HOURS
         LI,D2    'O'
         STW,D2   PTYPE             PURGE TYPE IS 'OLDER'
         CI,D1    ':'
         BE       PURHRS            COLON SAYS HOURS, NONE SAYS DAYS
         BAL,SR4  GET:NUM
         MI,D2    24                CONVERT TO HOURS
         B        PUROLD
PURHRS   EQU      %
         AI,R4    1                 SKIP :
         BAL,SR4  GET:NUM
PUROLD   EQU      %                 D2=HRS FOR BACKING DATE
         LW,R5    *DATEAD           SET PDATE IN BINARY 1/2-WDS
         STW,R5   PDATE
         LW,R5    *DATE1AD
         STW,R5   PDATE+1
         LH,R5    *TIMEAD
         STH,R5   PDATE+1
         LI,R5    -4
PUROLD1  EQU      %                 NOW CONVERT 4 1/2-WDS TO BINARY
         LH,D1    PDATE+2,R5
         AND,D1   L(X'F0F')
         LB,D4    D1,R2
         MI,D4    10
         LB,D1    D1,R3
         AW,D1    D4
         STH,D1   PDATE+2,R5
         BIR,R5   PUROLD1
*                   SUBTRACT HOURS FROM PDATE--FIRST HOURS
         LH,D4    PDATE,R2          HRS
         LH,D3    PDATE,R1          DAYS
         SW,D4    D2
         BGEZ     PUROLD2
         AI,D3    -1                -1 DAY
         AI,D4    24                + 24 HRS
         B        %-3
PUROLD2  EQU      %
         STH,D4   PDATE,R2          HRS ALL SET-NOW FIX DAYS
         LH,R7    PDATE             NO
         CI,D3    1
         BGE      PUROLD4           DAY OK
PUROLD2A EQU      %
         BDR,R7   PUROLD3
         MTH,-1   PDATE,R3          MO=0,DECR YR
         AI,R7    12
PUROLD3  EQU      %
         AH,D3    DAYS:MON,R7       ADD DAYS/MO  (IGNORE LEAP YEAR)
         BL       PUROLD2A
PUROLD4  EQU      %                 UPDATE FINISHED-STORE & CONVERT
         STH,D3   PDATE,R1          DAYS
         STH,R7   PDATE             MO
*                   NOW CONVERT BACK TO BINARY
         LI,R7    -4
PUROLD5  EQU      %
         LH,D1    PDATE+2,R7
         SAD,D1   -32
         DW,D1    L(10)
         STB,D2   D1,R2
         OR,D1    L(C'00')          MAKE EBCDIC
         STH,D1   PDATE+2,R7
         BIR,R7   PUROLD5
         B        PURGEM            GO DO PURGE
         SPACE    3
PURUNTIL EQU      %
         LI,D1    'U'
         STW,D1   PTYPE             PURGE TYPE='UNTIL'
         LI,SR2   UNTILTEXTC
         BAL,SR3  FIND:STRG         VERIFY 'UNTIL'
         BAL,SR3  SK:BL
         BAL,SR4  GET:NUM           GET BINARY NUMBER
         STW,D2   PNUM              PURGE UNTIL PNUM GRANULES AVALABLE
*
*
PURGEM   EQU      %
         BAL,SR2  DOPURGE
         BAL,SR4  PURGELOG          LOG GRANS NOW AVAIL
PURGESET1 EQU     %
*                                   RESTORE ERR:RET
         LW,D1    ERR:RET1
         STW,D1   ERR:RET
         B        PURGESET
         SPACE    3
PURGEKNO EQU      %
*                  COMMAND WAS 'NONE' OR HAD AN ERROR
         M:TYPE   (MESS,NONETEXTC)
         B        PURGESET1
         SPACE    3
PURMIN   EQU      %
*                   ROUTINE TO RESET  THRESHOLD VALUE
         LI,SR2   MINTEXTC
         BAL,SR3  FIND:STRG
         BAL,SR3  SK:BL
         CI,D1    '='
         BNE      %+2
         BIR,R4   %-3               IGNORE = IN MIN COMMAND
         BAL,SR4  GET:NUM
         STW,D2   THRESHOLDD
         B        PURGESET1
         SPACE    3
PURGE3   EQU      %
         LW,D1    *GRANRADAD
         AW,D1    *GRANPACKAD
         BL       PURGEX            NOT INITIALIZED
         AW,D1    INPROGRAN
         CW,D1    THRESHOLDD        CHK IF PURGE NEEDED
         BG       PURGEX             NO-EXIT
*                   LOG GRANS AVAIL & CHK FOR AUTO-PURGE
         BAL,SR4  PURGELOG
         LW,D1    *DATEAD           DD IN RH
         LH,D2    *TIMEAD           HH
         STH,D2   D1                HHDD
         CW,D1    AUTOFLAG
         BE       PURGEX            ALREADY DID AUTO THIS HOUR
*                   CHECK IF OPERATOR WANTS EXPIRED FILE PURGE
EXPURQ   M:KEYIN  (MESS,EXPURTXT),(REPLY,SEL:COM:BUF),(SIZE,1),(ECB,ECB)
         LW,D1    ECB
         BLZ      %-1
         LB,D1    SEL:COM:BUF,R1
         CI,D1    'N'               NO--EXIT
         BE       PURGEX
         CI,D1    'Y'               YES--DO EXPIRED FILE PURGE
         BNE      EXPURQ            NEITHER-ASK AGAIN
*                   DO AUTOPURGE
         LI,D1    'A'
         STW,D1   PTYPE             PURGE TYPE = AUTO
         M:TYPE   (MESS,AUTOTEXTC)
         BAL,SR2  DOPURGE
         BAL,SR4  PURGELOG
         LW,D1    *DATEAD
         STH,D1   AUTOFLAG,R1       --DD
         LH,D1    *TIMEAD
         STH,D1   AUTOFLAG          HHDD
         B        PURGESET
         SPACE    4
*              EXIT ROUTINE
*
PURGEX   EQU      %
         STW,R0   LOGFLAG
         B         *PURGEXIT
         TITLE    'DOPURGE SUBROUTINE'
         SPACE    2
DOPURGE  EQU      %
         STW,SR2  DOPURX            SAVE EXIT
         LW,D1    *DATE1AD          SETUP CDATE FOR COMPARISONS
         STW,D1   CDATE+1
         LH,D1    *TIMEAD
         STH,D1   CDATE+1           HHYY
         LW,D1    *DATEAD
         STW,D1   CDATE             MMDD
         STW,R0   PURACT
         STW,R0   PURACT+1
         LI,SR2   MAXABN            INITIALIZE ABN COUNTS
         STW,SR2  ABNCT
         LI,SR2   MAXABNAC
         STW,SR2  ABNACCT
PURNXA   EQU      %
         STW,R0   ENDAC
         CAL1,1   NXACT             GET NEXT ACCT-IF NONE,RETURN PURABN
         LW,D1    PURGEACCT+1
         STW,D1   PURACT
         LW,D1    PURGEACCT+2
         STW,D1   PURACT+1
*                     DO NOT PURGE :SYS
         LW,D1    PURGEACCT+1
         CW,D1    L(C':SYS')
         BNE      PURNXB
         LW,D1    PURGEACCT+2
         CW,D1    L(C'    ')
         BE       PURNXA
PURNXB   EQU      %
PURNXF   EQU      %
         CAL1,1   NXFID             GET NEXT FID -ETC
*                  IF FILE IS OPEN,SKIP
         LI,D1    2
         CW,D1    PURGEDESC
         BAZ       %+2              NOT LAST FID THIS ACCT
         STW,R1   ENDAC
         LB,D1    PURGEDESC         STATUS
         BNEZ     DOPURNXT          FILE IS OPEN
         LI,D1    X'200'
         CW,D1    PURGEDESC
         BANZ     DOPURNXT          NOPURGE SET...SKIP
*                   CHK IF EXPIRED
         LI,D4    PURFPAR           VLP LIST
         LI,D1    4                 EXPIRATION CODE
         BAL,R5   LOCCODE1
         B        PURNXP            EXP NOT FOUND--VERY STRANGE
         AI,D4    1
         LW,D2    NEVER
         CW,D2    *D4
         BE       DOPURNXT
         LI,D2    CDATE
         BAL,R5   COMPDAT
         B        PURNXP
*                 EXPIRED, CHK BACKUP BITS
         LW,D2    L(X'F0000')
         CS,D2    PURGEDESC         BACKUP BITS IN DYNAMIC DESCRIPTORS
         BNE      %+3
         LW,D2    BACKUPALLD        IS BACKUP REQUIRED FOR EXPIRED
         BNEZ     PURBK               YES
         BAL,SR3  DOPURDEL
         B        DOPURNXT
PURBK    EQU      %
         BAL,SR4  DOPURBKQ          ENQUEUE FOR BACKUP AND DELETION
         SPACE    2
DOPURNXT EQU      %
         LW,D1    ENDAC
         BEZ      PURNXF            TRY NEXT FILE
         B        PURNXA            TRY NEXT ACCOUNT
PURNXP   EQU      %         UNEXPIRED
         LW,D1    PTYPE
         CI,D1    'A'
         BE       DOPURNXT          AUTOPURGE-SKIP THIS FILE
*                     SKIP IF SYNON
         LI,D4    X'4000'
         CW,D4    PURGEDESC
         BANZ     DOPURNXT
*                   CHK ACCORDING TO PURGE TYPE, 'O' OR 'U'
         CI,D1    'U'
         BE       PURGEU            'UNTIL' TYPE
*                   DO PURGE 'OLDER'
*                   COMPARE ACCESS DATE WITH PURGE DATE
         LI,D4    PURFPAR
         LI,D1    X'F'              ACCESS VLP
         BAL,R5   LOCCODE1
         B        DOPURNXT          NOT FOUND-NEVER HAPPEN
         LB,D1    *D4,R2
         BEZ      DOPURNXT          NO ACCESS DATE SET
         LI,D2    PDATE
         AI,D4    1
         BAL,R5   COMPDAT
         B        DOPURNXT          ACCESS SINCE PURGE DATE
*                   PURGE IF BACKED UP OR,IF 'ALL',PURGE IF NOBACK UP
*                     SET OR ENQUEUE FOR BACKUP-PURGE IF NOBACKUP=0
         LW,D2    L(X'F0000')
         CS,D2    PURGEDESC         BACKUP FLAGS
         BNE      PURPUR            BACKED UP--ZAP IT
         LW,D1    ALLFLAG
         BEZ      DOPURNXT          NOT BACKED, NOT AN 'ALL'--SKIP IT
         LI,D1    X'800'
         CW,D1    PURGEDESC
         BAZ      PURENQ            ENQUEUE FOR BACKUP-PURGE
         SPACE    1
PURPUR   EQU      %
         BAL,SR3  DOPURDEL          ZAP IT
         B        DOPURNXT
         SPACE    1
PURENQ   EQU      %
         BAL,SR4  DOPURBKQ          ENQUEUE FOR BACKUP-PURGE
         B        DOPURNXT
         SPACE    3
PURGEU   EQU      %
*                   DO PURGE 'UNTIL'
         LW,D2    L(X'F0000')
         CS,D2    PURGEDESC         BACKUP FLAGS
         BNE      %+3
         LW,D2    ALLFLAG
         BEZ      DOPURNXT          NOT BACKED, NOT AN 'ALL'--SKIP IT
*                   MERGE INTO PURGE TABLE
         LW,SR2   PURDYN
         BNEZ     PURDOENT
         CAL1,8   GET:DYN
         BCR,8    PURSPG
         LI,D1    'A'               NO DYNAMIC PAGES-DO AUTO
         STW,D1   PTYPE
         B        DOPURNXT
PURSPG   EQU      %
         STW,SR2  PURDYN
         AI,SR2   -12
         STW,SR2  PURDYNPRE         ADDRESS TO REFERENCE PREVIOUS ENTRY
         STW,R0   PURDYNIX
PURDOENT EQU      %
         LW,R7    PURDYNIX
         CI,R7    2040
         BL       PURMOVENT
*                   TABLE IS FULL-CHK IF THIS FID OLDER
         BAL,SR4  GET:ACCESS
         AI,R7    -12               IX OF LAST ENTRY
         CW,SR2   *PURDYN,R7
         BGE      DOPURNXT          TABLE ENTRY IS OLDER
*                                   REPLACE ENTRY
PURMOVENT EQU     %
         BAL,SR4  GET:ACCESS
         STW,SR2  ENACS
*                   GET DYNAM & STAT DESC AND SIZE
         LI,D4    PURFPAR
         LI,D1    X'D'              SIZE
         BAL,R5   LOCCODE1
         B        DOPURNXT
         LW,SR2   *D4,R1
         LW,SR1   PURGEDESC
         SLS,SR1  -8
         STH,SR1  SR2
         STW,SR2  ENDSZ
*               MOVE ACCT AND FID
         LCI      2
         LM,SR1   PURGEACCT+1
         STM,SR1  ENACT
         LCI      8
         LM,SR1   PURGEFID+1
         STM,SR1  ENFID
         AI,R7    12
         STW,R7   PURDYNIX          SAVE NEW INDEX
*               NOW SORT TABLE ON INCREASING ACCESS DATE
PURSORT  EQU      %
         AI,R7    -12               STEP TO PRECEEDING ENTRY
         BEZ      PURMERGE          TOP OF TABLE
         LW,D1    ENACS             ACCESS DATE
         CW,D1    *PURDYNPRE,R7
         BGE      PURMERGE          FOUND SLOT
*                  SHOVE ENTRY DOWN
         LCI      12
         LM,SR1   *PURDYNPRE,R7
         STM,SR1  *PURDYN,R7
         B        PURSORT
*              MOVE IN NEW ENTRY
PURMERGE EQU      %
         LCI      12
         LM,SR1   ENACS
         STM,SR1  *PURDYN,R7
*                 RESTORE R0-R3
         LI,R0    0
         LI,R1    1
         LI,R2    2
         LI,R3    3
         B        DOPURNXT            NEXT!
         SPACE    5
*              ABN/ERR ROUTINE - PRIMARILY TO DETECT 'NO MORE ACCTS'
PURABN   EQU      %
PURERR   EQU      %
*
         SLS,SR3  -17
         CI,SR3   X'101'            END ACCTS CODE
         BE       PURCHTY            YES
         CI,SR3   X'100'            NOMORE FILES THIS ACCT--SHOULDNT BE
         BE       PURNXA
         SLS,SR3  -7
         CI,SR3   X'A'              CLOSED A CLOSED DCB-IGNORE
         BE       *SR1
         CI,SR3   3                 NON-EXISTENT FILE
         BE       *SR3RET
         CI,SR3   X'2E'             ALREADY OPEN
         BNE      PURABN1
         M:CLOSE  F:PURGE
         B        DOPURABC
PURABN1  EQU      %
         CI,SR3   X'55'             SYSTEM OVERLOAD
         BNE      DOPURABC          CHK ABN LOOP
         M:WAIT   50                WAIT A MINUTE & TRY AGAIN
         AI,SR1   -1
         B        *SR1
DOPURABC EQU      %                 CHK FOR POSSIBLE ABN LOOP
         MTW,-1   ABNCT
         BG       DOPURNXT
         LI,SR3   MAXABN            RESET CTR AND GO TO NXT ACCT
         STW,SR3  ABNCT
         MTW,-1   ABNACCT
         BG       PURNXA
         B        DOPUROUT          TOO MUCH TRUBL--GET OUT
         SPACE    3
PURCHTY  EQU      %
         LW,D1    PTYPE
         CI,D1    'U'
         BNE      DOPUROUT          NOT 'UNTIL' SO IS DONE
*               PROCESS PURGE TABLE
         LW,D1    PURDYN
         BEZ      DOPUROUT          IF NO PAGES,FOUND NONE TO PURGE
         LI,R7    -12
PURUN    EQU      %
         AI,R7    12
         STW,R7   PURIX
         CW,R7    PURDYNIX
         BGE      DOPUROUT          NO MORE ENTRIES
*               MOVE FID & ACCT INTO DCB
         AI,R7    2                 START OF ACCT
         LCI      2
         LM,SR1   *PURDYN,R7        ACCT
         STM,SR1  PURADJACT+1
         AI,R7    2
         LCI      8
         LM,SR1   *PURDYN,R7        FNE
         STM,SR1  PURADJFID+1
         CAL1,1   PURADJ            ADJUST DCB
*               CHK WHETHER BACKED UP
         AI,R7    -3
         LW,D2    L(X'F000000')
         CS,D2    *PURDYN,R7
         BNE      PURDEL            IS BACKED
         LW,D2    L(X'80000')
         CW,D2    *PURDYN,R7
         BANZ     PURDEL            'NOBACKUP' IS SET
*               ENQUEUE FOR BACKUP-PURGE
         BAL,SR4  DOPURBKQ
         B        PURTHRU
*               DELETE FILE
PURDEL   EQU      %
         BAL,SR3  DOPURDEL
*              CHECK IF ANY MORE NECESSARY
PURTHRU  EQU      %
         LW,R7    PURIX
         LW,D1    INPROGRAN
         AW,D1    *GRANRADAD
         AW,D1    *GRANPACKAD
         CW,D1    PNUM
         BL       PURUN             NEED MORE
*               PURGE COMPLETED
DOPUROUT EQU      %
         CAL1,9   SUPER:CLOSE       CLOSE SYMBIONTS
         STW,R0   LOGFLAG           PERMIT LOG
         LW,D1    *DATEAD           SET PURGE TIME
         STW,D1   AUTOFLAG
         LH,D1    *TIMEAD
         STH,D1   AUTOFLAG          HHDD
*               RELEASE DYNAM PAGE, IF ANY
         LI,D1    0
         XW,D1    PURDYN
         BEZ      %+2
         CAL1,8   FREE:DYN
         B        *DOPURX
         SPACE    3
*                    ROUTINE TO OBTAIN ACCESS TO TABLES
*                      AND SET THE VIRTUAL ADDRESSES
DO:TABLES:ADS  EQU  %
         DEF      DO:TABLES:ADS
         CAL1,8   GET:DYN1
         STW,SR2  SAD:FPT+1
         CAL1,8   FREE:VIR
         CAL1,8   SAD:FPT
         LI,SR3   X'1FE00'
         AND,SR3  INDADS
         LW,SR1   SAD:FPT+1
         SW,SR1   SR3
         LI,R5    NINADS
         AWM,SR1  INDADS-1,R5
         BDR,R5   %-1
         LW,SR1   SAD:FPT+1
         LI,SR2   X'1FE00'
         CS,SR1   TIMEAD
         BE       *SR4
         LI,R5    X'200'
         AWM,R5   SAD:FPT+1
         AWM,R5   SAD:FPT
         CAL1,8   GET:DYN1
         CAL1,8   FREE:VIR
         CAL1,8   SAD:FPT
         B        *SR4
         END

