*M*      PCLLIST LIST COMMAND PROCESSOR
LIST     DSECT    1
PLSECT   CSECT    1
         SYSTEM   SIG7
VERSION  EQU      2                 1=BPM, 2=UTS
         PAGE
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
* DISPLACEMENTS OF ATTRIBUTES IN PRINT BUFFER
ORG      EQU      2                 BYTE DISP
GRAN     EQU      1                 WORD DISP
REC      EQU      3
DATE     EQU      7
NAME     EQU      10
         TITLE    'LIST'
*P*      NAME:    PCLLIST
*P*
*P*      PURPOSE: TO SCAN THE LIST COMMAND FOR CORRECT SYNTAX AND TO
*P*               LIST THE NAMES OF FILES ON RAD, DISK PACK, OR TAPE AS
*P*               SPECIFIED BY THE COMMAND.  IF ATTRIBUTES ARE
*P*               REQUESTED FOR SINGLE FILES OR A FILE DIRECTORY
*P*               THE ORGANIZATION, RECORD COUNT, SIZE IN GRANULES, AND
*P*               MODIFICATION DATE FOR EACH FILE ARE LISTED.  DATE
*P*               ATTRIBUTES ARE ALSO LISTED IF THE EA OPTION IS USED.
*P*               THIS ROUTINE IS ALSO ENTERED TO PROCESS A REVIEW COMMAND.
*P*               A TAPE MAY BE IDENTIFIED BY THE 'LIST FT#SN' COMMAND.
         SPACE    5
* SUBS
         REF      CLRARG            INIT ARGTBL
         REF      GETARG            NEXT FIELD
         REF      DEVTRAN           DEVICE TYPE
         REF      BLDCB             OPEN DCB
         REF      CLOSEI            CLOSE DCB
         REF      ERROR             REMEMBER ERROR
         REF      BCD2BIN           XLATE TEXT
         REF      UNPRINT           NAME PRINTEER
         REF      SIXBACK           XLATE ANSSN
*DATA
         REF      DEVICE            ARGTBL PIECE
         REF      SFARG             USED TO SAVE DATES
         REF      TERM              OUT FROM GETARG
         REF      NCHAR             OUTPUT FROM GETARG
         REF      ARGBUF4           OUTPUT FROM GETARG
         REF      EATTRB            EA FLAG
         REF      WRTFPT            SCRATCH SPACE
         REF      CMBX              COMMAND POINTER
         REF      OPNXFPT           SPACE FOR OPNNXT
         REF      1BUF              BUFFER FOR X TO ABORT, ETC.
         REF      IN%ARG            INPUT RESOURCE TYOE
         REF      MAXCMBX           END OF SCANNER INPUT
         REF      INSER             M:EI LAST SN
         REF      OUTSER            M:EO LAST SN
*DCBS
         REF      M:UC,M:EI,M:LO
         REF      J:JIT
         REF      FILTRAN
         REF      HEX2BCD           MAKE TEXT OF BITS
         REF      JB:PCW            PLATEN WIDTH
         REF      M:EISN
         REF      PRTERR            PRINT ERRORS BEFORE TOF
         REF      ALLC              TYPE NAME/ERROR FOR DELETEALL
         REF      M:EO
         REF      BREAK
         REF      TOSWT
         REF      PRTNOF
         REF      PRTBUF            OUTPUT BUFFER
         REF      ARGBUFF,MODE,BIN2BCD
         REF      ATTRB
         REF      RDTBL
         REF      WRTBL
         REF      EXTBL
         REF      UNTBL
         REF      FILE
         REF      OPNFPT
         REF      IOBUF
         REF      SYNFLAG
         REF      ERRFLAG
         REF      LTSTCMBX
         REF      COPYSK,FROMFILE,TOFILE,DELETEF
         REF      REVIEW
         REF      TLABEL
         REF      GRANCNT
         REF      TLBLSIZE
         REF      COPYPHY
         REF      LISTCMBX,LISTTERM
         DEF      TESTFNC
         DEF      RANGEOUT          FOR COPYALL/STD AND TO LP
         DEF      REVRP             ONE BYTE READ CAL(FOR BREAK INPCL)
         DEF      READONE           ONE BYTE READ SUBROUTINE
DATETBL  EQU      TLABEL+4
SEVMAX   EQU      SFARG+8
         REF      RSSAVE
         REF      BOG
         PAGE
         USECT    LIST
         LCI      7
         PSM,R5   *R7
         CAL1,8   TIMECAL
         LI,SR2   0                 INITIALIZE FILE COUNT
         STW,R0   ATTRB,R7          ZERO ATTRIBUTE FLAG
         STW,R0   EATTRB            ZERO EXT ATTRIBUTE FLAG
         STW,R0   SEVMAX            MAX SEVERITY
         STW,R0   PRTBUF,R7
         STW,R0   GRANCNT           INITIALIZE GRANULE COUNT
         LI,R2    3
         STW,R2   COLSIZE,R7
LIST24   BAL,SR4  CLRARG            CLEAR ARGTBL
LIST25   EQU      %
         LW,R2    TERM,R7
         CI,R2    X'15'             'LIST' ONLY
         BE       LIST44
         CI,R2    '('               '(A)' POSSIBLE
         BE       LIST8             YES
         BAL,SR4  DEVTRAN           GO TRANSLATE DEVICE
         LW,R2    DEVICE,R7         VALID DEVICE
         CI,R2    3                 RAD
         BE       LIST2             YES
         CI,R2    5
         BE       LIST4             DP
         LI,R1    34                INVALID DEVICE TYPE
         MTW,0    DELETEF           IF REVIEW, TAPE ISNT OK
         BNEZ     LIST3
         CI,R2    4                 LT
         BE       LIST4
         CI,R2    6
         BE       LIST44            FT
         CI,R2    7
         BE       LIST4
         B        LIST3
LIST2    LW,R1    DEVICE+1,R7       TAPE REEL NO. SPECIFIED
         BEZ      LIST4             NO-O.K.
         LI,R1    22                ERROR-REEL NO. SPECIFIED FOR RAD
LIST3    BAL,SR4  ERROR
LIST4    LW,R5    TERM,R7
         CI,R5    '/'               DOES 'N.A.P' FOLLOW
         BE       LIST9             YES
LIST44   EQU      %
         LW,R5    TERM,R7
         CI,R5    '('               DOES 7T,9T, OR 'A' FOLLOW
         BE       LIST8             YES
         STW,R5   LISTTERM          SET TERMINATOR
         CI,R5    X'15'             PROPER TERMINATION
         BE       LIST5             YES
         CI,R5    ';'
         BE       LIST5             NEW DEVICE NEXT
         CI,R5    ','               MORE TO COME
         BNE      LIST18            NO, SYNTAX ERROR
         MTW,0    ATTRB,R7          COMMA OK IF FILE NAMES
         BGZ      LIST5
         MTW,0    FROMFILE          OR RANGE
         BNEZ     LIST9
LIST18   LI,R1    17                EH
LIST6    BAL,SR4  ERROR
LIST5    EQU      %
         LW,R1    CMBX,R7           SAVE POSITION IN LIE
         STW,R1   LISTCMBX
         CI,D2    1                 CAN EXECUTE
         BG       LISTEND           NO
         LI,R1    6
         CW,R1    DEVICE,R7    CHECK FOR PCL DEVICE.
         BE       LISTFT       YES.
         PAGE
LIST20   LI,R1    4                 OPEN NEXT, INPUT
         DO       VERSION=2
         LW,R1    =X'80004'         TESTFILE, OPEN NEXT, INPUT
         FIN
         LW,R5    ATTRB,R7          ATTRIBUTES WANTED
         BEZ      LIST21            NO
         LI,R1    2                 FPARAM, INPUT
         CI,R5    1                 'N.A.P' SPECIFIED
         BE       LIST21            YES
         LI,R1    6                 OPEN NEXT, FPARAM, INPUT
LIST21   EQU      %
         CAL1,1   FPTSET3           SET ERR/ABN FOR M
         BAL,SR4  BLDCB             GO-BUILD INPUT DCB
         LI,R2    2
         CB,R2    SR3               ANY FILES PRESENT
         BE       LIST32            MEBBE, TRY ONE MORE TIME
         MTB,0    SR3               ERR OR ABN IN BLDCB
         BNEZ     ERRADD            YES
         CI,D2    0
         BNE      SOMERR
         USECT    PLSECT
FPTSET2  GEN,8,7,17      X'06',0,M:EI
         DATA     X'C0000000'
         DATA     ERRADD
         DATA     ERRADD
FPTSET3  GEN,8,24 6,M:LO
         DATA     X'C0000000'
         DATA     ERRADD2
         DATA     ERRADD2
TIMECAL  GEN,8,24 X'10',DATETBL
         USECT    LIST
LIST1    LI,D3    PRTBUF
         CAL1,1   FPTSET2           SET ERRADD
         BAL,SR4  TESTFNC           TEST IF FILE WANTED
         B        LIST33            NO
         AW,D3    R7                BUFFER ADDRESS
         LI,R6    M:LO
         LI,R1    M:EI+23
         LW,R3    ATTRB,R7
         OR,R3    DELETEF           IF SIMPLE LIST,
         BNEZ     LIST19            DO IT HORIZONTALLY
         AI,SR2   0                 IF FIRST FILE, CLEAR BUFFER
         BNEZ     LIST191
LIST19   LI,R3    63
         LW,R2    ='    '
         STW,R2   *D3,R3
         BDR,R3   %-1
         STW,R2   *D3
         LW,R2    ATTRB,R7
         BNEZ     LISTATB           LIST A,EA
         MTW,0    DELETEF
         BNEZ     LIST17            REVIEW
         STB,R3   *D3               CLEAR BYTE COUNT
LIST191  LB,R3    *D3               WHERE TO PUT THIS ONE
         BNEZ     %+2
         LI,R3    -1                0 IS REALLY -1
         SAS,R3   -2                GET WORD OF LAST USED BYTE
         AW,R3    COLSIZE,R7
         DW,R3    COLSIZE,R7
         MW,R3    COLSIZE,R7
         AW,D3    R3
         BAL,SR4  UNPRINT
         SW,D3    R3
         XW,D3    R1                PUT BUFF ADR IN 1
         SLS,R3   2                 COMPUTE BYTES ACTUALLY USED
         AW,R3    R2                IN R3
         LI,R5    BA(JB:PCW)        GET PLATEN WIDTH
         LB,R5    0,R5
         LI,SR4   3                 ARE WE GOING TO A ME
         CS,SR4   M:LO
         BNE      %+4               NO, NOT EVEN A DEVICE
         LW,SR4   M:LO+1
         CI,SR4   X'6F00'
         BAZ      %+2               YES, USE PCW
         LI,R5    108               NO, ASSUME PRINTER
         CW,R3    R5                ARE WE OVER THE LIMIT NOW
         BLE      %+2               NO
         LB,R2    *R1               ANYTHING TO PUT OUT
         STB,R3   *R1               SET NEW SIZE
         BLEZ     LIST30            NOT YET
         LI,R3    1
         CAL1,1   FPTLFILE
         XW,R1    D3
         MTW,0    BREAK             IF BREAK HIT, FORGET THIS ONE
         BEZ      LIST19
         STW,R1   DELETEF           ENTIRELY (SEE LISTEND)
         B        LIST33
