         TITLE    'PCLLS - PCL LIST'
*
*        T E L E F I L E   P R O P R I E T A R Y   P R O D U C T
*
*        THIS DOCUMENT INCLUDES DATA AND INFORMATION CONSIDERED
*        PROPRIETARY TO TELEFILE COMPUTER PRODUCTS, INC.  REPRODUCTION,
*        DUPLICATION, DISCLOSURE OR DISSEMINATION, IN WHOLE OR IN PART,
*        TO OTHERS THAN REPRESENTATIVES OF THE UNITED STATES GOVERNMENT
*        SHALL NOT BE MADE WITHOUT PRIOR WRITTEN AUTHORIZATION OF
*        TELEFILE COMPUTER PRODUCTS, INC. NOTWITHSTANDING THE FORGOING,
*        USE OF THE DATA OR INFORMATION IN WHOLE OR IN PART FOR DESIGN,
*        PROCUREMENT OF MANUFACTURE IS STRICTLY FORBIDDEN.
*
*M*      PCLLIST LIST COMMAND PROCESSOR
LIST     DSECT    1
PLSECT   CSECT    1
         SYSTEM   SIG7
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
* 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
         PAGE
*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 ANS SN
*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      EXTBL,RDTBL,WRTBL,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
         REF      RSSAVE
         REF      BOG
*
         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
         PAGE
         USECT    LIST
         LCI      7
         PSM,R5   *R7
         CAL1,8   TIMECAL
         LI,R9    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   WRTFPT,R7
LIST24   BAL,R11  CLRARG            CLEAR ARGTBL
LIST25   LW,R2    TERM,R7
         CI,R2    X'15'             'LIST' ONLY
         BE       LIST44
         CI,R2    '('               '(A)' POSSIBLE
         BE       LIST8             YES
         BAL,R11  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 ISN'T OK
         BNE      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
         BE       LIST4             NO-O.K.
         LI,R1    22                ERROR-REEL NO. SPECIFIED FOR RAD
LIST3    BAL,R11  ERROR
LIST4    LW,R5    TERM,R7
         CI,R5    '/'               DOES 'N.A.P' FOLLOW
         BE       LIST9             YES
LIST44   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
         BG       LIST5
         MTW,0    FROMFILE          OR RANGE
         BNE      LIST9
LIST18   LI,R1    17                EH
LIST6    BAL,R11  ERROR
LIST5    LW,R1    CMBX,R7           SAVE POSITION IN LINE
         STW,R1   LISTCMBX
         CI,R13   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
         LW,R1    =X'80004'         TESTFILE, OPEN NEXT, INPUT
         LW,R5    ATTRB,R7          ATTRIBUTES WANTED
         BE       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   CAL1,1   FPTSET3           SET ERR/ABN FOR M:LO
         BAL,R11  BLDCB             GO-BUILD INPUT DCB
         LI,R2    2
         CB,R2    R10               ANY FILES PRESENT
         BE       LIST32            MAYBE, TRY ONE MORE TIME
         MTB,0    R10               ERR OR ABN IN BLDCB
         BNE      ERRADD            YES
         CI,R13   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,R14   PRTBUF
         CAL1,1   FPTSET2           SET ERRADD
         BAL,R11  TESTFNC           TEST IF FILE WANTED
         B        LIST33            NO
         AW,R14   R7                BUFFER ADDRESS
         LI,R6    M:LO
         LI,R1    M:EI+23
         LW,R3    ATTRB,R7
         OR,R3    DELETEF           IF SIMPLE LIST,
         BNE      LIST19            DO IT HORIZONTALLY
         AI,R9    0                 IF FIRST FILE, CLEAR BUFFER
         BNE      LIST191
LIST19   LI,R3    63
         LW,R2    ='    '
         STW,R2   *R14,R3
         BDR,R3   %-1
         STW,R2   *R14
         LW,R2    ATTRB,R7
         BNE      LISTATB           LIST A,EA
         MTW,0    DELETEF
         BNE      LIST17            REVIEW
         STB,R3   *R14              CLEAR BYTE COUNT
LIST191  LB,R3    *R14              WHERE TO PUT THIS ONE
         BNE      %+2
         LI,R3    -1                0 IS REALLY -1
         SAS,R3   -2                GET WORD OF LAST USED BYTE
         AW,R3    WRTFPT,R7
         DW,R3    WRTFPT,R7
         MW,R3    WRTFPT,R7
         AW,R14   R3
         BAL,R11  UNPRINT
         SW,R14   R3
         XW,R14   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,R11   3                 ARE WE GOING TO A ME
         CS,R11   M:LO
         BNE      KGC0%4            NO, NOT EVEN A DEVICE
         LW,R11   M:LO+1
         CI,R11   X'6F00'
         BAZ      %+2               YES, USE PCW
KGC0%4   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
         BLE      LIST30            NOT YET
         LI,R3    1
         CAL1,1   FPTLFILE
         XW,R1    R14
         MTW,0    BREAK             IF BREAK HIT, FORGET THIS ONE
         BE       LIST19
         STW,R1   DELETEF           ENTIRELY (SEE LISTEND)
         B        LIST33
LIST17   BAL,R11  UNPRINT           ENTER FILE NAME IN BUFFER
         LW,R1    R14
         MTW,0    2,R7              IS HEADER PRINTED
         BNE      %+3               YES
         MTW,1    2,R7              SET HEADER FLAG
         CAL1,1   REVFPT            PRINT HEADING
         BAL,R11  ABN14T            TEST FOR ACCESSABILITY
REVRET1  BAL,R11  LFILE
REVRET2  LB,R3    R10               DID WE GET ERROR
         CI,R3    X'F7'             BESIDES 08 (SYNON)
         BANZ     LIST26            YES, NO REQUEST
         LI,R11   LIST22            SET RETURN
