         SYSTEM   SIG7D
*
*
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      9
SR3      EQU      10
SR4      EQU      11
D1       EQU      12
D2       EQU      13
D3       EQU      14
D4       EQU      15
         PAGE
*
*        ALL DEFS IN PURGE FOLLOW
*
         DEF      DATEAD,DATE1AD,TIMEAD
         DEF      PURGE,PURGEP,PURGED
         DEF      INT,BADCOM,PURGEFLAGAD
         DEF      PURABN,PURERR,PURFPAR
         DEF      DOPURLIST,PURADJ,PURADJFID
         DEF      PURGEINT,DOPURDEL,BINTODEC
         DEF      GRANPACKAD,GRANRADAD
*
*        ALL REFS IN PURGE FOLLOW
*
         REF      GRANRAD,GRANPACK,GRANMIN
         REF      GRANRESET,PURGEFLAG,SLP:FPT
         REF      PURGEXIT,SEL:COM,LASTACCT
         REF      SEL:COM:BUF,ERR:RET,ERR:RET1
         REF      SUSPACCT,TYPE,KEYIN
         REF      ADJ:ACCT,SK:BL,FIND:STRG
         REF      DATE,TIME,F:EO
         REF      F:EI,MAILBOX,LASTRUN
         REF      NXACCT,MAIL:AC,MTIME
         REF      FMAILBX,LOCCODE1,COMPDAT
         REF      DO:REGS4,DEBUG,FPAR
         REF      SUSPNDED,SL:THRS,SL:BKUP
         REF      AUTOBACK,LASTREEL,TAPETYP
         REF      USERBKUP,SQMOUNT,BLDMAIL
         REF      OCDISP,PURGTAP,ENDTAPE
         REF      NOTAPFG,YESFL,SELFILL
         REF      SAVEALL,SQUIRREL,INCRMNTL
         REF      QUIT,SUSPEND,RESTART
         REF      HI,LOW,WRT:SAV
         REF      TAPETYPE,EI:DESC
PURGEDESC  EQU    EI:DESC
PURGEFID   EQU    F:EI+22
PURGEACCT  EQU    F:EI+31
SUPER:CLOSE EQU   6
PURE     CSECT    1
DATA     CSECT    0
         TITLE    'WORK TABLES AND MODIFIED ITEMS'
         USECT    DATA
*
*        THE FOLLOWING ARE CONTROL PARAMETERS THAT MAY BE VARIED TO SUIT
*          THE INDIVIDUAL INSTALLATION
*
PURGED   RES      0
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
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:FID DATA     BA(PURGEFID)+5,BA(PURGMSG)+28
INT      DATA     0                 1=ENTRY DUE TO OPERATOR 'INT'
ALLFLAG  DATA     0                 1='ALL' COMMAND
AUTOFLAG DATA     0                 HHDD OF LAST AUTOPURGE
ENDAC    DATA     0                 IF 1, LAST FILE OF ACCT
PURALLX  DATA     0                 IF 1, PURGE ALL EXPIRED FILES
EXPIRCNT  DATA    0                 CNT OF EXPIRED FILES DELETED
FCNT     DATA     0                 FILE CNT OF TOTAL FILES PURGED ON TAPE
EXPIRFG  DATA     0                 NONZERO--PURGE ONLY EXPIRED FILES
LOGGED   PZE
DYNBYT   DATA     2040              NO. BYTES FOR GETTING PGS
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
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
PURFPAR  RES,4    90                FPARAM AREA
COMBUF   RES      20
CBUFEND  EQU      %
*            ***   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
PURGMSG  TEXTC    '    ON DDLD PURGED FILE    '
         TEXT     '                                '
MAILFPT  DATA     PURGMSG
         DATA     PURGEACCT+1       ADDR. OF ACCT NO
PURGEMESSX EQU    %                 RESET COUNT SO ABOVE LOOKS LIKE ONE
         ORG      PURGMSG
         DATA,1   BA(PURGEMESSX)-BA(PURGMSG)-1
         ORG      PURGEMESSX
ENTPURGE TEXTC    'PURGE COMMAND? '
GRANSAV  TEXTC    'CURRENT THRESHOLD =        ;';
                  ,' CURRENT GRANULES =        '
         TITLE    'CONSTANTS'
COMMSG   TEXTC    'FILL COMMAND? '
         BOUND    8
DSMTMBS  DATA     BA(COMBUF)+1
         GEN,8,24 4,BA(DSMTXT)
CURGMBS  DATA     D3*4              BINTODEC LOADS D3-D4
         GEN,8,24 8,BA(GRANSAV)+48
THRESMBS DATA     D3*4
         GEN,8,24 8,BA(GRANSAV)+20
NEWTHMBS DATA     D3*4
         GEN,8,24 8,BA(NEWTHMSG)+16