COLSIZE  EQU      WRTFPT
LIST17   RES
         BAL,SR4  UNPRINT           ENTER FILE NAME IN BUFFER
         LW,R1    D3
         DO       VERSION=2
         MTW,0    2,R7              IS HEADER PRINTED
         BNEZ     %+3               YES
         MTW,1    2,R7              SET HEADER FLAG
         CAL1,1   REVFPT            PRINT HEADING
         BAL,SR4  ABN14T            TEST FOR ACCSEEABILITY
REVRET1  RES                        RETURN FOR AN14T
         BAL,SR4  LFILE
REVRET2  LB,R3    SR3               DID WE GET ERROR
         CI,R3    X'F7'             BESIDES 08 (SYNON)
         BANZ     LIST26            YES, NO REQUEST
         LI,SR4   LIST22            SET RETURN
READONE  RES
         LCI      4                 SAVE A FEW REGS
         PSM,SR1  *R7
         CAL1,8   TSFPT             READ DIFFERNENTLY IF HALF DUPLEX
         SLS,8    3                 OR 2741..MODE2/X10, MODE6/X80
         OR,SR1   SR4               PUT BOTH BITS TOGETHER
         SLS,8    -21               AND AT 4
         LI,SR2   4
         AND,SR2  SR1
         BNEZ     %+2
         LI,SR2   1                 READ ONE BYTE ON TTYS
REREAD1  STW,R0   1BUF              CLEAR BUFFER
REVRP    EQU      %
         CAL1,1   READFPT           READ REPLY
         BIR,SR1  %+2               GET REPLY FIRST TIME ONLY
         LB,R1    1BUF
         LW,SR4   1BUF
         LI,SR1   -100
         CI,SR4   X'FF'
         BANZ     REREAD1           KEEP TRYING
         CAL1,8   TSFPT             CHECK PLATEN POSITION
         STW,SR2  1BUF              SAVE OUTPUT COUNT
         SLS,SR2  -25
         STB,SR2  DELETEF
         LCI      4
         PLM,SR1  *R7
         B        *SR4
LIST27   RES
         MTB,0    DELETEF           DO WE NEED CR
         BEZ      LIST30            NO
         B        LIST26
LIST22   RES
         CI,R1    'E'               IF E, TERMINATE, REVIEW
         BNE      %+2
         MTW,1    BREAK
         CI,R1    'D'               IS DELETE WANTED
         BNE      LIST27            NO
         LH,R6    1BUF              CHECK OUTPUT COUNT
         CI,R6    X'FC'
         BAZ      REVDEL            VERY LITTLE, OK
         CAL1,1   WRTQUST
         B        LIST1             TRY AGAINE
WRTQUST  GEN,8,24 17,M:UC
         DATA     X'34000010',QUST,3,0
QUST     TEXT     '??  '
REVDEL   RES
         BAL,SR4  CLOSEI            CLOSE IN CASE OPEN (REV(A))
         LI,R2    0                 SET BUFFER/DISP FOR ABN14T
         LI,R1    OPNFPT
         AW,R1    R7                SET FPARAM, ABN14T BUFFER ADDR
         CAL1,1   REVOPN            OPEN FILE
         CAL1,1   FPTDELET          RELEASE FILE
         BAL,R6   RANDCHK           TEST IF RANDOM FILE
         CAL1,1   WRTDEL            WRITE *DELETED*
         AI,SR2   X'10000'          COUNT DELETED FILES
LIST26   CAL1,1   WRTCR             WRITE CARRIAGE RETURN
         STB,R0   DELETEF           RESET CR NEEDED FLAG
        FIN
         USECT    PLSECT
FPTLFILE GEN,8,24 X'91',R6
         DATA     X'34000010'
         PZE      *R1               BUFFER
         PZE      *R2               COUNT
         PZE      *R3               BYTE DISPLACEMENT
TSFPT    GEN,12,20 X'066',0
         USECT    LIST
LIST30   EQU      %
         AI,SR2   1                 INCREMENT FILE COUNT
         LI,R1    2                 IF NOT FILE, DO PEOF
         CW,R1    M:EI              IN CASE MULTIREEL FILE
         BAZ      %+2               ON TAPE
         CAL1,1   ATEOF
LIST33   BAL,SR4  CLOSEI            GO CLOSE M:EI
LIST31   EQU      %
         MTW,0    BREAK             BREAK SET
         STW,R0   BREAK             CLEAR BREAK
         BNEZ     LIST40            YES
         MTW,0    TOFILE            ANY MORE LISTING WANTED
         BLZ      LIST40            NO
         MTW,0    ATTRB,R7          WAS FID SPECIFIED
         BLEZ     LIST32            NO
         LW,R1    LISTCMBX          RESTORE SCAN POINTER
         STW,R1   CMBX,R7
         LW,R1    LISTTERM          GET TERMINATOR
         STW,R1   TERM,R7
         CI,R1    ';'               NEW DEVICE
         BE       LIST24            YES
         CI,R1    ','               ANOTHER FID
         BNE      LIST40            NO
         B        LIST9             YES - GO PROCESS
         DO       VERSION=2
LIST28   CAL1,1   WRTFB             WRITE 'FILE BUSY'
         B        LIST26
         FIN
LIST32   EQU      %
         BAL,SR4  OPNNXT
         BCS,8    LIST50            ALL DONE
         BE       LIST7             NOT GETTING ANYWHERE
         B        LIST1
REVOPN   GEN,8,7,17      X'14',0,M:EI
         DATA     X'C1200000'
         DATA     ABN14T,ABN14T
         DATA     4                 INOUT
         PZE      *R1
READFPT  GEN,8,24 X'10',M:UC
         DATA     X'34000000'
         PZE      1BUF
         PZE      *SR2
         DATA     0
WRTCR    GEN,8,24 X'11',M:UC
         DATA     X'34000010'
         DATA     REVMSG
         DATA     1
         DATA     0
REVFPT   GEN,8,24 X'11',M:UC
         DATA     X'34000010'
         DATA     REVMSG
         DATA     27
         DATA     0
REVMSG   TEXT     '
--ENTER D TO DELETE FILE.
'
DELMSG   TEXT     ' *DELETED*'
WRTDEL   GEN,8,24 X'11',M:UC
         DATA     X'34000010'
         DATA     DELMSG
         DATA     10
         DATA     0
WRTFB    GEN,8,24 X'11',M:UC
         DATA     X'34000010'
         DATA     FILEBUSY
         DATA     14
         DATA     0
         PAGE
TESTFNC  LB,R2    FROMFILE
         BEZ      TEST1             NO - FILE WANTED
         MTW,0    COPYPHY
         BNEZ     TEST1             COPYING TAPE IN PHYS ORDER
         LI,R4    1
TEST4    EQU      %
         CB,R4    M:EI+23           ARE WE PAST NAME IN DCB
         BG       *SR4              YES - FILE BELOW RANGE
         LB,R3    M:EI+23,R4        COMPARE FILE NAMES
         CB,R3    FROMFILE,R4
         BL       *SR4              BELOW RANGE - EXIT
         BG       TEST1
         AI,R4    1
         BDR,R2   TEST4
         LB,R4    SR3               IF NO SUCH FILE, DONT WANT
         CI,R4    3                 FIRST ONE
         BE       *SR4
TEST1    MTB,0    TOFILE            WAS A TO FILE SPECIFIED
         BEZ      TEST3             NO - FILE WANTED
         LI,R4    1
         LB,R2    TOFILE
         MTW,0    COPYPHY           COPYING TAPE IN PHYS ORDER
         BEZ      TEST5             NO
         CB,R2    M:EI+23           ARE NAME LENGTHS EQUAL
         BNE      TEST3             NO - FILE WANTED
TEST6    LB,R3    M:EI+23,R4
         CB,R3    TOFILE,R4         TEST IF WE HAVE FOUND TO FILE
         BNE      TEST3             NO - FILE WANTED
         AI,R4    1
         BDR,R2   TEST6
         AI,SR4   1
         B        TEST7             FOUND - TAKE WANTED EXIT
TEST5    EQU      %
         CB,R4    M:EI+23           ARE WE PAST NAME IN DCB
         BG       TEST3             YES - FILE IN RANGE
         LB,R3    M:EI+23,R4
         CB,R3    TOFILE,R4         COMPARE FILE NAMES
         BL       TEST3             IN RANGE
         BG       TEST2             OUT OF RANGE
         AI,R4    1
         BDR,R2   TEST5
         LB,R2    M:EI+23
         CB,R2    TOFILE            END OF RANGE HIT
         BNE      TEST2             YES
         AI,SR4   1
         B        TEST2
TEST3    AI,SR4   1
         B        *SR4              EXIT FOR FILE WANTED
TEST2    RES
         LI,R1    2                 IF TAPE FILES, KEEP LOOKING
         CW,R1    M:EI              IF NOT COPYPHY
         BANZ     *SR4
TEST7    RES
         LW,R1    =X'80000000'      SET END OF RANGE FLAG
         STS,R1   TOFILE
         B        *SR4
         PAGE
GETARG6  LI,R1    6
         B        GETARG
LIST8    BAL,SR4  GETARG6           GET NEXT ARGUMENT
         LW,R1    ARGBUFF,R7
         SLS,R1   -8                MAKE CI'C WORK
         CI,R1    X'1D940'          TEST IF 'R'ANGE
         BNE      %+3
         MTW,1    FROMFILE          SET FLAG FOR RANGE
         B        LIST11
         CI,R1    X'1C140'          TEST IF 'A'TTRIBUTES
         BE       LIST10            YES
         CI,R1    X'2C5C1'          TEST IF EA
         BE       LIST16            YES
         LI,R2    3                 MODE CODE FOR 7T
         CI,R1    X'2F7E3'          TEST IF '7T'
         BE       LIST12            7T
         LI,R2    4                 MODE CODE FOR 9T
         CI,R1    X'2F9E3'          TET IF '9T'
         BE       LIST12
         CI,R1    X'3D1D6'          JO(B)
         BE       LIST15
         CI,R1    X'2C3F9'
         BG       LIST14
         AI,R1    -X'2C3F0'         TEST IF COLUMN WIDTH.'CN'
         BLZ      LIST14            <C0
         BGZ      %+2
         LI,R1    99                C0 MEANS ONE PER LINE
         STW,R1   COLSIZE,R7
         B        LIST11
LIST12   LW,R1    DEVICE,R7
         CI,R1    4
         BE       LIST13            LT - OK
         CI,R1    6
         BE       LIST13            FT - OK
LIST14   LI,R1    25                ERROR-MODE SPEC NOT VALID
         BAL,SR4  ERROR
         B        LIST11
LIST15   RES
         MTW,0    ATTRB,R7          MUST HAVE FILENAME
         BLEZ     LIST14
         LW,R1    DEVICE,R7
         AI,R1    -3                DC,DP ONLY
         CI,R1    5
         BANZ     LIST14
         LI,R1    X'800'
         STS,R1   MODE,R7           SET THE BIT
         B        LIST11
LIST13   STW,R2   MODE+1,R7         SET CODE FOR 7T OR 9T
LIST11   LW,R2    TERM,R7
         CI,R2    ','               IS THERE ANOTHER OPTION
         BE       LIST8             YES
         CI,R2    ')'               VALID DELIMITER
         BNE      LIST18            NO - ERROR
         BAL,SR4  GETARG6           CHECK NEXT ARG
         MTW,0    ATTRB,R7          IF NO N.A.P YET,
         BLEZ     LIST111           NO DELIMITER HERE
         MTW,0    NCHAR,R7          IS ARGUMENT NULL
         BNEZ     LIST18            NO - ERROR
         B        LIST44