READONE  LCI      4                 SAVE A FEW REGS
         PSM,R8   *R7
         CAL1,8   TSFPT             READ DIFFERENTLY IF HALF DUPLEX
         SLS,8    3                 OR 2741..MODE2/X10, MODE6/X80
         OR,R8    R11               PUT BOTH BITS TOGETHER
         SLS,8    -21               AND AT 4
         LI,R9    4
         AND,R9   R8
         BNE      %+2
         LI,R9    1                 READ ONE BYTE ON TTYS
REREAD1  STW,R0   1BUF              CLEAR BUFFER
REVRP    CAL1,1   READFPT           READ REPLY
         BIR,R8   %+2               GET REPLY FIRST TIME ONLY
         LB,R1    1BUF
         LW,R11   1BUF
         LI,R8    -100
         CI,R11   X'FF'
         BANZ     REREAD1           KEEP TRYING
         CAL1,8   TSFPT             CHECK PLATEN POSITION
         STW,R9   1BUF              SAVE OUTPUT COUNT
         SLS,R9   -25
         STB,R9   DELETEF
         LCI      4
         PLM,R8   *R7
         B        *R11
LIST27   MTB,0    DELETEF           DO WE NEED CR
         BE       LIST30            NO
         B        LIST26
LIST22   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 AGAIN
WRTQUST  GEN,8,24 17,M:UC
         DATA     X'34000010',QUST,3,0
QUST     TEXT     '??  '
*
REVDEL   BAL,R11  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,R9    X'10000'          COUNT DELETED FILES
LIST26   CAL1,1   WRTCR             WRITE CARRIAGE RETURN
         STB,R0   DELETEF           RESET CR NEEDED FLAG
*
         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   AI,R9    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,R11  CLOSEI            GO CLOSE M:EI
LIST31   MTW,0    BREAK             BREAK SET
         STW,R0   BREAK             CLEAR BREAK
         BNE      LIST40            YES
         MTW,0    TOFILE            ANY MORE LISTING WANTED
         BL       LIST40            NO
         MTW,0    ATTRB,R7          WAS FID SPECIFIED
         BLE      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
LIST28   CAL1,1   WRTFB             WRITE 'FILE BUSY'
         B        LIST26
LIST32   BAL,R11  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      *R9
         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
         BE       TEST1             NO - FILE WANTED
         MTW,0    COPYPHY
         BNE      TEST1             COPYING TAPE IN PHYS ORDER
         LI,R4    1
TEST4    CB,R4    M:EI+23           ARE WE PAST NAME IN DCB
         BG       *R11              YES - FILE BELOW RANGE
         LB,R3    M:EI+23,R4        COMPARE FILE NAMES
         CB,R3    FROMFILE,R4
         BL       *R11              BELOW RANGE - EXIT
         BG       TEST1
         AI,R4    1
         BDR,R2   TEST4
         LB,R4    R10               IF NO SUCH FILE, DONT WANT
         CI,R4    3                 FIRST ONE
         BE       *R11
TEST1    MTB,0    TOFILE            WAS A TO FILE SPECIFIED
         BE       TEST3             NO - FILE WANTED
         LI,R4    1
         LB,R2    TOFILE
         MTW,0    COPYPHY           COPYING TAPE IN PHYS ORDER
         BE       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,R11   1
         B        TEST7             FOUND - TAKE WANTED EXIT
TEST5    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,R11   1
         B        TEST2
TEST3    AI,R11   1
         B        *R11              EXIT FOR FILE WANTED
TEST2    LI,R1    2                 IF TAPE FILES, KEEP LOOKING
         CW,R1    M:EI              IF NOT COPYPHY
         BANZ     *R11
TEST7    LW,R1    =X'80000000'      SET END OF RANGE FLAG
         STS,R1   TOFILE
         B        *R11
         PAGE
GETARG6  LI,R1    6
         B        GETARG
LIST8    BAL,R11  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'          TEST 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'
         BL       LIST14            <C0
         BG       %+2
         LI,R1    99                C0 MEANS ONE PER LINE
         STW,R1   WRTFPT,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,R11  ERROR
         B        LIST11
LIST15   MTW,0    ATTRB,R7          MUST HAVE FILENAME
         BLE      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,R11  GETARG6           CHECK NEXT ARG
         MTW,0    ATTRB,R7          IF NO N.A.P YET,
         BLE      LIST111           NO DELIMITER HERE
         MTW,0    NCHAR,R7          IS ARGUMENT NULL
         BNE      LIST18            NO - ERROR
         B        LIST44
LIST111  MTW,0    NCHAR,R7          IF WE HIT A DELIMITER
         BNE      KGC1%4            NO NEED TO REREAD
         MTW,0    DEVICE+2,R7       HAVE WE BEEN TO DEVTRAN
         BNE      LIST4             YES, DONT GO AGAIN
         B        LIST25            NO, STILL NEED DEVICE TYPE
KGC1%4   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
         BE       LIST25            GO GET ONE
         MTW,0    FILE,R7           IF ACCOUNT ALREADY THERE, MUST BE RANGE
         BE       LIST9             NO, MUST BE FID
         MTW,1    FROMFILE
LIST9    MTW,0    FROMFILE          IF RANGE, GET IT
         BE       %+3
         BAL,R11  REVIEW
         B        LIST44
         STW,R0   MODE,R7           RESET JOB FLAG
         BAL,R11  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
         BG       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
         BNE      LISTATB1          NO - SKIP HEADER
         LI,R6    M:LO              OUTPUT TO M:LO
         MTW,0    DELETEF           IF REVIEW, ADD DELETE MSG
         BE       KGC2%4
         LI,R6    M:UC              AND WRITE THROUGH UC
         CAL1,1   REVFPT
         MTB,-1   DELETEF           SET CR NEEDED FLAG