SYSTEXT  TEXT     ':SYS    '
BADCMSG  TEXTC    'EH? '
DSMTXT   TEXT     'DISM'
XFFFF    DATA     X'FFFF'
COMEXIT  PZE                        RETURN ADDRESS FROM GETCOM
NONE     TEXT     'NONE'
NONETEXTC TEXTC   'NONE'
PURGETEXTC TEXTC  'PURGE'
MINTEXTC TEXTC    'MIN'
ALLTEXTC TEXTC    'ALL'
UNTILTEXTC TEXTC  'UNTIL'
OLDERTEXTC TEXTC  'OLDER'
XTXT     TEXTC    'X'
NEWTHMSG TEXTC    'NEW THRESHOLD =        '
THEXCEED TEXTC    'CURRENT AVAILABLE GRANULES IS BELOW THRESHOLD'
REELTXT  TEXTC    'CURRENT REEL NUMBER = '
TYPETXT  TEXTC    'DEVICE TYPE = '
USERBTXT TEXTC    'USER-INITIATED BACKUP IS '
SQTXT    TEXTC    'USER-INITIATED BACKUP TAPES ARE '
USERMAIL TEXTC    'MAILBOXES IN USER''S ACCOUNTS ARE '
OCTXT    TEXTC    'OPERATOR''S CONSOLE DISPLAY IS '
PURGTXT1 TEXTC    'PURGED FILES ARE NOT SAVED TO TAPE'
PURGTXT2 TEXTC    'ALL PURGED FILES ARE SAVED TO TAPE'
PURGTXT3 TEXTC    'ONLY UPDATED PURGED FILES ARE SAVED TO TAPE'
DITABLE  EQU      %
         DATA     0
         DATA     BA(REELTXT)
         DATA     BA(TYPETXT)
         DATA     BA(USERBTXT)
         DATA     BA(SQTXT)
         DATA     BA(USERMAIL)
         DATA     BA(OCTXT)
PURGMSGS DATA     BA(PURGTXT1)
         DATA     BA(PURGTXT2)
         DATA     BA(PURGTXT3)
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
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:EI      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:EI      TEST FILE-NXTF
         DATA     X'C0000400'
         DATA     PURERR,PURABN
         SPACE    3
PURADJ   GEN,8,7,17   X'14',0,F:EI     ADJ DCB TO SET  FNE,ACCT
         DATA     X'E001',0
PURADJFID DATA    X'01000808',0,0,0,0,0,0,0,0
PURADJACT DATA    X'02010202',0,0
         DATA    0,0,0,0,0            ALLOW ROOM FOR PASS,PURGE
         SPACE    2
PURGEOPN GEN,8,24 X'14',F:EI
         DATA     X'C1000000'
         DATA     PURERR
         DATA     PURABN
         DATA     4
         SPACE    2
PURGECLS GEN,8,24 X'15',F:EI
         PZE      *0
         DATA     1
         SPACE    2
CLSPURGE GEN,8,24 X'15',F:EI
         DATA     0
         SPACE    2
WAITONE  GEN,8,24 X'F',50
         PAGE
         USECT    PURE
PURGEP   EQU      %
*
*        BAL,SR4  PURGESETCTR
*
*                  RESETS GRANMIN TO COUNT TO NEXT THRESHOLD LEVEL,AND
*                   GRANRESET TO-1/4 THRESHOLD VALUE IF GRANMIN HAS
*                   PASSED FIRST THRESHOLD. LINK=SR4
*
PURGESETCTR EQU   %
         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      %
         MTW,0    DEBUG
         BNEZ     *SR4
         STW,D1   *GRANMINAD
         STW,R5   *GRANRESETAD
         LCW,R5   R5
         STW,R5   THRESHOLDD        SET THE NEW THRESHOLD INTERNALLY
         B        *SR4
         PAGE
*
*        BAL,SR4  PURGELOG
*
*        INPUT:   NONE
*        OUTPUT:  CURRENT THRESHOLD AND GRANULE COUNT TO OC
PURGELOG EQU      %
         LW,SR1   *GRANRADAD
         AW,SR1   *GRANPACKAD
         BAL,SR3  BINTODEC
         LD,R4    CURGMBS           MOVE CURRENT GRAN COUNT TO MESSAGE
         MBS,R4   0
         LW,SR1   THRESHOLDD        GET CURRENT THRESHOLD
         BAL,SR3  BINTODEC
         LD,R4    THRESMBS
         MBS,R4   0                 CURRENT THRESHOLD TO MESSAGE
         LI,R5    GRANSAV
         CAL1,2   TYPE              PRINT ON OC
         B        *SR4
         PAGE
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
         PAGE
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
         BLE      *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
         PAGE
GET:ACCESS EQU    %   ****
*                 LOADS SR2 WITH THE ACCESS DATE FOUND IN PURFPAR, IN
*                   PACKED FORM- YYMMDDHH. USES SR1,R1,LOCCODE1 REGS
         LI,D4    FPAR
         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
         CAL1,9   5                 M:TRTN
         PAGE