LIST111  RES
         MTW,0    NCHAR,R7          IF WE HIT A DELIMITER
         BNEZ     %+4               NO NEED TO REREAD
         MTW,0    DEVICE+2,R7       HAVE WE BEEN TO DEVTRAN
         BNEZ     LIST4             YES, DONT GO AGAIN
         B        LIST25            NO, STILL NEED DEVICE TYPE
         LW,R1    LTSTCMBX          IF WE GOBBLED SOMETHING, REGURGITATE
         STW,R1   CMBX,R7           IF THERE WAS ONE
         LI,R1    ' '               SET GOOD DELIMITER FOR REVIEW
         STW,R1   TERM,R7
         MTW,0    DEVICE+2,R7       IF WE NEED A DEVICE STILL
         BEZ      LIST25            GO GET ONE
         MTW,0    FILE,R7           IF ACCOUNT ALREADY THERE, MUST BE RANGE
         BEZ      LIST9             NO, MUST BE FID
         MTW,1    FROMFILE
LIST9    RES
         MTW,0    FROMFILE          IF RANGE, GET IT
         BEZ      %+3
         BAL,SR4  REVIEW
         B        LIST44
         STW,R0   MODE,R7           RESET JOB FLAG
         BAL,SR4  FILTRAN
         LI,R1    1
         STW,R1   ATTRB,R7          SET ATTRIBUTE FLAG FOR 1 FILE
         LI,R1    X'FFFF'           ZERO 1 FILE EA FLAG
         STS,R0   EATTRB
         B        LIST44
LIST16   MTW,1    EATTRB            SET 1 FILE EA FLAG
         LI,R1    X'F0001'          AND ALL FILES FLAG IF FIRST
LIST10   MTW,0    ATTRB,R7          WAS FID SPECIFIED
         BGZ      LIST11            YES
         LI,R2    -1
         STW,R2   ATTRB,R7          SET ATTRB FLAG FOR ALL FILES
         BDR,R1   LIST11            IF NOT FROM EA,
         STW,R1   EATTRB            DONT SET ALL FILES EA FLAG
         B        LIST11
         PAGE
WEOFLO   GEN,8,24 2,M:LO
LISTATB  XW,R2    2,R7              IS THIS THE FIRST FILE
         BNEZ     LISTATB1          NO - SKIP HEADER
         LI,R6    M:LO              OUTPUT TO M:LO
         MTW,0    DELETEF           IF REVIEW, ADD DELETE MSG
         BEZ      %+4
         LI,R6    M:UC              AND WRITE THROUGH UC
         CAL1,1   REVFPT
         MTB,-1   DELETEF           SET CR NEEDED FLAG
         MTW,0    ATTRB,R7          NAME LIST OR RAGNE IN ONE ACCOUNT
         BGZ      NODATEHD          LIST, NO DATE/ACCOUNT
         CAL1,1   WEOFLO            TOP OF FORM FOR PRINTERS
         LI,D4    BA(DATETBL)       POINT TO BUFFER
         LI,D3    15                15 BYTES INTO BUFFER
         BAL,SR4  RANGEOUT          PUT XX#SSSS.AJSSD RF
         LW,R2    D3                SIZE OF OUTPUT
         ANLZ,D3  PRTBUFI7          RESTORE BUFFER ADDRESS
         LI,R3    0
         LI,R1    DATETBL           OUTPUT THE LINE
         AI,R2    1
         CAL1,1   FPTLFILE
NODATEHD RES
         LB,R2    LISTHEAD          LENGTH OF HEADER
         LI,R1    LISTHEAD          BUFFER ADR
         LW,SR4   DEVICE,R7
         CI,SR4   7
         BNE      %+2
         LI,R1    LISTHAT
         LI,SR4   LISTATB1
LFILE    RES
         LI,R3    1                 BTD
         LI,R6    M:LO
         MTW,0    DELETEF           IF REVIEW, USE UC, START AT
         BEZ      LFILE1            START OF LINE
         MTB,-1   DELETEF           SET/CHECK CR NEEDED FLAG
         BNC      %+2
         CAL1,1   WRTCR
         LI,R6    M:UC
LFILE1   RES
         CAL1,1   FPTLFILE          PRINT ATTRIBUTE HEADER
         B        *SR4
LISTATB1 EQU      %
         AI,D3    NAME
         LI,R1    M:EI+23
         BAL,SR4  UNPRINT           ENTER FILE NAME IN BUFFER
         LI,R1    PRTBUF
         AW,R1    R7
         AI,R2    NAME*4            LENGTH OF PRINT LINE
         STW,R0   SYNFLAG,R7        NO SYNON YET
         STW,R0   RDTBL             CLEAR ACCN COUNTS
         STW,R0   WRTBL
         STW,R0   EXTBL
         STW,R0   UNTBL
         LI,R6    8
         STW,R0   DATETBL-1,R6      ZERO DATE TABLE
         BDR,R6   %-1
         LI,SR4   LISTATB2
ABN14T   EQU      %
         LB,R3    SR3
         BEZ      *SR4              ALL IS OK
         CI,R3    8                 SYNON IS OK TOO
         BE       *SR4
         LCI      8
         PSM,SR4  *R7
         LB,R1    SR3
         SLS,R1   8
         AH,R1    SR3
         SLS,R1   -1
         BAL,SR4  HEX2BCD
         LCI      3
         PLM,R0   *R7
         STW,R3   D4                CODE TO D4
         LCI      4
         LM,SR4   INACCM            GET *INACCESSIBLE*
         LI,R3    -20
         LB,R4    16,R3
         AI,R2    1
         STB,R4   *R1,R2
         BIR,R3   %-3
         LCI      5
         PLM,SR4  *R7
         CI,SR4   LISTATB2          LIST OR REVIREW
         BE       LISTATB9          LIST
         STB,R0   DELETEF           REVIEW, RESET CR NEEDED F;AG
         B        REVRET1           YES
LISTATB2B PSW,1   *R7
         LB,R1    M:EI+12           GET KEYM
         BAL,SR4  BIN2BCD
         PLW,R1   *R7
         LI,R2    ' K'
         STH,R2   R3
         STW,R3   0,R1
         B        LISTATB2A
OPNEI    GEN,8,24 20,M:EI
         DATA     0                 NO OPTIONS
LISTATB2 LW,D3    R2                SAVE LINE LENGTH
         LW,R2    DEVICE,R7
         CI,R2    4            LABELED TAPE?
         BNE      %+4               NO
         LW,R3    TLABEL+1
         CW,R3    ='RFIL'           IS FILE RANDOM
         BE       LISTRAND          YES
         MTB,0    SR3               IF SYNON, OPEN THE REAL FILE
         BEZ      %+2
         CAL1,1   OPNEI
         LI,R3    X'F0'
         AND,R3   M:EI+5            GET ORG/FMT
         SLS,R3   -4
         CI,R2    7                 IF AT, USE FMTS
         BNE      %+2
         AI,R3    4
         LB,R3    ORGN,R3
         BEZ      LISTATB2B         KEYED, DO KEYMAX TOO
         LI,R4    ORG               GET BYTE DISPLACEMENT
         STB,R3   *R1,R4            PUT IN BUFFER
         CI,R2    7                 IF AT, PUT ITS ATTRS
         BNE      LISTATB2A
         LW,R5    R1
         CI,R3    'U'               BLOCKS ONLY FOR U FMT
         BE       LISTATAT7
         CI,R3    'F'               REC ONLY FOR FMT F
         BNE      LISTATAT2
         LW,R1    M:EI+18
         SLS,R1   -17
         BAL,SR4  BIN2BCD
         STW,R2   REC,R5
         STW,R3   REC+1,R5
LISTATAT2 LW,R1   M:EI+3            BLKSZ
         SLS,R1   -17
         BAL,SR4  BIN2BCD
         STW,R2   1,R5
         STW,R3   2,R5
LISTATAT7 CAL1,1  ATEOF
         LW,R1    M:EI+17           BLKCNT
         MTW,0    ATTRB,R7
         BGZ      %+2
         AWM,R1   GRANCNT
         BAL,SR4  BIN2BCD
         STW,R2   7,R5
         STW,R3   8,R5
         LI,R1    X'1FFFF'          GET FSN
         AND,R1   M:EI+16
         BAL,SR4  BIN2BCD
         STW,R3   6,R5
         LW,R1    R5                RESTORE LINE START
         LI,SR3   0
         LW,R2    D3
         BAL,SR4  LFILE
         B        LIST30
*
ATEOF    GEN,8,24 X'1C',M:EI
         DATA     0
*
LISTATB2A LI,R4   1                 SET BYTE DISP REGS FOR VLP SEARCH
         LI,R2    2
         LI,R3    3
         LW,SR3   M:EI+11           FPARAM ADDR
LISTATB3 LB,R5    *SR3              GET VLP CODE
         DO1      VERSION=1
         CI,R5    X'10'
         DO1      VERSION=2
         CI,R5    X'15'             MAX CODE
         BG       LISTATB4          NOT USEFUL
         MTB,0    *SR3,R2
         BEZ      LISTATB4          PARAMETER NOT PRESENT
         LCI      4                 SAVE A FEW REGS
         PSM,R1   *R7
         EXU      VLPTAB-1,R5       BRANCH IF WANTED - OTHERWISE NOP
         LCI      4
         PLM,R1   *R7
LISTATB4 MTB,0    *SR3,R4           TEST IF LAST ENTRY
         BNEZ     LISTATB7          YES
         LB,R5    *SR3,R3           GET LENGTH OF PARAMETER
         AW,SR3   R5                INCREMENT VLP POINTER
         AI,SR3   1                 INCREMENT FOR CODE WORD
         B        LISTATB3          GET NEXT CODE
LISTATB7 LI,R3    ORG
         LB,R2    *R1,R3
         CI,R2    'R'               IS ORG RANDOM
         BE       LISTATB6          YES - LEAVE NO. REC BLANK
         STW,R1   RSSAVE,R7         SAVE BUFFER ADR
         LI,R1    100               INITIALIZE PREC COUNT
LISTATB8 CAL1,1   FPTPREC           DO PRECORD TO GET NUM OF RECS
         USECT    PLSECT
FPTPREC  GEN,8,7,17      X'1D',0,M:EI
         DATA     X'C0000000'
         DATA     100               100 RECS (TO PERMIT BREAKS)
         DATA     ABNPREC           ABNORMAL ADR
         USECT    LIST
         MTW,0    BREAK
         BNEZ     LIST30
         AI,R1    100
         B        LISTATB8
*
ABNPREC  LW,R2    M:EI+4
         SLS,R2   -17               GET ARS FROM DCB
         SW,R1    R2                COMPUTE NUM OF RECS IN FILE
         LW,R2    DEVICE,R7         IF TAPE ACCUMULATE RECORDS
         CI,R2    4
         BNE      %+4
         MTW,0    ATTRB,R7
         BGZ      %+2
         AWM,R1   GRANCNT
         BAL,SR4  BIN2BCD           CONVERT TO BCD
         LW,R1    RSSAVE,R7         RESTORE BUFFER ADR
         STW,R2   REC,R1            ENTER NUM OF RECS IN PRINT LINE
         STW,R3   REC+1,R1