KGC2%4   MTW,0    ATTRB,R7          NAME LIST OR RAGNE IN ONE ACCOUNT
         BG       NODATEHD          LIST, NO DATE/ACCOUNT
         CAL1,1   WEOFLO            TOP OF FORM FOR PRINTERS
         LI,R15   BA(DATETBL)       POINT TO BUFFER
         LI,R14   15                15 BYTES INTO BUFFER
         BAL,R11  RANGEOUT          PUT XX#SSSS.AJSSD RF
         LW,R2    R14               SIZE OF OUTPUT
         ANLZ,R14 PRTBUFI7          RESTORE BUFFER ADDRESS
         LI,R3    0
         LI,R1    DATETBL           OUTPUT THE LINE
         AI,R2    1
         CAL1,1   FPTLFILE
NODATEHD LB,R2    LISTHEAD          LENGTH OF HEADER
         LI,R1    LISTHEAD          BUFFER ADR
         LW,R11   DEVICE,R7
         CI,R11   7
         BNE      %+2
         LI,R1    LISTHAT
         LI,R11   LISTATB1
LFILE    LI,R3    1                 BTD
         LI,R6    M:LO
         MTW,0    DELETEF           IF REVIEW, USE UC, START AT
         BE       LFILE1            START OF LINE
         MTB,-1   DELETEF           SET/CHECK CR NEEDED FLAG
         BNC      %+2
         CAL1,1   WRTCR
         LI,R6    M:UC
LFILE1   CAL1,1   FPTLFILE          PRINT ATTRIBUTE HEADER
         B        *R11
LISTATB1 AI,R14   NAME
         LI,R1    M:EI+23
         BAL,R11  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,R11   LISTATB2
ABN14T   LB,R3    R10
         BE       *R11              ALL IS OK
         CI,R3    8                 SYNON IS OK TOO
         BE       *R11
         LCI      8
         PSM,R11  *R7
         LB,R1    R10
         SLS,R1   8
         AH,R1    R10
         SLS,R1   -1
         BAL,R11  HEX2BCD
         LCI      3
         PLM,R0   *R7
         STW,R3   R15
         LCI      4
         LM,R11   INACCM            GET *INACCESSIBLE*
         LI,R3    -20
         LB,R4    16,R3
         AI,R2    1
         STB,R4   *R1,R2
         BIR,R3   %-3
         LCI      5
         PLM,R11  *R7
         CI,R11   LISTATB2          LIST OR REVIEW
         BE       LISTATB9          LIST
         STB,R0   DELETEF           REVIEW, RESET CR NEEDED FLAG
         B        REVRET1           YES
LISTATB2B PSW,1   *R7
         LB,R1    M:EI+12           GET KEYM
         BAL,R11  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,R14   R2                SAVE LINE LENGTH
         LW,R2    DEVICE,R7
         CI,R2    4                 LABELED TAPE?
         BNE      KGC3%4            NO
         LW,R3    TLABEL+1
         CW,R3    ='RFIL'           IS FILE RANDOM
         BE       LISTRAND          YES
KGC3%4   MTB,0    R10               IF SYNON, OPEN THE REAL FILE
         BE       %+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
         BE       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,R11  BIN2BCD
         STW,R2   REC,R5
         STW,R3   REC+1,R5
LISTATAT2 LW,R1   M:EI+3            BLKSZ
         SLS,R1   -17
         BAL,R11  BIN2BCD
         STW,R2   1,R5
         STW,R3   2,R5
LISTATAT7 CAL1,1  ATEOF
         LW,R1    M:EI+17           BLKCNT
         MTW,0    ATTRB,R7
         BG       %+2
         AWM,R1   GRANCNT
         BAL,R11  BIN2BCD
         STW,R2   7,R5
         STW,R3   8,R5
         LI,R1    X'1FFFF'          GET FSN
         AND,R1   M:EI+16
         BAL,R11  BIN2BCD
         STW,R3   6,R5
         LW,R1    R5                RESTORE LINE START
         LI,R10   0
         LW,R2    R14
         BAL,R11  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,R10   M:EI+11           FPARAM ADDR
LISTATB3 LB,R5    *R10              GET VLP CODE
         CI,R5    X'15'             MAX CODE
         BG       LISTATB4          NOT USEFUL
         MTB,0    *R10,R2
         BE       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    *R10,R4           TEST IF LAST ENTRY
         BNE      LISTATB7          YES
         LB,R5    *R10,R3           GET LENGTH OF PARAMETER
         AW,R10   R5                INCREMENT VLP POINTER
         AI,R10   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
         BNE      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      KGC4%4
         MTW,0    ATTRB,R7
         BG       %+2
         AWM,R1   GRANCNT