GETCOM0  EQU      %
         STW,SR4  COMEXIT           SAVE EXIT ADDRESS
GETCOM   EQU      %
         LI,R5    COMMSG
         LI,R6    COMBUF
         LI,R7    79
GETCOM1  CAL1,2   KEYIN
         LB,R7    COMBUF
         LB,R8    COMBUF,R7
         CI,R8    X'15'             MUST TERMINATE WITH N/L
         BNE      GETCOM
         CI,R7    1
         BLE      COMX              RETURN TO INTERRUPTED TASK
         LW,R8    COMBUF
         SLS,R8   8
         SLS,R8   -16
         LI,R7    COMTBLSZ
GETCOM2  EQU      %
         LH,R9    COMTABLE,R7
         AND,R9   XFFFF
         CW,R8    R9
         BE       COMVECT,R7
         BDR,R7   GETCOM2
BADCOM   EQU      %
         LI,R5    BADCMSG
         LI,R6    COMBUF
         LI,R7    79
         B        GETCOM1
GOGETCOM BAL,R5   WRT:SAV
         B        GETCOM
*
COMTABLE EQU      %
         GEN,16,16 0,'QU'
         TEXT,2   'SU','MO','DI','PU','RE','BE','SE','ST'
COMTBLSZ EQU      HA(%)-HA(COMTABLE)-1
*
         BOUND    4
COMVECT  NOP
         B        QUIT
         B        SUSPEND
         B        MOUNTUB
         B        DITYPE            (DISPLAY OR DISMOUNT)
         B        PURGSTRT
         B        RESTART
         B        BEGIN
         B        SET
         B        STATUS
*
COMX     EQU      %
         STW,R0   INT               CLEAR THE BREAK
         B        *COMEXIT          RETURN TO INTERRUPTED TASK
         PAGE
DITYPE   EQU      %
         LD,R4    DSMTMBS
         CBS,R4   0
         BE       DISMOUNT
         BAL,R5   SKP:FLD           GET NEXT FIELD
         B        DISPALL           NO NEXT FIELD => ALL
         BAL,R5   SKP:BL
         B        DISPALL
         CI,R9    'A'
         BE       DISPALL
         SLS,R9   8
         AI,R7    1
         LB,R8    CBUFEND,R7
         STB,R8   R9,R3
         LI,SR4   GETCOM            EXIT FROM DISP ROUTINES IS *SR4
DITYPE1  EQU      %
         BAL,R5   FINDSET
         B        BADCOM
         CI,R6    DISPSIZ           PURGE MESSAGES ARE SPECIAL
         BE       PURGEMSG
         LI,R5    BA(COMBUF)+1
         LW,R4    DITABLE,R6        SOURCE STRING
         LB,R8    0,R4
         STB,R8   R5
         MBS,R4   1
         B        FINDISP,R6        GET REST OF MESSAGE
*
DISPALL  EQU      %
         LI,R6    1
DISPALL1 EQU      %
         LH,R9    SETTABLE,R6
         AND,R9   XFFFF
         BAL,SR4  DITYPE1
         AI,R6    1
         CI,R6    DISPSIZ
         BLE      DISPALL1
         B        GETCOM
*
FINDISP  EQU      %
         DATA     0
         B        REELMSG
         B        TYPEMSG
         B        USERBMSG
         B        SQTAPMSG
         B        MAILMSG
         B        OCDIMSG
         B        PURGEMSG
DISPSIZ  EQU      %-FINDISP-1
         BE       BEGIN2
SET      EQU      %
         LI,R6    SET2              RETURN ADDRESS
SET1     EQU      %
         BAL,R5   SKP:FLD
         B        BADCOM            NEEDS A SECOND FIELD
         CI,R9    '='
         BE       BADCOM            NEED THAT SECOND FIELD FIRST
         BAL,R5   SKP:BL
         B        BADCOM            NO SECOND FIELD HERE EITHER
         SLS,R9   8
         AI,R7    1
         LB,R8    CBUFEND,R7
         STB,R8   R9,R3
         B        0,R6
SET2     EQU      %
         BAL,R5   FINDSET
         B        BADCOM            NO SUCH ANIMAL
SET3     EQU      %
         BAL,R5   SKP:FLD1          LOOK FOR THE '='
         B        BADCOM            NOT THERE => ERROR
         CI,R9    X'40'
         BNE      SET4              IF NOT BLANK, MUST BE '='
         BAL,R5   SKP:BL            SKIP INTERVENING BLANKS
         B        BADCOM
         B        SET3              LOOK FOR THAT '='
SET4     EQU      %
         AI,R7    1                 BUMP PAST THE '='
         BAL,R5   SKP:BL            GET THE NEXT FIELD
         B        BADCOM            ALL BLANKS FOLLOW TO N/L
         B        SETVECT,R6