LISTATB6 RES
         SLS,R1   2                 SAVE BA(BUFFER IN RSSAVE
         STW,R1   RSSAVE,R7         FOR WACC
         BAL,SR4  SYNONX            PRINT SYNON
         BAL,SR4  RACCTX            PRINT READ ACCOUNTS
         BAL,SR4  WACCTX            PRINT WRITE ACCOUNTS
         DO       VERSION=2
         BAL,SR4  EACCTX       PRINT EXECUTE ACCOUNTS.
         BAL,SR4  UACCTX       PRINT VEHICLE ACCOUNT.
         FIN
         LW,R2    D3                PRINT THE LINE
         LW,R1    RSSAVE,R7
         SLS,R1   -2
         LI,SR3   0                 CLEAR ERROR REG
LISTATB9 BAL,SR4  LFILE             PUT IT OUT
         MTW,0    EATTRB            WAS 'EA' SPECIFIED
         BEZ      %+2
         BAL,SR4  DATELIST          GO LIST DATE ATTRIBUTES
         MTW,0    DELETEF           ARE WE REVIEW
         BNEZ     REVRET2           YES
         B        LIST30            GO CLOSE FILE
LISTRAND LI,R2    'R'               RANDOM FILE ON TAPE
         LI,R4    ORG
         STB,R2   *R1,R4            PUT 'R' IN PRINT BUFFER
         LI,R4    1
         LI,SR3   TLABEL+1          LOC -1 OF NO OF GRANULES
         BAL,SR4  GRANULE           GO PUT GRANULES IN BUFFER
         B        LISTATB2A         GET REST OF ATTRIBUTES
ERRADD   LB,R1    SR3
         LI,R2    X'FF00'           IS THERE A NAME
         CW,R2    M:EI+22
         BAZ      LIST7             NO
         CI,R1    8                 SYNON
         BE       LIST1             YES
         MTW,0    ATTRB,R7          IF SELECTIVE, USE % MESSAGE
         BLEZ     LIST1             NOT
LIST7    EQU      %
         LI,R1    0                 NO-REPORT ERROR
         BAL,SR4  ERROR
SOMERR   RES
         BAL,SR4  D2CHK             UPDATE ERR SEVERITY
         MTW,0    ATTRB,R7          WAS FID SPECIFIED
         BGZ      LIST31            YES
LIST40   RES
         LW,R1    LISTTERM
         CI,R1    X'15'             END OF COMMAND
         BE       %+4
         LI,R1    30                ERROR - IMPROPER TERMINATION
         BAL,SR4  ERROR
         BAL,SR4  D2CHK
LISTEND  RES
         LW,R5    DEVICE,R7
         LW,R5    LSTTXTS,R5        GET APPROPROPRAITE MESS
         LW,D2    SEVMAX            GET MAX LEVEL
         CI,SR2   1                 IF ONE FILE, NO COUNT
         BNE      %+2
         LI,SR2   0
         MTW,0    DELETEF           IS THIS ONLINE REVIEW
         BNEZ     LIST42            YES, NO LAST LINE
         MTW,0    ATTRB,R7
         BNEZ     LIST42            NOT SIMPLE LIST
         LI,R3    1                 PRINT LAST LINE
         LI,R1    PRTBUF
         AW,R1    R7
         LB,R2    *R1
         BEZ      %+2
         CAL1,1   FPTLFILE
LIST42   BAL,SR4  PRTERR            PUT OUT THE ERRORS
         LW,SR1   GRANCNT           GET TOTAL GRANULES
         SCS,SR1  16                THEN THE REST
         BAL,SR4  PRTNOF            PRINT 'XXX TOTAL GRANULES'
         MTW,0    ATTRB,R7          IF NOT SELECTIVE, TOP OF FORM
         BGEZ     RETURN
         CAL1,1   WEOFLO
RETURN   EQU      %
         LCI      7
         PLM,R5   *R7               RESTORE REGISTERS
         B        *SR4              RETURN
LSTTEXT  TEXT     '.. % FILES LISTED, % DELETED, %% TOTAL GRANULES
'
LSTLTXT  TEXT     '.. % FILES LISTED, %%% TOTAL RECORDS
'
LSTATXT  TEXT     '.. % FILES LISTED, %%% TOTAL BLOCKS
'
LSTTXTS  EQU      %-3               DC IS MIN
         DATA     LSTTEXT,LSTLTXT,LSTTEXT,LSTLTXT,LSTATXT
ERRADD2  LI,R1    0                 REPORT M:LO ERROR
         BAL,SR4  ERROR
         LI,R1    56                ERROR WRITING LO
         BAL,SR4  ERROR
         B        RETURN
LIST50   LB,R2    NOFILES           GET MESSAGE COUNT
         CI,SR2   0
         BNEZ     LIST40            GOT SOME
         LI,R1    M:UC              SELECT BATCH OR ONLINE
         LC       BOG
         BCS,12   %+3               BRANCH IF ONLINE OR GHOST
         LI,R1    M:LO
         AI,R2    -1                REMOVE N/L CHAR
         CAL1,1   FPTNOFIL
         USECT    PLSECT
FPTNOFIL GEN,8,7,17      X'91',0,R1
         DATA     X'34000010'
         DATA     NOFILES           BUFFER
         PZE      *R2               COUNT
         DATA     1                 BTD
NOFILES  TEXTC    'NO FILES IN DIRECTORY
'
         USECT    LIST
         B        RETURN
D2CHK    CW,D2    SEVMAX
         BLE      %+2
         STW,D2   SEVMAX
         LI,D2    0
         B        *SR4
         PAGE
* SUBROUTINE CDATE MOVES THE CREATION DATE FROM FPARAM TO THE
* PRINT BUFFER.
CDATE    LI,R4    0
         LW,R4    *SR3,R4           GET 1ST WORD OF DATE
         LI,R5    0
         SLD,R4   -16               SEPARATE MONTH AND DAY
         SLS,R5   -16
         CI,R5    X'F00'            MORE THAN 9
         BANZ     %+2
         AI,R5    -X'F000'          NO, ONLY ONE DIGIT
         OR,R5    ='    '
         STW,R5   DATE,R1           PUT DAY IN BUFFER
         AI,R4    -X'F1F0'+10       CONVERT MOS OVER 9
         BGZ      %+2
         AI,R4    X'100'-10         AND THOSE LESS TOO
         LW,R5    MONTH,R4
         STW,R5   DATE+1,R1         PUT MONTH IN BUFFER
         INT,R5   *SR3,R2           GET YEAR WORD
         SLS,R5   8                 POSITION
         OR,R5    ='    '
         STW,R5   DATE+2,R1         PUT IN BUFFER
         LB,R4    *SR3              CHK IF LOOKING AT FPARAM CODE '0A'
         CI,R4    X'A'
         BNE      *SR4
         LW,R4    *SR3,R3           GET HR AND MIN
         LW,R5    =X'40404040'
         SCD,R4   -16               HRS IN R4; MIN IN R5
         SLS,R5   -8
         LI,R6    ':'
         STB,R6   R5                GENERATE HR:MIN FOR BUFFER
         SCD,R4   -8                AND POSITION THEM
         LCI      2
         STM,R4   DATE-2,R1         AND STORE IN BUFFER
         B        *SR4              RETURN
         PAGE
* THE FOLLOWING SUBROUTINES HANDLE THE SAVING OF DATE ATTRIBUTES IN
* DATETBL AND LISTING THESE ATTRIBUTES IF THE 'EA' OPTION WAS USED.
EDATE    LI,R5    0                 EXPIRATION DATE
         B        ADATE1
MDATE    LI,R5    2                 CREATION DATE
         B        ADATE1
BDATE    MTB,0    *SR3,R2           BACKUP DATE
         BEZ      *SR4              NO DATE ENTERED
         LI,R5    4
         B        ADATE1
ADATE    LI,R5    6                 ACCESS DATE
ADATE1   LW,R3    *SR3,R4
         STW,R3   DATETBL,R5        MOVE DATE FROM VLP TO DATE TABLE
         LW,R3    *SR3,R2
         STW,R3   DATETBL+1,R5
         B        *SR4
*
DATELIST LI,D3    4                 LIST 4 DATES IF PRESENT
         PSW,SR4  *R7               SAVE LINK
         LW,R1    ='    '
         STW,R1   IOBUF,R7
         LI,SR3   DATETBL
         LI,R6    0                 INDEX INTO TDATE
DATEL2   LW,R5    *SR3
         BEZ      DATEL3            NO DATE IN THIS TABLE ENTRY
         LCI      4
         LM,R1    TDATE,R6          MOVE TEXT INFO TO LINE
         STM,R1   IOBUF+1,R7
         LI,R3    2
         LI,R2    1                 SET UP REGS FOR CDATE
         LW,R1    R7
         AI,R1    IOBUF-2           PUT AT IOBUF+5
         CW,R5    ='NEVE'
         BE       DATEL4            EXP DATE IS NEVER
         BAL,SR4  CDATE             ENTER DATE IN LINE
DATEL5   EQU      %
         AI,R1    2                 START OF BUFFER
         LI,R2    DATE*4+12         LENGTH
         LW,R5    R6                SAVE TDATE INDEX
         BAL,SR4  LFILE
         LW,R6    R5
DATEL3   AI,SR3   2                 INCREMENT DATETBL POINTER
         AI,R6    4                 INCREMENT TDATE INDEX
         BDR,D3   DATEL2            LOOP 4 TIMES
         PLW,SR4  *R7               RESTORE LINK
         B        *SR4
DATEL4   LW,R4    ='    '
         STW,R4   IOBUF+5,R7
         STW,R5   IOBUF+6,R7        PUT 'NEVER' IN LINE
         LW,R5    *SR3,R2
         STW,R5   IOBUF+7,R7
         B        DATEL5
         PAGE
* SUBROUTINE GRANULE GETS THE GRANULE SIZE FROM FPARAM, CONVERTS IT
* TO BCD, AND ENTERS THE VALUE IN THE PRINT BUFFER.
GRANULE  PSW,SR4  *R7               SAVE LINK REG
         PSW,R1   *R7               SAVEER1
         LW,R1    *SR3,R4           GET NO. OF GRANULES
         LW,R3    SYNFLAG,R7        NO COUNT IF SYNON
         BNEZ     GRAN1             DONT COUNT IT
         LW,R3    ATTRB,R7          OR SINGLE FILES
         BGZ      GRAN1
         MTW,0    DELETEF           OR REVIEW(A)
         BNEZ     GRAN1
         AWM,R1   GRANCNT           UPDATE GRANULE COUNT
GRAN1    RES
         BAL,SR4  BIN2BCD           CONVERT TO BCD
         PLW,R1   *R7
         STW,R2   GRAN,R1
         STW,R3   GRAN+1,R1
         PLW,SR4  *R7               RESTORE LINK
         B        *SR4              RETURN
*
* SUBROUTINE FNAME IS ENTERED ON A '01' VLP CODE.  EXIT IS MADE TO
* SYNON IF NAME IN FPARAM AND NAME IN DCB DO NOT MATCH.
FNAME    LW,R5    DEVICE,R7         CHECK DEVICE CODE
         CI,R5    5            TEST IF DP.
         BE       %+3          YES.
         CI,R5    3                 RAD FILE
         BNE      *SR4              NO - EXIT
         LW,R4    SR3               GET FPARAM ADDRESS
         AI,R4    1                 ADDRESS OF NAME
         LB,R5    *R4               GET COUNT OF FPARAM NAME
         CB,R5    M:EI+23           SAME LENGTH AS DCB FILE NAME
         BNE      SYNON             NO - MUST BE SYNON
         LB,R3    M:EI+23,5         COMPARE NAMES
         CB,R3    *R4,R5
         BNE      SYNON
         BDR,R5   %-3
         B        *SR4              RETURN
SYNON    RES
         LI,R3    IOBUF+210
         AW,R3    R7                COMPUTE DEST ADR
         STW,R3   SYNFLAG,R7        SAVE ADR OF SYNON NAME
         LI,R1    8
         LW,R2    *SR3,R1           MOVE SYNON TO TEMP AREA
         STW,R2   *R3,R1
         BDR,R1   %-2
         B        *SR4              RETURN
*
* SUBROUTINE SYNONX GETS THE SYNON FROM FPARAM AND PRINTS THE LINE
* 'SYNON= XXX'.
SYNONX   EQU      %
         LW,R4    SYNFLAG,R7
         BEZ      *SR4              NO SYNONYM
         LI,D4    1                 ONLY ONE
         MTB,1    SR4               FLAG FOR TEXTCC INPUT
         BAL,R5   WACC20            DO EM
         TEXTC    '  SYNON='
*
GACCT    CVA,R5   RDWREXUN-27       CONVERT CODE TO TBL ADDR
         LB,R4    *SR3,R2           # WORDS
         STW,SR3  1,R5              WHERE THEY ARE
         CI,R4    1                 ISS THERE ONLY ONE WORD
         BNE      GACCT1            NO
         LCI      2
         LM,R2    *SR3              WHAT IS IT
         LI,R2    4                 IF ALL OR NONE, POINT TO
         BNE      %+3               ONE WITH BLANKS AFTER IT
         ANLZ,R3  %+2
         STW,R3   1,R5
         CW,R3    ALLT-2,R2
         BDR,R2   %-4
GACCT1   STW,R4   0,R5
         B        *SR4
RDWREXUN DATA     UNTBL-RDTBL
WD3      DATA     3
         DATA     EXTBL-UNTBL+RDTBL
         DATA     WRTBL+UNTBL-EXTBL-RDTBL
         DATA     UNTBL-EXTBL
         BOUND    8
ALLT     TEXT     'ALL  '
NONET    TEXT     'NONE'
BLANKT   TEXT     ' '
*
* SUBROUTINE RACCTX GETS READ ACCOUNTS FROM TABLE RDACCT, FORMATS THEM
* IN THE PRINT BUFFER, AND PRINTS THE LINE.
RACCTX   LW,D4    RDTBL
         BEZ      *SR4
         LW,R4    RDTBL+1           ADDRESS THEREOF
         CI,D4    2                 DONT CHECK FIRST OF MANY
         BG       RACC10
         LCI      2
         LM,R2    1,R4
         CD,R2    ALLT
         BNE      RACC10
         STW,R0   EXTBL             IGNORE EX INFO IF READ ALL
         STW,R0   UNTBL             AND UNDER
         B        *SR4
RACC10   BAL,R5   WACC19            GO TO ACCOUNT FORMATTER
         TEXTC    '  READ='
         DO       VERSION=2
*
* SUBROUTINE EACCTX GETS EXECUTE ACCOUNTS FROM TABLE EXACCT,
* FORMATS THEM INTO THE PRINT BUFFER, AND PRINTS THE LINE.
EACCTX   EQU      %
         LW,D4    EXTBL
         BEZ      *SR4
         LW,R4    EXTBL+1
         BAL,R5   WACC19
         TEXTC    '  EXECUTE='
*
* SUBROUTINE UACCTX GETS VEHICLE ACCOUNT FROM TABLE UNACCT,
* FORMATS THEM INTO THE PRINT BUFFER, AND PRINTS THE LINE.
UACCTX   EQU      %
         LW,D4    UNTBL
         BEZ      *SR4               NONE
         LW,R4    UNTBL+1
         MTB,1    SR4               SET UNDER FLAG
         DW,D4    WD3               COUNT ENTRIES (3-WORD ONES)
         BAL,R5   WACC20            AND PRINT EM
         TEXTC    '  VEHICLE='
         FIN
*
* SUBROUTINE WACCTX GETS WRITE ACCOUNTS FROM TABLE WRTACCT, FORMATS
* THEM IN THE PRINT BUFFER, AND PRINTS THE LINE.
WACCTX   LW,D4    WRTBL
         BEZ      *SR4
         LW,R4    WRTBL+1
         CI,D4    2                 DONT CHECK FIRST OF NAMY
         BG       WACC10
         LCI      2
         LM,R2    1,R4
         CD,R2    NONET             IS DEFAULT SPECIFIED
         BE       *SR4              YES - EXIT
WACC10   BAL,R5   WACC19
         TEXTC    '  WRITE='
WACC19   SLS,D4   -1                2-WORD ENTRIES
WACC20   STB,R0   R5                CLEAR HEADER COUNT
         LW,R1    R5                PUT OUT HEADER
         B        WACC45
WACC60   BAL,R1   WACC45            PUT , AFTER EACH
         TEXTC    ', '
WACC30   EQU      %
         SW,R1    R5                IF HEADER LAST GET IT TOO
         STB,R0   R5                IF NAME IS TOO LONG
         BNEZ     %+2
         STB,R2   R5
WACC40   LCI      2
         LM,R2    1,R4              GET ACCOUNT FROM TABLE
         ANLZ,R1  WACC40+1
         MTB,0    SR4               IF UNDER, ALREADY TEXTC
         BNEZ     WACC44
         LI,R1    IOBUF+22
         AW,R1    R7
         STB,R3   *R1               LAST BYTE TO TEMP BUFFER
         AI,R1    -2                BEG OF TEXTC
         SLD,R2   -8
         OR,R2    =X'08000000'      SET UP IN TEXTC FORMAT
         STD,R2   *R1
         LI,R2    ' '               STRIP BLANKS
         LB,R3    *R1
         CB,R2    *R1,R3
         BNE      %+2
         BDR,R3   %-2
         STB,R3   *R1
WACC44   MTB,1    R1                SET NAME FLAG
WACC45   RES
         LCI      4
         PSM,SR4  *R7
         AW,D3    RSSAVE,R7         GEN BYTE ADDR
         SCS,D3   -2                IF PROPER FORMAT
         BAL,SR4  UNPRINT           ENTER ACCOUNT IN BUFFER
         LCI      4
         PLM,SR4  *R7
         AW,D3    R2                ADJUST FOR THIS ONE
         MTB,0    R1                IS THIS NAME OR HEADER
         BE       WACC30            HEADER, GET NAME
         LW,R1    RSSAVE,R7
         CI,R1    BA(%)             IF LIST, LIMIT TO M:LO PLATEN
         BL       WACC48            ELSE 108 BYTES
         LI,R1    X'FF00'
         AND,R1   M:LO+1
         CI,R1    X'9000'
         BNE      WACC48
         LI,R1    BA(JB:PCW)
         CB,D3    0,R1
         B        %+2
WACC48   CI,D3    108
         BG       WACC50
         AI,R4    2
         MTB,0    SR4               IF UNDER, 3 WORD ENTRIES
         BEZ      %+2
         AI,R4    1
         BDR,D4   WACC60            BR IF MORE ACCOUNTS
         B        *SR4
WACC50   EQU      %
         SW,D3    R2                SCRUB LAST ONE
         LB,R2    R5                AND HEADER IF THERE
         SW,D3    R2
         LW,R2    D3                SIZE
         LW,R1    RSSAVE,R7
         SLS,R1   -2
         PSW,SR4  *R7               SAVE RETURN
         BAL,SR4  LFILE
         LI,D3    0                 RESET SIZE
         PLW,SR4  *R7               RSTORE RETURN
         B        WACC20            PUTOUT A NEW HEADER
*
* BRANCH TABLE ORDERED BY VLP CODE
VLPTAB   BAL,SR4  FNAME             FILE NAME
         NOP                        ACCT
         NOP                        PASSWORD
         BAL,SR4  EDATE             EXPIRATION DATE
         BAL,SR4  GACCT             READ ACCOUNTS
         BAL,SR4  GACCT             WRITE ACCOUNTS
         NOP                        INSN
         NOP                        OUTSN
         NOP                        ORG
         BAL,SR4  CDATE+1
         BAL,SR4  SYNON             SYNON
         NOP
         BAL,SR4  GRANULE           GRANULES
         BAL,SR4  MDATE             CREATION DATE
         BAL,SR4  ADATE             ACCESS DATE
         BAL,SR4  BDATE             BACKUP DATE
         DO       VERSION=2
         NOP
         NOP
         NOP
         BAL,SR4  GACCT             EXECUTE ACCOUNTS
         BAL,SR4  GACCT             EXECUTE VEHICLES
         NOP
         NOP
         NOP
         FIN
TDATE    TEXT     '  WILL EXPIRE'
         TEXT     '  CREATED  ON'
         TEXT     '  BACKED UP ON'
         TEXT     '  LAST ACCESS ON'
FILEBUSY TEXT     ' **FILE BUSY**      '
INACCM   TEXT     ' *INACCESSIBLE* '
LISTHEAD TEXTC    'ORG    GRAN     REC    LAST MODIFIED    NAME'
LISTHAT  TEXTC    'FMT     BLK     REC     FSN  BLOCKS     NAME'
MONTH    EQU      %-1
         TEXT     ' JAN'
         TEXT     ' FEB'
         TEXT     ' MAR'
         TEXT     ' APR'
         TEXT     ' MAY'
         TEXT     ' JUN'
         TEXT     ' JUL'
         TEXT     ' AUG'
         TEXT     ' SEP'
         TEXT     ' OCT'
         TEXT     ' NOV'
         TEXT     ' DEC'
ORGN     DATA     'CCKR'-'K'**8
         DATA     'UFDV','U***','****','****'
         PAGE
LISTFT   EQU      %
         LI,R1    1
         CW,R1    DEVICE+1,R7       WAS ONLY ONE INSN SPECIFIED
         BE       LISTFT2           YES
         LI,R1    31
         BAL,SR4  ERROR             REPORT ERROR - MORE THAN ONE INSN
         B        RETURN
LISTFT2  LI,R1    0
         BAL,SR4  BLDCB             BUILD M:EI AND OPEN
         CI,D2    1
         BG       RETURN            ERROR ON OPEN - EXIT
         CAL1,1   FPTREW            REWIND
         CAL1,1   SPFPT             SPACE FORWARD ONE FILE
         CAL1,1   SETEIDCB          SET ERR AND ABN ADDRESSES
         CAL1,1   SKIPREC           BACK OVER HEADER RECORDS
         CAL1,1   SKIPREC
         CAL1,1   SKIPREC
         LI,R1    PRTBUF+1          FIRST BUFFER ADDR
         AW,R1    R7
         CAL1,1   RDACN             READ LABEL REC
         LW,R2    0,R1
         CW,R2    =':LBL'           LABEL REC
         BNE      LISTFT7           NO
         AI,R1    -1                BUFFER FOR MSG (PRTBUF)
         LCI      2
         LM,R2    INSN
PRTBUFI7 RES
         STM,R2   PRTBUF,R7         SET UP PRINT LINE
         LI,R2    11                LINE LENGTH
         LI,R3    1                 BTD
         LI,R6    M:LO
         CAL1,1   FPTLFILE          PRINT INSN
         AI,R1    4                 :ACN BUFFER (PRTBUF+4)
         CAL1,1   RDACN             READ ACCT REC
         LW,R5    0,R1
         CW,R5    =':ACN'           IS REC ACCT REC
         BNE      LISTFT7           NO
         LCI      2
         LM,R5    ACCT
         STM,R5   PRTBUF+3,R7
         AI,R1    -1
         LI,R2    15                LINE LENGTH
         LI,R6    M:LO
         CAL1,1   FPTLFILE          PRINT ACCOUNT
         CAL1,1   FPTREW            REWIND THE TAPE
         LW,R2    PRTBUF+2,R7       CHECK FOR SAME SN AS FT
         CW,R2    M:EISN
         BE       %+2
         CAL1,1   FPTREW1           REMOVE IF DIFFERENT SN
         BAL,SR4  CLOSEI
         MTW,-2   DEVICE,R7         CHANGE TO LT
         LI,R1    PRTBUF+PRTBUF+PRTBUF+PRTBUF+8
         STW,R1   DEVICE+2,R7       POINT TO SN
         MTW,2    FILE,R7           SET ACCOUNT ONLY
         AI,R1    11                POINT TO ACCOUNT
         STW,R1   FILE+1,R7
         LW,R1    DOTS              TERMINATE STUFF
         STW,R1   PRTBUF+3,R7
         STW,R1   PRTBUF+4,R7
         STW,R1   PRTBUF+7,R7
         STW,R1   MAXCMBX,R7        SET LIMIT
         B        LIST20            AND USE LIST LOGIC
DOTS     TEXT     '....'
*
LISTFT7  LB,R2    UNLABEL           UNLABELED TAPE
         LI,R1    UNLABEL
         LI,R3    1                 BTD
         LI,R6    M:LO              SET UP DCB
         CAL1,1   FPTLFILE          PRINT -UNLABELED TAPE-
         B        RETURN            EXIT
*
FTABN    LB,R2    SR3               GET ABN CODE
         CI,R2    7
         BE       *SR1              LOST DATA IS OK
         LI,R1    0
         B        LIST6             REPORT ERROR AND QUIT
SKIPREC  GEN,8,7,17      X'1D',0,M:EI
         DATA     X'80000010'
         DATA     1
SETEIDCB GEN,8,24 6,M:EI
         DATA     X'C0000000'
         DATA     FTABN
         DATA     FTABN
RDACN    GEN,8,7,17      X'10',0,M:EI
         DATA     X'F0000010'
         DATA     FTABN
         DATA     FTABN
         PZE      *R1
         DATA     24
INSN     TEXT     ' INSN = '
ACCT     TEXT     ' ACCT = '
UNLABEL  TEXTC    'UNLABELED TAPE'
         TITLE    'REM-REW'
REW      DSECT    1                 REWIND
         LCI      7
         PSM,R5   *R7               SAVE REGISTERS
         BAL,SR4  CLRARG            CLEAR ARGUMENT TABLE
         MTW,3    DEVICE,R7         DEFAULT FT
         LW,R1    TERM,R7
         CI,R1    '#'
         BE       %+3               SPECIAL FT FORM
         CI,R1    ' '
         BNE      REW7
         BAL,SR4  DEVTRAN           GET DEVICE CODE AND REEL NO
         LW,R1    DEVICE,R7
         CI,R1    4                 MUST BE LT,FT,AT OR DP
         BL       REWA              ERROR
         CI,R1    7
         BLE      REW1              OK
REWA     LI,R1    34                INVALID DEVICE SPECIFICATION
         B        REW2+1
REW1     RES
         CI,D2    1                 ERROR DETECTED
         BG       RETURN            YES
REW7     LW,R5    DEVICE+1,R7       GET # OF SNS
         CI,R5    1                 REWIND PERMITS ONLY ONE
         BLE      %+3
         CI,D1    6                 REMOVE MORE IS OK
         BNE      SPE5-1
         LW,R1    TERM,R7
         CI,R1    X'15'             ANOTHER REEL NO. FOLLOW
         BE       REW6              NO
         CI,R1    '('               OPTION FOLLOW
         BE       REWB              YES
         LW,R2    DEVICE,R7
         CI,R2    7                 ANS TAPE
         BNE      REW2              NO - ERROR
         CI,R1    '/'               DOES FILE NAME FOLLOW
         BE       REWC              YES, USE IT
         AI,R5    0                 NO, BETTER HAVE SN
         BEZ      REW2              NONE, ERROR
         B        REW6              GO ONE, USE IT
REWC     BAL,SR4  FILTRAN           GO GET FILE NAME
         B        REW6
REWB     EQU      %
         BAL,SR4  GETARG6           GET OPTION
         LW,R1    TERM,R7
         CI,R1    ')'               CORRECT DELIMITER
         BNE      REW2              NO, ERROR
         LW,R2    ARGBUFF,R7        GET OPTION
         CW,R2    RINGT             IS IT RING
         BE       REW3              YES
         MTB,-2   R2                IS IT 2 CHARS
         BNEZ     REW2              NO
         AI,R2    'T'-' '           MAKE LAST CHAR A 'T'
         SLD,R2   -8
         CB,R2    R3                IS LAST CHAR A 'T'
         BNE      REW2              NO
         XW,R2    IN%ARG,R7         SET RESOUREC TYPE
         BNEZ     REW2              ALREADY SET
         B        REW6
RINGT    TEXTC    'RING'
         RES      -1
REW3     RES
         LI,R1    8                 RING, USE INOUT OPEN
         B        REW6+1
REWE     EQU      %
         BAL,SR4  GETARG6           GET NULL FIELD
         MTW,0    NCHAR,R7          IS FIELD NULL
         BNEZ     REW2              NO - SYNTAX ERROR
         LW,R2    TERM,R7
         CI,R2    '/'               DOES FILE NAME FOLLOW
         BE       REWC              YES
REW6     EQU      %
         LI,R1    0
         LW,R2    DEVICE,R7
         CI,R2    5
         BG       REW5              FT OR AT
         BE       REW8              DP
         MTW,2    DEVICE,R7         CHANGE LT TO FT
REW5     EQU      %
         CI,R2    7                 IF AT, USE OPNNXT
         BNE      %+4               UNLESS FILE SPECIFIED
         MTW,0    FILE,R7
         BNEZ     %+2
         AI,R1    X'400'
         CI,D1    6                 IF REMOVE DO TEST OPN
         BNE      %+2
         OR,R1    =X'80000'
         BAL,SR4  BLDCB             GO BUILD INPUT DCB
         MTB,-2   SR3               IF END OF ALL FILES
         BEZ      REW9              TRY ONE MORE TIME
         CI,D2    1                 ERROR DETECTED
         BG       RETURN            YES-RETURN
         CI,D1    7                 CHECK COMMAND TYPE
         BL       REW4              REMOVE(6)
         BG       RETURN            MOUNT(2832)
         CAL1,1   FPTREW            NO-REWIND
         USECT    PLSECT
FPTREW   GEN,8,7,17      X'01',0,M:EI
         USECT    REW
         B        RETURN            RETURN
REW9     RES
         MTW,-1   ERRFLAG
         LI,D2    0                 CLEAR ERROR
         CI,D1    6                 BUT ONLY IF REMOVE
         BNE      RETURN            OF ANS TAPE
         BAL,SR4  OPNNXT
         AI,SR3 0
         BEZ      REW4              WORKED
REW10    LI,R1    0
         BAL,SR4  ERROR
         B        RETURN
REW8     EQU      %
         DO       VERSION=1
         B        REWA
         ELSE
         CI,D1    7
         BE       REWA              REW - ERROR FOR DP
         BG       REW5+2            MOUNT
         MTW,0    DEVICE+1,R7
         BEZ      REW2              MUST HAVE SN FOR DP
         LI,R1    4                 OPEN NEXT, INPUT
         BAL,SR4  BLDCB
         LW,R1    =X'00200000'
         CW,R1    M:EI              WAS FILE OPENED
         BAZ      RETURN            NO - RELEASED BY OPEN
REW4     CAL1,1   FPTREW1
         LW,R5    INSER             CLEAR SN OF REMOVED DEVICE
         BAL,SR4  CLOSEI
         LI,R1    INSER
         CW,R5    INSER
         BE       %+4
         CW,R5    OUTSER
         BNE      RETURN
         LI,R1    OUTSER
         STW,R0   0,R1
         B        RETURN
REW2     LI,R1    17                SYNTAX ERROR
         BAL,SR4  ERROR
         B        RETURN            EXIT
         USECT    PLSECT
FPTREW1  GEN,8,7,17      X'15',0,M:EI
         DATA     X'20'             REMOVE
         FIN
         TITLE    'WRITE END OF FILE'
WEOF     DSECT    1
         LCI      7
         PSM,R5   *R7
         LW,R1    TERM,R7
         CI,R1    X'15'             PARAMETERS PRESENT
         BNE      WEOF2             YES, GETEM
         LI,R1    M:EO              ASSUME EO
         MTW,0    TOSWT,R7
         BNEZ     WEOF1             GOOD GUESS
         LH,R1    M:EI+1            NO OUT, IS EI INOUT (SPE)
         CI,R1    8
         BAZ      WEOF3             NOTHING TO WRITE ON
         LI,R1    M:EI
WEOF1    RES
         CAL1,1   SETEOF            SET ERR/ABN IN DCB
         CAL1,1   FPTWEOF           WRITE AN EOF
         B        RETURN
FPTWEOF  GEN,8,24 X'82',1
SETEOF   GEN,8,24 X'86',1           SETDCB *R1
         DATA     X'C0000000',WEOFER,WEOFER
*
WEOF2    RES
         BAL,SR4  CLRARG
         MTW,3    DEVICE,R7         DEFAULT FT
         LI,D1    1                 SET OUTPUT FLAG
         BAL,SR4  DEVTRAN
         LW,R2    DEVICE,R7
         CI,R2    6                 MUST BE FT,LP,CP OR PP
         BE       %+3
         CI,R2    9
         BL       REWA
         LI,R1    1                 BUILD OUTPUT DCB
         BAL,SR4  BLDCB
         CI,D2    2                 GIVE UP
         BGE      RETURN            YUP
         LI,R1    M:EO
         STW,R1   TOSWT,R7          SET DEVICE OUT THERE
         B        WEOF1
*
WEOF3    LI,R1    20                NO DEFINED OUTPUT DEVICE
         B        REW2+1
*
WEOFER   LI,R1    0                 IO ERROR
         B        REW2+1
         TITLE    'OPEN NEXT M:EI AND CHECK THAT NAME CHANGES'
OPNNXT   DSECT    1
         LCI      2                 SAVE REGS
         PSM,SR1  *R7
         LI,SR1   X'100'
         CH,SR1   M:EI+23           IF NO FILE NAME NOW, MUST
         BE       OPNX9             ALREADY HAVE ERROR
         LW,SR1   =X'C0000400'      OPNNXT,ERR,ABN
         STW,SR1  OPNXFPT+1
         LI,SR1   OPNX1             ERR,ABN ADDR
         STW,SR1  OPNXFPT+2
         STW,SR1  OPNXFPT+3
         LI,SR1   TLBLSIZE          SET TLABEL SIZE
         STB,SR1  TLABEL
         LW,SR3   M:EI+11           CLEAR FPARAM
         STW,R0   *SR3
         STW,R0   TLABEL+1          CLEAR RANDOM ID
         LI,SR3   0
         LI,SR2   BA(OPNXFPT+5)
         OR,SR2   =X'20000000'      MOVE 32 BYTES
         LI,SR1   BA(M:EI+23)
         MBS,SR1  0
         CAL1,1   OPNXFPT
         OR,SR4   =X'20000000'      SET GOOD RETURN IF OPEN
         B        OPNX9
OPNX1    AI,SR2   -32               BACK TO START OF FILE NAME
         LI,SR1   BA(M:EI+23)
         AW,SR2   =X'20000000'      COMPARE 32 BYTES
         CBS,SR1  0
         STCF     SR4
OPNX9    LB,SR1   SR3               SET CC=8 IF END OF ALL FILES
         CI,SR1   2
         BNE      %+2
         OR,SR4   =X'80000000'
         LCI      2
         PLM,SR1  *R7
         LC       SR4               SET CC
         B        *SR4
         TITLE    'SPACE AFTER LAST FILE'
SPE      DSECT    1
         LCI      7
         PSM,R5   *R7               SAVE REGISTERS
         BAL,SR4  CLRARG            CLEAN -ARGTBL-
         BAL,SR4  DEVTRAN           GO-TRANSLATE DEVICE
         LW,R2    DEVICE,R7
         CI,R2    4                 LT SPECIFICATION
         BE       SPE1              YES
         LI,R1    34                ERROR-NOT LT SPECICATION
         CI,R2    7                 AT
         BE       SPE1
         CI,2     6                 OR FT
         BNE      SPE5
SPE1     LI,R1    31
         LW,R2    DEVICE+1,R7       CHECK ONE MAX SN
         BDR,R2   SPE5
SPE2     CI,D2    1                 ANY ERRORS
         BGE      SPE51             YES, ABORT BATCH JOB
         LI,SR1   X'1400'           MIGHT GET NO-RING-IN-MIDDLE-OF-REEL
         LI,R1    30                CHECK TERMINATION
         LW,R2    TERM,R7
         CI,R2    X'15'
         BNE      SPE5              NOT RIGHT
SPE7     EQU      %
         LI,R1    X'C'              INOUT-UPDATE,OPEN NEXT
         BAL,SR4  BLDCB
         LI,SR2   0                 INITIALIZE FILE COUNT
         CH,SR1   SR3
         BNE      SPE8              NO
         CAL1,1   OPNIFT            YES, REWIND FIRST
         LI,SR1   -1                ONLY DO THIS ONCE
         CAL1,1   FPTREW
         BAL,SR4  CLOSEI
         B        SPE7
SPE8     LW,R2    M:EI              IF DEVICE
         CI,R2    1                 MUST USE SPF,READ LOOP
         BANZ     SPE4
SPE3     BAL,SR4  CLOSEI            GO-CLOSE THE FILE
         AI,SR2   1                 COUNT FILES SKIPPED
         MTW,0    BREAK
         BNEZ     SPE6              GIVE UP
         BAL,SR4  OPNNXT            TRY TO OPEN NEXT FILE
         BCS,8    SPE6              GOT 02 ABN, ALL DONE
         BNE      SPE3              AT LEAST THE NAME CHANGED
SPEEX    LI,R1    0                 IO ERROR
SPE5     RES
         BAL,SR4  ERROR
SPE51    LI,D2    4                 ABORT BATCH JOB
         B        RETURN
SKIPTXT  TEXT     '.. % FILES SKIPPED
'
SPE6     RES
         LI,R5    SKIPTXT
         BAL,SR4  PRTNOF
         LI,R1    1
         CW,R1    M:EI              IF DEVICE NPO NAME
         BANZ     RETURN
         LCI      4
         LM,R1    LASTFN            PUT LAST FILE NAME TOO
         STM,R1   TLABEL
         STW,R2   TLABEL+4
         LI,D3    TLABEL+4
         LI,R1    M:EI+23
         BAL,SR4  UNPRINT
         AI,R2    17
         LI,R3    X'15'             ADD NEWLINE IF ONLINE
         STB,R3   TLABEL,R2
         LI,R6    M:LO
         LI,R1    TLABEL            BUFFER ADDRESS
         LB,R3    J:JIT             GET TYPE, SET BTD
         BEZ      %+3
         LI,R6    M:UC
         AI,R2    1
         CAL1,1   FPTLFILE
         B        RETURN
LASTFN   TEXT     'LAST FILE NAME ='
OPNIFT   GEN,8,24 20,M:EI           OPEN INPUT,DEVICE
         DATA     X'C1000400'       INPUT, NXTF
         DATA     SPE7,SPE7         TRYAGAIN
         DATA     1                 INPUT
SPE4     LW,R2    =X'00200000'
         CW,R2    M:EI              IF NOT OPEN, PRINT IO ERROR
         BAZ      SPEEX
         CAL1,1   SKIPREC           SKIP BACK IN CASE AT END NOW
         CAL1,1   SPFPT             SKIP ONE FILE
         AI,SR2   1
         CAL1,1   SPRFPT            READ A RECORD, ABNS IF AT END
         MTW,0    BREAK
         BE       %-4               NO MARK HERE, TRY NEXT ONE
SPE9     CAL1,1   SKIPREC           SKIP BACK OVER SECOND MARK
         B        SPE6              AND RETURN
         TITLE    'SPACE FILE'
SPF      DSECT    1                 SPACE FILE
         LCI      7
         PSM,R5   *R7               SAVE REGISTERS
         BAL,SR4  CLRARG            ZERO -ARGTBL-
         MTW,3    DEVICE,R7         FT DEFAULT
         BAL,SR4  DEVTRAN           GO-TRANSLATE DEVICE
         LI,R1    34                MUST BE FT
         LW,R2    DEVICE,R7
         CI,R2    6                 FT
         BNE      SPFE              NOT FT
         LI,R1    31                MAX ONE SN
         LW,R2    DEVICE+1,R7
         BDR,R2   SPFE              TOO MANY
         LW,R2    TERM,R7
         CI,R2    ','
         BE       SPF2
         CI,R2    X'15'             IS COMMAND DONE
         BE       SPF2              YES
         CI,R2    '('               DOES OPTION FOLLOW
         BNE      SPF9              NO - BAD SYNTAX
         BAL,SR4  GETARG6
         LW,R2    ARGBUFF,R7
         CW,R2    =X'02F7E340'      IS IT 7T
         BNE      SPF9              NO - ERROR
         LW,R2    TERM,R7
         CI,R2    ')'               CORRECT TERMINATION
         BNE      SPF9              NO
         LI,R2    3
         STW,R2   MODE+1,R7         SET MODE CODE FOR 7T
         BAL,SR4  GETARG6
         MTW,0    NCHAR,R7
         BNEZ     SPF9              FIELD NOT NULL-ERROR
SPF2     EQU      %
         LI,R1    0                 OPEN IN INPUT MODE
         CI,D2    1                 ANY ERRORS IN SCAN
         BG       RETURN            YES - EXIT
         LW,SR4   CMBX,R7
         STW,SR4  WRTFPT,R7         SAVE CMBX
         BAL,SR4  BLDCB             GO OPEN M:EI
         CI,D2    1                 IF OPEN FAILED, QUIT
         BG       SPR1              AND PRINT MESSAGE
         LW,SR4   WRTFPT,R7
         STW,SR4  CMBX,R7      RESTORE CMBX.
         LCI      2
         LM,R1    SPFPT
         STM,R1   WRTFPT,R7         INITIALIZE MOVE FILE FPT
         LI,R1    0
         BAL,SR4  GETARG            GO-GET DIRECTION AND NO. OF FILES
         LI,R1    ARGBUF4+1         LOCATION OF DIRECTION AND NO. OF FIL
         LW,R2    NCHAR,R7          NO. OF CHARS IN ARGUMENT
         BAL,SR4  BCD2BIN           GO-CONVERT NO. OF FILES TO BINARY
         CI,R4    2                 OVERFLOW
         BNE      SPF3              NO
         LI,R1    10                BAD NUMMER
SPFE     RES
         BAL,SR4  ERROR
         B        RETURN
SPF3     CI,R4    1                 DIRECTION INDICATOR PRESENT
         BNE      SPF6              NO
         LB,R3    *R7,R1
         CI,R3    '-'               BACKWARD DIRECTION
         BE       SPF4              YES
         CI,R3    '+'               FORWARD DIRECTION
         BE       SPF5              YES
         LI,R1    37                ERROR-NOT A VALID DIRECTION INDICAT.
         B        SPFE
SPF4     LI,R3    X'10'
         STS,R3   WRTFPT+1,R7       SET BACKWARD DIRECTION
SPF5     AI,R1    1                 PASS OVER DIRECTION BYTE
         AI,R2    -1
         BAL,SR4  BCD2BIN           GO-CONVERT NO. OF FILES
         CI,R4    0                 NORMAL TERMINATION
         BE       SPF6              YES
         LI,R1    30                ERROR-INVALID TERMINATION
         BAL,SR4  ERROR
SPF6     CI,D1    8                 IS THIS SPF OR SPR
         BNE      SPR
         CAL1,1   WRTFPT,R7         MOVE THE TAPE A FILE
         BDR,R3   %-1
         B        RETURN            RETURN
SPF9     LI,R1    17
         B        SPFE
SPFPT    GEN,8,7,17      X'1C',0,M:EI
         DATA     0
SPR      LCI      2
         LM,1     SPRFPT
         OR,2     WRTFPT+1,R7       GET DIRECTION FLAG
         LI,R4    SPR1              AND ABN ADDR
         LCI      4
         STM,R1   WRTFPT,R7
         CAL1,1   WRTFPT,R7         DO IT
         B        RETURN
SPR1     LI,R1    0
         B        SPFE
SPRFPT   GEN,8,7,17 X'1D',,M:EI
         DATA     X'C0000000'
         DATA     1,SPE9            COUNT AND ABN FOR SPF FT
         TITLE    'DELETEALL'
DELETEAL DSECT    1
         LCI      7
         PSM,R5   *R7               SAVE REGISTERS
         BAL,SR4  CLRARG            CLEAR ARG TABLE
         LW,R1    TERM,R7
         CI,R1    X'15'             TEST FOR END OF COMMAND
         BE       DEVRTN            YES - SIMPLE DELETEALL
         CI,R1    ','
         BE       DEVRTN            NULL FROM FIELD
         LI,R6    DEVRTN
DEVTEST  BAL,SR4  CLRARG            CLEAR ARG TABLE
         BAL,SR4  DEVTRAN           TRANSLATE DEVICE
         LW,R2    DEVICE,R7         CHECK DELETEABILITY OF DEVICE
         CI,R2    3
         BE       0,R6              DC-EXIT
         CI,R2    5                 TEST IF DP
         BE       0,R6              YES-EXIT
         B        DELETE6           NO-ERROR
DEVRTN   LI,SR2   0                 INITIALIZE FILE COUNT
         STW,R7   2,R7              SET LIST NAMES FLAG
         LW,R1    TERM,R7
          CI,R1   X'15'             END OF COMMAND
         BE       DELALL3           YES
         LI,R1    -1
         STW,R1   COPYSK            ASSUME RANGE SPEC PRESENT
         BAL,SR4  REVIEW            GO PROCESS RANGE
         CI,D2    1
         BG       ALL9              ERROR - GO EXIT
DELALL3  EQU      %
         LI,R1    14                INOUT,NXTF,M:EI,FPARAM
         BAL,SR4  BLDCB
         CI,D2    2                 IF COMMAND IS TO BE ABORTED
         BG       ALL10             DO IT
         LB,R1    SR3               ANY FILES TO DELETE
         CI,R1    2
         BE       LIST50            NO
         DO       VERSION=2
         LC       BOG
         BCR,4    DELALL2           BR. IF NOT INTERACTIVE. SKIP CONFIRMATION OF
*                                   DELETEALL COMMAND
         LCI      3
         LM,R1    DELETEM           PUT MESSAGE IN
         STM,R1   TLABEL
         LI,D3    9
         LI,D4    BA(TLABEL)        BUFFER
         LI,SR4   DELALL1           RETURN
*
RANGEOUT LCI      7
         PSM,R5   *R7
         STW,D4   RSSAVE,R7
         LI,D4    1                 ONE THING AT A TIME
         LW,R3    ='    '           SET UP A NULL SN
         STD,R3   TLABEL+20
         LI,R4    TLABEL+19         POINT TO IT
         LW,R2    M:EISN            GET A REAL ONE
         LW,R5    DEVICE,R7         GET PROPER DEVICE CODE
         CI,R5    7                 IF AT, UPACK SN
         BNE      %+2
         BAL,SR4  SIXBACK
         LW,R5    DEVTXTS,R5        GET DEVICE TEXT
         STW,R5   TLABEL+22         STUFF IT AWAY
         LI,R5    '#'               PUT # AFTER IN CASE SN IS NEEDED
         STB,R5   TLABEL+23
         LW,SR4   M:EISN-1          ANY SNS
         CI,SR4   X'FF00'
         BAZ      %+3
         MTB,1    TLABEL+22         PUT # IN FRONT
         STD,R2   TLABEL+20
         LI,R5    TLABEL+22
         BAL,SR4  WACC20            YES PUT MSG
         LI,R4    X'20'             IF EO IS OPEN, JUST THE FILE NAME
         CH,R4    M:EO
         BANZ     RANGEOUT1
         LI,R4    FROMFILE-1
         MTB,0    FROMFILE          ANY RANGE
         BEZ      %+2
         BAL,SR4  FROMM             YES, PUT START
         LI,R4    M:EI+31
         BAL,SR4  DOTACCT           .ACCT
         LI,R4    TOFILE-1
         MTB,0    TOFILE
         BEZ      %+2
         BAL,SR4  TOM               TO TOFILE
         B        RANGEOUT2
RANGEOUT1 LI,R4   M:EI+22
         BAL,SR4  SLASHM
         LI,R4    M:EI+31
         BAL,SR4  DOTACCT
RANGEOUT2 LCI     7
         PLM,R5   *R7               RETURN
         B        *SR4
DELALL1  RES
         LW,R3    D3                GET DISP
         AI,R3    1                 GET TO HOLE
         LI,R4    '?'               ADD QUESTON MARK
         STB,R4   TLABEL,R3
         STB,R3   TLABEL
         CAL1,2   FPTALL            KEYIN THE QUEST
         LCI      2                 CHECK RESPONSE
         LM,R2    TLABEL
         CD,R2    YES%
         BE       %+4               GOOD ONE
         AI,R3    -X'80000'         TRY LIN FEED TOO
         CD,R2    YES%
         BNE      RETURN            NO-RETURN
         FIN
         STW,R0   BREAK             CLEAR BREAK
         USECT    PLSECT
FPTALL   DATA     X'4000000',X'F0000000',TLABEL,TLABEL,20,TLABEL
         BOUND    8
YES%     DATA     'YES'+5**24,'%TEA'+(13-'T')**16
DELETEM  TEXT     ' DELETEALL'
FROMM    MTB,1    SR4
         BAL,R5   WACC20
         TEXTC    ' FROM '
DEVTXTS  EQU      %-3
         TEXTC    ' DC'
         TEXTC    ' LT'
         TEXTC    ' DP'
         TEXTC    ' FT'
         TEXTC    ' AT'
SLASHM   MTB,1    SR4
         BAL,R5   WACC20
         TEXTC    '/'
DOTACCT  LW,R5    DEVICE,R7         NO ACCOUNT FOR AT
         CI,R5    7
         BE       *SR4
         BAL,R5   WACC20
         TEXTC    '.'
TOM      MTB,1    SR4               TEXTC
         BAL,R5   WACC20
         TEXTC    ' TO '
FPTSET   GEN,8,7,17      X'06',0,M:EI
         DATA     X'C0000000'
         DATA     ERRABN
         DATA     ERRABN
         USECT    DELETEAL
DELALL2  CAL1,1   FPTSET            SET ERR ABN ADDRS
         BAL,SR4  TESTFNC           TEST IF FILE IN RANGE
         B        ALL5              NO - SAVE FILE
         BDR,SR3  ERRABN            DIDNT GET IT OPEN
         CAL1,1   FPTDELET          RELEASE THE FILE
         BAL,R6   RANDCHK           TEST IF RANDOM FILE
ALL4     BAL,SR4  ALLC              COUNT FILE, LIST IT
ALL5     BAL,SR4  CLOSEI            CLOSE DCB IF OPEN
         LW,R1    BREAK             ARE WE TO STOP
         BNEZ     ALL9              YES
         MTW,0    TOFILE            ANY MORE FILES WANTED
         BLZ      ALL9              NO
         BAL,SR4  OPNNXT
         BCS,8    ALL9              ALL DONE
         BE       ALL10             DONT LOOP
         B        DELALL2           RELEASE IT
ERRABN   LB,R1    SR3
ALL8     CI,R1    8                 SYNONYM NAME
         BE       ALL5              YES-SKIP IT
         B        ALL4              NO TYPE MESSAGE
ALL10    RES
         LI,R1    0                 YES-REPORT ERROR
         BAL,SR4  ERROR
ALL9     LI,R5    DELTEXT           ADDR OF MESSAGE
         STH,R0   SR2               CLEAR SKIPPED COUNT
         B        LIST42            PRINT FILES/GRANULES
*
DELTEXT  TEXT     '.. % FILES DELETED, %%% GRANULES
'
RANDCHK  LI,R1    X'F0'
         AND,R1   M:EI+5            IS ORG RANDOM
         CI,R1    X'30'
         BNE      ADDGRAN           NO, JUST ACCUMULATE GRANULES
         LI,SR3   0
         CAL1,1   OPNTRY            TRY TO OPEN AGAIN
         PSW,SR4  *R7               FILE WAS NOT DELETED
         BAL,SR4  CLOSEI            GO CLOSE
         PLW,SR4  *R7
RAND1    EOR,SR3  03ABN             DID WE GET NO FILE
         CAL1,1   FPTSET            SET DELETEALL ERRABN
         MTW,0    DELETEF           REVIEW COMMAND
         BEZ      %+3               NO
         CAL1,1   FPTSET2           RESET ERR AND ABN ADR
         BDR,SR3  LIST28            AND TYPE MESSAGE
         BDR,SR3  0,R6              PRINT MESSAGE IF THERE IS ONE
ADDGRAN  LW,SR3   M:EI+11           CHECK FILENAME FOR SYNON
         AI,SR3   X'80001'          POINT TO FIT NAME, NEG FOR ALLC
         LB,R1    *SR3
         CB,R1    M:EI+23           IF NAMES DONT MATCH, NO GRANS
         BNE      ADDGRANX          SINCE IT IS JUST A FD ENTRY
         LB,SR1   *SR3,R1
         CB,SR1   M:EI+23,R1
         BNE      ADDGRANX
         BDR,R1   %-3
         LW,R1    M:EI+11           RESTORE POINTER TO FPARAM
ADDGRAN1 RES
         LI,SR1   255
         AND,SR1  *R1
         AW,R1    SR1               SKIP FILENAME ENTRY
         AI,R1    1
         LH,SR1   *R1
         CI,SR1   X'FF'             ARE WE DONE
         BANZ     0,R6
         CI,SR1   X'D00'            IS THIS SIZE ENTRY
         BNE      ADDGRAN1          NO
         LW,SR1   1,R1
         AWM,SR1  GRANCNT
ADDGRANX LI,SR3   0                 CLEAR ERROR REG
         B        0,R6
         USECT    PLSECT
OPNTRY   GEN,8,24 X'14',M:EI
         DATA     X'C0000000'
         DATA     RAND1,RAND1
03ABN    GEN,8,24 3,M:EI
         TITLE    'DELETE'
DELETE   DSECT    1                 DELETE COMMAND
         LCI      7
         PSM,R5   *R7               SAVE REGISTERS
         LI,R5    0                 INITIALIZE SEVERITY LEVEL
         LI,SR2   0                 INITIALIZE FILE COUNT
         STW,R0   2,R7              RESET ACCESS FILE HEAD FLAG
         LW,R4    TERM,R7
         CI,R4    ';'               ONLY BLANK, #, -, /, AND ' ARE OK
         BNE      DELETE5           DEVTRAN GETS THE REST
         LI,R1    17                ERROR - NO FILE NAME PRESENT
DELETE7  EQU      %
         BAL,SR4  ERROR
         B        RETURN
DELETE5  BAL,R6   DEVTEST
         LW,R1    TERM,R7
         CI,R1    '/'               MUST BE FILE NEXT
         BNE      DELETE7-1
         LW,R6    CMBX,R7           SCAN ENTIRE COMMAND FOR SYNTAX ERRORS
         BAL,SR4  FILTRAN
DELETE8  LW,R1    TERM,R7           MUST BE ',', OR X'15'
         CI,R1    ','
         BE       %-3               GET NEXT ONE
         CI,R1    '('
         BNE      DELETE9
         BAL,SR4  GETARG6           MUST BE JOB
         LW,R1    ARGBUFF,R7
         CW,R1    JOBT
         BNE      DELETE7-1
         LW,R1    TERM,R7
         CI,R1    ')'
         BNE      DELETE7-1
         BAL,SR4  GETARG6
         LW,R1    NCHAR,R7
         BEZ      DELETE8           OK.
DELETE9  RES
         CI,R1    X'15'
         BNE      DELETE7-1
         CI,D2    1                 ANY SYNTAX ERRORS
         BG       RETURN
         STW,R6   CMBX,R7           RESTORE STARTING POINT
DELETE3  EQU      %
         BAL,SR4  FILTRAN           GO-CONVERT N.A.P
         STW,R0   MODE,R7           RESET JOB FLAG
         LW,R1    TERM,R7
         CI,R1    '('               IF OPTION, IT'S JB
         BNE      %+3
         LI,R1    X'800'            SET JOB FLAG
         STW,R1   MODE,R7
         LI,R1    10
DELETE1  LI,R1    10                INOUT,FPARAM
         BAL,SR4  BLDCB             GO-BUILD INPUT DCB
         CI,D2    2                 CHECK ERROR SEVERITY
         BG       RETURN            BAD ONE
         BE       DELETE2           DIDNT GET IT OPEN
         CAL1,1   FPTDELET          RELEASE THE FILE
         LI,SR4   DELETE2
         BAL,R6   RANDCHK           TEST IF RANDOM FILE
         USECT    PLSECT
FPTDELET GEN,8,7,17      X'15',0,M:EI
         DATA     X'80000000'
         DATA     1                 RELEASE
         USECT    DELETE
         AI,SR2   1                 BUMP FILE COUNT
DELETE2  LW,R4    MODE,R7           IF JOB FILE, SKIP OVER OPTION
         BEZ      %+3
         BAL,SR4  GETARG6
         BAL,SR4  GETARG6           AND )
         LW,R4    TERM,R7
         CW,D2    R5
         BLE      %+2
         LW,R5    D2                UPDATE SEVERITY LEVEL
         LW,R1    BREAK
         STW,R0   BREAK
         BNEZ     DELETE4
         LI,D2    0                 RESET SEVERITY FOR NEXT FILE
         CI,R4    ','
         BE       DELETE3           ANOTHER FID
DELETE4  LW,D2    R5                SET SEVERITY LEVEL
         B        ALL9
DELETE6  LI,R1    34                INVALID DEVICE
         B        DELETE7
JOBT     TEXTC    'JOB'
         END