KGC4%4   BAL,R11  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 SLS,R1   2                 SAVE BA(BUFFER IN RSSAVE
         STW,R1   RSSAVE,R7         FOR WACC
         BAL,R11  SYNONX            PRINT SYNON
         BAL,R11  RACCTX            PRINT READ ACCOUNTS
         BAL,R11  WACCTX            PRINT WRITE ACCOUNTS
         BAL,R11  EACCTX            PRINT EXECUTE ACCOUNTS.
         BAL,R11  UACCTX            PRINT VEHICLE ACCOUNT.
         LW,R2    R14               PRINT THE LINE
         LW,R1    RSSAVE,R7
         SLS,R1   -2
         LI,R10   0                 CLEAR ERROR REG
LISTATB9 BAL,R11  LFILE             PUT IT OUT
         MTW,0    EATTRB            WAS 'EA' SPECIFIED
         BE       %+2
         BAL,R11  DATELIST          GO LIST DATE ATTRIBUTES
         MTW,0    DELETEF           ARE WE REVIEW
         BNE      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,R10   TLABEL+1          LOC -1 OF NO OF GRANULES
         BAL,R11  GRANULE           GO PUT GRANULES IN BUFFER
         B        LISTATB2A         GET REST OF ATTRIBUTES
ERRADD   LB,R1    R10
         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
         BLE      LIST1             NOT
LIST7    LI,R1    0                 NO-REPORT ERROR
         BAL,R11  ERROR
SOMERR   BAL,R11  D2CHK             UPDATE ERR SEVERITY
         MTW,0    ATTRB,R7          WAS FID SPECIFIED
         BG       LIST31            YES
LIST40   LW,R1    LISTTERM
         CI,R1    X'15'             END OF COMMAND
         BE       LISTEND
         LI,R1    30                ERROR - IMPROPER TERMINATION
         BAL,R11  ERROR
         BAL,R11  D2CHK
LISTEND  LW,R5    DEVICE,R7
         LW,R5    LSTTXTS,R5        GET APPROPROPRAITE MESS
         LW,R13   SEVMAX            GET MAX LEVEL
         CI,R9    1                 IF ONE FILE, NO COUNT
         BNE      %+2
         LI,R9    0
         MTW,0    DELETEF           IS THIS ONLINE REVIEW
         BNE      LIST42            YES, NO LAST LINE
         MTW,0    ATTRB,R7
         BNE      LIST42            NOT SIMPLE LIST
         LI,R3    1                 PRINT LAST LINE
         LI,R1    PRTBUF
         AW,R1    R7
         LB,R2    *R1
         BE       %+2
         CAL1,1   FPTLFILE
LIST42   BAL,R11  PRTERR            PUT OUT THE ERRORS
         LW,R8    GRANCNT           GET TOTAL GRANULES
         SCS,R8   16                THEN THE REST
         BAL,R11  PRTNOF            PRINT 'XXX TOTAL GRANULES'
         MTW,0    ATTRB,R7          IF NOT SELECTIVE, TOP OF FORM
         BGE      RETURN
         CAL1,1   WEOFLO
RETURN   LCI      7
         PLM,R5   *R7               RESTORE REGISTERS
         B        *R11              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,R11  ERROR
         LI,R1    56                ERROR WRITING LO
         BAL,R11  ERROR
         B        RETURN
LIST50   LB,R2    NOFILES           GET MESSAGE COUNT
         CI,R9    0
         BNE      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,R13   SEVMAX
         BLE      %+2
         STW,R13  SEVMAX
         LI,R13   0
         B        *R11
         PAGE
* SUBROUTINE CDATE MOVES THE CREATION DATE FROM FPARAM TO THE
* PRINT BUFFER.
CDATE    LI,R4    0
         LW,R4    *R10,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
         BG       %+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   *R10,R2           GET YEAR WORD
         SLS,R5   8                 POSITION
         OR,R5    ='    '
         STW,R5   DATE+2,R1         PUT IN BUFFER
         LB,R4    *R10              CHK IF LOOKING AT FPARAM CODE '0A'
         CI,R4    X'A'
         BNE      *R11
         LW,R4    *R10,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        *R11              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    *R10,R2           BACKUP DATE
         BE       *R11              NO DATE ENTERED
         LI,R5    4
         B        ADATE1
ADATE    LI,R5    6                 ACCESS DATE
ADATE1   LW,R3    *R10,R4
         STW,R3   DATETBL,R5        MOVE DATE FROM VLP TO DATE TABLE
         LW,R3    *R10,R2
         STW,R3   DATETBL+1,R5
         B        *R11
*
DATELIST LI,R14   4                 LIST 4 DATES IF PRESENT
         PSW,R11  *R7               SAVE LINK
         LW,R1    ='    '
         STW,R1   IOBUF,R7
         LI,R10   DATETBL
         LI,R6    0                 INDEX INTO TDATE
DATEL2   LW,R5    *R10
         BE       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,R11  CDATE             ENTER DATE IN LINE
DATEL5   AI,R1    2                 START OF BUFFER
         LI,R2    DATE*4+12         LENGTH
         LW,R5    R6                SAVE TDATE INDEX
         BAL,R11  LFILE
         LW,R6    R5
DATEL3   AI,R10   2                 INCREMENT DATETBL POINTER
         AI,R6    4                 INCREMENT TDATE INDEX
         BDR,R14  DATEL2            LOOP 4 TIMES
         PLW,R11  *R7               RESTORE LINK
         B        *R11
DATEL4   LW,R4    ='    '
         STW,R4   IOBUF+5,R7
         STW,R5   IOBUF+6,R7        PUT 'NEVER' IN LINE
         LW,R5    *R10,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,R11  *R7               SAVE LINK REG
         PSW,R1   *R7               SAVEER1
         LW,R1    *R10,R4           GET NO. OF GRANULES
         LW,R3    SYNFLAG,R7        NO COUNT IF SYNON
         BNE      GRAN1             DONT COUNT IT
         LW,R3    ATTRB,R7          OR SINGLE FILES
         BG       GRAN1
         MTW,0    DELETEF           OR REVIEW(A)
         BNE      GRAN1
         AWM,R1   GRANCNT           UPDATE GRANULE COUNT
GRAN1    BAL,R11  BIN2BCD           CONVERT TO BCD
         PLW,R1   *R7
         STW,R2   GRAN,R1
         STW,R3   GRAN+1,R1
         PLW,R11  *R7               RESTORE LINK
         B        *R11              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      *R11              NO - EXIT
         LW,R4    R10               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        *R11              RETURN
SYNON    LI,R3    IOBUF+210
         AW,R3    R7                COMPUTE DEST ADR
         STW,R3   SYNFLAG,R7        SAVE ADR OF SYNON NAME
         LI,R1    8
         LW,R2    *R10,R1           MOVE SYNON TO TEMP AREA
         STW,R2   *R3,R1
         BDR,R1   %-2
         B        *R11              RETURN
*
* SUBROUTINE SYNONX GETS THE SYNON FROM FPARAM AND PRINTS THE LINE
* 'SYNON= XXX'.
SYNONX   LW,R4    SYNFLAG,R7
         BE       *R11              NO SYNONYM
         LI,R15   1                 ONLY ONE
         MTB,1    R11               FLAG FOR TEXTCC INPUT
         BAL,R5   WACC20            DO EM
         TEXTC    '  SYNON='
*
GACCT    CVA,R5   RDWREXUN-27       CONVERT CODE TO TBL ADDR
         LB,R4    *R10,R2           # WORDS
         STW,R10  1,R5              WHERE THEY ARE
         CI,R4    1                 IS THERE ONLY ONE WORD
         BNE      GACCT1            NO
         LCI      2
         LM,R2    *R10              WHAT IS IT
         LI,R2    4                 IF ALL OR NONE, POINT TO
KGCA%4   BNE      %+3               ONE WITH BLANKS AFTER IT
         ANLZ,R3  %+2
         STW,R3   1,R5
         CW,R3    ALLT-2,R2
         BDR,R2   KGCA%4
GACCT1   STW,R4   0,R5
         B        *R11
RDWREXUN DATA     UNTBL-RDTBL
WR14     DATA     3
         DATA     EXTBL-UNTBL+RDTBL
         DATA     WRTBL+UNTBL-EXTBL-RDTBL
         DATA     UNTBL-EXTBL
         BOUND    8
ALLT     TEXT     'ALL  '
NONET    TEXT     'NONE'
         TEXT     ' '               IS THIS USED?? - KGC
*
* SUBROUTINE RACCTX GETS READ ACCOUNTS FROM TABLE RDACCT, FORMATS THEM
* IN THE PRINT BUFFER, AND PRINTS THE LINE.
RACCTX   LW,R15   RDTBL
         BE       *R11
         LW,R4    RDTBL+1           ADDRESS THEREOF
         CI,R15   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        *R11
RACC10   BAL,R5   WACC19            GO TO ACCOUNT FORMATTER
         TEXTC    '  READ='
*
* SUBROUTINE EACCTX GETS EXECUTE ACCOUNTS FROM TABLE EXACCT,
* FORMATS THEM INTO THE PRINT BUFFER, AND PRINTS THE LINE.
EACCTX   LW,R15   EXTBL
         BE       *R11
         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   LW,R15   UNTBL
         BE       *R11              NONE
         LW,R4    UNTBL+1
         MTB,1    R11               SET UNDER FLAG
         DW,R15   WR14              COUNT ENTRIES (3-WORD ONES)
         BAL,R5   WACC20            AND PRINT EM
         TEXTC    '  VEHICLE='
*
* SUBROUTINE WACCTX GETS WRITE ACCOUNTS FROM TABLE WRTACCT, FORMATS
* THEM IN THE PRINT BUFFER, AND PRINTS THE LINE.
WACCTX   LW,R15   WRTBL
         BE       *R11
         LW,R4    WRTBL+1
         CI,R15   2                 DONT CHECK FIRST OF NAMY
         BG       WACC10
         LCI      2
         LM,R2    1,R4
         CD,R2    NONET             IS DEFAULT SPECIFIED
         BE       *R11              YES - EXIT
WACC10   BAL,R5   WACC19
         TEXTC    '  WRITE='
WACC19   SLS,R15  -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   SW,R1    R5                IF HEADER LAST GET IT TOO
         STB,R0   R5                IF NAME IS TOO LONG
         BNE      %+2
         STB,R2   R5
WACC40   LCI      2
         LM,R2    1,R4              GET ACCOUNT FROM TABLE
         ANLZ,R1  WACC40+1
         MTB,0    R11               IF UNDER, ALREADY TEXTC
         BNE      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   LCI      4
         PSM,R11  *R7
         AW,R14   RSSAVE,R7         GEN BYTE ADDR
         SCS,R14  -2                IF PROPER FORMAT
         BAL,R11  UNPRINT           ENTER ACCOUNT IN BUFFER
         LCI      4
         PLM,R11  *R7
         AW,R14   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,R14   0,R1
         B        %+2
WACC48   CI,R14   108
         BG       WACC50
         AI,R4    2
         MTB,0    R11               IF UNDER, 3 WORD ENTRIES
         BE       %+2
         AI,R4    1
         BDR,R15  WACC60            BR IF MORE ACCOUNTS
         B        *R11
WACC50   SW,R14   R2                SCRUB LAST ONE
         LB,R2    R5                AND HEADER IF THERE
         SW,R14   R2
         LW,R2    R14               SIZE
         LW,R1    RSSAVE,R7
         SLS,R1   -2
         PSW,R11  *R7               SAVE RETURN
         BAL,R11  LFILE
         LI,R14   0                 RESET SIZE
         PLW,R11  *R7               RSTORE RETURN
         B        WACC20            PUTOUT A NEW HEADER
*
* BRANCH TABLE ORDERED BY VLP CODE
VLPTAB   BAL,R11  FNAME             FILE NAME
         NOP                        ACCT
         NOP                        PASSWORD
         BAL,R11  EDATE             EXPIRATION DATE
         BAL,R11  GACCT             READ ACCOUNTS
         BAL,R11  GACCT             WRITE ACCOUNTS
         NOP                        INSN
         NOP                        OUTSN
         NOP                        ORG
         BAL,R11  CDATE+1
         BAL,R11  SYNON             SYNON
         NOP
         BAL,R11  GRANULE           GRANULES
         BAL,R11  MDATE             CREATION DATE
         BAL,R11  ADATE             ACCESS DATE
         BAL,R11  BDATE             BACKUP DATE
         NOP
         NOP
         NOP
         BAL,R11  GACCT             EXECUTE ACCOUNTS
         BAL,R11  GACCT             EXECUTE VEHICLES
         NOP
         NOP
         NOP
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   LI,R1    1
         CW,R1    DEVICE+1,R7       WAS ONLY ONE INSN SPECIFIED
         BE       LISTFT2           YES
         LI,R1    31
         BAL,R11  ERROR             REPORT ERROR - MORE THAN ONE INSN
         B        RETURN
LISTFT2  LI,R1    0
         BAL,R11  BLDCB             BUILD M:EI AND OPEN
         CI,R13   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 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,R11  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    R10               GET ABN CODE
         CI,R2    7
         BE       *R8               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'
         PAGE     'REM-REW'
REW      DSECT    1                 REWIND
         LCI      7
         PSM,R5   *R7               SAVE REGISTERS
         BAL,R11  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,R11  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     CI,R13   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,R12   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
         BE       REW2              NONE, ERROR
         B        REW6              GO ONE, USE IT
REWC     BAL,R11  FILTRAN           GO GET FILE NAME
         B        REW6
REWB     BAL,R11  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
         BNE      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
         BNE      REW2              ALREADY SET
         B        REW6
RINGT    TEXTC    'RING'
         RES      -1
REW3     LI,R1    8                 RING, USE INOUT OPEN
         B        REW6+1
         BAL,R11  GETARG6           GET NULL FIELD
         MTW,0    NCHAR,R7          IS FIELD NULL
         BNE      REW2              NO - SYNTAX ERROR
         LW,R2    TERM,R7
         CI,R2    '/'               DOES FILE NAME FOLLOW
         BE       REWC              YES
REW6     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     CI,R2    7                 IF AT, USE OPNNXT
         BNE      KGC6%4            UNLESS FILE SPECIFIED
         MTW,0    FILE,R7
         BNE      %+2
         AI,R1    X'400'
KGC6%4   CI,R12   6                 IF REMOVE DO TEST OPN
         BNE      %+2
         OR,R1    =X'80000'
         BAL,R11  BLDCB             GO BUILD INPUT DCB
         MTB,-2   R10               IF END OF ALL FILES
         BE       REW9              TRY ONE MORE TIME
         CI,R13   1                 ERROR DETECTED
         BG       RETURN            YES-RETURN
         CI,R12   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     MTW,-1   ERRFLAG
         LI,R13   0                 CLEAR ERROR
         CI,R12   6                 BUT ONLY IF REMOVE
         BNE      RETURN            OF ANS TAPE
         BAL,R11  OPNNXT
         AI,R10   0
         BE       REW4              WORKED
         LI,R1    0
         BAL,R11  ERROR
         B        RETURN
REW8     CI,R12   7
         BE       REWA              REW - ERROR FOR DP
         BG       REW5+2            MOUNT
         MTW,0    DEVICE+1,R7
         BE       REW2              MUST HAVE SN FOR DP
         LI,R1    4                 OPEN NEXT, INPUT
         BAL,R11  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,R11  CLOSEI
         LI,R1    INSER
         CW,R5    INSER
         BE       KGC7%4
         CW,R5    OUTSER
         BNE      RETURN
         LI,R1    OUTSER
KGC7%4   STW,R0   0,R1
         B        RETURN
REW2     LI,R1    17                SYNTAX ERROR
         BAL,R11  ERROR
         B        RETURN            EXIT
*
         USECT    PLSECT
FPTREW1  GEN,8,7,17 X'15',0,M:EI
         DATA     X'20'             REMOVE
         PAGE     '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
         BNE      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    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    BAL,R11  CLRARG
         MTW,3    DEVICE,R7         DEFAULT FT
         LI,R12   1                 SET OUTPUT FLAG
         BAL,R11  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,R11  BLDCB
         CI,R13   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
         PAGE     'OPEN NEXT M:EI AND CHECK THAT NAME CHANGES'
*
OPNNXT   DSECT    1
         LCI      2                 SAVE REGS
         PSM,R8   *R7
         LI,R8    X'100'
         CH,R8    M:EI+23           IF NO FILE NAME NOW, MUST
         BE       OPNX9             ALREADY HAVE ERROR
         LW,R8    =X'C0000400'      OPNNXT,ERR,ABN
         STW,R8   OPNXFPT+1
         LI,R8    OPNX1             ERR,ABN ADDR
         STW,R8   OPNXFPT+2
         STW,R8   OPNXFPT+3
         LI,R8    TLBLSIZE          SET TLABEL SIZE
         STB,R8   TLABEL
         LW,R10   M:EI+11           CLEAR FPARAM
         STW,R0   *R10
         STW,R0   TLABEL+1          CLEAR RANDOM ID
         LI,R10   0
         LI,R9    BA(OPNXFPT+5)
         OR,R9    =X'20000000'      MOVE 32 BYTES
         LI,R8    BA(M:EI+23)
         MBS,R8   0
         CAL1,1   OPNXFPT
         OR,R11   =X'20000000'      SET GOOD RETURN IF OPEN
         B        OPNX9
OPNX1    AI,R9    -32               BACK TO START OF FILE NAME
         LI,R8    BA(M:EI+23)
         AW,R9    =X'20000000'      COMPARE 32 BYTES
         CBS,R8   0
         STCF     R11
OPNX9    LB,R8    R10               SET CC=8 IF END OF ALL FILES
         CI,R8    2
         BNE      %+2
         OR,R11   =X'80000000'
         LCI      2
         PLM,R8   *R7
         LC       R11               SET CC
         B        *R11
         PAGE     'SPACE AFTER LAST FILE'
*
SPE      DSECT    1
         LCI      7
         PSM,R5   *R7               SAVE REGISTERS
         BAL,R11  CLRARG            CLEAN -ARGTBL-
         BAL,R11  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
         CI,R13   1                 ANY ERRORS
         BGE      SPE51             YES, ABORT BATCH JOB
         LI,R8    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     LI,R1    X'C'              INOUT-UPDATE,OPEN NEXT
         BAL,R11  BLDCB
         LI,R9    0                 INITIALIZE FILE COUNT
         CH,R8    R10
         BNE      SPE8              NO
         CAL1,1   OPNIFT            YES, REWIND FIRST
         LI,R8    -1                ONLY DO THIS ONCE
         CAL1,1   FPTREW
         BAL,R11  CLOSEI
         B        SPE7
SPE8     LW,R2    M:EI              IF DEVICE
         CI,R2    1                 MUST USE SPF,READ LOOP
         BANZ     SPE4
SPE3     BAL,R11  CLOSEI            GO-CLOSE THE FILE
         AI,R9    1                 COUNT FILES SKIPPED
         MTW,0    BREAK
         BNE      SPE6              GIVE UP
         BAL,R11  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     BAL,R11  ERROR
SPE51    LI,R13   4                 ABORT BATCH JOB
         B        RETURN
SKIPTXT  TEXT     '.. % FILES SKIPPED
'
SPE6     LI,R5    SKIPTXT
         BAL,R11  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,R14   TLABEL+4
         LI,R1    M:EI+23
         BAL,R11  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
         BE       %+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         TRY AGAIN
         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
KGCB%4   CAL1,1   SPFPT             SKIP ONE FILE
         AI,R9    1
         CAL1,1   SPRFPT            READ A RECORD, ABNS IF AT END
         MTW,0    BREAK
         BE       KGCB%4            NO MARK HERE, TRY NEXT ONE
SPE9     CAL1,1   SKIPREC           SKIP BACK OVER SECOND MARK
         B        SPE6              AND RETURN
         PAGE     'SPACE FILE'
*
SPF      DSECT    1                 SPACE FILE
         LCI      7
         PSM,R5   *R7               SAVE REGISTERS
         BAL,R11  CLRARG            ZERO -ARGTBL-
         MTW,3    DEVICE,R7         FT DEFAULT
         BAL,R11  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,R11  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,R11  GETARG6
         MTW,0    NCHAR,R7
         BNE      SPF9              FIELD NOT NULL-ERROR
SPF2     LI,R1    0                 OPEN IN INPUT MODE
         CI,R13   1                 ANY ERRORS IN SCAN
         BG       RETURN            YES - EXIT
         LW,R11   CMBX,R7
         STW,R11  WRTFPT,R7         SAVE CMBX
         BAL,R11  BLDCB             GO OPEN M:EI
         CI,R13   1                 IF OPEN FAILED, QUIT
         BG       SPR1              AND PRINT MESSAGE
         LW,R11   WRTFPT,R7
         STW,R11  CMBX,R7           RESTORE CMBX.
         LCI      2
         LM,R1    SPFPT
         STM,R1   WRTFPT,R7         INITIALIZE MOVE FILE FPT
         LI,R1    0
         BAL,R11  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,R11  BCD2BIN           GO-CONVERT NO. OF FILES TO BINARY
         CI,R4    2                 OVERFLOW
         BNE      SPF3              NO
         LI,R1    10                BAD NUMMER
SPFE     BAL,R11  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,R11  BCD2BIN           GO-CONVERT NO. OF FILES
         CI,R4    0                 NORMAL TERMINATION
         BE       SPF6              YES
         LI,R1    30                ERROR-INVALID TERMINATION
         BAL,R11  ERROR
SPF6     CI,R12   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
         PAGE     'DELETEALL'
*
DELETEAL DSECT    1
         LCI      7
         PSM,R5   *R7               SAVE REGISTERS
         BAL,R11  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,R11  CLRARG            CLEAR ARG TABLE
         BAL,R11  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,R9    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,R11  REVIEW            GO PROCESS RANGE
         CI,R13   1
         BG       ALL9              ERROR - GO EXIT
DELALL3  LI,R1    14                INOUT,NXTF,M:EI,FPARAM
         BAL,R11  BLDCB
         CI,R13   2                 IF COMMAND IS TO BE ABORTED
         BG       ALL10             DO IT
         LB,R1    R10               ANY FILES TO DELETE
         CI,R1    2
         BE       LIST50            NO
         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,R14   9
         LI,R15   BA(TLABEL)        BUFFER
         LI,R11   DELALL1           RETURN
*
RANGEOUT LCI      7
         PSM,R5   *R7
         STW,R15  RSSAVE,R7
         LI,R15   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,R11  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,R11   M:EISN-1          ANY SNS
         CI,R11   X'FF00'
         BAZ      %+3
         MTB,1    TLABEL+22         PUT # IN FRONT
         STD,R2   TLABEL+20
         LI,R5    TLABEL+22
         BAL,R11  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
         BE       %+2
         BAL,R11  FROMM             YES, PUT START
         LI,R4    M:EI+31
         BAL,R11  DOTACCT           .ACCT
         LI,R4    TOFILE-1
         MTB,0    TOFILE
         BE       %+2
         BAL,R11  TOM               TO TOFILE
         B        RANGEOUT2
RANGEOUT1 LI,R4   M:EI+22
         BAL,R11  SLASHM
         LI,R4    M:EI+31
         BAL,R11  DOTACCT
RANGEOUT2 LCI     7
         PLM,R5   *R7               RETURN
         B        *R11
DELALL1  LW,R3    R14               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       KGC8%4            GOOD ONE
         AI,R3    -X'80000'         TRY LIN FEED TOO
         CD,R2    YES%
         BNE      RETURN            NO-RETURN
KGC8%4   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    R11
         BAL,R5   WACC20
         TEXTC    ' FROM '
DEVTXTS  EQU      %-3
         TEXTC    ' DC'
         TEXTC    ' LT'
         TEXTC    ' DP'
         TEXTC    ' FT'
         TEXTC    ' AT'
SLASHM   MTB,1    R11
         BAL,R5   WACC20
         TEXTC    '/'
DOTACCT  LW,R5    DEVICE,R7         NO ACCOUNT FOR AT
         CI,R5    7
         BE       *R11
         BAL,R5   WACC20
         TEXTC    '.'
TOM      MTB,1    R11               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,R11  TESTFNC           TEST IF FILE IN RANGE
         B        ALL5              NO - SAVE FILE
         BDR,R10  ERRABN            DIDNT GET IT OPEN
         CAL1,1   FPTDELET          RELEASE THE FILE
         BAL,R6   RANDCHK           TEST IF RANDOM FILE
ALL4     BAL,R11  ALLC              COUNT FILE, LIST IT
ALL5     BAL,R11  CLOSEI            CLOSE DCB IF OPEN
         LW,R1    BREAK             ARE WE TO STOP
         BNE      ALL9              YES
         MTW,0    TOFILE            ANY MORE FILES WANTED
         BL       ALL9              NO
         BAL,R11  OPNNXT
         BCS,8    ALL9              ALL DONE
         BE       ALL10             DONT LOOP
         B        DELALL2           RELEASE IT
ERRABN   LB,R1    R10
         CI,R1    8                 SYNONYM NAME
         BE       ALL5              YES-SKIP IT
         B        ALL4              NO TYPE MESSAGE
ALL10    LI,R1    0                 YES-REPORT ERROR
         BAL,R11  ERROR
ALL9     LI,R5    DELTEXT           ADDR OF MESSAGE
         STH,R0   R9                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,R10   0
         CAL1,1   OPNTRY            TRY TO OPEN AGAIN
         PSW,R11  *R7               FILE WAS NOT DELETED
         BAL,R11  CLOSEI            GO CLOSE
         PLW,R11  *R7
RAND1    EOR,R10  03ABN             DID WE GET NO FILE
         CAL1,1   FPTSET            SET DELETEALL ERRABN
         MTW,0    DELETEF           REVIEW COMMAND
         BE       %+3               NO
         CAL1,1   FPTSET2           RESET ERR AND ABN ADR
         BDR,R10  LIST28            AND TYPE MESSAGE
         BDR,R10  0,R6              PRINT MESSAGE IF THERE IS ONE
ADDGRAN  LW,R10   M:EI+11           CHECK FILENAME FOR SYNON
         AI,R10   X'80001'          POINT TO FIT NAME, NEG FOR ALLC
         LB,R1    *R10
         CB,R1    M:EI+23           IF NAMES DONT MATCH, NO GRANS
         BNE      ADDGRANX          SINCE IT IS JUST A FD ENTRY
         LB,R8    *R10,R1
         CB,R8    M:EI+23,R1
         BNE      ADDGRANX
         BDR,R1   %-3
         LW,R1    M:EI+11           RESTORE POINTER TO FPARAM
ADDGRAN1 LI,R8    255
         AND,R8   *R1
         AW,R1    R8                SKIP FILENAME ENTRY
         AI,R1    1
         LH,R8    *R1
         CI,R8    X'FF'             ARE WE DONE
         BANZ     0,R6
         CI,R8    X'D00'            IS THIS SIZE ENTRY
         BNE      ADDGRAN1          NO
         LW,R8    1,R1
         AWM,R8   GRANCNT
ADDGRANX LI,R10   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
         PAGE     'DELETE'
*
DELETE   DSECT    1                 DELETE COMMAND
         LCI      7
         PSM,R5   *R7               SAVE REGISTERS
         LI,R5    0                 INITIALIZE SEVERITY LEVEL
         LI,R9    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  BAL,R11  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,R11  FILTRAN
DELETE8  LW,R1    TERM,R7           MUST BE ',', OR X'15'
         CI,R1    ','
         BE       %-3               GET NEXT ONE
         CI,R1    '('
         BNE      DELETE9
         BAL,R11  GETARG6           MUST BE JOB
         LW,R1    ARGBUFF,R7
         CW,R1    JOBT
         BNE      DELETE7-1
         LW,R1    TERM,R7
         CI,R1    ')'
         BNE      DELETE7-1
         BAL,R11  GETARG6
         LW,R1    NCHAR,R7
         BE       DELETE8           OK.
DELETE9  CI,R1    X'15'
         BNE      DELETE7-1
         CI,R13   1                 ANY SYNTAX ERRORS
         BG       RETURN
         STW,R6   CMBX,R7           RESTORE STARTING POINT
DELETE3  BAL,R11  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,R11  BLDCB             GO-BUILD INPUT DCB
         CI,R13   2                 CHECK ERROR SEVERITY
         BG       RETURN            BAD ONE
         BE       DELETE2           DIDNT GET IT OPEN
         CAL1,1   FPTDELET          RELEASE THE FILE
         LI,R11   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,R9    1                 BUMP FILE COUNT
DELETE2  LW,R4    MODE,R7           IF JOB FILE, SKIP OVER OPTION
         BE       %+3
         BAL,R11  GETARG6
         BAL,R11  GETARG6           AND )
         LW,R4    TERM,R7
         CW,R13   R5
         BLE      %+2
         LW,R5    R13               UPDATE SEVERITY LEVEL
         LW,R1    BREAK
         STW,R0   BREAK
         BNE      DELETE4
         LI,R13   0                 RESET SEVERITY FOR NEXT FILE
         CI,R4    ','
         BE       DELETE3           ANOTHER FID
DELETE4  LW,R13   R5                SET SEVERITY LEVEL
         B        ALL9
DELETE6  LI,R1    34                INVALID DEVICE
         B        DELETE7
JOBT     TEXTC    'JOB'
         END