*
SETVECT  EQU      %
         DATA     0
         B        REELCHG
         B        TYPECHG
         B        USERBCHG
         B        SQMTCHG
         B        MAILCHG
         B        OCDICHG
         B        PURGCHG
         PAGE
BEGIN    EQU      %
         BAL,R6   SET1              GET TWO CHARACTER OPTION IN R9
*                                    ERRORS IN SET GO TO BADCOM.
         LI,R6    BGNTBLSZ
BEGIN1   EQU      %
         LH,R10   BGNTBL,R6
         AND,R10  XFFFF
         CW,R9    R10
         BE       BEGIN2
         BDR,R6   BEGIN1
         B        BADCOM
BEGIN2   EQU      %
         LW,R7    LASTRUN           CHECK TO SEE IF ALREADY ACTIVE
         BEZ      BEGIN3
         LD,R4    TAPETYPE,R7       GET NAME OF ACTIVE PROCESS
         AI,R5    -BA(FPAR)+BA(COMBUF)
         MBS,R4   1
         LI,R4    BA(ACTIVTXT)
         LB,R8    0,R4
         STB,R8   R5
         MBS,R4   1
         B        TYPEIT            TELL THE GUY WHAT'S ACTIVE
BEGIN3   EQU      %
         STW,R0   INT               CLEAR THE BREAK
         B        BGNVECT,R6
*
BGNVECT  DATA     0
         B        SAVEALL
         B        SQUIRREL
         B        INCRMNTL
         B        PURGSTRT
         B        YESFL
         B        SELFILL
*
BGNTBL   EQU      %
         GEN,16,16 0,'SA'
         TEXT     'SQ','IN','PU','FI'
         DATA,2   X'E2C5'
BGNTBLSZ EQU      HA(%)-HA(BGNTBL)-1
*
ACTIVTXT TEXTC    ' IS CURRENTLY ACTIVE - MUST QUIT OR SUSPEND'
         PAGE
         BOUND    4
REELMSG  EQU      %
         LI,R4    4
         STB,R4   R5
         LI,R4    BA(LASTREEL)
         MBS,R4   0
*
TYPEIT   AI,R5    -BA(COMBUF)-1
         STB,R5   COMBUF
         LI,R5    COMBUF
         CAL1,2   TYPE
         B        *SR4
*
REELCHG  EQU      %
         LW,R4    NOTAPFG
         BEZ      REELCHG1
         LI,R5    NOTNOW            CAN'T CHANGE WHEN ALREADY MOUNTED
         CAL1,2   TYPE
         B        GETCOM
REELCHG1 EQU      %
         LI,R4    3
REELCHG3 EQU      %
         SLS,R9   8
         AI,R7    1
         LB,R8    CBUFEND,R7
         STB,R8   R9,R3
         BDR,R4   REELCHG3
*
         BAL,R5   CHKREEL           VERIFY FORMAT OF REEL #
         B        BADCOM
         STW,R9   LASTREEL
         B        GOGETCOM
*
NOTNOW   TEXTC    'COMMAND NOT LEGAL WHEN TAPE IS ALREADY MOUNTED'
*
TYPEMSG  EQU      %
         LI,R4    BA(TAPETYP)
         STB,R2   R5
         MBS,R4   2
         B        TYPEIT
*
TYPECHG  EQU      %
         SLS,R9   8
         AI,R7    1
         LB,R8    CBUFEND,R7
         STB,R8   R9,R3
         STW,R9   TAPETYP
         B        GOGETCOM
*
USERBMSG EQU      %
         LW,R4    USERBKUP
         BLZ      *SR4              SHOULDN'T HAPPEN
         CI,R4    1
         BG       *SR4              SHOULDNT HAPPEN
         LW,R4    USERBTBL,R4       GET APPROPRIATE FINISHING TEXT
         LB,R8    0,R4
         STB,R8   R5
         MBS,R4   1
         B        TYPEIT
*
USERBTBL DATA     BA(NALLOWD)
         DATA     BA(IALLOWD)
*
NALLOWD  TEXTC    'NOT ALLOWED'
IALLOWD  TEXTC    'ALLOWED'
*
USERBCHG EQU      %
         LI,R4    1
         CI,R9    'Y'
         BE       USBCHG2
         BDR,R4   %+1
         CI,R9    'N'
         BNE      BADCOM
USBCHG2  EQU      %
         STW,R4   USERBKUP
         MTW,0    NOTAPFG
         BEZ      GOGETCOM
         LW,R4    USERBKUP
         BNEZ     GOGETCOM          IF = 1, LEAVE TAPE ALONE
         BAL,SR4  ENDTAPE
         B        GOGETCOM
*
SQTAPMSG EQU      %
         LW,R4    SQMOUNT
         BLZ      *SR4              SHOULDN'T HAPPEN
         CI,R4    1
         BG       *SR4              SHOULDN'T HAPPEN
         LW,R4    SQTAPTBL,R4
         LB,R8    0,R4
         STB,R8   R5
         MBS,R4   1
         B        TYPEIT
*
SQTAPTBL DATA     BA(DSMNTED)
         DATA     BA(MOUNTED)
*
DSMNTED  TEXTC    'DISMOUNTED AFTER EACH CALL'
MOUNTED  TEXTC    'LEFT MOUNTED'
*
SQMTCHG  EQU      %
         LI,R4    1
         CI,R9    'Y'
         BE       SQMTCHG2
         BDR,R4   %+1
         CI,R9    'N'
         BNE      BADCOM
SQMTCHG2 EQU      %
         STW,R4   SQMOUNT
         CI,R4    0
         BNE      GOGETCOM          LEAVE IT MOUNTED
         BAL,SR4  ENDTAPE
         B        GOGETCOM
*
MOUNTUB  EQU      %
         LI,R4    1                 SET TO LEAVE SQ TAPE MOUNTED
         B        SQMTCHG2
*
DISMOUNT EQU      %
         LI,R4    0                 SET TO DISMOUNT SQ TAPE
         B        SQMTCHG2
*
MAILMSG  EQU      %
         LW,R4    BLDMAIL
         BLZ      *SR4              SHOULDN'T HAPPEN
         CI,R4    1
         BG       *SR4              YOU SHOULD KNOW BY NOW
         LW,R4    MAILTBL,R4
         LB,R8    0,R4
         STB,R8   R5
         MBS,R4   1
         B        TYPEIT
*
MAILTBL  DATA     BA(NOTBLT)
         DATA     BA(AREBLT)
*
NOTBLT   TEXTC    'NOT BUILT'
AREBLT   TEXTC    'BUILT'
*
MAILCHG  EQU      %
         LI,R4    1
         CI,R9    'Y'
         BE       MAILCHG2
         BDR,R4   %+1
         CI,R9    'N'
         BNE      BADCOM
MAILCHG2 EQU      %
         STW,R4   BLDMAIL
         B        GOGETCOM
*
OCDIMSG  EQU      %
         LW,R4    OCDISP
         BLZ      *SR4
         CI,R4    1
         BG       *SR4
         LW,R4    OCDITBL,R4
         LB,R8    0,R4
         STB,R8   R5
         MBS,R4   1
         B        TYPEIT
*
OCDITBL  DATA     BA(DISPOFF)
         DATA     BA(DISPON)
*
DISPOFF  TEXTC    'TURNED OFF'
DISPON   TEXTC    'TURNED ON'
*
OCDICHG  EQU      %
         LI,R4    1
         CI,R9    'Y'
         BE       OCDICHG2
         BDR,R4   %+1
         CI,R9    'N'
         BNE      BADCOM
OCDICHG2 EQU      %
         STW,R4   OCDISP
         B        GOGETCOM
*
PURGEMSG EQU      %
         AW,R6    PURGTAP
         BLZ      *SR4
         CI,R6    DISPSIZ+2
         BG       *SR4
         LW,R4    DITABLE,R6
         LI,R5    BA(COMBUF)+1
         LB,R8    0,R4
         STB,R8   R5
         MBS,R4   1
         B        TYPEIT
*
PURGCHG  EQU      %
         LI,R4    2
         CI,R9    'S'
         BE       PURGCHG2
         BDR,R4   %+1
         CI,R9    'O'
         BE       PURGCHG2
         BDR,R4   %+1
         CI,R9    'N'
         BNE      BADCOM
PURGCHG2 EQU      %
         STW,R4   PURGTAP
         MTW,0    NOTAPFG
         BEZ      GOGETCOM
         MTW,0    PURGTAP
         BNEZ     GOGETCOM
         LW,R4    LASTRUN
         CI,R4    4                 IS A PURGE RUNNING NOW?
         BNE      GOGETCOM           NO, LEAVE TAPE ALONE
         BAL,SR4  ENDTAPE
         B        GOGETCOM
         PAGE
DOPURDEL EQU      %
*                 DELETES THE FILE DESCRIBED IN THE F:EI DCB AND
*                   LOGS ITS DESCRIPTION
         STW,SR3  SR3RET
         MTW,0    DEBUG
         BNEZ     %+3
         CAL1,1   PURGEOPN
*                 ERR,ABN= PURERR,PURABN; INOUT
         CAL1,1   PURGECLS
         LW,SR4   LOGGED            HAS ACTION BEEN LOGGED YET?
         BNEZ     *SR3RET           YES, BACKUP LOGGED IT
         BAL,SR4  DOPURLIST         FILE WAS NOT SAVED, MUST LOG
         B        *SR3RET
         PAGE
*
*        BAL,R5   SKP:FLD           START AT BEGINNING OF COMBUF
*            * OR *
*        BAL,R5   SKP:FLD1          BUFFER POINTER IN R7 ALREADY
*
*        INPUT:   R7 <= NEGATIVE INDEX INTO COMBUF (OPTIONAL)
*        OUTPUT:  R7 <= NEGATIVE INDEX TO FIRST BLANK OR '='
*                  FOLLOWING THE INPUT STRING. EXITS SKIPPING
*                 * OR *
*                 EXITS NORMALLY IF (N/L) DETECTED BEFORE A BLANK.
*
*        USES:    R7,R9
*
SKP:FLD  EQU      %
         LI,R7    -79               SKIP THE COUNT IN BYTE 1
SKP:FLD1 EQU      %
         LB,R9    CBUFEND,R7
         CI,R9    X'40'
         BE       1,R5
         CI,R9    '='
         BE       1,R5
         CI,R9    X'15'
         BE       0,R5
         BIR,R7   SKP:FLD1
         B        BADCOM
         PAGE
*
*        BAL,R5   SKP:BL
*
*        INPUT:   R7 <= NEGATIVE INDEX OF BLANK IN COMBUF
*        OUTPUT:  R7 <= NEGATIVE INDEX OF NEXT NON-BLANK IN COMBUF
*                  EXITS SKIPPING UNLESS (N/L) DETECTED FIRST;
*                   THEN EXIT IS NORMAL, IE TO CALL + 1
*
SKP:BL   EQU      %
         LB,R9    CBUFEND,R7
         CI,R9    X'15'
         BE       0,R5
         CI,R9    X'40'
         BNE      1,R5
         BIR,R7   SKP:BL
         B        BADCOM
*
*        BAL,R5   CHKREEL
*
*        INPUT:   R9 <= REEL NUMBER TO BE CHECKED
*        OUTPUT:  EXITS SKIPPING IF OK, NORMALLY OTHERWISE
*        USES:    R4,R8
*
CHKREEL  EQU      %
         LI,R4    -4
CHKREEL1 EQU      %
         LB,R8    R10,R4
         CB,R8    LOW,R4
         BL       0,R5
         CB,R8    HI,R4
         BG       0,R5
         BIR,R4   CHKREEL1
         B        1,R5
         PAGE
*
*        BAL,R5   FINDSET
*
*        INPUT:   R9 <= 2 BYTE FIELD TO FIND IN SETTABLE
*        OUTPUT:  R6 <= INDEX TO ENTRY IN SETTABLE
*                 EXITS SKIPPING
*                 * OR *
*                 IF NOT FOUND, EXIT TO CALL+1
*        USES:    R6,R10
*
FINDSET  EQU      %
         LI,R6    SETBLSZ
FINDSET1 EQU      %
         LH,R10   SETTABLE,R6
         AND,R10  XFFFF
         CW,R9    R10
         BE       1,R5              GOT IT
         BDR,R6   FINDSET1
         B        0,R5              NOT FOUND
*
SETTABLE EQU      %
         GEN,16,16 0,'RE'
         TEXT,2   'TY','US','SQ','MA','OC','PU'
SETBLSZ  EQU      HA(%)-HA(SETTABLE)-1
         PAGE
         BOUND    4
STATUS   EQU      %
         LI,R6    0
         LW,R7    LASTRUN
         BEZ      SUSPSTAT          NOTHIN ACTIVE
         LI,D1    SUSPSTAT
STATSUBR EQU      %
         LD,R4    TAPETYPE,R7
         AI,R5    -BA(FPAR)+BA(COMBUF) MAKE COMBUF THE PRINT BUFFER
         MBS,R4   0
         LW,R4    STFILLER,R6
         LB,R8    0,R4
         STB,R8   R5
         MBS,R4   1
         LW,R4    ACCTADDR,R6
         LI,R8    8
         STB,R8   R5
         MBS,R4   0
         BAL,SR4  TYPEIT
         B        *D1
*
SUSPSTAT EQU      %
         LI,R6    1
         LW,R7    SUSPNDED
         BEZ      GRANDISP
         BAL,D1   STATSUBR          TELL OF SUSPENDED OPERATION
*
GRANDISP EQU      %
         BAL,SR4  PURGELOG
         B        GETCOM
*
ACTEXT   TEXTC    ' IS ACTIVE - ACCOUNT = '
SUSPTXT  TEXTC    ' IS SUSPENDED - ACCOUNT = '
*
STFILLER DATA     BA(ACTEXT)
         DATA     BA(SUSPTXT)
*
ACCTADDR DATA     BA(LASTACCT)
         DATA     BA(SUSPACCT)
         PAGE
DOPURLIST EQU     %
*                 PRINTS PURGE MESSAGE FOR FID.ACCT IN M:PURGE DCB
         LB,R5    F:EO+11           POS OF SN
         LW,D1    F:EO+X'44',R5     OUTSN NO.
         MTW,0    LOGGED            HAS FILE BEEN SAVED TO TAPE?
*                                   (SN MEANINGLESS IF NOT)
         BNEZ     %+2               FILE HAS BEEN SAVED
         LW,D1    NONE              FILE HAS NOT BEEN SAVED
         STW,D1   PURGMSG+2         PUT SN OR NONE IN MESSAGE.
*                 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
*    PRINT MESSAGE    'HH:MM MMM DD BY 'ACCOUNT' ON DDLD   PURGED FILE "F I L E
*
         LI,SR3   MAILFPT           ADDR. OF MSG
         LW,D4    BLDMAIL           0 => NO MAILBOX
*                 CHECK WHETHER TIME HAS CHANGED
         LW,R6    *TIMEAD
         XW,R6    MTIME
         CW,R6    MTIME
         BNE      MAILBOX           RET MAILBOX IS *SR4
         B        FMAILBX           TIME HAS NOT CHANGED
         PAGE
DOPURTAP  EQU     %
         STW,SR4  BKQX              SAVE LINK REG
         STW,R1   LOGGED            SET LOGGED IN BACKUP FLAG
*
         LCI      2
         LM,R6    F:EI+32           GET ACCT FROM DCB
         STM,R6   NXACCT
         STM,R6   ADJ:ACCT
         STM,R6   MAIL:AC
         BAL,SR4  AUTOBACK          GO BACKUP FILE ON TAPE
*
         MTW,1    FCNT              INCR TOTAL FILES PURGED ON TAPE
         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
         LW,SR4   PURGEXIT          GET EXIT ADDRESS FOR GETCOM
         MTW,0    INT
         BG       GETCOM0
         MTW,0    *GRANMINAD
         BLE      PURGESET               REACHED THRESHOLD
         MTW,0    *GRANRESETAD           REACHED THRESHOLD RESET
         BL       PURGEX            NOTHING TO DO
PURGESET EQU      %
         LI,R5    THEXCEED
         CAL1,2   TYPE
         BAL,SR4  PURGESETCTR
         BAL,SR4  PURGELOG          LOG GRANS AVAILABLE
         LW,SR1   THRESHOLDD
         BAL,SR3  BINTODEC
         LD,R4    NEWTHMBS
         MBS,R4   0
         LI,R5    NEWTHMSG
         CAL1,2   TYPE
         B        PURGEX
*
PURGSTRT EQU      %
         LI,R5    ENTPURGE
         LI,R6    SEL:COM:BUF
         LI,R7    40
         CAL1,2   KEYIN
*
         STW,R0   INT               CLEAR INTERRUPT FLAG
         STW,R0   EXPIRFG           CLEAR EXPIRED FLAG
         STW,R0   PURALLX           CLEAR PURGE ALL EXP. IND.
         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
         CI,D1    'O'               WAS KEYIN  'ALL OLDER'
         BE       OLDER             YES
         LI,SR2   XTXT              ' ALL X' KEYIN
         BAL,SR3  FIND:STRG
         MTW,1    EXPIRFG           FLAG PURGE ONLY EXPIRED FILES
         LB,D1    SEL:COM,R4        GET NEXT CHAR
         CI,D1    X'15'             N/L OR L/F
         BLE      ALLEXPUR          YES--PURGE ALL EXP.
         BAL,SR3  SK:BL
         CI,D1    'U'               WAS KEYIN 'ALLX UNTIL'
         BE       PURUNTIL          YES
         B        PURGEKNO
*
*  HERE TO PURGE ALL EXPIRED FILES
*
ALLEXPUR EQU      %
         MTW,1    PURALLX           SET PURGE ALL EXP IND
         BAL,SR2  DOPURGE
         BAL,SR4  PURGELOG
         LI,SR2   PURGEX
         STW,SR2  DOPURX
         B        PURTHRU           EXIT-- PURTHRU TO PURGEX
*
OLDER    EQU      %
*
         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
         LI,R5    NONETEXTC
         CAL1,2   TYPE
         LW,SR4   PURGEXIT
         B        PURGE
         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
         LW,SR4   PURGEXIT
         B        PURGE
         SPACE    3
*              EXIT ROUTINE
*
PURGEX   EQU      %
         STW,R0   INT               CLEAR THE INT FLAG
         B         *PURGEXIT
         TITLE    'DOPURGE SUBROUTINE'
         SPACE    2
DOPURGE  EQU      %
         STW,SR2  DOPURX            SAVE EXIT
         LI,R4    4
         STW,R4   LASTRUN
         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
*
         LW,R4    PURGTAP
         LW,R5    PURGMSGS,R4
         SLS,R5   -2                MAKE A WORD ADDRESS
         CAL1,2   TYPE              TELL THE DISPOSITION OF FILES
         LI,R6    25                HALF A MINUTE WAIT FOR NONE SAVED
         LW,R4    R4
         BNEZ     PURNXA            FILES WILL BE SAVED
         STH,R6   SLP:FPT,R1
         CAL1,8   SLP:FPT           GIVE OPERATOR HALF A MINUTE TO
*                                    THINK ABOUT NOT SAVING FILES.
PURNXA   EQU      %
         STW,R0   ENDAC
         CAL1,1   NXACT             GET NEXT ACCT-IF NONE,RETURN PURABN
         LCI      2
         LM,D1    PURGEACCT+1       GET ACCOUNT FROM DCB
         STM,D1   PURACT
         STM,D1   LASTACCT
         CD,D1    SYSTEXT
         BE       PURNXA            DONT PURGE :SYS
PURNXF   EQU      %
         MTW,0    INT
         BEZ      %+2
         BAL,SR4  GETCOM0           SEE WHAT HE WANTS NOW.
         STW,R0   LOGGED            SET NOT LOGGED FLAG.
         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
         LI,D1    X'200'
         CW,D1    PURGEDESC
         BANZ     DOPURNXT          NOPURGE SET...SKIP
*                   CHK IF EXPIRED
         LI,D4    FPAR
         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
         MTW,0    EXPIRFG           PURGE ONLY EXPIR. FILES
         BEZ      PURNXP            NO
         LI,D2    CDATE
         BAL,R5   COMPDAT
         B        DOPURNXT
         MTW,0    PURALLX           PURGE ALL EXPIR.
         BEZ      PURNXP            NO
*                 EXPIRED, CHK BACKUP BITS
         MTW,1    EXPIRCNT          CNT NO. EXPIRED FILES PURGED
*
         LW,D2    L(X'F0000')
         CS,D2    PURGEDESC         BACKUP BITS IN DYNAMIC DESCRIPTORS
         BNE      SAVECHK
         LW,D2    BACKUPALLD        IS BACKUP REQUIRED
         BNEZ     PURNXP1           GO BACKUP ON TAPE
         B        SAVECHK
         SPACE    2
DOPURNXT EQU      %
         LW,D1    ENDAC
         BEZ      PURNXF            TRY NEXT FILE
         B        PURNXA            TRY NEXT ACCOUNT
PURNXP   EQU      %         UNEXPIRED
*                     SKIP IF SYNON
         LI,D4    X'4000'
         CW,D4    PURGEDESC
         BANZ     DOPURNXT
*                   CHK ACCORDING TO PURGE TYPE, 'O' OR 'U'
         LW,D1    PTYPE
         CI,D1    'U'
         BE       PURGEU            'UNTIL' TYPE
*                   DO PURGE 'OLDER'
*                   COMPARE ACCESS DATE WITH PURGE DATE
         LI,D4    FPAR
         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      SAVECHK           BACKED UP.  CHECK FOR SAVE ANYWAY
         LW,D1    ALLFLAG
         BEZ      DOPURNXT          NOT BACKED UP, NOT AN 'ALL' => SKIP
PURNXP1  EQU      %
         LW,D1    PURGTAP
         CI,D1    1
         BL       PURZAP            DELETE WITHOUT SAVING
*                                   FALL THROUGH => SAVE ON ONE SET
*                                    OR SAVE IF NOT DONE ALREADY
PURENQ   EQU      %
         BAL,SR4  DOPURTAP          MAKE THE PURGE TAPE
PURZAP   EQU      %
         BAL,SR4  DOPURDEL          DELETE THE FILE
         B        DOPURNXT          GET NEXT FILE
*
SAVECHK  LW,D1    PURGTAP
         CI,D1    1
         BE       PURENQ            ALL FILES ARE TO BE SAVED
         B        PURZAP            HAS BEEN SAVED ALREADY OR
*                                    WE DON'T CARE.
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
         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
         CW,R7    DYNBYT            START WITH 2040 BYTES I.E. 1 PG
         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    FPAR
         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
         CAL1,1   CLSPURGE
*                 NO OPTIONS
         B        DOPURABC
PURABN1  EQU      %
         CI,SR3   X'55'             SYSTEM OVERLOAD
         BNE      DOPURABC          CHK ABN LOOP
         CAL1,8   WAITONE           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      %
         STW,R0   LOGGED            SET NOT LOGGED FLAG
         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
*                 BACKUP ON TAPE
         BAL,SR4  DOPURTAP
*               DELETE FILE
PURDEL   EQU      %
         BAL,SR3  DOPURDEL
*              CHECK IF ANY MORE NECESSARY
PURTHRU  EQU      %
         LW,R7    PURIX
         LW,D1    *GRANRADAD
         AW,D1    *GRANPACKAD
         CW,D1    PNUM
         BL       PURUN             NEED MORE
*               PURGE COMPLETED
DOPUROUT EQU      %
         CAL1,9   SUPER:CLOSE       CLOSE SYMBIONTS
         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
         PAGE
*                    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

