         TITLE    '               R A D E D I T   S E G M E N T   1'            
         SPACE    2                                                             
         SYSTEM   SIG7FDP                                                       
         SYSTEM   OPTIONS                                                       
*                                                                               
*                                                                               
*  DEFINITIONS                                                                  
         DEF      RADSEG1,SEG1END   BEGIN, END OF THIS SEGMENT                  
*                                                                               
*  COMMAND PROCESSORS IN THIS SEGMENT                                           
         DEF      ALLOT                                                         
         DEF      DELETE                                                        
         DEF      DUMP                                                          
         DEF      TRUNCATE                                                      
         DEF      UTILITY                                                       
         DEF      INIT                                                          
         DEF      ADD                                                           
         DEF      XDMP                                                          
         DEF      STDLB                                                         
*                                                                               
************************                                                        
*                          1 => 'INIT', 'ADD' LEGAL COMMANDS                    
*                                                                               
*                                                                               
         TITLE    '               R A D E D I T   S E G M E N T   1'            
*                                                                               
*  UNIVERSAL REFERENCE TO PUSH/PULL STACK SUPPLIED BY OLOAD                     
         REF      U:PCB                                                         
*                                                                               
*                                                                               
*  DCB'S IN CONTEXT SEGMENT                                                     
         REF      M:C,M:LL,M:OC,M:LO                                            
         REF      M:BI,M:BO,M:X1                                                
         REF      F:SI,F:SI2,SIFNAME                                            
         REF      F:SO,F:SO2,SOFNAME                                            
         REF      F:BI,BIBUFF,BIFNAME                                           
         REF      F:LI                                                          
*                                                                               
*  FPT'S IN CONTEXT SEGMENT                                                     
         REF      READSI,SIBUFF,SIBCNT,SICOMPL                                  
         REF      WRITESO,SOBUFF,SOBCNT,SOCOMPL                                 
         REF      RDDISC,RDDISC4,RDDISC5,RDDISC6                                
         REF      WRDISC,WRDISC4,WRDISC5                                        
         REF      READBI,WRITEBO                                                
         REF      ASNFILE                                                       
         REF      TYPE,TYPE1,TYPE2,TYPRERR                                      
         REF      PRINT,PRINT1,PRINT2                                           
         REF      WRITELO,BYTCNT                                                
         REF      SKIPRSI,SKIPNSI,SKIPRSO,SKIPNSO                               
         REF      SKIPRCD,SKIPRCD1,NUMRECS                                      
         REF      SETRSIZE,SETRSIZ2,SETDCBAT                                    
         REF      STIMER,WAITTIME,STDLBCAL                                      
*                                                                               
* FPT'S DEFINED IN ROOT1                                                        
         REF      OPENC,OPENLL,OPENOC,OPENANY                                   
         REF      OPENSI,OPENSO,OPENSL,OPFLEIN                                  
         REF      CLOSESO,CLOSESI,CLOSEANY                                      
         REF      CLFLEIN,CLOSEBI,CLOSEBO,CLOSEOC                               
         REF      CLOSELL,CLOSELI,CLOSEX1,CLOSESL                               
         REF      READBIH,READLI,READX1,RDDISCS                                 
         REF      WRITEBOH,WRITEX1,WRDISCS                                      
         REF      REWINDBI,REWINDBO,REWINFBI,REWINDSO                           
         REF      UNLOADBO,SKIPFSO,FSKIPLI,SKIPFILE,SETX1                       
         REF      REWIND,WEOF,UNLOAD                                            
         REF      VFCSO0,VFCSO1,WEOFSO,WEOFBO                                   
         REF      MODESI0,MODESO0,MODESI1,MODESO1                               
         REF      MODESODD,MODESOND                                             
         REF      ASNAREA,ASNDEV,ASNOPLB                                        
         REF      GETAINFO,GETFILNM,GETRSIZE                                    
*                                                                               
*  ERROR MESSAGES IN CONTEXT SEGMENT                                            
         REF      MESS0,MESS2,MESS4,MESS5,MESS9                                 
         REF      MESS14,MESS18,MESS20,MESS21,MESS22,MESS23                     
         REF      MESS40,MESS41                                                 
*                                                                               
*  ERROR MESSAGES IN ROOT1 (RS1000)                                             
         REF      MESS1,MESS7,MESS8,MESS10                                      
         REF      MESS11,MESS16,MESS19,MESS28                                   
         REF      MESS30,MESS31,MESS32,MESS35                                   
*                                                                               
*  MISC VARIABLES IN CONTEXT SEGMENT                                            
         REF      BCKEND,BPEND,BPEND1,BACKSZE,BCKSZE                            
         REF      SPARAM,SPARAMF1,SPARAMF2                                      
         REF      BUFF1,BUFF2,BUFF3,BUFF4                                       
         REF      LIBFLAG,LINEIMAG,COLPTR                                       
         REF      AREANAME,FILENAME,AREA,ACNTNAME                               
         REF      AREAASGN,DEVASGN,OPLBASGN                                     
         REF      GIOCT                                                         
         REF      MAPSW,MAXMASD                                                 
         REF      ERRFCN,ERRORSW,CONESW                                         
         REF      FREECELL,DIRCHAIN,ENDCHAIN                                    
*                                                                               
* DATA DEFINED IN ROOT1                                                         
         REF      ZEROS,BLNK,DCW1,DCW2,DCTDATA,DCBOPENF                         
         REF      FPSP,CKXA,CKXABT                                              
         REF      ILLNMES,ILLTOTL                                               
         REF      M1,M2,M3,M4,M5,M6,M7,M8,M9                                    
         REF      M14,M15,M16,M17,M19,M24,M31                                   
         REF      ML8,ML15,ML16,ML24                                            
         REF      X200000,Y8                                                    
         REF      KWFILE,KWLIB,KWALL                                            
         REF      STATFLAG                                                      
         REF      GIOBITS,GIOOBIT,GIODBIT,GIOFBIT,GIOABIT,GIOFA                 
*                                                                               
*  TABLES IN CONTEXT SEGMENT                                                    
         REF      AREASWS,AREASWSX                                              
         REF      MASTDICT,MASDNAME,MASDBOA,MASDEOA                             
         REF      MASDSIZE,MASDTPC,MASDSPT,MASDWPS                              
         REF      MASDWP,MASDDEVA,MASDDCTI,MASDMODL                             
         REF      MASDZERO,MASDLEOF,MASDFREE,MASDUSED                           
         REF      MASDLOST,MASDNDS,MASDNFIL,MASDFRMT,MASDEND                    
         REF      DIRENAME,DIREBOT,DIREEOT,DIRENSEC                             
         REF      DIREFSIZ,DIRERSIZ,DIREGSIZ,DIRERF                             
         REF      DIREORG,DIRESD,DIRESTAT,DIREXTNT,DIRELEN                      
         REF      DIREESIZ,DIREACNT,DIREFIX,DIREPRIO,DIREEND                    
         REF      MODULE,EBCDIC,DEFREF,MODIR                                    
         REF      MODULSZE,MODIRSZE,DREFSZE,EBDICSZE                            
         REF      MODULMAX,MODIRMAX,DREFMAX,EBDICMAX                            
*                                                                               
* CONSTANTS USED THROUGH OUT THE SYSTEM                                         
*             AREA INDICIES                                                     
         REF      SPINDEX,FPINDEX,BPINDEX,BTINDEX                               
         REF      XAINDEX,CKINDEX,ISINDEX,OSINDEX                               
*            FILE DIRECTORY FORMAT INDEX DEFINITIONS                            
         REF      DIRSIZE,DIRLHDR,LNDIRHDR                                      
         REF      DIRINFO,DIRNEXT,DIRIDW1,DIRIDW2                               
         REF      DIRNAM1,DIRNAM2,DIRFLGS,DIRLEN,DIRGRSZ,DIRFSIZ                
         REF      DIRBOT,DIREOT,DIRXTNT,DIRESIZ,DIRACT1,DIRACT2                 
         REF      DIRUNB,DIRBLK,DIRCOMP,DIRSEQN,DIRDIRC                         
*            VALUES SET AND USED BY 'UNPKDIRE'                                  
         REF      ORGUNB,ORGBLK,ORGCOMP                                         
         REF      FILDELTD,FILBDTRK,FILGOODF,FILENTRY,LDIREHDR                  
*             VALUES USED TO BUILD LINKED CORE DIRECTORIES                      
         REF      BACLINK,FWDLINK,XBACLINK,XFWDLINK,SIZEDIR                     
*                                                                               
*  ROUTINES IN ROOT1                                                            
         REF      EXEC,EXEC1                                                    
         REF      SCAN,PROCSCN,TYPRNT,PROCKYIN                                  
         REF      GETIOID,GETFID,GETDEV,GETOPLB,GETANY                          
         REF      ABORT,END,ABNERR,ABNADDR,ERADDR                               
         REF      ABNCONT,ABNRETRY,ABNABORT,WPERR,OPENERR                       
         REF      ERROROUT,ERRORINA,ERROR%PL,OUTFILNM,OUT%MSG                   
         REF      ERROR01,ERROR02,ERROR04,ERROR05,ERROR06                       
         REF      ERROR10,ERROR11,ERROR19,ERROR28,ERROR35,ERROR41               
         REF      GETFSTSD,GETNXTSD,GET1SFIL,GETNXFIL                           
         REF      GETAX,UNPKMASD,UNPKDIRE,GAN,PACKDIRE                          
         REF      FNDROM                                                        
*                                                                               
*  GENERAL PRINT-LINE / PRINT ROUTINES                                          
         REF      %PL               PRINT LINE BUFFER                           
         REF      %CP               CURRENT CHARACTER POSITION IN %PL           
         REF      %TITLINE          TITLE LINE FOR PAGE HEADERS                 
         REF      %19@3             LINES REMAINING ON PAGE                     
         REF      %19@4             SWITCH: TITLE LINE TO BE OUTPUT             
         REF      %1        CLEAR THE PRINT LINE                                
         REF      %2        SET CP                                              
         REF      %3        STEP CP                                             
         REF      %4        STORE CHARACTER                                     
         REF      %5        STORE TEXT STRING                                   
         REF      %6        STORE TEXTC STRING                                  
         REF      %7        STORE TIME                                          
         REF      %8        CONVERT AND STORE INTEGER                           
         REF      %9        ENTER DATE                                          
         REF      %11       PRINT PRINT LINE                                    
         REF      %12       PRINT PRINT LINE, UPSPACE CONTROL                   
         REF      %13       PAGE PRINTER AND OUT ANY TITLE LINE                 
         REF      %14       PAGE PRINTER AND PRINT THE PRINT-LINE               
         REF      %15       PRINT A TEXT STRING                                 
         REF      %16       PRINT A TEXTC STRING                                
*                                                                               
*                                                                               
*                                                                               
*                                                                               
*  REFERENCES PECULIAR TO SEGMENT 1                                             
*                                                                               
*                                                                               
         REF      DAFLG,SRECVAL,ERECVAL,DAHDR,DFHDR,DFHDRE                      
         REF      DCDMP80,DCDMP81,DCDMP82                                       
         REF      DCDMP83,DCDMP84,DCDMP85                                       
         REF      DCDMP91,DCDMP92,DCDMP93,DCDMP94,DCDMP94A                      
         REF      DCDMP95,DCDMP96,DCDMP97,DCDMP98                               
         REF      POSFILE,POSREC                                                
         REF      DELTRUNC,ALLOTFPT,ALLFPTGS                                    
         REF      %9GETOD,%9TOD                                                 
         REF      NFIL,RDSDISC,RDSDISC4,RDSDISC6       (FOR XDMP)               
         PAGE                                                                   
         SPACE    2                                                             
*        DEFINITIONS FOR 'XDMP'                                                 
*                                                                               
XDPBEG   EQU      MODIRSZE          BA(START BYTE FOR A LINE OF OUTPUT)         
XDPEND   EQU      DREFSZE           BA(LAST BYTE TO OUTPUT)                     
TMCOUNT  EQU      EBDICSZE          TAPEMARK (E-O-F) FOUND SWITCH               
XDTTYSW  EQU      MODULSZE          1 IF TTY/TERMINAL; ELSE 0                   
XDPMSG   EQU      MAPSW             ADDR OF TYPE OF XDMP MESSAGE                
XDMPCAL  EQU      MODIRMAX          ADDRESS OF CAL TO READ RECORD/SECTOR        
XDRECSW  EQU      DREFMAX           >0 IF 'RECS' OPTION ON XDMP CMND            
XDFILESW EQU      EBDICMAX          >0 IF A FILE SPECIFIED TO XDMP              
*                                                                               
*                                                                               
*                                                                               
*        DEFINITIONS FOR 'INIT' AND 'ADD'                                       
*                                                                               
         DO       #PRIV                                                         
VSN      EQU      DIRENAME                                                      
*                                                                               
INITSW   EQU      MAPSW             'INIT' / 'ADD' SWITCH                       
ADDSW    EQU      MAXMASD           NUMBER OF ADDED AREAS COUNT/ SWITCH         
*                                                                               
*                                                                               
INITYPE  EQU      MODIRSZE          INITIALIZATION TYPE FOR ENTIRE DISC         
ALOPCKTL EQU      DREFSZE           END OF AREA PCKTS READ FROM VTOC            
SKIPCKTL EQU      EBDICSZE          END OF SKIP PCKTS READ FROM DISC            
         FIN                        #PRIV                                       
*                                                                               
         PAGE                                                                   
         SPACE    2                                                             
PUSH     CNAME    1                 PUSH REGISTERS INTO STACK                   
PULL     CNAME    0                 PULL REGISTERS FROM STACK                   
         PROC                                                                   
        DO       NUM(AF)=1          SAVE ONLY ONE REGISTER ?                    
LF(1)    GEN,8,4,20        X'8'+NAME,AF(1),U:PCB                                
        ELSE     NUM(AF)=0          SAVE MULTIPLE REGISTERS                     
LF(1)    LCI      AF(1)&X'F'                                                    
         GEN,8,4,20        X'A'+NAME,AF(2),U:PCB                                
        FIN                                                                     
         PEND                                                                   
*                                                                               
*                                                                               
BIFFGD   CNAME    4                                                             
         PROC                                                                   
LF       LC       *STATFLAG                                                     
         GEN,1,7,4,3,17  AFA(1),X'68',NAME,AF(2),AF(1)                          
         PEND                                                                   
*                                                                               
*                                                                               
ERRP     CNAME                                                                  
         PROC                       DEFINE ERROR PROCESSOR TABLES               
         DO       NUM(AF)>0                                                     
LF        GEN,8,24 AF(1),AF(2)                                                  
         ELSE                                                                   
LF        GEN,32   0                END OF LIST                                 
         FIN                                                                    
         PEND                                                                   
         SPACE    3                                                             
         OPEN     Q,I                                                           
TXT      CNAME    0                                                             
TXTC     CNAME    1                                                             
         PROC                                                                   
Q        SET      S:UT(AF)                                                      
I        SET      S:NUMC(Q)                                                     
Q(I+1)   SET      ' '                                                           
Q(I+2)   SET      ' '                                                           
Q(I+3)   SET      ' '                                                           
         DO       NAME=0                                                        
LF       TEXT     S:PT(Q(1),Q(2),Q(3),Q(4))                                     
         LIST     0                                                             
         ORG      %-1                                                           
         TEXT     AF                                                            
         ELSE                                                                   
LF       DATA     (((I)**8+Q(1))**8+Q(2))**8+Q(3)                               
         LIST     0                                                             
         ORG      %-1                                                           
         TEXTC    AF                                                            
         FIN                                                                    
         LIST     1                                                             
         PEND                                                                   
         CLOSE    Q,I                                                           
         SPACE    3                                                             
*        LIST     0                 DO NOT LIST % ROUTINE PROCS                 
***********************************************************************         
*                                                                               
*                                                                               
*                 LOAD REGISTER WITH ARGUMENT FOR A % ROUTINE.                  
*        CALL:                                                                  
*              LF ARG,REG  AF(I)                                                
*                 WHERE LF IS THE LABEL FIELD FROM THE %ROUTINE CALL,           
*                       REG IS THE REGISTER TO BE LOADED IF THERE IS            
*                       AN ARGUMENT PRESENT, AND                                
*                       AF(I) IS THE I-TH ARGUMENT TO THE %ROUTINE.             
*                 IF AF(I) IS NULL,  LF  IS DEFINED BY A RES 0                  
*                                                                               
ARG      CNAME                                                                  
         PROC                                                                   
         DO       NUM(AF)>0         AN ARGUMENT GIVEN ?                         
          DO       TCOR(AF,S:INT,S:C)>0    IS IT A CONSTANT ?                   
           DO       SCOR(AF,R0,R1,R2,R3,R4,R5,R6,R7,R8,R9,;   IS IT A           
                            R10,R11,R12,R13,R14,R15)>0        REGISTER ?        
LF          LW,CF(2)  AF                LOAD VALUE FROM WORD (REG)              
           ELSE                     SCOR = 0  ==> CONSTANT                      
LF          LI,CF(2)  AF                LOAD CONSTANT                           
           FIN                                                                  
          ELSE                      TCOR = 0 ==> NOT A CONSTANT                 
LF         LW,CF(2)  AF                 IT IS A SYMBOL; LOAD FROM IT            
          FIN                                                                   
         ELSE                                                                   
          DO       NUM(LF)>0        IS THERE A LABEL ?                          
LF         RES      0               DEFINE IT                                   
          FIN                                                                   
         FIN                                                                    
         PEND                                                                   
***********************************************************************         
         SPACE    3                                                             
***********************************************************************         
*                                                                               
*                                                                               
*        LOAD PARAMETER REGISTER WITH ARGUMENT ADDRESS FOR A % ROUTINE          
*        CALL:                                                                  
*              LF ARGA,REG   AF(I)                                              
*                 WHERE  LF  IS THE LABEL FIELD FROM THE %ROUTINE CALL,         
*                        REG IS THE REGISTER TO BE LOADED, IF THERE             
*                          IS AN ARGUMENT PRESENT, AND                          
*                        AF(I)  IS THE I-TH ARGUMENT TO THE %ROUTINE            
*                 IF AF(I) IS NULL, LF IS DEFINED BY A  RES  0                  
*                                                                               
ARGA     CNAME                                                                  
         PROC                                                                   
         DO       NUM(AF)>0         AND PARAMETERS ?                            
          DO       ((NUM(AF)=1)&(AFA(1)=0))                                     
LF         LI,CF(2)   AF                                                        
          ELSE                                                                  
LF         LW,CF(2)   AF                                                        
          FIN                                                                   
         ELSE                                                                   
          DO       NUM(LF)>0                                                    
LF         RES      0                                                           
          FIN                                                                   
         FIN                                                                    
         PEND                                                                   
***********************************************************************         
         SPACE    3                                                             
CLRPL    CNAME                                                                  
*                          CLEAR CURRENT PRINT LINE                             
         PROC                                                                   
LF       BAL,R14  %1                CLEAR THE PRINT LINE                        
         PEND                                                                   
         SPACE    3                                                             
SETCP    CNAME                                                                  
*                          SET CHARACTER POINTER (CP)                           
*                 R15 <= NEW VALUE OF CP                                        
         PROC                                                                   
LF       ARG,R15  AF                GET NEW CP VALUE                            
         BAL,R14  %2                SET IT                                      
         PEND                                                                   
         SPACE    3                                                             
STEPCP   CNAME                                                                  
*                           STEP CP LEFT OR RIGHT                               
*                 R15 <= CP STEP VALUE                                          
*                                   R15 > 0 ==>  RIGHT                          
*                                   R15 = 0 ==>  NO CHANGE                      
*                                   R15 < 0 ==>  LEFT                           
*                 R15 IS RETURNED WITH NEW VALUE OF CP                          
         PROC                                                                   
LF       ARG,R15  AF                GET STEP VALUE                              
         BAL,R14  %3                SET IT                                      
         PEND                                                                   
         SPACE    3                                                             
CHAR     CNAME                                                                  
*                          STORE CHARACTER IN PL                                
*                 R15 <= CHARACTER TO STORE, IN RIGHTMOST BYTE                  
         PROC                                                                   
LF       ARG,R15  AF                GET CHARACTER IF GIVEN                      
         BAL,R14  %4                STORE AWAY                                  
         PEND                                                                   
         SPACE    3                                                             
CHARS    CNAME    %5                                                            
PRTCHR   CNAME    %15                                                           
*                           STORE CHARACTER (TEXT) STRING  (,AND PRINT)         
*                 R2  <= WORD ADDRESS OF START OF 'TEXT' STRING                 
*                 R1  <= NUMBER OF CHARACTERS TO STORE                          
*                 R0  <= BYTE INDEX RELATIVE TO R2 OF 1ST CHARACTER             
         PROC                                                                   
LF       ARG,R1   AF(1)             GET STRING LENGTH                           
         ARGA,R2  AF(2)             GET START ADDRESS                           
         DO       NUM(AF(3))>0      OFFSET GIVEN ?                              
          ARG,R0   AF(3)            GET OFFSET                                  
         ELSE                                                                   
          DO1      NUM(AF)>0        SET DEFAULT ONLY IF PARAMS GIVEN            
          LI,R0    0                ELSE START AT 1ST CHARACTER                 
         FIN                                                                    
         BAL,R14  NAME              CALL REQUESTED ROUTINE                      
         PEND                                                                   
         SPACE    3                                                             
STRNG    CNAME    %6                                                            
PRTTXT   CNAME    %16                                                           
*                           STORE TEXTC STRING (, AND PRINT)                    
*                 R2  <= ADDRESS OF START OF TEXTC STRING                       
         PROC                                                                   
LF       ARGA,R2  AF                LOAD ADDRESS OF TEXTC STRING                
         BAL,R14  NAME                                                          
         PEND                                                                   
         SPACE    3                                                             
TIME     CNAME                                                                  
*                           CONVERT AND STORE INTEGER AS TIME                   
*                 R15 <= TIME, IN SECONDS, TO BE CONVERTED                      
         PROC                                                                   
LF       ARG,R15  AF                GET TIME                                    
         BAL,R14  %7                CONVERT AND STORE                           
         PEND                                                                   
         SPACE    3                                                             
INTGR    CNAME                                                                  
*                           CONVERT AND STORE INTEGER                           
*                 R0  <= BASE OF CONVERSION (10 = DEC, 16 = HEX, 2 = BIN)       
*                 R1  <= FILL CHARACTER FOR LEADING UNUSED POSITIONS            
*                 R2  <= WIDTH OF FIELD (NUMBER OF DIGITS TO OUTPUT)            
*                 R15 <= INTEGER TO CONVERT (AS A 32 POSITIVE INTEGER)          
         PROC                                                                   
         DO       NUM(LF)>0                                                     
LF        RES      0                                                            
         FIN                                                                    
         OPEN     I                                                             
         DO       NUM(AF(1))>0                                                  
I         SET      SCOR(AF(1),DEC,HEX,BIN)                                      
           DO       I>0                                                         
            DO1      I=1                                                        
            LI,0     10             SET DECIMAL                                 
            DO1      I=2                                                        
            LI,0     16             SET HEX                                     
            DO1      I=3                                                        
            LI,0     2              SET BINARY                                  
           ELSE                                                                 
            ARG,R0   AF(1)          SET BASE                                    
           FIN                                                                  
         FIN                                                                    
*                                                                               
         DO       NUM(AF(2))>0                                                  
I         SET      SCOR(AF(2),SPAC,ZERO)                                        
           DO       I>0                                                         
            DO1      I=1                                                        
            LI,1     C' '           SET LEADING SPACES                          
            DO1      I=2                                                        
            LI,1     C'0'           SET LEADING ZEROES                          
           ELSE                                                                 
            ARG,R1   AF(2)          GET LEADING/FILL CHARACTER                  
           FIN                                                                  
         FIN                                                                    
*                                                                               
         ARG,R2   AF(3)             SET NUMBER OF DIGIT PLACES                  
         ARG,R15  AF(4)             SET VALUE TO CONVERT                        
         CLOSE    I                                                             
         BAL,R14  %8                CONVERT AND ENTER                           
         PEND                                                                   
EJECT    CNAME                                                                  
*                           POSITION PRINTER AT TOP OF NEW PAGE                 
*                 (IF A TITLE LINE EXISTS, PRINT AT TOP OF PAGE AND             
*                 (POSITION PRINTER AT NEXT LINE.                               
         PROC                                                                   
LF       BAL,R14  %13               EJECT PRINTER TO 1ST LINE OF NEW PAGE       
         PEND                                                                   
         SPACE    3                                                             
DATE     CNAME                                                                  
         PROC                                                                   
LF       BAL,R14  %9                GET AND ENTER DATE                          
         PEND                                                                   
         SPACE    3                                                             
PRNT     CNAME    1                                                             
PRTUP    CNAME    0                                                             
*                 FOR PRTUP:                                                    
*                 R15 <= UPSPACE COUNT IN NUMBER OF LINES; |N| < 8              
*                                   R15 > 0 ==> UPSPACE AFTER PRINT             
*                                   R15 = 0 ==> DO NOT UPSPACE                  
*                                   R15 < 0 ==> UPSPACE BEFORE PRINT            
         PROC                                                                   
         DO       NAME                                                          
LF        BAL,R14  %11              SIMPLY PRINT THE LINE                       
         ELSE                                                                   
LF        ARG,R15  AF               GET UPSPACE COUNT,                          
          BAL,R14  %12              THEN PRINT WITH UPSPACE                     
         FIN                                                                    
         PEND                                                                   
         SPACE    3                                                             
PRTPAG   CNAME                                                                  
         PROC                                                                   
LF       BAL,R14  %14               PAGE THE PRINTER, PRINT PL                  
         PEND                                                                   
         SPACE    3                                                             
         CLOSE    ARG,ARGA                                                      
         LIST     1                                                             
         PAGE                                                                   
RADSEG1  RES      0                                                             
R0       EQU      0                 GENERAL REGISTER 0                          
R1       EQU      1                 GENERAL REGISTER 1                          
R2       EQU      2                 GENERAL REGISTER 2                          
R3       EQU      3                 GENERAL REGISTER 3                          
R4       EQU      4                 GENERAL REGISTER 4                          
R5       EQU      5                 GENERAL REGISTER 5                          
R6       EQU      6                 GENERAL REGISTER 6                          
R7       EQU      7                 GENERAL REGISTER 7                          
LINK     EQU      8                 LINKAGE REGISTER 8                          
R8       EQU      8                 GENERAL REGISTER 8                          
R9       EQU      9                 GENERAL REGISTER 9                          
R10      EQU      10                GENERAL REGISTER 10                         
R11      EQU      11                GENERAL REGISTER 11                         
R12      EQU      12                GENERAL REGISTER 12                         
R13      EQU      13                GENERAL REGISTER 13                         
R14      EQU      14                GENERAL REGISTER 14                         
RLNK     EQU      R14               STD LINK FOR NEW ROUTINES                   
R15      EQU      15                GENERAL REGISTER 15                         
         PAGE                                                                   
         SPACE    2                                                             
K:PAGE   EQU      X'174'            WORD WITH LINES PER PAGE IN BYTE 1          
K:DCT1   EQU      X'176'            NUMBER OF DEVICE ENTRIES                    
K:DCT16  EQU      X'177'            DEVICE TYPE INDEX ADDRESS                   
K:MONTH  EQU      X'1EA'            TABLE OF NAMES OF MONTHS                    
K:NUMDA  EQU      X'14B'            HIGHEST VALID INDEX VALUE                   
         PAGE                                                                   
         SPACE    2                                                             
*                           P BITS IN FPTS                                      
P0       EQU      1**23                                                         
P1       EQU      1**31                                                         
P2       EQU      1**30                                                         
P3       EQU      1**29                                                         
P4       EQU      1**28                                                         
P5       EQU      1**27                                                         
P6       EQU      1**26                                                         
P7       EQU      1**25                                                         
P8       EQU      1**24                                                         
P9       EQU      1**23                                                         
P10      EQU      1**22                                                         
P11      EQU      1**21                                                         
P12      EQU      1**20                                                         
P13      EQU      1**19                                                         
P14      EQU      1**18                                                         
P15      EQU      1**17                                                         
P16      EQU      1**16                                                         
P17      EQU      1**15                                                         
*                                                                               
F7       EQU      1**0                                                          
F6       EQU      1**1                                                          
F5       EQU      1**2                                                          
F4       EQU      1**3                                                          
F3       EQU      1**4                                                          
F2       EQU      1**5                                                          
F1       EQU      1**6                                                          
F0       EQU      1**7                                                          
F8       EQU      1**8                                                          
         PAGE                                                                   
         SPACE    2                                                             
******** ERROR MESSAGES ********                                                
MESS3    TXTC     'INVALID RSIZE. UNBLOCKED ORGANIZATION GIVEN'                 
MESS13   TXTC     'SREC VALUE GREATER THAN EREC VALUE'                          
MESS42   TXTC     'DISC ALREADY MOUNTED'                                        
MESS43   TXTC     'CANNOT ''ADD'' TO A NON-CP-R INITIALIZED DISC'               
MESS44   TXTC     'VSN ERROR: DISC VSN = '''  LLLLLLLL' FILLED IN IN PL         
XMESS6   TXTC     'FILE '                                                       
XMESS6A  TXTC     ' DOES NOT EXIST'                                             
MESS51   TXTC     'UNABLE TO ASSIGN OPLABEL: ERROR CODE = '                     
MESS52   TXTC     'OPLABEL '  XX DOES NOT EXIST                                 
         PAGE                                                                   
*                                                                               
KM8      DATA     -8                                                            
K10      DATA     10                                                            
X80000   DATA     X'00080000'                                                   
*                                                                               
KEY%TABL EQU      %-1      INDEX    LEGAL OPTION KEYWORDS FOR ALLOT             
FSIZ     TEXT     'FSIZ' E   1                                                  
RSIZ     TEXT     'RSIZ' E   2                                                  
GSIZ     TEXT     'GSIZ' E   3                                                  
ESIZ     TEXT     'ESIZ' E   4                                                  
ORG      TEXT     'ORG '     5                                                  
FORMAT   TEXT     'FORM' AT  6                                                  
RF       TEXT     'RF  '     7                                                  
FIX      TEXT     'FIX '     8                                                  
*                                                                               
KEY%TOTL EQU      %-KEY%TABL-1                                                  
*                                                                               
KEY%FSIZ EQU      FSIZ-KEY%TABL     INDEX FOR FSIZE                             
KEY%ORG  EQU      ORG-KEY%TABL      INDEX FOR ORG AND FORMAT                    
KEY%RF   EQU      RF-KEY%TABL       INDEX FOR RF                                
KEY%FIX  EQU      FIX-KEY%TABL      INDEX FOR FIX                               
*                                                                               
*                                                                               
KEY%STOR EQU      %-1               WHERE TO STORE THE SIZES                    
         STW,R8   DIREFSIZ                                                      
         STW,R8   DIRERSIZ                                                      
         STW,R8   DIREGSIZ                                                      
         STW,R8   DIREESIZ                                                      
*                                                                               
*                           KEYWORDS FOR 'DUMP' OPTIONS                         
KWSREC   TEXT     'SREC'            START RECORD                                
KWEREC   TEXT     'EREC'            END RECORD                                  
KWRECS   TEXT     'RECS'            XDMP FILES BY RECORDS KEYWORD               
         PAGE                                                                   
         SPACE    2                                                             
KWORGS   EQU      %-1       LEGAL FORMAT (ORG) INDICATORS                       
         TEXT     'U   '            UNBLOCKED                                   
         TEXT     'B   '            BLOCKED                                     
         TEXT     'C   '            COMPRESSED                                  
#ORGS    EQU      %-KWORGS-1        DEFINE NUMBER OF LEGAL ORG CODES            
*                                                                               
*                                                                               
*                                                                               
*        ALLOT CAL PARAMETER WORDS    ESIZ IS OPTIONAL AND THE OTHERS           
*                                     MOVE IF ESIZ IS ABSENT                    
ALOTESIZ PZE      *DIREESIZ         LOC OF ESIZ IF GIVEN                        
ALOTGSIZ PZE      *DIREGSIZ         LOC OF GSIZE                                
ALOTACNT PZE      ACNTNAME          LOC OF ACCOUNTNAME                          
*                                                                               
ALOTPWRD DATA     X'FD000010'       STANDARD, ALWAYS PRESENT P-BITS             
FPTBIT07 DATA     P7                P-BIT 07 --  ESIZE                          
FPTBITF5 DATA     F5                F-BIT 05 --  FIX BIT                        
*                                                                               
*                           CONSTANTS USED BY ALLOT                             
*                                                                               
LIBRSIZ  EQU       30               REC SIZE FOR MODULE LIBRARY FILES           
MAXRSIZB EQU      128               MAX RSIZE FOR BLOCKED FILES                 
DEFALTRS EQU      128               DEFAULT RSIZE FOR BLOCKED FILES             
*                                                                               
ALOTCODE EQU      X'5A80'           ALLOT CODE AND P0 BIT FOR FPT               
TRUNCODE EQU      X'5C80'           TRUNCATE FPT CODE AND P0 BIT                
DELECODE EQU      X'5B80'           DELETE   FPT CODE AND P0 BIT                
RFFLAG   EQU      X'20'             RES FGD F2 FLAG FOR ALLOT FPT               
         PAGE                                                                   
         DO       #PRIV                                                         
*                           CONSTANTS AND EQUATES FOR 'INIT' & 'ADD'            
*                                                                               
*                               OFFSETS INTO VTOC SECTOR                        
*                                                                               
VTOCBOOT EQU      0                 START OF BOOTSTRAP IN SECTOR 0              
VTOCVSN1 EQU      20                VOLUME SERIAL NUMBER, PART 1                
VTOCVSN2 EQU      21                (IN 22 WORD BOOT)     PART 2                
VTOCVTOC EQU      22                LOC OF 'VTOC' IN VTOC                       
VTOCDAT1 EQU      23                DATE OF VOLUME INITIALIZATION               
VTOCDAT2 EQU      24                IN FORM 'MONDD YY'                          
VTOCUDT1 EQU      25                DATE OF LAST VOULME UPDATE (ADD)            
VTOCUDT2 EQU      26                IN FORM 'MONDD YY'                          
VTOCWPS  EQU      27                WORDS PER SECTOR                            
VTOCSPT  EQU      28                SECTORS PER TRACK                           
VTOCTPC  EQU      29                TRACKS PER CYLINDER                         
VTOCBOA  EQU      30                FIRST SECTOR AVAILABLE FOR ALLOCATN         
VTOCEOA  EQU      31                LAST  SECTOR AVAILABLE FOR ALLOCATN         
VTOCNDS  EQU      32                NUMBER OF DIRECTORY SECTORS                 
VTOCNAA  EQU      33                NUMBER OF AREAS ALLOCATED ON DISC           
VTOCALOC EQU      34                FIRST ALLOCATION PACKET SPACE               
*                                                                               
VTOC:LBL EQU      0         CP-V    LOC OF LABEL WORD                           
VTOCLBL1 EQU      1         CP-V    VSN WORD 1                                  
VTOCLBL2 EQU      2         CP-V    VSN WORD 2                                  
*                                                                               
VTOCDNDS EQU      1                 DEFAULT # DIRECTORY SECTORS ON INIT         
*                                                                               
CPI1     SET      5                                                             
CPI2     SET      CPI1+5                                                        
CPAREA   SET      CPI2+5                                                        
CPWPC    SET      CPI2+11                                                       
CPBOA    SET      CPI2+14                                                       
CPEOA    SET      CPI2+21                                                       
CPINIT   SET      CPI2+29                                                       
         PAGE                                                                   
*                                                                               
*                                                                               
*                           INITIALIZATION CODES                                
INITOVR  EQU      0                 NO CLEARING                                 
INITFAST EQU      1                 CLEAR ONLY SECTOR 0 (DIRE SECTOR)           
INITALL  EQU      2                 CLEAR ALL OF AREA                           
*                                                                               
*                           WRITE PROTECT CODES                                 
INITWPP  EQU      0                 PUBLIC ACCESS                               
INITWPB  EQU      1                 BACKGROUND                                  
INITWPF  EQU      2                 FOREGROUND                                  
INITWPS  EQU      3                 SYSTEM                                      
INITWPX  EQU      5                 IOEX                                        
*                                                                               
*                           ALLOCATION PACKET FORMAT (OFFSETS)                  
SIZAPCKT EQU      4                 WORDS PER ALLOCATION PACKET                 
PCKTNAME EQU      0       W & HW    NAME OF AREA                                
PCKTWP   EQU      1           HW    WRITE PROTECT                               
PCKTINIT EQU      1       W         INIT TYPE                                   
PCKTBOA  EQU      2       W         BEGIN SECTOR OF AREA                        
PCKTEOA  EQU      3       W         END SECTOR OF AREA                          
*                                                                               
*                           SPECIAL AREA NAME CODES                             
*                                                                               
PCKTSKIP EQU      X'FFFF'           'SKIP' PED AREA                             
PCKTAVAL EQU      X'0000'           UNALLOCATED SPACE                           
         PAGE                                                                   
         SPACE    2                                                             
*                           CONSTANTS USED BY 'INIT' AND 'ADD'                  
*                                                                               
KWVTOC   TEXT     'VTOC'            ID WORD FOR CP-R INITED DISCS               
KW:LBL   TEXT     ':LBL'            CP-V INIT'D DISC ID WORD                    
KWSKIP   TEXT     'SKIP'            FOR SKIPPED AREAS OF DISC                   
*                                                                               
INITCODS EQU      %-1                                                           
         TEXT     'OVR '      0     NO CLEARING                                 
         TEXT     'FAST'      1     ONLY CLEAR SECTOR 0 OF EACH AREA            
         TEXT     'ALL '      2     CLEAR ENTIRE AREA                           
         TEXT     ' XXX'      3     IMPOSSIBLE FOR NOW                          
#INICODS EQU      %-INITCODS-1      NUMBER OF CODES                             
*                                                                               
WPCODES  EQU      %-1        LIST OF LEGAL WRITE PROTECTION CODES               
         TEXT     'P   '      0     PUBLIC                                      
         TEXT     'B   '      1     BACKGROUND                                  
         TEXT     'F   '      2     FOREGROUND                                  
         TEXT     'S   '      3     SYSTEM                                      
         TEXT     ' ***'      4     IMPOSSIBLE                                  
         TEXT     'X   '      5     IOEX                                        
#WPCODES EQU      %-WPCODES-1       NUMBER OF LEGAL CODES                       
*                                                                               
*                                                                               
         BOUND    8                                                             
INITPURG TXT      'PURGE   '        FORCE 'INIT' OF DISC WITH NEW VSN           
         FIN                        #PRIV                                       
         PAGE                                                                   
******** ROUTINE ALLOT ********                                                 
*                                                                               
*        INPUT    DIRECTIVE PARAMETERS                                          
*                                                                               
*        OUTPUT   ENTRY IN PERMANENT FILE DIRECTORY                             
*                                                                               
*        FUNCTION CREATES A NEW FILE DIRECTORY ENTRY IN THE PERMANENT           
*                 DIRECTORY IN THE AREA SPECIFIED.  IT USES THE                 
*                 ALLOT CAL TO CREATE THE ENTRY                                 
*                                                                               
*        CALL     FROM ROOT1 (RS1000) VIA A SIMPLE BRANCH                       
*                                                                               
*        SUBROUTINES   SCAN, UNPKMASD, CHKAREA                                  
*                                                                               
*                                                                               
ALLOT    RES      0         'ALLOT'                                             
         LI,R0    ALLOT69           SET ERR FUNCTION ADDRESS                    
         STW,R0   ERRFCN                                                        
         LI,R0    0                 SET TO CLEAR OUT THE DIRE TABLE             
         LI,R1    -(DIREEND-DIRENAME)  TO NO PARRAMETERS GIVEN                  
         STW,R0   DIREEND,R1                                                    
         BIR,R1   %-1                                                           
*                                                                               
         MTW,-1   DIREESIZ          SET DIREESIZ TO NONE DIFFERENTLY            
         BAL,LINK SCAN              GET 'FILE' OPTION KEYWORD                   
         CI,R6    0                 WERE THERE ERRORS ?                         
         BL       ERROR02             YES, GIVE ERROR ITEM XX                   
*                                                                               
         LW,R9    ML24                                                          
         CS,R8    KWFILE            DID WE ACTUALLY GET 'FILE' ?                
         BNE      ERROR02             NO, GIVE ERROR ITEM XX                    
*                                                                               
         BAL,LINK GETFID            GET THE FILE ID                             
         CI,R6    0                 ANY ERRORS ?                                
         BLE      ERROR02             YES, REPORT AS ERROR ITEM XX              
*                                                                               
         BAL,RLNK CHKAREA           CHECK AREA, GET AREA INFO IF OK             
         B        ERROR04           NOT OK, GIVE AREA NOT A RADEDIT AREA        
*                                                                               
************************************                                            
*                                                                               
*                                                                               
ALLOT1   RES      0         PROCESS OPTIONS                                     
         CI,R6    2                 MORE OPTIONS TO FOLLOW ?                    
         BE       ALLOT10             NO, SET UP DEFAULTS AND DO CAL            
*                                                                               
         LI,R1    1                 SET SCAN TO SCAN IN EBCDIC                  
         STW,R1   SPARAMF1                                                      
         BAL,LINK SCAN              GET NEXT OPTION                             
         CI,R6    0                 ANY ERRORS ?                                
         BL       ERROR02             YES, REPORT IT                            
*                                                                               
         LI,R1    KEY%TOTL          SET NUMBER OF LEGAL OPTIONS                 
         LW,R9    ML24                                                          
*                                                                               
ALLOT2   RES      0         SCAN LIST OF OK OPTION KEYWORDS                     
         CS,R8    KEY%TABL,R1       IS THIS ONE ?                               
         BE       ALLOT3              YES, PROCESS IT                           
*                                                                               
         BDR,R1   ALLOT2                NO, LOOK ON                             
         B        ERROR02           NOT FOUND: GIVE ERROR                       
*                                                                               
ALLOT3   RES      0         LEGAL OPTION KEYWORD FOUND                          
         LI,R0    DIRERF            SET UP TO MARK 'RF' AS GIVEN                
         CI,R1    KEY%RF            IS IT THE 'RF' OR 'FIX' OPTIONS ?           
         BL       ALLOT4              NO, IT HAS A SUBOPTION TO SCAN            
*                                                                               
         BE       %+2               IS IT 'RF' ?                                
*                                                                               
         LI,R0    DIREFIX             NO, SET UP TO SET 'FIX'                   
*                                                                               
         CI,R6    0                 DOES A SUBFIELD FOLLOW ?                    
         BE       ERROR02             YES, THIS IS AN ERROR                     
*                                                                               
         LI,R1    1                 NO, SET 'RF' OR 'FIX' FLAG                  
         STW,R1   *R0               AS POINTED TO                               
         B        ALLOT1            TEST IF MORE OPTIONS TO PROCESS             
*                                                                               
*                                                                               
ALLOT4   RES      0         PROCESS OPTIONS WITH SUBOPTIONS                     
         CI,R6    0                 DO MORE FIELDS FOLLOW ?                     
         BNE      ERROR02             NO, GIVE ERROR                            
*                                                                               
         CI,R1    KEY%ORG           PROCESSING ORG/FORMAT OPTION ?              
         BL       ALLOT8              NO, PARAM WITH NUMERIC PARAM              
*                                                                               
         BAL,LINK SCAN              GET FORMAT CODE                             
         CI,R6    0                 ANY ERRORS FOUND ?                          
         BLE      ERROR02             YES, REPORT                               
*                                                                               
         LI,R2    #ORGS             SET LENGTH OF LIST TO SCAN                  
*                                                                               
ALLOT5   RES      0         VALIDATE ORG SPECIFICATION                          
         CW,R8    KWORGS,R2         IS IT OK ?                                  
         BE       ALLOT6              YES, SET ORG TYPE                         
         BDR,R2   ALLOT5              NO, SCAN MORE                             
         B        ERROR02           NOT FOUND: GIVE ERROR                       
*                                                                               
ALLOT6   RES      0         SET FILE'S ORG                                      
         AI,R2    -1                ADJUST TO ZERO RELATIVE                     
         STW,R2   DIREORG           SET ORG IN DIRE TABLE                       
         DO       #CFILES=0         IF COMPRESSED NOT ALLOWED                   
          CI,R2    ORGCOMP           IS IT COMPRESSED ?                         
          BE       ERROR02             YES, GIVE ERROR                          
         FIN                                                                    
         B        ALLOT1            GO GET ANOTHER OPTION IF NAY                
*                                                                               
ALLOT8   RES      0         PROCESS FSIZE, RSIZE, GSIZE, ESIZE                  
         LI,R0    4                 SET SCAN TO GET DECIMAL VALUES              
         STW,R0   SPARAMF1                                                      
         BAL,LINK SCAN              GET THE SIZE                                
         CI,R6    0                 ERROR OR NOT END OF OPTION ?                
         BLE      ERROR02             YES, GIVE ERROR ITEM XX                   
*                                                                               
         EXU      KEY%STOR,R1       STORE SIZE IN CORRECT ENTRY                 
         B        ALLOT1            TEST IF MORE OPTIONSR                       
*                                                                               
*                                                                               
************************************                                            
*                                                                               
*                                                                               
ALLOT10  RES      0         VALIDATE PARAMETERS CONSISTENCY                     
         LW,R0    AREA              GET AREA INDEX                              
         MTW,+00  DIRERF            IS PROGRAM TO BE RES FGD ?                  
         BEZ      ALLOT11             NO, ANY AREA OK                           
*                                                                               
         CI,R0    FPINDEX           IS THE AREA 'FP' ?                          
         BNE      ERROR09             NO, ERROR: RES FGD MUST BE IN FP          
*                                                                               
ALLOT11  RES      0         CHECK FOR LIBRARY FILE ALLOTS                       
         CI,R0    FPINDEX           IS IT A LIBRARY AREA                        
         BG       ALLOT20             NO, GO CHECK SIZES                        
*                                                                               
         LD,R8    FILENAME          TEST IF IT IS A LIBRARY FILE                
         LI,R2    4                                                             
*                                                                               
ALLOT12  RES      0         SCAN LIST OF LIB FILES FOR THE NAME                 
         CD,R8    MODULE-2,R2       IS IT THIS ONE ?                            
         BE       ALLOT13             YES                                       
         BDR,R2   ALLOT12           NO, TEST ANOTHER                            
         B        ALLOT20           NO A LIB FILE; CONTINUE ON                  
*                                                                               
ALLOT13  RES      0         ALLOCATING A LIB FILE: CHECK ORG, RSIZE, ETC        
         LI,R0    ORGUNB            GET USUAL LIB ORG                           
         CI,R2    1                 ALLOCATING MODULE FILE ?                    
         BNE      ALLOT14             NO, SET ORG                               
*                                                                               
         LI,R1    LIBRSIZ           FORCE RSIZE TO 120 FOR MODULE               
         STW,R1   DIRERSIZ          IN CASE USER DID NOT                        
         LI,R0    ORGBLK            AND ALSO FORCE ORG TO BLOCKED               
*                                                                               
ALLOT14  RES      0         SET FORCED ORG, GSIZE                               
         STW,R0   DIREORG           SET ORG APPROPRIATELY FOR FILE              
         LI,R0    0                 SET GSIZE TO ZERO SO IT WILL DEFAULT        
         STW,R0   DIREGSIZ                                                      
*                                                                               
*                                                                               
ALLOT20  RES      0         CHECK PARAMS GIVEN FOR OK SIZES                     
         LW,R0    DIREGSIZ          GET GRANULE SIZE                            
         CI,R0    X'3FFF'           GREATER THAN MAX PROCESSABLE ?              
         BG       ALLOT51             YES, GIVE ERROR AND ABORT ALLOT           
*                                                                               
         LW,R1    DIRERSIZ          R1 <= RSIZE; R0 <= GSIZE                    
         LW,R2    DIREORG           R2 <= ORG                                   
         B        ALLOT22,R2        CHECK RSIZE ACCORDING TO ORG                
*                                                                               
ALLOT22  B        ALLOT27     UNB                                               
         B        ALLOT24     BLK                                               
         B        ALLOT27     COMP                                              
*                                                                               
*                                                                               
ALLOT24  RES      0         BLOCKED ORG: CHECK TOO BIG                          
         CI,R1    MAXRSIZB          IS IT TOO BIG FOR BLOCKED ORG ?             
         BLE      ALLOT30             NO, OK                                    
*                                                                               
         LI,R15   MESS3             NO, OUT WARNING MESSAGE                     
         BAL,LINK TYPRNT            SAYING ORG CHANGED TO UNB                   
         LI,R2    ORGUNB            THEN CHANGE THE ORG TO THAT                 
         STW,R2   DIREORG                                                       
         B        ALLOT30           THEN CONTINUE                               
*                                                                               
*                                                                               
ALLOT27  RES      0         UNBLOCKED OR COMPRESSED: NO CHECKS NEEDED           
*                                                                               
*                                                                               
ALLOT30  RES      0         BUILD THE FPT FOR THE CAL                           
         LD,R0    FILENAME          MOVE FILE NAME TO FPT                       
         LCI      2                                                             
         STM,R0   ALLOTFPT+4        INTO WORDS 5 AND 6                          
         LW,R0    MASDNAME          MOVE AREA NAME                              
         STW,R0   ALLOTFPT+0        AS NAME AND AREA ARE HARD CODED             
         LI,R0    ALOTCODE          SET 'ALLOT' CODE, P0 BIT                    
         STH,R0   ALLOTFPT+0                                                    
         LCI      2                 GET MOVEABLE FPT WORDS IN REGS              
         LM,R9    ALOTGSIZ          AND PUT THEM IN FPT WHERE THEY GO           
         STM,R9   ALLFPTGS          IF ESIZE IS ABSENT                          
         LI,R0    0                 ASSUME NO ESIZE OR RF IN P-BITS             
         MTW,+0   DIRERF            IS FILE RES FGD ?                           
         BEZ      ALLOT31             NO, DO NOT SET FLAG                       
*                                                                               
         LI,R0    RFFLAG            SET RES FGD FLAG IN P-BIT WORD              
*                                                                               
ALLOT31  RES      0         CHECK ESIZE                                         
         MTW,+0   DIREESIZ          WAS 'ESIZE' GIVEN ?                         
         BLZ      ALLOT32             NO, DO NOT PUT IN FPT                     
*                                                                               
         LW,R8    ALOTESIZ          IT WAS; ADD ITS PARAM TO FPT                
         LCI      3                 RESTORE GSIZE, ACNTNAME                     
         STM,R8   ALLFPTGS          FPT WORDS MOVED DOWN ONE WORD               
         OR,R0    FPTBIT07          AND SET ESIZE P-BIT                         
         MTW,+0   DIREFIX           IS 'FIX' REQUESTED ?                        
         BEZ      ALLOT32             NO, DO NOT SET                            
*                                                                               
         OR,R0    FPTBITF5          YES, SET 'FIX' BIT IN FPT                   
*                                                                               
ALLOT32  RES      0         PROCESS ACCOUNT NAME IF GIVEN                       
         OR,R0    GIOCT             SET FILE ID P-BITS AS SCANNED               
*                                                                               
ALLOT33  RES      0         FINISH FPT FORMATION, ISSUE CAL                     
         OR,R0    ALOTPWRD          ADD IN BITS ALWAYS PRESENT                  
         STW,R0   ALLOTFPT+1        AND SET                                     
         CAL1,7   ALLOTFPT          SYSTEM!! ALLOT THAT FILE !                  
         B        EXEC1             DONE: GO GET NEXT COMMAND                   
         PAGE                                                                   
         SPACE    2                                                             
ALLOT51  RES      0         ERROR IN GSIZE VALUE                                
         LW,R8    GSIZ              GET INSERT VALUE                            
         B        ERROR05           GO FORM MESSAGE AND OUT IT                  
*                                                                               
ALLOT52  RES      0         ERROR IN RSIZE VALUE                                
         LW,R8    RSIZ              GET INSERT VALUE                            
         B        ERROR05           GO FORM MESSAGE AND OUT IT                  
*                                                                               
ALLOT53  RES      0         ERROR IN FORMAT                                     
         LW,R8    FORMAT            GET INSERT VALUE                            
         B        ERROR05           GO FORM MESSAGE AND OUT IT                  
*                                                                               
*                                                                               
         SPACE    2                                                             
ALLOT69  ERRP     X'4A',ALLOT52     BYTE COUNT INVALID: GIVE GSIZ ERROR         
         ERRP     X'70',ERROR04     BAD AREA: GIVE AREA NOT ALLOCATED           
         ERRP     X'71',ERROR07     ILLEGAL FILENAME: DUP FILE IN ALLOT         
         ERRP     X'72',ERROR01     NO SPACE: OUT DISK OVERFLOW                 
         ERRP     X'77',ALLOT53     ILLEGAL FORMAT: ERROR IN FORMAT             
         ERRP     X'FF',0           GO TO ROOT1 FOR ALL OTHER ERRORS            
         PAGE                                                                   
******** ROUTINE DUMP ********                                                  
*                                                                               
*        INPUT    DIRECTIVE PARAMETERS                                          
*                                                                               
*        OUTPUT   DUMP TO LO DEVICE                                             
*                                                                               
*        FUNCTION DUMPS THE SPECIFIED RANDOM OR SEQUENTIAL ACCESS FILES         
*                 ONTO THE LO DEVICE                                            
*                                                                               
*        CALL     B  DUMP                                                       
*                                                                               
*        SUBROUTINES USED                                                       
*                                                                               
DUMP     RES      0                                                             
         LI,R0    DUMPERF           SET ERR FUNCTION TABLE FOR US               
         STW,R0   ERRFCN                                                        
         LW,R0    BPEND             USEBACKGRND AS BUFFER                       
         STW,R0   BIBUFF                                                        
         LI,R3    0                                                             
         STW,R3   DAFLG             IF DA FLG=1 DUMP AREA  =0 DUMP FILE         
         STW,R3   SRECVAL                                                       
         LI,R3    X'7FFFF'          SET LAST TO DUMP = MAX                      
         STW,R3   ERECVAL                                                       
         LW,R3    BCKSZE            SCRATCH SPACE SIZE IN BYTES                 
         SLS,R3   17                ALIGN FOR DCB INSERTION                     
         STS,R3   F:BI+3                                                        
*                                                                               
         BAL,LINK SCAN              DETERMINE IF FILE OR AREA TO DUMP           
         CI,R6    -1                                                            
         BNE      DUMP1             NO ERRORS; TEST FOR 'FILE' KEYWORD          
*                                                                               
         CI,R10   C'.'              ERROR; CAUSED BY '.' BEFORE AREA ?          
         BNE      ERROR02             NO, GIVE 'ERROR ITEM XX'                  
*                                                                               
         BAL,LINK SCAN              SCAN THE AREA NAME                          
         CI,R6    -1                AND ERRORS ?                                
         BLE      ERROR02             YES, REPORT 'ERROR ITEM XX'               
         B        DUMP2             NO, VALIDATE THE AREA                       
*                                                                               
DUMP1    RES      0         TEST FOR 'FILE' KEYWORD OR AREA NAME                
         LI,R9    X'FFF00'                                                      
         CS,R8    KWFILE                                                        
         BE       DUMP3                                                         
*                                                                               
DUMP2    RES      0         VALIDATE AREA NAME FOR AREA DUMP                    
         BAL,RLNK GETAX             GET AREA'S INDEX AND DEVICE INFO            
         B        ERROR02             ERROR OF SOME SORT: ERROR 02              
         SCS,R8   16                RIGHT JUSTIFY NAME                          
         STW,R8   AREANAME          SET NAME OF AREA                            
         LD,R8    ZEROS             SET TO USE WHOLE AREA                       
         STD,R8   FILENAME                                                      
         LW,R8    GIOFBIT           SET ONLY AREA.FILENAME GIVEN                
         STW,R8   GIOCT                                                         
         MTW,+1   DAFLG             SET PROCESSING AN AREA                      
         BAL,RLNK UNPKMASD          GET INFO ABOUT DEVICE                       
         B        ERROR04           SHOULDN'T HAPPEN, BUT IF IT DOES...         
         B        DUMP4             GET AREA INFO AND DO DUMP                   
*                                                                               
DUMP3    RES      0         PROCESS A FILE                                      
         CI,R6    0                 DOES MORE INFO FOLLOW 'FILE' ?              
         BNE      ERROR02             NO, IT SHOULD: ERROR 02                   
*                                                                               
         BAL,LINK GETFID            GET THE FILE ID                             
         CI,R6    0                 ERROR FOUND OR NOT END OF FIELD ?           
         BLE      ERROR02             YES: REPORT IT                            
         LW,R8    AREANAME          MOVE AREA NAME TO MASD TABLES;              
         STW,R8   MASDNAME          THEN LEFT-JUSTIFY TO FORM                   
         SLS,R8   16                OF A JUST SCANNED NAME                      
         BAL,RLNK GETAX             VERIFY AREA NAME, GET ITS INDEX             
         B        ERROR02             ILLEGAL AREA; GIVE ERROR 02               
         CLM,R1   CKXA              IS AREA MAINTAINED BY RADEDIT ?             
         BCR,6    ERROR02             NO, GIVE AN ERROR                         
*                                                                               
DUMP4    RES      0         GET INFO ON THE AREA TO PROCESS                     
         CI,R6    2                 CHECK FOR (SREC,VALUE)  (EREC,VALUE)        
         BE       DUMP20                                                        
DUMP5    RES      0                                                             
         LI,R1    1                 GET (SREC,VALUE) AND (EREC,VALUE)           
         STW,R1   SPARAMF1                                                      
         BAL,LINK SCAN                                                          
         CI,R6    0                                                             
         BNE      DUMP85                                                        
         LI,R2    0                                                             
         LI,R9    X'FFF00'                                                      
         CS,R8    KWSREC                                                        
         BE       DUMP10                                                        
         AI,R2    1                 IF R2=0 SAVE SREC VALUE                     
         CS,R8    KWEREC            IF R2=1 SAVE EREC VALUE                     
         BNE      DUMP85                                                        
DUMP10   RES      0                                                             
         LI,R1    4                                                             
         STW,R1   SPARAMF1          GET VALUE                                   
         BAL,LINK SCAN                                                          
         CI,R6    0                                                             
         BLEZ     DUMP85                                                        
         CI,R2    0                                                             
         BNE      DUMP15                                                        
         STW,R8   SRECVAL                                                       
         B        DUMP17                                                        
DUMP15   RES      0                                                             
         STW,R8   ERECVAL                                                       
DUMP17   RES      0                                                             
         CI,R6    1                 ANY MORE FIELDS TO PROCESS                  
         BE       DUMP5                                                         
DUMP20   RES      0                                                             
         LW,R8    GIOCT             SET FILENAME AND OPTIONAL ACCOUNT           
         LW,R9    GIOFA             NAME, IF A FILE WAS SPECIFIED,              
         STS,R8   ASNFILE+1         IN THE FPT TO                               
         LI,R2    F:BI              ASSIGN FILE OR AREA AS REQUESTED            
         CAL1,1   ASNFILE           TO INPUT DCB                                
         MTW,00   DAFLG             IS DUMP OF AND AREA?                        
         BEZ      DUMP40              NO, A FILE; OUT FILE HEADER               
*                                                                               
         LI,R2    DAHDR             POINT AT HEADER FOR AREAS                   
*                                                                               
DUMP23   EQU      %         ENTER AREA INFO INTO HEADER                         
         STRNG                      (ADDR OF STRING IN R2)                      
         CHARS    2,MASDNAME,2      PUT AREA NAME INTO PRINT LINE               
         PRTPAG                     PRINT LINE ON TOP OF A NEW PAGE             
*                                                                               
         LI,R2    F:BI              POINT AT DCB TO USE FOR FILE                
         CAL1,1   OPENANY           AND OPEN INPUT FILE                         
*                                                                               
         LW,R9    SRECVAL           IF SREC=0 DO NOT SKIP                       
         BEZ      DUMP25                                                        
         LW,R3    R9                                                            
         MTW,0    DAFLG                                    /SIG7-2974/*C015734  
         BNEZ     DUMP24                                   /SIG7-2974/*C015734  
         CAL1,1   REWIND            INSURE SKIP STARTS FROM BEGINNING           
         AI,R3    -1                                                            
         BEZ      DUMP25                                                        
DUMP24   STW,R3   SKIPRCD1                                 /SIG7-2974/*C015734  
         CAL1,1   SKIPRCD           SKIP RECORDS                                
DUMP25   RES      0                                                             
         LW,R3    ERECVAL           IF SREC=0 SET=TO LAST SECTOR IN AREA        
DUMP30   RES      0                                                             
         CW,R3    R9                CHECK IF SREC>EREC                          
         BGE      DUMP35                                                        
         CAL1,1   CLFLEIN                                                       
         LI,R15   MESS13            ERROR                                       
         B        DUMP90                                                        
DUMP35   RES      0                                                             
         LW,R10   DAFLG             SET DUMP MODE = RECS, AREA                  
         B        DCDMP             DUMP SPECIFIED RECORDS                      
*           WILL RETURN TO EXEC1                                                
*                                                                               
*                                                                               
DUMP40   EQU      %         ENTER PAGE HEADER FOR A FILE DUMP                   
         STRNG    DFHDR             ENTER 'DUMP OF FILE '                       
         CHARS    8,FILENAME,0      THEN THE FILE'S NAME                        
         LI,R2    DFHDRE            POINT AT REST OF FILE DUMP HEADER           
         MTW,00   SRECVAL           WAS A START RECORD GIVEN ?                  
         BNEZ     DUMP23              YES, START THERE                          
*                                                                               
         MTW,+1   SRECVAL           NO, SET TO START AT RECORD 1                
         B        DUMP23            ENTER REST OF HEADER; DO DUMP               
*                                                                               
*                                                                               
*                                                                               
*                                                                               
DUMP85   EQU      ERROR02                                                       
DUMP90   EQU      ERROROUT                                                      
*                                                                               
*                                                                               
*                                                                               
*                                                                               
DUMPERF  ERRP     X'05',DCDMP30     EOD: CLEAN UP DUP LINES STUFF               
         ERRP     X'06',DCDMP40     EOF: SAY DUMP COMPLETE                      
         ERRP     X'1C',DCDMP30     EOT: CLEAN UP DUP LINES AND STOP            
         ERRP     X'FF',0           FOR OTHER ERRORS GO TO EXEC'S FCNS          
         TITLE    '**** SBR TO DUMP DISC ON LO ****'                            
*                                                                               
*                                   CALL IS  BAL,LINK DCDMP                     
*                                     WHERE                                     
*                                   SRECVAL = 1ST SECTOR OR RECORD              
*                                   ERECVAL = LAST SECTOR OR RECORD             
*                                                         TO DUMP               
*                                       R10=0, DUMP IN RECORD FORMAT            
*                                          =NONZERO, DUMP IN SECT. FMT.         
*                                   USES R0, R5-R11                             
*                                                                               
DCDMP    RES      0                                                             
         LW,R0    SRECVAL           MOVE BEGIN AND END RECORD NUMBERS           
         STW,R0   DCDMP97                                                       
         LW,R0    ERECVAL                                                       
         STW,R0   DCDMP96           LAST TO DO                                  
         STW,R10  DCDMP98           SAVE R10                                    
         LI,R0    0                                                             
         STW,R0   DCDMP94A          HOUSEKEEP                                   
         STW,R0   DCDMP92                                                       
         MTW,-1   DCDMP97           REDUCE BECAUSE GETS STEPPED                 
DCDMP2   MTW,1    DCDMP97           STEP TO NEXT SECTOR/RECORD                  
         LW,R11   DCDMP97                                                       
         BAL,LINK BINBCD            CHANGE SECTOR NO. TO BCD                    
         LI,R6    R10*4             GET BA OF R10                               
         LI,R9    5                                                             
         LW,R0    DCDMP98                                                       
         BEZ      %+3                                                           
         LI,R7    BA(DCDMP82)+8                                                 
         B        %+2                                                           
         LI,R7    BA(DCDMP83)+8     STORE SECT. NO. IN PROPER IMAGE             
         BAL,LINK MOVBYTE                                                       
DCDMP5   LW,R0    DCDMP97                                                       
         CW,R0    DCDMP96           HAVE WE READ LAST SECTOR                    
         BG       DCDMP9            YES                                         
         LI,R0    0                 NO                                          
         STW,R0   DCDMP95           RESET WORD COUNT                            
         CAL1,1   RDDISCS           GO READ NEXT SECT./REC. FORM RAD            
DCDMP6   LW,R0    F:BI+4            GET NO. BYTES READ                          
         CI,R0    X'60000'                                                      
         BAZ      %+2                                                           
         AW,R0    X80000            INCR BYTE COUNT BY ONE WORD                 
         SLS,R0   -19               CHANGE TO WORDS                             
         STW,R0   DCDMP93           SAVE NO. WORDS IN SECT./REC.                
         LI,R5    0                                                             
DCDMP7   LW,R0    DCDMP94A          IS THERE A LAST VALUE TO COMPARE            
         BNEZ     DCDMP8            YES                                         
         LW,R0    *BIBUFF,R5                                                    
         STW,R0   DCDMP94           TAKE FIRST WORD AS COMPARE VALUE            
         MTW,1    DCDMP94A          SET FLAG THAT VALUE EXISTS                  
DCDMP8   LW,R0    *BIBUFF,R5                                                    
         CW,R0    DCDMP94           SEARCH FOR FIRST WORD UNLIKE OTHERS         
         BNE      DCDMP9            FOUND ONE                                   
         AI,R5    1                 STEP INDEX                                  
         CW,R5    DCDMP93                                                       
         BNE      DCDMP8            NOT END OF BUFFER                           
         LW,R0    DCDMP95           WAS WHOLE BUFFER THE SAME                   
         BNEZ     DCDMP17           NO                                          
         MTW,1    DCDMP97           YES, STEP SECT1REC COUNT                    
         MTW,1    DCDMP92           SET FLAG TO PRINT 'SECT X-Y' LINE           
         B        DCDMP5                                                        
DCDMP9   MTW,-1   DCDMP94A          RESET FLAG THAT NEED NEW VALUE              
         LW,R0    DCDMP92           SHOULD 'SECT X-Y' LINE BE OUTPUT            
         BEZ      DCDMP13           NO                                          
         LW,R11   DCDMP97           YES                                         
         AI,R11   -1                GET LAST DUPLICATE SEC/REC NO.              
         BAL,LINK BINBCD            GHANGE TO BCD                               
         LI,R6    R10*4             GET BA OF R10                               
         LI,R9    5                                                             
         LW,R0    DCDMP98                                                       
         BEZ      %+3                                                           
         LI,R7    BA(DCDMP82)+19    SECTOR FORMAT                               
         B        %+2                                                           
         LI,R7    BA(DCDMP83)+19    RECORD FORMAT                               
         BAL,LINK MOVBYTE           STORE FINAL SEC/REC                         
         LW,R11   DCDMP94           GET DUPLICATED VALUE                        
         BAL,LINK HEXBCD                                                        
         LI,R6    R10*4             GET BA OF R10                               
         LI,R9    8                                                             
         LW,R0    DCDMP98                                                       
         BEZ      DCDMP11                                                       
         LI,R7    BA(DCDMP82)+33    SECTOR FORMAT                               
         LI,R0    DCDMP82                                                       
         B        DCDMP12                                                       
DCDMP11  LI,R7    BA(DCDMP83)+33    RECORD FORMAT                               
         LI,R0    DCDMP83                                                       
DCDMP12  STW,R0   WRITELO+4         STORE BUFFER ADD. IN FPT                    
         BAL,LINK MOVBYTE           STORE DUP. VALUE IN IMAGE                   
         LI,R0    41                BYTE COUNT                                  
         STW,R0   WRITELO+5                                                     
         CAL1,1   WRITELO           GO PRINT 'SEC X-Y' LINE                     
         LI,R0    0                                                             
         STW,R0   DCDMP92           CLEAR FLAG TO PRINT THIS LINE               
DCDMP13  LW,R0    DCDMP97                                                       
         CW,R0    DCDMP96           ARE WE DONE                                 
         BG       DCDMP40           YES                                         
         LW,R0    DCDMP95           DO WE NEED SEC XXXX LINE                    
         BNEZ     DCDMP17           NO                                          
         LW,R11   DCDMP97           YES                                         
         BAL,LINK BINBCD            CHANGE SEC/REC NO. TO BCD                   
         LI,R6    R10*4             GET BA OF R10                               
         LI,R9    5                                                             
         LW,R0    DCDMP98                                                       
         BEZ      DCDMP15                                                       
         LI,R7    BA(DCDMP80)+8                                                 
         LI,R0    DCDMP80           SECTOR FORMAT                               
         B        DCDMP16                                                       
DCDMP15  LI,R7    BA(DCDMP81)+8                                                 
         LI,R0    DCDMP81                                                       
DCDMP16  STW,R0   WRITELO+4         BUFFER ADDRESS TO FPT                       
         BAL,LINK MOVBYTE           STORE SEC/REC NO. IN IMAGE                  
         LI,R0    13                BYTE COUNT                                  
         STW,R0   WRITELO+5                                                     
         CAL1,1   WRITELO           GO PRINT SEC XXXX LINE                      
DCDMP17  LW,R0    R5                                                            
         SW,R0    DCDMP95                                                       
         CI,R0    16                WAS 16 WORDS IN A ROW THE SAME              
         BL       DCDMP23           NO                                          
         CW,R5    DCDMP93           YES, IS THIS END OF BUFFER                  
         BE       %+2               YES                                         
         AND,R5   KM8               NO, KNOCK BACK TO MODULO 8                  
         AI,R5    -1                SET TO LAST DUP. VALUE                      
         LW,R11   DCDMP95           GET INITIAL WORD COUNT                      
         BAL,LINK BINBCD                                                        
         LI,R6    (R10*4)+1         GET BA OF FIRST CHAR.                       
         LI,R7    BA(DCDMP85)+30                                                
         LI,R9    4                                                             
         BAL,LINK MOVBYTE           STORE INITIAL WORD NO. IN IMAGE             
         LW,R11   R5                                                            
         BAL,LINK BINBCD            CHANGE LAST WORD NO. TO BCD                 
         LI,R9    4                                                             
         LI,R6    (R10*4)+1         GET BA OF FIRST CHAR.                       
         LI,R7    BA(DCDMP85)+40                                                
         BAL,LINK MOVBYTE           STORE LAST WORD NO. IN IMAGE                
         LW,R11   DCDMP94           GET DUPLICATED VALUE                        
         BAL,LINK HEXBCD                                                        
         LI,R6    R10*4             GET BA OF R10                               
         LI,R7    BA(DCDMP85)+53                                                
         LI,R9    8                                                             
         BAL,LINK MOVBYTE           STORE DUP. VALUE IN IMAGE                   
         LI,R0    DCDMP85                                                       
         STW,R0   WRITELO+4                                                     
         LI,R0    68                                                            
         STW,R0   WRITELO+5                                                     
         CAL1,1   WRITELO           GO PRINT 'WS X-Y' LINE                      
         AI,R5    1                 STEP TO FIRST WORD OF NEXT LINE             
DCDMP20  STW,R5   DCDMP95           SAVE NEXT INITIAL WORD NO.                  
         CW,R5    DCDMP93           END OF BUFFER                               
         BGE      DCDMP2            YES, GO READ NEXT SEC/REC                   
         B        DCDMP7            NO                                          
DCDMP23  LW,R5    DCDMP95           RESET TO INITIAL WORD NO.                   
         LW,R11   R5                                                            
         BAL,LINK BINBCD            CHANGE WORD NO. TO BCD                      
         LI,R6    (R10*4)+1         GET BA OF FIRST CHAR.                       
         LI,R7    BA(DCDMP84)+3                                                 
         LI,R9    4                                                             
         BAL,LINK MOVBYTE           STORE WORD NO. IN IMAGE                     
         LW,R0    DCDMP93           GET LWA                                     
         SW,R0    R5                IS THERE LESS THAN 8 WORDS LEFT             
         CI,R0    8                                                             
         BL       %+2               YES, USE REMAINDER ONLY                     
         LI,R0    8                                                             
         STW,R0   DCDMP91           SET FOR 8 VALUES                            
         LI,R9    BA(DCDMP84)+8     BA OF FIRST VALUE                           
DCDMP25  LW,R11   *BIBUFF,R5                                                    
         BAL,LINK HEXBCD            CHANGE VALUE TO BCD                         
         LI,R6    R10*4             GET BA OF R10                               
         LW,R7    R9                                                            
         LI,R9    8                                                             
         BAL,LINK MOVBYTE           STORE VALUES IN IMAGE                       
         AI,R7    2                 STEP TO NEXT BFA                            
         STW,R7   R9                                                            
         AI,R5    1                                                             
         MTW,-1   DCDMP91           DONE                                        
         BNEZ     DCDMP25           (3                                          
         LI,R0    DCDMP84                                                       
         STW,R0   WRITELO+4                                                     
         LI,R0    86                                                            
         STW,R0   WRITELO+5                                                     
         CAL1,1   WRITELO           GO PRINT NORMAL LINE 'WDXXX XX...'          
         LI,R7    20                                                            
         LW,R0    BLNK              BLANK OUT BUFFER                            
         STW,R0   DCDMP84+1,R7                                                  
         BDR,R7   %-1                                                           
         B        DCDMP20                                                       
*                                                                               
*                                   ENTER HERE UPON EOD OR EOT                  
DCDMP30  LI,R0    0                                                             
         STW,R0   DCDMP96           SET LWA T/ ZERO                             
         B        DCDMP9                                                        
DCDMP40  LI,R0    DCDMP86           PRINT 'DUMP COMPLETE'                       
         STW,R0   WRITELO+4                                                     
         LI,R0    16                                                            
         STW,R0   WRITELO+5                                                     
         CAL1,1   WRITELO                                                       
         CAL1,1   CLFLEIN           CLOSE THE FILE                              
         B        EXEC1             RETURN FOR NEXT COMMAND                     
*                                                                               
*                                   PRINT IMAGES                                
*                                                                               
DCDMP86  TEXT     'ADUMP COMPLETE. '                                            
*                                                                               
*%*  FOLLOWING ARE IN ROOT-CONTEXT                                              
*%*DCDMP80 TEXT   'ASECTOR XXXXX'   BYTE 1=DOUBLE SPACE                         
*%*DCDMP81 TEXT   'ARECORD XXXXX'                                               
*%*DCDMP82 TEXT   'ASECTOR XXXXX THRU YYYYY CONTAIN ZZZZZZZZ'                   
*%*DCDMP83 TEXT   'ARECORD XXXXX THRU YYYYY CONTAIN ZZZZZZZZ'                   
*%*DCDMP84 DATA,1 X'C0','W','D','X' BYTE 1=SINGLE SPACE                         
*%*      TEXT     'XX                                    '                      
*%*      TEXT     '                                          '                  
*%*DCDMP85 DATA,2 X'C040','  '      BYTE 1=SINGLE SPACE                         
*%*      TEXT     '                  **** WD XXXX THRU YYYY'                    
*%*      TEXT     ' CONTAIN ZZZZZZZZ ****'                                      
*%*                                                                             
*%*DCDMP91 DATA   0                 TEMP STORAGE                                
*%*DCDMP92 DATA   0                 FLAG TO PRINT 'SEC X-Y' LINE                
*%*DCDMP93 DATA   0                 WORDS PER SECT. OR REC.                     
*%*DCDMP94 DATA   0                 DUPLICATED VALUE                            
*%*DCDMP94A DATA  0                 FLAG THAT NEED NEW DUP. VALUE               
*%*DCDMP95 DATA   0                 WORD COUNT                                  
*%*DCDMP96 DATA   0                 LWA OF SEC/REC                              
*%*DCDMP97 DATA   0                 FWA OF SECT/REC                             
*%*DCDMP98 DATA   0                 R10                                         
         TITLE    '**** SBR TO MOVE BYTE STRING ****'                           
*                                                                               
*                                   CALL IS BAL,LINK MOVBYTE                    
*                                     WHERE                                     
*                                      R6=BA TO MOVE FROM                       
*                                      R7=BA TO STORE INTO                      
*                                      R9=NO. BYTES TO MOVE                     
*                                   USES R0, R6-R9                              
*                                                                               
MOVBYTE  LB,R0    0,R6                                                          
         STB,R0   0,R7              MOVE BYTES                                  
         AI,R6    1                                                             
         AI,R7    1                                                             
         BDR,R9   MOVBYTE                                                       
         B        *LINK                                                         
*                                                                               
*                                   CALL IS  BAL,LINK BINBCD                    
*                                    WHERE                                      
*                                     R11= VALUE TO BE CONVERTED                
*                                   EXITS                                       
*                                     R6,R7=VALUE IN BCD                        
*                                   USES R6,R7,R10,R11                          
*                                                                               
BINBCD   RES      0                                                             
         PUSH     LINK              SAVE RETURN                                 
         LI,R8    5                 FIVE CHARACTERS                             
         LI,R7    R7*4              BA OF R7                                    
BINBCD1  LI,R10   0                                                             
         DW,R10   K10               CHANGE TO BCD                               
         AI,R10   X'F0'                                                         
         STB,R10  0,R7                                                          
         AI,R7    -1                NEXT HIGHER ORDER DIGIT                     
         BDR,R8   BINBCD1                                                       
         STD,R6   R10                                                           
         PULL     LINK                                                          
         B        *LINK                                                         
         PAGE                                                                   
******** SUBROUTINE HEXBCD ********                                             
*                                   CALL IS BAL,LINK HEXBCD                     
*                                     WHERE R11= VALUE TO CONVERT               
*                                   EXITS R10,R11= VALUE IN BCD                 
*                                                                               
HEXBCD   RES      0                 CONVERT HEX TO BCD                          
         PUSH     4,R5              SAVE R5-R8                                  
         LI,R7    -28               SHIFT INDEX                                 
         LI,R6    0                                                             
         LW,R8    R11                                                           
HEXBCD1  LW,R5    R8                                                            
         SLS,R5   0,R7              GET NEXT CHAR                               
         AND,R5   M4                                                            
         AI,R5    X'F0'                                                         
         CI,R5    X'FA'             CHANGE TO BCD                               
         BL       %+2                                                           
         AI,R5    -X'39'                                                        
         STB,R5   R10,R6            STORE IT                                    
         AI,R6    1                                                             
         AI,R7    4                                                             
         BLEZ     HEXBCD1           NOT DONE YET                                
         PULL     4,R5              RESTORE R5-R8                               
         B        *LINK                                                         
         TITLE    '*****  TRUNCATE PROCESSOR  *****'                            
         SPACE    2                                                             
******** ROUTINE TRUNCATE ********                                              
*                                                                               
*        INPUT    DIRECTIVE PARAMETERS                                          
*                                                                               
*        OUTPUT   TRUNCATED ENTRY(S) IN PERMANENT FILE DIRECTORY                
*                                                                               
*        FUNCTION TRUNCATES EMPTY SPACE FROM THE END OF SPECIFIED FILES,        
*                 SETTING THE DIRECTORY ENTRY EQUAL TO THE ACTUAL               
*                 INSTEAD OF THE ESTIMATED FILE LENGTH.                         
*                                                                               
*        CALL     B  TRUNCATE                                                   
*                                                                               
*        CALLS    SCAN,UNPKMASD,GET1SFIL,GETNXFIL,UNPKDIRE,GETAX                
*        USES     TRUNCATE CAL TO DO THE ACTUAL TRUNCATION                      
*                                                                               
TRUNCATE RES      0         TRUNCATE FILES OR AREAS OR BOTH                     
         LI,R0    TRUNCODE          SET FPT TO TRUNCATE                         
         STH,R0   DELTRUNC                                                      
         LI,R0    TRUNC69           SET ADDRESS OF ERROR FUNCTION TABLE         
         STW,R0   ERRFCN                                                        
*                                                                               
TRUNC1   RES      0         PROCESS PARAMETERS                                  
         BAL,LINK SCAN              GET KEYWORD OR AREA NAME                    
         CI,R6    -1                ERROR FOUND ?                               
         BLE      TRUNC11             YES, TEST FOR AREA PREFIX '.'             
*                                                                               
         LW,R9    ML24                                                          
         CS,R8    KWFILE            IS IT KEYWORD 'FILE' ?                      
         BNE      TRUNC12             NO, ASSUME AN AREA NAME                   
*                                                                               
         CI,R6    0                 YES, MORE PARAMS FOLLOWING ?                
         BNE      ERROR02             NO, GIVE 'ERROR ITEM XX'                  
*                                                                               
         BAL,LINK GETFID            GET FILE ID NAME                            
         CI,R6    -1                ERRORS FOUND SCANNING 'FID' ?               
         BLE      ERROR02             YES, GIVE 'ERROR ITEM XX'                 
*                                                                               
         BAL,RLNK CHKAREA           VALIDATE AREA NAME, GET INFO                
         B        ERROR04           NOT ALLOCATED - GIVE THAT ERROR             
*                                                                               
TRUNC5   RES      0         PROCESS A FILE NAME                                 
         LCI      2                 STORE NAME IN FPT                           
         LM,R8    FILENAME                                                      
         CD,R8    BLNK                                                          
         BE       ERROR02           B IF NAME IS OMITTED                        
         LCI      2                                                             
         STM,R8   DELTRUNC+3        STORE NAME IN FPT                           
         STM,R8   DIRENAME          AND IN STND SPOT IN CASE OF ERRORS          
         LW,R8    GIOCT             PUT THE ACCOUNT NAME'S P14 BIT IN           
         LI,R9    P14               FPT IF A NAME WAS GIVEN                     
         STS,R8   DELTRUNC+1                                                    
         CAL1,7   DELTRUNC          TRUNCATE THE FILE                           
         CI,R6    1                 WHAT FOLLOWS ... ?                          
         BG       EXEC1             NOTHING; END OF COMMAND                     
         BE       TRUNC1            NEXT FILED; SCAN NEW KEYWORD                
         B        ERROR02                                                       
         PAGE                                                                   
         SPACE    2                                                             
TRUNC10  RES      0         PROCESS NEXT IN LIST OF AREA NAMES                  
         BAL,LINK SCAN              GET A NAME                                  
         CI,R6    0                 WERE ANY ERRORS FOUND ?                     
         BGE      TRUNC12             NO, TEST IF A VALID AREA NAME             
*                                                                               
TRUNC11  RES      0         ERROR SCANNING AN AREA NAME: TEST FOR '.'           
         CI,R10   C'.'              WAS ERROR DUE TO A '.' ?                    
         BNE      ERROR02             NO, REAL ERROR: GIVE 'ERROR ITEM XX'      
*                                                                               
         AI,R11   -X'0100'          BACK ITEM COUNT UP 1                        
         B        TRUNC10           AND SCAN THE AREA NAME                      
*                                                                               
TRUNC12  RES      0         PROCESS AREA TRUNCATE                               
         SLS,R8   -16               RT-ALIGN AREA NAME                          
         STW,R8   AREANAME          SET FOR CHKAREA                             
         BAL,RLNK CHKAREA           VALIDATE AREA, GET AREA INFO                
         B        ERROR04           NOT ALLOCATED - GIVE ERROR                  
         BAL,RLNK GET1SFIL          GET 1ST ENTRY IN THE DIRE                   
         B        ERROR41           ERROR IN DIRE; REPORT                       
         B        TRUNC21           DIRE EMPTY; DONE                            
*        B        TRUNC15           FOUND FIRST; PROCESS                        
*                                                                               
*                                                                               
TRUNC15  RES      0         PROCESS FILE ENTRY AT (R5)                          
         BAL,RLNK UNPKDIRE          UNPACK THE DIRECTORY ENTRY                  
         LW,R0    DIRESTAT          IS IT AN ACTIVE FILE ?                      
         CI,R0    FILGOODF          I.E., NOT DELETED OR BADTRACK ?             
         BNE      TRUNC18             NO, SKIP IT                               
*                                                                               
         LW,R0    DIREFSIZ          DOES IT HAVE ANY RECORDS IN IT ?            
         BEZ      TRUNC18             NO, SKIP IT                               
*                                                                               
         LCI      2                                                             
         LM,R0    DIRENAME          MOVE NAME TO FPT                            
         STM,R0   DELTRUNC+3                                                    
         LM,R0    DIREACNT                                                      
         STM,R0   ACNTNAME          PUT ACNT NAME IN PLACE                      
         CAL1,7   DELTRUNC          TRUNCATE THE FILE                           
*                                                                               
TRUNC18  RES      0         DONE WITH CURRENT FILE; FIND NEXT                   
         BAL,RLNK GETNXFIL          GET NEXT ENTRY                              
         B        ERROR41           ERROR; REPORT                               
         B        TRUNC30           DONE WITH DIRE; TEST MORE TO DO             
         B        TRUNC15           GOT NEXT; PROCESS IT                        
*                                                                               
*                                                                               
*                                                                               
TRUNC21  RES      0         AREA EMPTY                                          
         LI,R15   MESS14            SET ERROR MESSAGE ADDR                      
         LW,R0    MASDNAME          GET NAME OF AREA                            
         LI,R1    3                                                             
         STH,R0   *R15,R1           INSERT NAME                                 
         BAL,LINK TYPRNT            OUT WARNING MESSAGE                         
*                                                                               
*                                                                               
TRUNC30  RES      0         DONE WITH AN AREA; TEST WHAT TO DO NEXT             
         CAL1,1   CLFLEIN           CLOSE DIRE FPT                              
         CI,R6    1                 WHERE ARE WE IN THE COMMAND ?               
         BLE      TRUNC10           MORE PARAMS FOLLOW; GO PROCESS              
         B        EXEC1             AT END OF COMMAND; GET A NEW ONE            
         PAGE                                                                   
         SPACE    2                                                             
CHKAREA  RES      0         VALIDATE AREA NAME; SET IN FPT; GET AREA INFO       
         PUSH     RLNK              SAVE RETURN LINK                            
         LW,R8    AREANAME          GET DISK AREA NAME                          
         STH,R8   R8                LEFT-ALIGN IT                               
         BAL,RLNK GETAX             CHECK IF AREA DEFINED, GET INDEX            
         B        ERROR04             NOT; GIVE 'AREA NOT ALLOCATED'            
*                                                                               
         CLM,R1   CKXABT            MAINTAINED BY RADEDIT ?                     
         BCS,6    %+2                 YES                                       
         B        ERROR11             NO, GIVE 'NOT MAINTAINED BY RADEDIT'      
*                                                                               
         SLS,R8   -16               RIGHT JUSTIFY AREA NAME                     
         LI,R2    1                 SET AREA NAME IN TRUNCATE FPT               
         STH,R8   DELTRUNC,R2       AS IT NEEDED THE EBCDIC NAME                
         PULL     RLNK              RESTORE RETURN LINK                         
         B        UNPKMASD          UNPACK AREA INFO.  LINK REMAINS THE         
*                                   LINK TO THIS ROUTINE AND RETURNS ARE        
*                                   TO OUR CALLER.                              
         PAGE                                                                   
         SPACE    2                                                             
DELET69  RES      0         DELETE   CAL ERROR PROCESSING TABLES                
         ERRP     X'03',DELETE10    NON-EXIST FILE: OUT WARNING                 
         ERRP     X'71',DELETE10    BAD FILENAME: OUT WARNING                   
*                                                                               
*                 DELETE DOES NOT REPORT ERROR FOR NON-EXISTENT FILE            
*                 IT THEREFORE FINDS THE ERROR FIRST AND GIVES WARNING          
*                                                                               
TRUNC69  RES      0         TRUNCATE CAL ERROR PROCESSING TABLES                
         ERRP     X'03',ERROR06     NONEXIST FILE                               
         ERRP     X'42',WPERR       WRITE PROTECT                               
         ERRP     X'70',ERROR11     BAD AREA                                    
         ERRP     X'71',ERROR06     BAD FILENAME                                
         ERRP     X'FF',0           CONTINUE WITH DEFAULT PROCESSING            
         TITLE     '**** DELETE ROUTINE ****'                                   
*                                                                               
******** ROUTINE DELETE ********                                                
*                                                                               
*        INPUT    DIRECTIVE PARAMETERS                                          
*                                                                               
*        OUTPUT   DELETED ENTRY IN PERMANENT FILE DIRECTORY                     
*                                                                               
*        FUNCTION DELETES AN ENTRY FROM A PERMANENT FILE DIRECTORY BY           
*                 CALLING THE DELETE CAL FOR FILES AND CLEARING THE             
*                 ENTRY IN MODIR AND DEFREF FOR LIBRARY ROMS.                   
*                                                                               
*        CALLS:   SCAN,CHKAREA,UNPKMASD,GETAX, FNDROM                           
*                                                                               
DELETE   RES      0         DELETE A FILE OR LIBRARY ROM                        
         LI,R0    DELET69           SET ERROR FUNCTION TABLE ADDRESS            
         STW,R0   ERRFCN                                                        
         LI,R0    DELECODE          SET FPT TO DO DELETES                       
         STH,R0   DELTRUNC                                                      
         LI,R0    0                 SET NOT DELETING LIBRARY ENTRIES            
         STW,R0   LIBFLAG                                                       
*                                                                               
DELETE1  RES      0         GET KEYWORD AND TEST WHICH DELETE TO DO             
         BAL,LINK SCAN              SCAN FOR THE KEYWORD                        
         CI,R6    0                 MORE FOLLOWING KEYWORD ?                    
         BNE      ERROR02             NO, GIVE 'ERROR ITEM XX'                  
*                                                                               
         LW,R9    ML24              SET MASK TO TEST FOR 'FIL '                 
         CS,R8    KWFILE            IS IT 'FILE' ?                              
         BE       DELETE2             YES, OK                                   
*                                                                               
         MTW,+1   LIBFLAG           ASSUME IT IS 'LIB'                          
         CW,R8    KWLIB             IS 'LIB' SPECIFIED ?                        
         BNE      ERROR02             NO, GIVE ERROR ITEM                       
*                                                                               
DELETE2  RES      0         GET AND VALIDATE AREA NAME                          
         BAL,LINK GETFID            GET FILE ID                                 
         CI,R6    -1                ERRORS FOUND SCANNING 'FID' ?               
         BLE      ERROR02             YES, GIVE ERROR ITEM XX                   
*                                                                               
         BAL,RLNK CHKAREA           VALIDATE AREA, GET AREA INFO                
         B        ERROR04           IF AREA IS NOT ALLOCATED                    
*                                                                               
         MTW,+00  LIBFLAG           ARE WE DELETING LIB ROMS ?                  
         BEZ      DELETE3             NO, NO SPECIAL CHECK FOR SP, FP           
*                                                                               
         CLM,R1   FPSP              IS IT A LEGAL LIBRARY AREA ?                
         BCR,6    DELETE20            YES, GO DELETE THE ROM                    
         B        ERROR10               NO, GIVE ERROR 'NO LIB'                 
*                                                                               
DELETE3  RES      0         SET FILE NAME                                       
*                                                                               
         LCI      2                 STORE FILE NAME IN THE FPT                  
         LM,R8    FILENAME                                                      
         STM,R8   DELTRUNC+3                                                    
         LW,R8    GIOCT             PUT THE ACCOUNT NAME'S P14 PRESENCE         
         LI,R9    P14               BIT IN THE FPT IF A NAME WAS GIVEN          
         STS,R8   DELTRUNC+1                                                    
         CAL1,7   DELTRUNC          DELETE IT, SYSTEM                           
*                                                                               
DELETE5  RES      0         TEST FOR LISTED FILENAMES                           
         CI,R6    1                 MORE TO DO ?                                
         BG       EXEC1             END OF CARD; NO, GET NEXT COMMAND           
         BE       DELETE1           END OF FIELD; GET ANOTHER KEYWORD           
         B        ERROR02                                                       
         PAGE                                                                   
         SPACE    2                                                             
DELETE10 RES      0         DELETE OF AN NONEXISTANT FILE                       
         STRNG    XMESS6            ENTER 1ST PART OF MESSAGE                   
         BAL,RLNK OUTFILNM                                                      
         STRNG    XMESS6A                                                       
         LW,R15   %CP               GET LENGTH OF FORMED MESSAGE AND            
         STB,R15  %PL               SET AS LENGTH OF STRING IN BUFFER           
         LI,R15   %PL                                                           
         BAL,LINK TYPRNT            OUT WARNING MESSAGE                         
         B        DELETE5           LOOP FOR LISTED PARAMETERS                  
         PAGE                                                                   
         SPACE    2                                                             
DELETE20 RES      0         DELETE A LIBRARY ROM FROM THE DIRECTORIES           
         BAL,RLNK FNDROM            FIND ROM IN MODIR FILE IF PRESENT           
         B        ERROROUT            NOT FOUND; GIVE ERROR IN R15              
*                                                                               
         STW,R2   R9                SAVE POINTER                                
         LI,R1    0                                                             
         LI,R4    3                                                             
         STW,R1   *BPEND,R2         ZERO OUT MODIR ENTRY                        
         AI,R2    1                                                             
         BDR,R4   %-2                                                           
         CAL1,1   WRDISCS                                                       
         CAL1,1   CLFLEIN                                                       
*                                                                               
         LD,R0    DEFREF            PREPARE TO READ DEFREF FILE                 
         STD,R0   BIFNAME                                                       
         CAL1,1   OPFLEIN                                                       
         LI,R2    F:BI              POINT AT DCB FOR 'GET RSIZE'                
         CAL1,1   GETRSIZE          GET LENGTH OF THE 1 RECORD IN BYTES         
         CI,R0    0                 IS SIZE = 0, ==> NO LIB AT ALL ?            
         BLEZ     DELETE23            YES, WE ARE IN DESIRED STATE              
*                                                                               
         CW,R0    BCKSZE            WILL MODIR FIT IN BKG SPACE ?               
         BGE      ERROR19             NO, GIVE ERROR                            
*                                                                               
*                                                                               
         STW,R0   SETRSIZ2          YES, SET BYTE COUNT IN DCB AS               
         CAL1,1   SETRSIZE          DEFAULT IN READING IN ITS RECORD            
         CAL1,1   RDDISCS           READ IN DEFREF FILE                         
         CAL1,1   CLFLEIN                                                       
*                                                                               
         SLS,R0   -1                HWD. ENTRIES IN DEFREF FILE                 
         SLS,R9   1                                                             
         LI,R3    0                                                             
         LI,R5    0                                                             
DELETE21 RES      0                                                             
         AH,R5    *BPEND,R3         GET ENTRY SIZE                              
         AI,R3    1                                                             
         LH,R4    *BPEND,R3         GET MODIR FILE INDEX OF ENTRY               
         CW,R4    R9                INDEXEX COMPARE                             
         BE       DELETE22          YES                                         
         LW,R3    R5                                                            
         CW,R3    R0                                                            
         BNE      DELETE21                                                      
         B        DELETE23          INDEX WASNT FOUND                           
DELETE22 RES      0                                                             
         LI,R4    -1                SET INDEX TO -1                             
         STH,R4   *BPEND,R3                                                     
         CAL1,1   WRDISCS                                                       
*                                                                               
DELETE23 RES      0         DELETE COMPLETE; CLOSE FILE AND SEE IF MORE         
         CAL1,1   CLFLEIN           CLOSE LIBRARY DIRECTORY FILE                
         B        DELETE5           AND SEE IF MORE PARAMETERS                  
         TITLE    '**** PROCESS FILE,REC. POSITION COMMANDS ****'               
*                                                                               
*        UTILITY COMMON ENTRY POINT                                             
*                                                                               
A08      EQU      ERROR02                                                       
SCANPMA  EQU      SPARAM+1                                                      
*                                                                               
*                                                                               
UTILITY  RES      0         COMMON POSITIONING COMMANDS PROCESSOR               
         PUSH     R1                SAVE INDEX OF COMMAND TO DO                 
         LI,R0    UTILERF           SET ERR FUNCTION TABLE ADDRESS              
         STW,R0   ERRFCN                                                        
         LI,R2    F:BI              POINT AT DCB TO USE FOR OPS                 
         BAL,LINK GETANY            GET NAME OF DEV/OPLB/FILE                   
         CI,R6    -1                ANY ERRORS FOUND ?                          
         BLE      ERROR02             YES, GIVE 'ERROR ITEM XX'                 
*                                                                               
         LW,R8    GIOCT             GET P-BITS FOR WHAT WAS FOUND               
         CW,R8    GIODBIT           IS IT A DEVICE NAME ?                       
         BANZ     U1                  YES, ASSIGN DEVICE                        
*                                                                               
         CW,R8    GIOOBIT           IS IT AN OPLABEL ?                          
         BANZ     U2                  YES, ASSIGN THAT                          
*                                                                               
         LW,R0    AREANAME          FILE: ONLY BT FILES ALLOWED                 
         AND,R0   M16               INSURE AREA NAME IS 'BT'                    
         CI,R0    C'BT'             IS IT THE LEGAL AREA NAME ?                 
         BNE      ERROR02             NO, GIVE 'ERROR ITEM XX'                  
*                                                                               
         LW,R9    GIOFA             SET FILE, RESET ACCOUNT BITS                
         STS,R8   ASNFILE+1                                                     
         CAL1,1   ASNFILE           ASSIGN THE FILE TO THE DCB                  
         B        U3                AND CONTINUE WITH PROCESSING                
*                                                                               
U1       RES      0         ASSIGN DEVICE TO THE DCB                            
         CAL1,1   ASNDEV                                                        
         B        U3                THEN CONTINUE                               
*                                                                               
U2       RES      0         ASSIGN OPLABEL TO THE DCB                           
         CAL1,1   ASNOPLB                                                       
*                                                                               
U3       RES      0         PROCESS PARAMS TO SPECIFIC COMMANDS                 
         PULL     R1                GET INDEX TO CORRECT COMMAND                
         LW,R1    ULIST-1,R1                                                    
         B        *R1                                                           
ULIST    DATA     U01               PFIL                                        
         DATA     V01               PREC                                        
         DATA     W01               SFIL                                        
         DATA     X01               REWI                                        
         DATA     Y01               UNLOAD                                      
         DATA     Z01               WEOF                                        
         PAGE                                                                   
         SPACE    2                                                             
*        MUST CLOSE FILES TO KEEP RFT BOOKKEEPING STRAIGHT.                     
*        THIS DOES NOT LOSE POSITION BECAUSE                                    
*        ONLY BT FILES AND FILES ACCESSED VIA OPLABELS MAY BE                   
*        POSITIONED, AND THESE MAINTAIN THEIR RFT ENTRIES                       
*        (THUS THEIR POSITION) EVEN WHEN CLOSED.                                
*                                                                               
U99      RES      0         CLOSE DCB AND EXIT TO EXEC                          
         CAL1,1   CLOSEANY          CLOSE THE DCB                               
         B        EXEC1             GO GET NEXT COMMAND                         
*                                                                               
*                                   PFIL COMMAND                                
U01      RES      0                                                             
         CI,R6    2                                                             
         BE       U03               END OF CARD                                 
         BAL,LINK SCAN              GO GET BACK INPUT                           
         CI,R6    2                                                             
         BNE      A08               ERROR, NOT END OF CARD                      
         LI,R9    X'FFF00'                                                      
         CS,R8    U90                                                           
         BNE      A08               ERROR, NOT 'BAC'                            
         LI,R0    X'10'                                                         
         B        %+2                                                           
U03      LI,R0    0                                                             
         STW,R0   POSFILE+1                                                     
         CAL1,1   POSFILE           GO POSITION FILE                            
         B        U99               B TO CLOSE IF NECESSARY                     
*                                                                               
U90      TEXT     'BAC '                                                        
*                                                                               
*                                                                               
*                                   PREC COMMAND                                
V01      RES      0                                                             
         MTW,4    SCANPMA           SET TO 5 FOR BCD OR DECIMAL                 
         LI,R1    1                                                             
         STW,R1   POSREC+2          INITIALIZE NO. REC. TO ONE                  
         LI,R0    8                 INIT TO WAIT AND                            
         STH,R0   POSREC+1,R1       INIT. TO FORWARD                            
V02      CI,R6    2                                                             
         BE       V05               END OF CARD                                 
         BAL,LINK SCAN                                                          
         CI,R6    0                                                             
         BL       A08               ERROR                                       
         CI,R9    0                 IS IT A NO.                                 
         BNE      %+3               NO                                          
         STW,R8   POSREC+2          YES, STORE NO. REC. TO SKIP                 
         B        V02                                                           
         LI,R9    X'FFF00'                                                      
         CS,R8    U90               WAS 'BAC' INPUT                             
         BNE      A08               NO, ERROR                                   
         LI,R1    1                                                             
         LI,R0    X'18'             WAIT BIT AND                                
         STH,R0   POSREC+1,R1       SET BACKWARDS BIT IN FPT                    
         B        V02                                                           
V05      CAL1,1   POSREC            GO POSITION RECORD                          
         B        U99               B TO CLOSE IF NECESSARY                     
*                                                                               
*                                                                               
*                                   SFIL COMMAND                                
W01      RES      0                                                             
         MTW,4    SCANPMA           SET TO 5 FOR BCD OR DECIMAL                 
         LI,R1    1                 INIT SKIP COUNT TO 1 FILE                   
         LI,R0    X'28'             SET FPT BITS FOR SKIP (X'20'),              
         STW,R0   POSFILE+1         WAIT (X'08'), AND FWD (X'10' = 0)           
W02      CI,R6    2                                                             
         BE       W05               END OF CARD                                 
         BAL,LINK SCAN                                                          
         CI,R6    0                                                             
         BL       A08               ERROR                                       
         CI,R9    0                 WAS A NO. INPUT                             
         BNE      %+3               NO                                          
         LW,R1    R8                SET NUMBER OF FILES TO SKIP                 
         B        W02                                                           
         LI,R9    X'FFF00'                                                      
         CS,R8    U90               WAS 'BAC' INPUT                             
         BNE      A08               NO, ERROR                                   
         LI,R0    X'10'                                                         
         AWM,R0   POSFILE+1         SET DIR BIT TO BACK                         
         B        W02                                                           
W05      CAL1,1   POSFILE           GO SKIP A FILE                              
         BDR,R1   %-1               SKIP THE NECESSARY NUMBER OF FILES          
         B        U99               B TO CLOSE IF NECESSARY                     
*                                                                               
*                                                                               
*                                   REWIND COMMAND                              
X01      RES      0                                                             
         CI,R6    2                                                             
         BNE      A08               ERROR IF NOT END OF CARD                    
         CAL1,1   REWIND                                                        
         B        U99               B TO CLOSE IF NECESSARY                     
*                                                                               
*                                                                               
*                                   UNLOAD COMMAND                              
Y01      RES      0                                                             
         CI,R6    2                                                             
         BNE      A08               ERROR                                       
         CAL1,1   UNLOAD                                                        
         B        U99               B TO CLOSE IF NECESSARY                     
*                                                                               
*                                                                               
*                                   WEOF COMMAND                                
Z01      RES      0                                                             
         LI,R1    1                 INITIALIZE NO. TO ONE                       
         CI,R6    2                                                             
         BE       Z03               END OF CARD                                 
         CI,R6    0                                                             
         BNE      A08               ERROR                                       
         MTW,3    SCANPMA           SET TO 4 FOR DECIMAL                        
         BAL,LINK SCAN              GET NO. OF EOF'S                            
         CI,R6    2                                                             
         BNE      A08               ERROR IF NOT END OF CARD                    
         LW,R1    R8                                                            
Z03      CAL1,1   WEOF              WRITE AN EOF                                
         BDR,R1   Z03               LOOP TILL PROPER NO. WRITTEN                
         B        U99               B TO CLOSE IF NECESSARY                     
         PAGE                                                                   
         SPACE    2                                                             
UTILERF  ERRP     X'05',U99         EOF: CLOSE DCB AND GET NEXT COMMAND         
         ERRP     X'06',U99         EOD: DO SAME                                
         ERRP     X'1C',U99         EOT: DO SAME                                
         ERRP     X'1D',U99         BOT: DO SAME                                
         ERRP     X'03',ERRPOS1     NON-EXIST FILE: WARN AND IGNORE             
         ERRP     X'42',WPERR       WRT RESTRICT: SEE IF OK                     
         ERRP     X'0A',0           CLOSED DCB: IGNORE CLOSES                   
         ERRP     X'2E',OPENERR     OPEN DCB: CLOSE AND REOPEN                  
         ERRP     0,ERRPOS3         ALL OTHER: WARN AND IGNORE                  
UTILERFX ERRP     X'FF',0           LINK TO ROOT'S ERR FUNCTIONS                
*                                                                               
*                                                                               
ERRPOS1  RES      0         FILE DID NOT EXIST ON POSIT                         
         STRNG    XMESS6            FORM MESSAGE: ENTER 'FILE'                  
         CHARS    8,FILENAME        INSERT FILENAME                             
         STRNG    XMESS6A           THEN REST OF MESSAGE                        
         LW,R15   %CP               SET LENGTH OF MESSAGE                       
         STB,R15  %PL                                                           
         LI,R15   %PL               POINT AT NOW FORMED MESSAGE                 
         B        ERRPOS            GO TO COMMON WARNING ROUTINE                
*                                                                               
*                                                                               
ERRPOS3  RES      0         ALL OTHER ERRORS                                    
         LB,R11   R10               MOVE ERROR CODE                             
         BAL,LINK HEXBCD            CONVERT                                     
         STW,R10  MESS40+5          STORE IN MESSAGE                            
         LI,R15   MESS40            SET LOC OF MESSAGG                          
         B        ERRPOS            GO OUT WARNING                              
*                                                                               
*                                                                               
ERRPOS   RES      0         OUT A WARNING MESSAGE AND CONTINUE                  
         BAL,LINK TYPRNT            OUT THE MESSAGE                             
         LI,R0    UTILERFX          SET TO NOT USE OUR ERR FCN                  
         STW,R0   ERRFCN            FOR ANY MORE ERRORS                         
         B        U99               INSURE THE DCB IS CLOSED                    
         PAGE                       STDLB COMMAND PROCESSOR                     
         SPACE    2                 -----------------------                     
STDLB    RES      0         ASSIGN A STANDARD LABEL AS REQUESTED                
         LI,R0    STDLBERF          SET ERROR PROCESSING                        
         STW,R0   ERRFCN             TO PROCESS ALL ERRORS SPECIAL              
         BAL,LINK SCAN              GET OPLABEL TO ASSIGN                       
         CI,R6    0                 DOES MORE FOLLOW ?                          
         BNE      ERROR02             NO, MUST; 'ERROR ITEM XX'                 
*                                                                               
         CI,R10   2                 WERE EXACTLY 2 CHARACTERS SCANNED ?         
         BNE      ERROR02             NO, ALSO 'ERROR ITEM XX'                  
*                                                                               
         SLS,R8   -16               RIGHT JUSTIFY THE NAME AND INSERT           
         LI,R9    X'FFFF'           IT INTO WORD 0 OF THE FPT                   
         STS,R8   STDLBCAL                                                      
         BAL,LINK GETANY            GET WHAT IS TO BE ASSIGNED TO IT            
         CI,R6    1                 IS THIS THE LAST ITEM IN CMND ?             
         BL       ERROR02             NO, IT MUST BE; 'ERROR ITEM XX'           
*                                                                               
         LW,R8    GIOCT             GET WHAT WAS GIVEN AND SET THE              
         LW,R9    GIOBITS           STDLB CAL TO ASSIGN AS REQUIRED             
         STS,R8   STDLBCAL+1        BY SETTING NECESSARY P-BITS                 
         CW,R8    GIOOBIT           IS ASSIGNMENT TO ANOTHER OPLABEL ?          
         BAZ      STDLB3              NO, P3 OR P4 WORD OK                      
*                                                                               
         LW,R8    Y8                YES, SET P2 INDIRECT BIT FOR ADDR           
*                                                                               
STDLB3   RES      0         SET INDIRECT BIT IF OPLB, ELSE RESET IT             
         LW,R9    Y8                                                            
         STS,R8   STDLBCAL+3        DEV/FILE PARAM = ADDR; OPLB=*ADDR           
         CAL1,7   STDLBCAL          DO THE ASSIGNMENT                           
         CI,R6    1                 WAS THIS LAST STDLB IN COMMAND ?            
         BLE      STDLB               NO, GET ANOTHER                           
         B        EXEC1               YES, GO GET NEXT COMMAND                  
         PAGE                       STDLB COMMAND ERROR PROCESSING              
         SPACE    2                 ------------------------------              
STDLBERF ERRP     X'03',ERROR06     NON-EXIST FILE; OUT MSG TO SAY SO           
         ERRP     X'74',STDLBX2     ILLEGAL OPLABEL; SAY NOT DEFINED            
         ERRP     00000,STDLBX1     ALL OTHERS; SAY UNABLE TO ASSIGN            
*                                                                               
*                                                                               
STDLBX1  RES      0         UNABLE TO DO ASSIGNMENT                             
         STRNG    MESS51            OUT MESSAGE TO SAY UNABLE                   
         LB,R15   R10               GET ERROR CODE                              
         INTGR    HEX,ZERO,2        AND ERROR CODE FROM R10                     
         B        ERROR%PL          OUT MESSAGE; DO NORMAL ERROR PROCESS        
*                                                                               
*                                                                               
STDLBX2  RES      0         ILLEGAL OPLABEL                                     
         STRNG    MESS52            OUT 'OPLABEL '                              
         CHARS    2,STDLBCAL,2      OUT          OP                             
         STRNG    XMESS6A           OUT           ' DOES NOT EXIST'             
         B        ERROR%PL          OUT MESSAGE; DO NORMAL ERROR PROCESS        
         TITLE    '          I N I T    &    A D D  '                           
         SPACE    1                                                             
************************************************************************        
*                                                                      *        
*                 I N I T     &     A D D                              *        
*                                                                      *        
************************************************************************        
*                                                                               
*        REGISTER USAGE IN 'INIT' AND 'ADD'                                     
*                                                                               
*        R0,R1,R2 GENERAL WORK REGISTERS, PARAMS TO % ROUTINES                  
*        R3       HAS LOCATION OF LAST ALLOCATION PACKET + 1 IN THE             
*                 VTOC IN THE BPEND BUFFER (WORK SPACE).                        
*        R4       HAS LOCATION OF THE LAST SKIP ALLOCATION PACKET IN            
*                 BUFF3 (AND BUFF4).                                            
*        R5       HAS THE ADDRESS OF THE WORKSPACE (BPEND).                     
*        R6       RETURN CODE FROM SCAN UNTIL ALL OF PARAMETERS HAVE            
*                 BEEN PROCESSED; THEN POINTS AT THE REMAINING SPACE            
*                 PACKET IN THE BPEND BUFFER AFTER THE SKIP SPACE AND           
*                 FREE SPACE PACKETS HAVE BEEN MOVED THERE.                     
*        R7       POINTS AT SPARAMF TABLE DURING SCAN; POINTS AT THE            
*                 CURRENT PACKET FOR MAPPING, OR OTHER PROCESSING AFTER         
*                 SCANNING IS COMPLETED.                                        
*        R8-R11   USED BY SCAN; USED AS WORK REGISTERS                          
*        R12,R13  WORK REGISTERS                                                
*        R14      LINK TO NEW SUBROUTINES AND % ROUTINES; WORK WITH R15         
*        R15      PARAMETER TO % ROUTINES; WORK                                 
         TITLE    '          I N I T    &    A D D  '                           
         SPACE    1                                                             
         DO       #PRIV                                                         
************************************************************************        
*                                                                      *        
*                 I N I T     &     A D D                              *        
*                                                                      *        
************************************************************************        
*                                                                               
INIT     RES      0          INIT A MOUNTABLE DISC PACK                         
         LI,R0    0                 SET IN 'INIT'                               
         B        INITADD           AND DO COMMON SCANNING                      
*                                                                               
*                                                                               
*                                                                               
ADD      RES      0          ADD NEW AREAS TO AN INIT'D DISC PACK               
         LI,R0    1                 SET IN 'ADD'                                
*                                                                               
*                                                                               
INITADD  RES      0          COMMON PROCESSOR FOR 'INIT' AND 'ADD'              
         STW,R0   INITSW            SET WHICH WE ARE DOING                      
         LI,R0    0                 SET NOTHING ADDED TO VTOC                   
         STW,R0   ADDSW                                                         
         LW,R5    BPEND             SET TO USE BUFFER SPACE FOR VTOC            
         STW,R5   BIBUFF            FIX UP F:BI DCB                             
         LD,R8    BLNK              CLEAR VSN TO NONE GIVEN                     
         STD,R8   VSN                                                           
         LI,R0    -1                SET TO NO INIT TYPE GIVEN                   
         STW,R0   INITYPE                                                       
         LW,R0    BACKSZE           IS THERE AT LEAST 6 SECTORS OF              
         CI,R0    256*6             BACKGROUND SPACE ?                          
         BL       ERROR19             NO, GIVE ERROR AND STOP NOW               
         PAGE                                                                   
         SPACE    2                                                             
         BAL,LINK SCAN              GET DEVICE NAME                             
         CI,R6    -1                ANY ERRORS ?                                
         BLE      ERROR02             YES, REPORT 'ERROR ITEM XX'               
*                                                                               
         LCI      2                                                             
         STM,R8   DEVASGN           SET NAME OF DEVICE TO ASSIGN                
         STD,R8   R12               SAVE DEVICE NAME                            
         SLD,R8   -24               CONVERT TO DCT16 FORMAT                     
         OR,R8    DCTDATA           TO TEST IF A VALID DEVICE                   
*                                                                               
         LH,R1    *K:DCT1           GET NUMBER OF DEVICES TO CHECK              
*                                                                               
INIT1    RES      0         TEST IF DEVICE WAS DEFINED IN SYSGEN                
         CD,R8    *K:DCT16,R1       IS IT IN THE DEVICE LIST                    
         BE       INIT2               YES, LEGAL DEVICE                         
         BDR,R1   INIT1             NOT YET, TRY SOME MORE                      
         B        ERROR02           NOT LEGAL: ERROR ITEM XX                    
*                                                                               
INIT2    RES      0         DEVICE DEFINED: A DISC DEVICE ?                     
         SLD,R8   8                 GET THE 'YY' FROM 'YYNDD'                   
         AND,R8   M16               TO TEST IF A 'DP' TYPE DEVICE               
         CI,R8    C'DP'             IS IT A DISC ?                              
         BNE      ERROR02             NO, ERROR                                 
         PAGE                                                                   
         SPACE    2                                                             
         LW,R2    K:NUMDA           GET NUMBER OF AREAS TO CHECK                
*                                                                               
INIT3    RES      0         CHECK IF ANY AREA IN MASTD IS ON THIS DISC          
         STW,R2   AREA              SET AREA INDEX FOR UNPKMASD                 
         BAL,R14  UNPKMASD          GET ITS DEVICE INDEX                        
         B        INIT4               AREA NOT ALLOCATED; SKIP IT               
*                                                                               
         CW,R1    MASDDCTI          IS IT ON THE SAME DEVICE ?                  
         BE       ERROR42             YES, GIVE ERROR                           
*                                                                               
INIT4    RES      0         STEP TO NEXT AREA                                   
         AI,R2    -1                DECREMENT POINTER                           
         CI,R2    -1                LOOP UNTIL INDEX ZERO IS DONE               
         BG       INIT3                                                         
*                                                                               
         LCI      2                                                             
         STM,R12  DEVASGN           SET DEVICE NAME BACK FOR LATER USE          
         PAGE                                                                   
*                 OK TO 'INIT' OR 'ADD' TO DISC: GET VSN, ETC                   
*                                                                               
         CI,R6    0                 DO VSN AND/OR INIT FOLLOW ?                 
         BG       INIT10              NO, VALIDATE DISC TYPE AND VSN            
*                                                                               
         BAL,LINK SCAN              GET VSN OR INIT TYPE                        
         CI,R6    0                 WHAT WAS FOUND: ?                           
         BL       ERROR02            ERROR, REPORT IT                           
         BG       INIT6              END OPTION OR CARD; TEST VSN/INIT          
*                                                                               
         STD,R8   VSN               END SUBFIELD; STORE VSN                     
         BAL,LINK SCAN              GET INIT TYPE                               
         CI,R6    -1                TEST FOR ERRORS                             
         BLE      ERROR02             FOUND ONE, REPORT IT                      
*                                                                               
         BAL,RLNK INITCHKI          CHECK INIT TYPE                             
         B        INIT5               NOT LEGAL INIT; TRY DISC PURGE            
*                                                                               
         STW,R1   INITYPE           SET INITIALIZATION TYPE                     
         CI,R6    0                 DO MORE OPTIONS FOLLOW ?                    
         BG       INIT10              NO, GO START DISC VALIDATION              
*                                                                               
         BAL,LINK SCAN              GET POSSIBLE 'PURGE' OPTION                 
         CI,R6    0                 ANY ERRORS OR NOT END OF OPTION?            
         BLE      ERROR02             YES, GIVE ERROR ITEM XX                   
         PAGE                                                                   
         SPACE    2                                                             
INIT5    RES      0         TEST FOR 'INIT' OVERRIDE OPTION 'PURGE'             
         CD,R8    INITPURG          IS IT THAT KEYWORD ?                        
         BNE      ERROR02             NO, GIVE ERROR                            
*                                                                               
         MTW,+0   INITSW              YES, ARE WE DOING AN 'INIT' ?             
         BNEZ     ERROR02             NO, MUST BE; GIVE ERROR ITEM XX           
*                                                                               
         LI,R12   1                 FLAG FOR INIT PURGE                         
         B        INIT10A                                                       
*                                                                               
*                                                                               
INIT6    RES      0         ONE OPTION AFTER DEVICE NAME; TEST WHICH            
         BAL,RLNK INITCHKI          TEST IF VALID INIT TYPE                     
         B        INIT8               NOT, ASSUME A VSN                         
*                                                                               
         STW,R1   INITYPE           OK, SET INIT TYPE                           
         B        INIT10            GO VALIDATE DISC                            
*                                                                               
INIT8    RES      0         ASSUME A VSN                                        
         STD,R8   VSN               SAVE THE USER GIVEN VSN                     
         PAGE                                                                   
         SPACE    1                                                             
INIT10   RES      0          VALIDATE INPUT PARAMS WITH THOSE ON DISC           
         LI,R12   0                 FLAG FOR NO PURGE                           
INIT10A  RES      0                                                             
         LI,R2    F:BI              SET UP TO USE THE F:BI DCB                  
         CAL1,1   ASNDEV            ASSIGN                                      
         CAL1,1   GETAINFO          GET DEVICE INFO, ETC                        
         LW,R0    MASDWPS           SET BYTE COUNT FOR SECTOR 0 READ            
         SLS,R0   2                                                             
         STW,R0   RDDISC4                                                       
         STW,R0   WRDISC4                                                       
         LI,R0    0                 SET TO READ/WRITE SECTOR 0                  
         STW,R0   RDDISC5                                                       
         STW,R0   WRDISC5                                                       
         CI,R12   1                                                             
         BE       INIT20            B IF PURGE NEEDED                           
         CAL1,1   RDDISC            READ SECTOR ZERO                            
*                                                                               
*                 TEST TYPE OF DISC (CP-R/CP-V) AND 'VSN'                       
*                                                                               
         LD,R12   VSN               GET VSN TO LOOK FOR                         
         LW,R0    VTOC:LBL,R5       SEE IF IT IS A CP-V TYPE DISC               
         CW,R0    KW:LBL            DOES IT HAVE A CP-V LABEL ?                 
         BE       INIT11              YES, TEST VSN                             
*                                                                               
         LW,R0    VTOCVTOC,R5       TEST FOR CP-R VTOC                          
         CW,R0    KWVTOC            IS IT ONE OF OUR DISCS ?                    
         BE       INIT13              YES, TEST VSN                             
*                                                                               
         CD,R12   BLNK              WAS A VSN GIVEN ON INIT/ADD COMMAND ?       
         BE       ERROR02             NO, INVALID VSN ERROR                     
*                                                                               
         MTW,+0   INITSW            YES, IN 'ADD' ?                             
         BNEZ     ERROR43                 ERROR, MUST DO 'INIT'                 
*                                                                               
         B        INIT20            GO INIT A DISC                              
         PAGE                                                                   
         SPACE    2                                                             
INIT11   RES      0          VALIDATE A 'CP-V' DISC                             
         MTW,+00  INITSW            DOING AN ADD ?                              
         BNEZ     ERROR43             YES, ERROR                                
*                                                                               
         LW,R8    VTOCLBL1,R5       GET CP-V'S VSN                              
         LW,R9    VTOCLBL2,R5                                                   
         CD,R8    R12               DO THE VSN'S MATCH ?                        
         BE       INIT20              YES, INIT THE DISC IN CP-R FORMAT         
*                                                                               
         CD,R12   BLNK              DO WE HAVE A VSN FROM THE COMMAND ?         
         BNE      ERROR44             YES, VSN'S DON'T MATCH; ERROR             
*                                                                               
         STD,R8   VSN               SET DISC'S VSN AS ONE TO USE                
         B        INIT20            AND GO FORM 'CP-R' VTOC                     
*                                                                               
INIT13   RES      0         VALIDATE 'CP-R' DISC                                
         LW,R8    VTOCVSN1,R5       GET VSN FROM CP-R DISC                      
         LW,R9    VTOCVSN2,R5                                                   
         CD,R8    R12               DO THE VSN'S MATCH ?                        
         BE       INIT15              YES, TEST IF IN 'INIT' OR 'ADD'           
*                                                                               
         CD,R12   BLNK              WAS A VSN GIVEN IN THE COMMAND ?            
         BNE      ERROR44             YES, INVALID VSN                          
*                                                                               
         STD,R8   VSN               NO, USE DISC'S AS CORRECT VSN               
         PAGE                                                                   
         SPACE    2                                                             
INIT15   RES      0         IF IN 'ADD' INSURE ALL VTOC SECTORS ARE READ        
         MTW,+0   INITSW            ARE WE DOING AN 'ADD' ?                     
         BEZ      INIT20              NO, 'INIT'. GO FORM NEW VTOC              
*                                                                               
         LW,R15   VTOCNDS,R5        GET NUMBER OF SECTORS IN VTOC               
         CI,R15   1                 IS IT ONLY ONE ?                            
         BLE      INIT16              YES, GO GET INFO FROM IT                  
*                                                                               
         MW,R15   MASDWPS           CONVERT TO WORDS WE MUST READ               
         SLS,R15  2                 CONVERT TO BYTES AND SET FOR READ           
         STW,R15  RDDISC4           OF ENTIRE VTOC                              
         CAL1,1   RDDISC            READ IT ALL IN                              
*                                                                               
INIT16   RES      0         GET PREVIOUS ALLOCATIONS FROM VTOC                  
         LI,R4    BUFF3             SET INDEX TO SKIPPED SPACE HOLDING BUFFER   
         LW,R3    VTOCNAA,R5        GET NUMBER OF ALLOCATED AREAS               
         MI,R3    SIZAPCKT          CONVERT TO WORDS USED, THEN                 
         AI,R3    VTOCALOC           TO INDEX TO LAST ALLOCATED AREA +1         
         AW,R3    R5                NOW MAKE ACTUAL ADDRESS OF PACKET           
         LW,R2    R3                IN VTOC SECTOR; COPY FOR MOVE LOOP          
         AI,R2    -SIZAPCKT         ADJUST DOWN FOR INCREMENT NEXT              
*                                                                               
INIT17   RES      0         SEARCH FOR UNUSED SPACE PACKET                      
         AI,R2    SIZAPCKT          STEP TO NEXT PACKET                         
         LCI      SIZAPCKT          MOVE IT                                     
         LM,R12   PCKTNAME,R2                                                   
         LH,R0    R12               GET AREA NAME                               
         BEZ      INIT18            ZERO = UNUSED SPACE PACKET;                 
*                                                                               
         LCI      SIZAPCKT          MOVE TO SKIPPED AREA STORAGE  TEMP          
         STM,R12  PCKTNAME,R4       >> ASSUMES 4 WORDS PER PACKET <<<           
         AI,R4    SIZAPCKT          STEP TO POINT AT NEXT FREE SPACE            
         B        INIT17            LOOK AT NEXT ENTRY                          
*                                                                               
INIT18   RES      0         FREE SPACE PACKET FOUND; SAVE; GET INIT TYPE        
         LCI      SIZAPCKT          SAVE AWAY                                   
         STM,R12  MASDUSED                                                      
         AND,R12  M8                GET INIT TYPE FROM WHEN 'INIT'D             
         MTW,+00  INITYPE           WAS ONE INPUT WITH COMMAND ?                
         BGEZ     INIT29              YES, USE IT AS THE DEFAULT                
*                                                                               
         STW,R12  INITYPE             NO, USE DEFAULT FROM DISC                 
         B        INIT29            GO SET PTRS TO PREVIOUS ALLOCATN'S          
         PAGE                                                                   
         SPACE    2                                                             
*                 FORM A NEW CP-R FORMAT VTOC FOR THE DISC                      
*                                                                               
INIT20   RES      0         INITIALIZE A DISC                                   
         LW,R1    MASDWPS           SET SIZE OF A SECTOR                        
         LW,R8    R5                COPY START ADDRESS OF THE BUFFER            
         AI,R8    -1                ADJUST FOR CLEARING                         
         AW,R1    R1                DO 2 SECTORS' WORTH                         
         LI,R0    0                                                             
*                                                                               
INIT21   RES      0         CLEAR THE VTOC                                      
         STW,R0   *R8,R1                                                        
         STW,R0   BUFF3-1,R1        AND CLEAR SKIPPED AREA HOLDING AREA         
         BDR,R1   INIT21                                                        
*                                                                               
         LI,R1    22                MOVE THE 22 WORD BOOT STRAP                 
*                                                                               
INIT22   RES      0                                                             
         LW,R0    DISCBOOT-1,R1                                                 
         STW,R0   *R8,R1                                                        
         BDR,R1   INIT22                                                        
*                                                                               
*                           FORM VTOC WORDS 22 - 34 IN REGISTERS                
         LW,R9    KWVTOC            WORD 22 = 'VTOC'                            
         LCI      2                 MOVE THE VSN TO THE HEADER AS               
         LM,R10   VSN               THE LAST 2 WORDS OF THE                     
         STM,R10  VTOCVSN1,R5       BOOTSTRAP HEADER                            
         BAL,RLNK GETADATE          GET TODAY'S DATE AS INIT DATE               
         LD,R10   R12               COPY AS UPDATE DATE                         
         LW,R14   MASDWPS           MOVE DEVICE CONSTANTS                       
         LW,R15   MASDSPT                                                       
         LW,R0    MASDTPC                                                       
         LW,R1    MASDBOA                                                       
         LW,R2    MASDEOA                                                       
         LI,R3    VTOCDNDS          SET SIZE OF VTOC AREA                       
         LI,R4    0                 SET NUMBER OF ALLOCATED AREAS = 0           
         AW,R1    R3                ADJUST BEGIN OF SPACE AFTER VTOC            
         LCI      VTOCALOC-VTOCVTOC   STORE                                     
         STM,R9   VTOCVTOC,R5                                                   
         LI,R15   INITWPP           SET FIRST PACKET = UNUSED SPACE             
         LW,R0    INITYPE           GET USER INPUT INIT TYPE; ANY GIVEN         
         BGEZ     INIT24              YES, USE IT                               
*                                                                               
         LI,R0    INITOVR             NO, SET TO DEFAULT = 'OVR'                
         STW,R0   INITYPE           AND SAVE FOR AREA DEFAULTS                  
*                                                                               
INIT24   RES      0         STORE FREE SPACE PACKET IN VTOC, SPACE HOLE         
         LCI      SIZAPCKT                                                      
         STM,R15  VTOCALOC,R5       PUT IN VTOC'S FIRST POSSIBLE SPACE          
         STM,R15  MASDUSED          PUT IN AVAILABLE SPACE HOLE                 
         LI,R4    BUFF3             SET NO 'SKIP' PACKETS                       
         LI,R3    VTOCALOC          AND NO ALLOCATED AREAS                      
         AW,R3    R5                IN VTOC BUFFER                              
         B        INIT29            GO PROCESS ALLOCATION INFORMATION           
         PAGE                                                                   
         SPACE    2                                                             
INIT29   RES      0         AREA AND SKIP INFO SEPARATED; SAVE POINTERS         
         STW,R4   SKIPCKTL          SAVE LAST+1 SKIP PACKET ADDRESS             
         STW,R3   ALOPCKTL          SAVE LAST+1 AREA PACKET ADDRESS             
*                                                                               
*                           CONTENTS OF REGISTERS THAT ARE IMPORTANT            
*                                                                               
*        R3 :     LOC OF LAST+1 ALLOC PACKET IN VTOC BUFFER                     
*        R4 :     LOC OF LAST+1 'SKIP' PACKET IN BUFF3 (AND BUFF4)              
*        R5 :     ADDRESS OF VTOC ( = CONTENTS OF BPEND )                       
*        ALOPCKTL  HAS COPY OF R3                                               
*        SKIPCKTL  HAS COPY OF R4                                               
*                 THESE ARE SAVED AS THE LIMITS OF THE ALLOCATIONS READ         
*                 FROM THE DISC'S VTOC. THEY ARE USED TO TELL WHERE TO          
*                 START PERFORMING AREA INITIALIZATIONS FOR NEW AREAS.          
*                                                                               
*                                                                               
*                                                                               
*        THE VTOC (IN (BPEND) ) AND THE 'SKIP' PACKETS IN BUFF3 & BUFF4         
*        NOW LOOK AS IF THEY WERE JUST ALLOCATED, (OR, IF DOING AN              
*        'INIT', AS IF NOTHING HAS BEEN ALLOCATED YET).                         
*          NEW ALLOCATIONS WILL HAVE THEIR PACKETS ADDED TO THESE TWO           
*        LISTS STARTING AT  'INIT30'  BELOW IF WE ARE DOING AN  'ADD'.          
*          WHEN THE END OF THE COMMAND IS FOUND THE 'SKIP' LIST AND THE         
*        FREE SPACE PACKET WILL BE MOVED BACK TO THE VTOC AND THE VTOC          
*        WRITEN IF ANY CHANGES WERE MADE. IF NO NEW AREAS WERE DEFINED          
*        THE VTOC SECTOR IS NOT WRITTEN OUT.                                    
*          IN EITHER CASE, A MAP OF THE ALLOCATIONS IS THEN LISTED.             
         PAGE                                                                   
         SPACE    2                                                             
INIT30   RES      0         PROCESS NEW AREA ALLOCATIONS                        
         CI,R6    2                 END OF INPUT ?                              
         BE       INIT40              YES, WRITE VTOC IF NECESSARY              
*                                                                               
         BAL,LINK SCAN              GET AN AREA NAME                            
         CI,R6    -1                ERRORS FOUND ?                              
         BLE      ERROR02             YES, GIVE 'ERROR ITEM XX'                 
*                                                                               
         CW,R8    KWSKIP            IS THIS TO BE A SKIPPED AREA ?              
         BE       INIT33              YES, POINT AT SKIP AREA INFO              
*                                                                               
         CI,R10   2                 EXACTLY 2 CHARACTERS IN NAME ?              
         BNE      ERROR02             NO, ILLEGAL AREA NAME                     
*                                                                               
         LH,R8    R8                PROPOGATE SIGN OF AREA NAME                 
         LW,R2    R3                COPY LOC OF LAST ALLOC PACKET               
         LW,R10   VTOCNAA,R5        GET NUMBER OF AREAS NOW ALLOCATED           
         BEZ      INIT32            IF NONE, JUST ADD IT NOW                    
*                                                                               
INIT31   RES      0         INSURE NAME NOT ALREADY USED                        
         AI,R2    -SIZAPCKT         STEP TO PREVIOUS PACKET                     
         LW,R9    PCKTNAME,R2       GET NAME OF AN AREA                         
         CH,R8    R9                ARE THEY THE SAME ?                         
         BE       ERROR02             YES, DUPLICATE AREA NAME                  
*                                                                               
         BDR,R10  INIT31            AND LOOP TO TEST ALL                        
*                                                                               
INIT32   RES      0         AREA NAME UNIQUE: OK TO ADD IT                      
         MTW,+1   VTOCNAA,R5        STEP NUMBER OF ALLOCATED AREAS              
         LW,R2    R3                SET LOC WHERE TO BUILD NEW PACKET           
         AI,R3    SIZAPCKT          STEP POINTER TO NEXT FREE SPACE             
         B        INIT34            AND GO START PACKET BUILDING                
*                                                                               
INIT33   RES      0         FORM NAME FOR A SKIPPED AREA                        
         LI,R8    PCKTSKIP          GET SKIPPED AREA'S NAME                     
         LW,R2    R4                SET WHERE TO BUILD THE PACKET               
         AI,R4    SIZAPCKT          STEP POINTER TO NEXT FREE SPACE             
*                                                                               
INIT34   RES      0         PUT NAME IN PACKET AT (R2)                          
         SLS,R8   16                LEFT JUSTIFY NAME AND FORM A                
         STW,R8   PCKTNAME,R2       PARTIAL PCKT: = NAME ONLY HERE              
         MTW,+1   ADDSW             STEP COUNT OF NEWLY ALLOCATED AREAS         
         LI,R0    4                 SET TO SCAN # SECTORS IN DECIMAL            
         STW,R0   SPARAMF1                                                      
         BAL,LINK SCAN              GET NUMBER OF SECTORS TO ALLOCATE           
*                                                                               
         LI,R0    1                 RESET SCAN TO EBCDIC                        
         STW,R0   SPARAMF1                                                      
         CI,R6    0                 IF ERRORS OR NO MORE PARAMS ?               
         BNE      ERROR02             YES, REPORT 'ERROR ITEM XX'               
*                                                                               
         LW,R9    R8                COPY NUMBER OF SECTORS TO ALLOT             
         BLEZ     ERROR02           IF ZERO, 'ERROR ITEM XX'                    
*                                                                               
         AW,R9    MASDUSED+PCKTBOA  ADD FIRST FREE SECTOR                       
         AI,R9    -1                LAST SECTOR NEEDED                          
         CW,R9    MASDUSED+PCKTEOA                                              
         BG       INITERR1          B IF WONT FIT                               
         XW,R8    MASDUSED+PCKTBOA  SET NEW FIRST FREE; GET START               
*                                   OF NEW AREA                                 
         AWM,R8   MASDUSED+PCKTBOA  SET NEW FIRST FREE SECTOR                   
         LCI      2                 STORE BEGIN, END SECTOR IN PACKET           
         STM,R8   PCKTBOA,R2                                                    
         BAL,LINK SCAN              GET WRITE PROTECTION CODE                   
         CI,R6    -1                IF ANY ERRORS ?                             
         BLE      ERROR02             YES, REPORT                               
*                                                                               
         LI,R1    #WPCODES          SEARCH LIST OF LEGAL WP CODES               
*                                                                               
INIT35   RES      0         VALIDATE WRITE PROTECT CODE                         
         CW,R8    WPCODES,R1                                                    
         BE       INIT38            FOUND, OK                                   
         BDR,R1   INIT35            NOT FOUND YET, KEEP LOOKIN'                 
         B        ERROR02           NOT LEGAL; GIVE ERROR                       
*                                                                               
INIT38   RES      0         WRITE PROTECT CODE OK; PUT IN PACKET                
         AI,R1    -1                ADJUST TO BE ZERO RELATIVE (0, 1...)        
         OR,R1    PCKTNAME,R2       PUT IN RIGHT HALF OF 1ST WORD               
         STW,R1   PCKTNAME,R2                                                   
         LW,R1    INITYPE           GET DISC DEFAULT INIT TYPE                  
         STW,R1   PCKTINIT,R2       STORE IN PACKET                             
         CI,R6    0                 MORE PARAMS IN THIS GROUP ?                 
         BNE      INIT30              NO, USE DEFAULT; GET NEXT AREA IF ONE     
*                                                                               
         BAL,LINK SCAN              GET INIT TYPE                               
         CI,R6    0                 IF ANY ERRORS OR NOT END OPTION ?           
         BLE      ERROR02                                                       
*                                                                               
         BAL,RLNK INITCHKI          CHECK INIT TYPE                             
         B        ERROR02           ERROR; GIVE 'ERROR ITEM XX'                 
*                                                                               
         STW,R1   PCKTINIT,R2       STORE IN PACKET                             
         B        INIT30            GET NEXT AREA IF THERE IS ONE               
         PAGE                                                                   
         SPACE    2                                                             
INIT40   RES      0         END PARAMETER PROCESSING                            
*                                   IF ANYTHING CHANGED, REWRITE VTOC           
         MTW,+0   INITSW            ARE WE IN 'INIT' ?                          
         BEZ      INIT41              YES, WRITE NEW VTOC                       
*                                                                               
         MTW,+0   ADDSW             NO, WAS ANYTHING ADDED ?                    
         BEZ      INIT60              NO, JUST MAP VTOC                         
*                                                                               
         BAL,RLNK GETADATE          GET TODAY'S DATE                            
         LCI      2                 AND SET AS DATE WE DID THE 'ADD'            
         STM,R12  VTOCUDT1,R5       TO UPDATE THE VTOC                          
*                                                                               
INIT41   RES      0         COMBINE AREA, SKIP, AND FREE SPACE PACKETS          
         LW,R6    R3                COPY WHERE 1ST SKIP PCKT GOES               
         LI,R1    -BUFF3            ADJUST POINTER TO START OF NEW SKIP         
         AWM,R1   SKIPCKTL          PCKT TO POINT TO THEIR NEW LOCATION         
         AWM,R3   SKIPCKTL          IN THE VTOC BUFFER; THEN COMPUTE            
         AW,R1    R4                NUMBER OF WORDS OF SKIP PCKT INFO           
         LW,R8    R6                COPY LOC OF LAST+1 ALLOC PACKET             
         AI,R8    -1                ADJUST FOR BDR LOOP AND ITS INDEX 0         
         AW,R6    R1                AND SET NEW END OF VTOC INFO IN R6          
*                                                                               
         CI,R1    0                                                             
         BLE      INIT42A           B IF NO SKIP WORDS TO MOVE                  
INIT42   RES      0         MOVE 'SKIP' PACKETS TO AFTER ALLOC PACKETS          
         LW,R0    BUFF3-1,R1                                                    
         STW,R0   *R8,R1                                                        
         BDR,R1   INIT42                                                        
*                                                                               
INIT42A  RES      0                                                             
         LCI      SIZAPCKT          NOW MOVE THE FREE SPACE PACKET              
         LM,R12   MASDUSED                                                      
         STM,R12  PCKTNAME,R6                                                   
         PAGE                                                                   
         SPACE    2                                                             
*           ALOPCKTL = LOC OF 1ST NEW AREA PCKT IN VTOC BUFFER                  
*           SKIPCKTL = LOC OF 1ST NEW SKIP PCKT IN VTOC BUFFER                  
*           R3       = LOC OF LAST+1 AREA PCKT IN VTOC BUFFER                   
*           R4       = LOC OF LAST+1 SKIP PCKT IN BUFF3 & BUFF4                 
*           R6       = LOC OF AVAIL SPACE PCKT IN VTOC BUFFER                   
*                                                                               
*        TEST IF VTOC STILL FITS IN THE SPACE ALLOTED FOR IT                    
*                                                                               
         LW,R9    R6                COMPUTE NUMBER OF SECTORS NEEDED            
         AI,R9    SIZAPCKT          SET TOTAL LENGTH OF VTOC INFO               
         SW,R9    R5                AND CONVERT BACK TO WORD COUNT              
         LI,R8    0                                                             
         AW,R9    MASDWPS           ROUND IT UP TO NEXT FULL SECTOR             
         AI,R9    -1                                                            
         DW,R8    MASDWPS                                                       
         CW,R9    VTOCNDS,R5        IS VTOC STILL BIG ENOUGH ?                  
         BLE      INIT48              YES, GO WRITE IT OUT                      
*                                                                               
*     VTOC GREATER THAN ALLOWED SPACE:                                          
*        IF IN 'INIT', ADJUST ALL SECTOR ADDRESSES UP BY THE NUMBER THE         
*        VTOC GREW.                                                             
*        IF IN 'ADD', CHECK IF FIRST ALLOCATED AREA IS A 'SKIP', AND IF         
*        SO, SHRINK ITS SIZE TO MAKE ROOM FOR LARGER VTOC. IF THE SIZE          
*        OF THE 'SKIP' AREA GOES TO ZERO, OR THE 1ST AREA IS NOT A              
*        'SKIP' AREA, DISC OVERFLOW HAS OCCURRED.                               
*                                                                               
         MTW,+00  INITSW            ARE WE IN 'INIT' ?                          
         BEZ      INIT43              YES, ADJUST SECTOR ADDRESSES              
*                                                                               
         STW,R9   VTOCNDS,R5        SET NEW NUMBER OF VTOC SECTORS              
         CI,R4    BUFF3             ARE THERE ANY SKIPPED AREAS ?               
         BE       INITERR1            NO, DISC OVERFLOW                         
*                                                                               
         LW,R0    PCKTBOA,R3        YES, GET ITS START SECTOR                   
         CW,R0    VTOCBOA,R3        IS IT START OF ALLOCATABLE SPACE ?          
         BNE      INITERR1            NO, ERROR; OVERFLOW                       
*                                                                               
         CW,R9    PCKTEOA,R3        WILL ANY ROOM REMAIN IN SKIP AREA ?         
         BGE      INITERR1            NO, ERROR                                 
*                                                                               
         STW,R9   PCKTBOA,R3        YES, SET NEW START SECTOR                   
         STW,R9   VTOCBOA,R5        IN PACKET AND VTOC                          
         B        INIT48            AND WRITE VTOC                              
*                                                                               
INIT43   RES      0         ADJUST START/END SECTORS FOR LARGER VTOC            
         SW,R9    VTOCNDS,R5        GET NUMBER OF SECTORS VTOC GREW             
         AWM,R9   VTOCNDS,R5        AND STEP VTOC SIZE THAT MANY                
         AWM,R9   VTOCBOA,R5        AND START OF AVAIL SPACE ON DISC            
         LW,R7    R5                COPY ADDRESS OF START OF VTOC               
         AI,R7    VTOCALOC          COMPUTE START OF ALLOC PACKETS              
*                                                                               
INIT44   RES      0         ADJUST START/END SECTORS FOR AREA PACKETS           
         CW,R7    R6                HAVE WE REACHED THE SPACE PACKET ?          
         BGE      INIT45              YES, FIX IT UP AND WRITE VTOC             
*                                                                               
         AWM,R9   PCKTBOA,R7                                                    
         AWM,R9   PCKTEOA,R7                                                    
         AI,R7    SIZAPCKT                                                      
         B        INIT44            LOOP TO TEST/DO NEXT                        
*                                                                               
INIT45   RES      0         ADJUST FREE SPACE PACKET                            
         AW,R9    VTOCBOA,R7        COMPUTE NEW BEGINNING OF FREE SPACE         
         STW,R9   VTOCBOA,R7                                                    
         AI,R9    -1                ALLOW OVERFLOW 1 SECTOR: = FULL             
         CW,R9    VTOCEOA,R7        ANY SPACE LEFT ?                            
         BG       INITERR1            NO, EXCEEDED SPACE AVAILABLE              
*                                                                               
INIT48   RES      0         WRITE VTOC                                          
         LW,R9    VTOCNDS,R5        GET NUMBER OF VTOC SECTORS TO WRITE         
         LI,R8    0                                                             
         STW,R8   WRDISC5           SET TO START AT SECTOR 0                    
         MW,R8    MASDWPS           CONVERT TO WORDS                            
         SLS,R9   2                 THEN TO BYTES,                              
         STW,R9   WRDISC4           AND SET IN WRITE FPT                        
         CAL1,1   WRDISC            WRITE THEM OUT                              
         PAGE                                                                   
         SPACE    2                                                             
INIT50   RES      0         PERFORM 'INIT' OPTIONS FOR NEW AREAS                
         LW,R15   MASDWPS           COMPUTE NUMBER OF WORDS NEEDED BY           
         MW,R15   VTOCNDS,R5        THE VTOC IN THE BUFFER SPACE                
         LW,R1    BACKSZE           END OF BUFFER SPACE - END OF VTOC           
         SW,R1    R15               = WORDS FREE FOR CLEAR THE DISC             
         CW,R1    MASDWPS           IS THERE AT LEAST 1 SECTOR ?                
         BL       ERROR19             NO, ERROR: NOT ENUF BCKG SPACE            
*                                                                               
         AW,R15   R5                MAKE IT THE ADDRESS OF LAST+1 AND           
         STW,R15  BIBUFF            SET WHERE TO START WRITES FROM              
         AI,R15   -1                ADJUST FOR CLEAR BDR LOOP                   
         LI,R0    0                                                             
         LW,R2    R1                COPY NUMBER OF WORDS IN BUFFER SPACE        
*                                                                               
INIT51   RES      0         CLEAR THE UNUSED BUFFER SPACE                       
         STW,R0   *R15,R2                                                       
         BDR,R2   INIT51                                                        
*                                                                               
         DW,R1    MASDWPS           CONVERT TO NUMBER OF SECTORS                
         LW,R2    R1                AND SAVE IN R2                              
         LW,R7    ALOPCKTL          GET POINTER TO 1ST NEW AREA PCKT            
*                                                                               
INIT52   RES      0         INITIALIZE DISC FOR AN AREA ALLOCATION              
         CW,R7    R3                HAVE WE REACHED LAST PCKT ?                 
         BGE      INIT54              YES, GO DO SKIP PACKETS                   
*                                                                               
         BAL,RLNK INITAREA          PERFORM INITIALIZATION                      
         AI,R7    SIZAPCKT          STEP TO NEXT PACKET                         
         B        INIT52            AND TEST IF DONE                            
*                                                                               
INIT54   RES      0         PROCESS SKIP AREAS                                  
         LW,R7    SKIPCKTL          POINT AT 1ST NEW SKIP AREA                  
*                                                                               
INIT55   RES      0         INITIALIZE DISC FOR SKIP ALLOCATION                 
         CW,R7    R6                HAVE WE DONE THE LAST NEW ONE ?             
         BGE      INIT57              YES, TEST IF CLEAR AVAIL SPACE            
*                                                                               
         BAL,RLNK INITAREA          PROCESS THE AREA                            
         AI,R7    SIZAPCKT          STEP TO NEXT PACKET                         
         B        INIT55            AND LOOP FOR NEXT                           
*                                                                               
INIT57   RES      0         PROCESS FREE SPACE                                  
         MTW,+0   INITSW            ARE WE IN 'INIT' ?                          
         BGZ      INIT60              NO, 'ADD' - DON'T RECLEAR FREE SPAE       
*                                                                               
         LW,R7    R6                POINT AT FREE SPACE PACKET                  
         BAL,RLNK INITAREA          AND CLEAR IT                                
*                                                                               
*                                                                               
INIT60   RES      0         OUT MAP OF NEW ALLOCATIONS AND EXIT                 
         BAL,R14  INITMAP           OUT THE MAP                                 
         PRTPAG                     SKIP TO A NEW PAGE                          
         CAL1,1   CLFLEIN           INSURE DISC DCB CLOSED HERE                 
         B        EXEC1             GO GET NEXT COMMAND                         
         PAGE                                                                   
         SPACE    2                                                             
INITMAP  RES      0         OUT VTOC MAP OF (UPDATED OR ERROR) DISC             
         PUSH     R14               SAVE LINK FOR CALLING OTHER SUBROUTS        
         SETCP    CPI2-1            SET CP TO INDENT COLUMN #2                  
         STRNG    AHDR0             OUT PAGE HEADER LINE                        
         LI,R2    VTOCVSN1          POINT AT VSN IN VTOC                        
         AW,R2    R5                                                            
         CHARS    8                 OUT THE 8 CHARS WORTH                       
         CHAR     C''''             OUT CLOSING QUOTE                           
         CHAR     C' '              AND AN EXTRA SPACE                          
         PRTPAG                     PRINT ON A NEW PAGE                         
         PRTUP    2                 SKIP 2 LINES                                
         SETCP    CPI2              RESET CP                                    
         STRNG    AHDR1I            OUT THE 'INITIALIZIED' MESSAGE              
         STEPCP   1                                                             
         LW,R2    R5                SET LOC OF VTOC START                       
         AI,R2    VTOCDAT1          AND POINT AT INIT DATA                      
         CHARS    8                 OUT THE DATE                                
         MTW,+0   INITSW            ARE WE DOING AN 'INIT' ?                    
         BEZ      INITMAP2            YES, OUT DEVICE DISC IS ON                
*                                                                               
         PRNT                       ELSE PRINT INIT DATE AND THEN               
         SETCP    CPI2              OUT WHEN LAST 'ADD' WAS DONE                
         STRNG    AHDR1A            ENTER 'UPDATED '                            
         LW,R2    R5                SET LOC OF VTOC START AND THEN              
         AI,R2    VTOCUDT1          POINT AT THE LAST UPDATE DATE               
         CHARS    8                  ENTER DATE LAST UPDATED                    
         MTW,+00  ADDSW             WERE WE DOING AN 'ADD' UPDATE ?             
         BGZ      INITMAP2            YES, GO OUT DEVICE ADDRESS,TOO            
*                                                                               
         PRNT                       NO, JUST MAP; PRINT UPDATE DATE             
         SETCP    CPI2              RESET CP                                    
         LI,R2    AHDR1M            SET TO OUTPUT 'MAPPED'                      
         MTW,+00  ADDSW             IS THAT WHAT WE ARE DOING ?                 
         BGEZ     %+2                 YES, SO OUT IT                            
*                                                                               
         LI,R2    AHDR1X            NO, ERROR MAP: POINT AT 'ERROR MAP'         
*                                                                               
         STRNG                      OUT WHATEVER WE JUST DECIDED                
         BAL,RLNK GETADATE          GET TODAY'S DATE                            
         CHARS    8,R12             AND ENTER IT AS DATE OF MAP                 
*                                                                               
INITMAP2 RES      0         OUT WHERE DISC IS MOUNTED                           
         STEPCP   3                 SPACE 3 COLUMNS                             
         STRNG    AHDR1L            OUT 'MOUNTED ON DEVICE '                    
         CHARS    6,MASDDEVA        OUT DEVICE NAME                             
         PRTUP    2                 PRINT AND SKIP A LINE                       
         SETCP    CPI1              SET CP TO INDENT COLUMN 1                   
         STRNG    AHDR2             ENTER DEVICE CONSTANTS HEADER               
         PRTUP    2                 PRINT, SPACE A LINE                         
         LI,R7    (AHDR3END-AHDR3)/(AHDR31-AHDR3)   SET NUMBER OF LINES         
         LI,R8    AHDR3             SET LOC OF START OF MESSAGES                
         LI,R9    VTOCWPS           SET LOC OF START OF DATA                    
         AW,R9    R5                                                            
*                                                                               
INITMAP4 RES      0         OUT 5 LINES OF DEVICE INFO                          
         SETCP    CPI2                                                          
         LW,R2    R8                SET LOC OF TEXT                             
         STRNG                      ENTER TEXT                                  
         LW,R15   *R9                                                           
         INTGR    DEC,SPAC,5                                                    
         PRNT                       PRINT IT                                    
         AI,R9    1                 STEP TO NEXT VALUE                          
         AI,R8    AHDR31-AHDR3                                                  
         BDR,R7   INITMAP4          DO 5 LINE'S WORTH                           
*                                                                               
         PRTUP    2                 SPACE 2 LINES                               
         SETCP    CPI1                                                          
         STRNG    AHDR4             OUT 'AREA ALLOCATION:' LINE                 
         PRTUP    2                                                             
         SETCP    CPI2              OUT COLUMN HEADERS                          
         STRNG    AHDR45                                                        
         PRNT                                                                   
         LI,R8    1                 SET AREA SEQUENCE NUMBER                    
         LI,R7    VTOCALOC          SET ADDRESS OF 1ST ALLOC PACKET             
         AW,R7    R5                                                            
*                                                                               
INITMAP5 RES      0         TEST FOR AND PROCESS AN AREA ALLOC PACKET           
         LW,R10   PCKTNAME,R7       GET AREA'S NAME                             
         LH,R12   R10                                                           
         AND,R12  M16                                                           
         CI,R12   PCKTSKIP          IS IT A SKIP PACKET                         
         BE       INITMAP7            YES, END OF AREAS; DO SKIP INFO           
*                                                                               
         CI,R12   PCKTAVAL          IS IT THE AVAILABLE SPACE PACKET ?          
         BE       INITMAP9            YES, END OF PACKET INFO                   
*                                                                               
         BAL,R14  ADDMAP            OUT A LINE OF INFO                          
         B        INITMAP5          AND TEST IF MORE TO DO                      
*                                                                               
INITMAP7 RES      0         PROCESS 'SKIP' PED PACKETS                          
         PRTUP    2                 SPACE AFTER AREA ALLOCATION INFO            
         SETCP    CPI1                                                          
         STRNG    AHDR5             OUT 'SKIPPED AREA:' MESSAGE                 
         PRTUP    2                                                             
         LI,R8    1                 SET INDEX NUMBER FOR SKIPPED AREAS          
*                                                                               
INITMAP8 RES      0         PROCESS A 'SKIP' PACKET                             
         LW,R10   PCKTNAME,R7       GET THE NAME                                
         LH,R12   R10                                                           
         CI,R12   PCKTAVAL          IS THIS THE AVAILABLE SPACE PACKET ?        
         BE       INITMAP9            YES, OUT THAT INFO                        
*                                                                               
         BAL,R14  ADDMAPS           OUT A LINE OF SKIP AREA INFO                
         B        INITMAP8          LOOP TO TEST FOR ANOTHER                    
*                                                                               
INITMAP9 RES      0         READY TO DO 'AVAILABLE SPACE' INFO                  
         PRTUP    2                 SPACE 2 LINES                               
         SETCP    CPI1                                                          
         STRNG    AHDR6             OUT 'SPACE REMAINING:' MESSAGE              
         PRTUP    2                                                             
         BAL,R14  ADDMAPA           OUT FREE SPACE INFO                         
         PULL     R14               RECOVER LINK                                
         B        *R14              AND RETURN                                  
         PAGE                                                                   
         SPACE    2                                                             
INITERR1 RES      0         ALLOCATIONS EXCEED SPACE; GIVE ERROR MAP            
         LI,R0    -1                SET NOT IN 'INIT' OR 'ADD'                  
         STW,R0   INITSW            TO FORCE TO SPECIAL LINE IN MAP             
         STW,R0   ADDSW                                                         
         CLRPL                      CREATE A LINE FULL OF '*' AS THE            
         LI,R15   C'*'              MAP'S TITLE LINE TO HELP SHOW IT            
         LI,R1    132               IS AN ERROR MAP, NOT THE REAL ONE           
         CHAR                       OUT THE '*' CHAR 132 TIMES                  
         BDR,R1   %-1                                                           
         BAL,R14  INITMAP           THEN OUT THE MAP                            
         B        ERROR01           THEN GIVE NORMAL 'DISC OVERFLOW' ERR        
         PAGE                                                                   
         SPACE    2                                                             
INITCHKI RES      0         CHECK INITIALIZATION CODES                          
         CI,R10   4                 IS THE STRING TOO BIG FOR INIT CODES        
         BG       *RLNK               YES, RETURN NOT INIT CODE                 
*                                                                               
         LI,R1    #INICODS                                                      
*                                                                               
INICHKIA RES      0         SEARCH LIST FOR GIVEN ONE                           
         CW,R8    INITCODS,R1       IS IT THIS ONE                              
         BE       INICHKIB            YES, RETURN                               
         BDR,R1   INICHKIA          NO, TRY ANOTHER                             
         B        *RLNK             NOT LEGAL; RETURN NOT FOUND                 
*                                                                               
INICHKIB RES      0         FOUND, RETURN INDEX                                 
         AI,R1    -1                ADJUST TO A ZERO RELATIVE INDEX             
         AI,RLNK  1                                                             
         B        *RLNK                                                         
         PAGE                                                                   
         SPACE    2                                                             
GETADATE RES      0         GET DAY'S DATE, CONVERT TO FORM 'JUL04 76'          
         CAL1,8   %9GETOD           GET TODAY'S DATE                            
         LCI      2                                                             
         LM,R12   %9TOD+1           GET 'X MON DD' FOR INIT DATE                
         LI,R0    C' '                                                          
         STB,R0   R12               MAKE LOOK LIKE '  MON DD'                   
         SCD,R12  8                 SHIFT TO ' MON DD '                         
         SCS,R13  8                 THEN 'MONDD  '                              
         SCD,R12  8                 AND THEN 'MONDD   '                         
         LW,R0    %9TOD+3           GET WORD WITH YEAR, THUS ',;YY'             
         AND,R0   M16               REMOVE EXTRA JUNK - '--YY'                  
         OR,R13   R0                AND PRODUCE 'MOND' 'D YY'                   
         B        *RLNK             RETURN WITH DATE IN R12 & R13               
         PAGE                                                                   
         SPACE    2                                                             
*                 R2 = MAX NUMBER OF SECTORS IN BUFFER SPACE OF ZEROS           
*                 R7 = ADDRESS OF PACKET TO PROCESS                             
*                 R14= RETURN ADDRESS                                           
*                                                                               
*                                                                               
INITAREA RES      0         PERFORM AREA INITIALIZATION                         
         LW,R15   PCKTINIT,R7       GET AREAS INIT CODE                         
         AND,R15  M16                                                           
         CI,R15   INITOVR           IS IT 'OVR', NO CLEARING AT ALL ?           
         BE       *RLNK               YES, RETURN ALL DONE                      
*                                                                               
         LW,R9    MASDWPS           GET WORDS IN ONE SECTOR                     
         LW,R0    PCKTBOA,R7        GET START SECTOR OF AREA                    
         STW,R0   WRDISC5           AND SET AS SECTOR TO WRITE                  
         CI,R15   INITFAST          'FAST' INIT, = CLEAR 1 SECTOR ONLY ?        
         BE       INIAREA6            YES, GO CLEAR THE 1 SECTOR                
*                                                                               
*                          CLEAR ENTIRE AREA                                    
         LW,R1    PCKTEOA,R7        GET NUMBER OF SECTORS TO CLEAR              
         SW,R1    R0                END - BEGIN + 1                             
         AI,R1    1                                                             
         MW,R9    R2                COMPUTE # WORDS IN BUFFER SPACE             
         SLS,R9   2                 AND CONVERT TO BYTES FOR FPT                
         STW,R9   WRDISC4                                                       
*                                                                               
INIAREA2 RES      0         WRITE 1 BUFFER SPACE'S WORTH OF ZEROS               
         CW,R1    R2                MORE THAN 1 BUFFER SPACE LEFT TO GO?        
         BLE      INIAREA4            NO, WRITE A SHORT WRITE'S WORTH           
*                                                                               
         CAL1,1   WRDISC            CLEAR R2 SECTORS WORTH                      
         AWM,R2   WRDISC5           STEP SECTOR ADDRESS                         
         SW,R1    R2                AND DECREMENT SECTOR YET TO WRITE           
         B        INIAREA2          AND TRY SOME MORE                           
*                                                                               
INIAREA4 RES      0         COMPUTE SIZE OF LAST WRITE                          
         LW,R9    MASDWPS           WORDS PER SECTOR * NUMBER OF                
         MW,R9    R1                SECTORS LEFT TO CLEAR                       
*                                                                               
INIAREA6 RES      0         CLEAR DIRECTORY OR REMAINING SECTORS                
         SLS,R9   2                 CONVERT TO BYTES                            
         STW,R9   WRDISC4                                                       
         CAL1,1   WRDISC                                                        
         B        *RLNK             RETURN                                      
         PAGE                                                                   
         SPACE    2                                                             
ADDMAP   RES      0         OUT A LINE OF MAP INFO FOR A AREA                   
         PUSH     R14               SAVE LINK                                   
         SETCP    CPAREA            SET CP FOR AREA NAME, THEN                  
         CHARS    2,R10,0           OUT AREA NAME                               
         B        ADDMAP2           CONTINUE AFTER 'SKIP' INFO ENTRY            
*                                                                               
ADDMAPS  RES      0         OUT A LINE OF MAP INFO FOR A SKIP AREA              
         PUSH     R14               SAVE RETURN                                 
*                                                                               
ADDMAP2  RES      0         OUT A LINE STARTING WITH PROTECT CODE               
         SETCP    CPWPC             SET CP                                      
         LW,R2    R10               COPY WRITE PROTECT CODE                     
         AND,R2   M7                EXTRACT IT OUT                              
         AI,R2    WPCODES+1         INDEX INTO TABLE                            
         CHARS    4                 AND OUT IT                                  
         SETCP    CPI2              SET START COLUMN FOR INDEX                  
         INTGR    DEC,SPAC,2,R8     OUT AREA INDEX NUMBER                       
         CHAR     C'.'              AND . AFTER IT                              
         B        ADDMAP3           CONTINUE AFTER 'FREE SPACE' ENTRY           
*                                                                               
ADDMAPA  RES      0         OUT A LINE OF MAP INFO FOR AVAILABLE SPACE          
         PUSH     R14               SAVE RETURN                                 
*                                                                               
ADDMAP3  RES      0         OUT A LINE STARTING WITH BOA                        
         SETCP    CPBOA             SET CP                                      
         LW,R15   PCKTBOA,R7        GET BEGIN SECTOR                            
         INTGR    DEC,SPAC,5        OUT A 5 DIGIT NUMBER                        
         SETCP    CPEOA                                                         
         LW,R15   PCKTEOA,R7        GET END SECTOR                              
         INTGR                      OUT ANOTHER 5 DIGIT NUMBER                  
         SETCP    CPINIT            SET CP FOR INIT CODE                        
         LW,R2    PCKTINIT,R7       GET INIT TYPE                               
         AI,R2    INITCODS+1        SET LOC OF EBCDIC STRING                    
         CHARS    4                 AND OUT IT                                  
         PRNT                       PRINT 1 LINE OF INFO                        
         AI,R7    SIZAPCKT          STEP TO NEXT PACKET                         
         AI,R8    1                 STEP INDEX NUMBER                           
         PULL     R14               RECOVER RETURN ADDRESS                      
         B        *R14              AND GO BACK                                 
         PAGE                                                                   
         SPACE    2                                                             
*                                   TITLES FOR 'INIT' & 'MAP' MAPS              
AHDR0    TXTC     ' ALLOCATION FOR DISC '''                                     
AHDR1I   TXTC     'INITIALIZED'                                                 
AHDR1A   TXTC     'UPDATED ON'                                                  
AHDR1M   TXTC     'MAPPED ON'                                                   
AHDR1X   TXTC     '*** ERROR MAP ***'                                           
AHDR1L   TXTC     'MOUNTED ON DEVICE '                                          
AHDR2    TXTC     'DEVICE CONSTANTS:'                                           
AHDR3    TXTC     'WORDS PER SECTOR:    '                                       
AHDR31   TXTC     'SECTORS PER TRACK:   '                                       
         TXTC     'TRACKS PER CYLINDER: '                                       
         TXTC     'BEGIN SECTOR:        '                                       
         TXTC     'END SECTOR:          '                                       
         TXTC     'VTOC SIZE IN SECTORS:'                                       
AHDR3END RES      0                          END OF DEVICE CONSTANT MSGS        
*                                                                               
AHDR4    TXTC     'AREA ALLOCATION:'                                            
AHDR45   TXTC     '    AREA  WP    BOA    EOA   INIT'                           
AHDR5    TXTC     'SKIPPED AREAS:'                                              
AHDR6    TXTC     'SPACE REMAINING:'                                            
         PAGE                                                                   
         SPACE    2                                                             
DISCBOOT EQU      %%        BASE OF BOOT STRAP WRITTEN TO DISC VTOC             
BOOT     ASECT                      MAKE AN ABSOLUTE SECTION                    
         ORG      DISCBOOT          BUT LOAD IT HERE                            
         LOC      BOOT+X'2A'        AND MAKE EXECUTE FROM LOC X'2A' ...         
BOOTBEGN RES      0         OUT 'NOT SYSLOAD' AND DISC'S VSN                    
         LI,R0    DA(BOOT7)         WRITE OUT OUR NAME                          
         SIO,R0   001               TO TYA01                                    
         BCS,12   %-1               LOOP UNTIL TYPE STARTS                      
*                                                                               
BOOT1    RES      0         LOOP TO SOUND TONE WHILE THE OPERATOR               
         LI,R5    50000             FIGURES OUT WHERE SYSLOAD IS                
*                                                                               
BOOT2    RES      0                                                             
         STD,R5   R2                                                            
         WD,0     X'41'                                                         
         BDR,R2   %                                                             
         WD,0     X'40'                                                         
         BDR,R3   %                                                             
         LW,R3    R5                                                            
         SLS,R3   -3                                                            
         SW,R5    R3                                                            
         BDR,R5   BOOT2             LOOP AND DO IT ALL AGAIN                    
         B        BOOT1                                                         
*                                                                               
*                                                                               
BOOT7    GEN,8,24 5,BA(BOOTMSG)     WRITE, LOC OF MESSAGE                       
         GEN,8,24 8,BA(BOOTEND)-BA(BOOTMSG)   HTE, LENGTH OF MESSAGE IN BYTES   
*                                                                               
BOOTMSG  DATA     X'1515D5D6'       CR, CR, 'N', 'O'                            
         TEXT     ' LOAD. VSN='                                                 
BOOTVSN  TEXT     'A NO NO!'                                                    
*                                                                               
*                                                                               
BOOTEND  EQU      %                                                             
*                                                                               
*                                                                               
         USECT    DISCBOOT                                                      
         ORG      DISCBOOT+(BOOTEND-BOOTBEGN)                                   
       ELSE     CPRE00                                                          
INIT     RES      0         DUMMY ROUTINE FOR THE 'INIT' COMMAND                
ADD      RES      0         DUMMY ROUTINE FOR THE 'ADD'  COMMAND                
         B        ERROR02           GIVE 'ERROR ITEM 01'                        
         FIN                        #PRIV                                       
         TITLE    '     E D I T   DEVICE/AREA/FILE '                            
         SPACE    2                                                             
*        FORMAT OF COMMAND:                                                     
*                                 --    OPTIONAL PARAMETERS        --           
*                                 |                                 |           
*                                 |                                 |           
*                   YYNDD         |                                 |           
*        :XDMP    ( OP          ) | ,(FILE,II),(FROM,MM),(TO,NN)    |           
*                   FID           |                                 |           
*                                 |                                 |           
*                                 --                               --           
*                                                                               
*                                                                               
*                           COLUMN INDICIES FOR OUTPUT INFORMATION              
*                                   INDEXED VALUES: 0 = PRINT; 1 = TTY          
CPDATE   SET      40                POSITION OF DATE IN TITLE LINE              
INDENT   SET      12                START COL FOR DUP LINES MESSAGE             
CPBYTE   SET      1                 START COLUMN FOR BYTE ADDRESS               
CPHEX    DATA      14,12            START COLUMNS FOR HEX DATA                  
CPSR1    DATA      99,55            COLUMN FOR '*' BEFORE GRAPHICS              
CPSR2    DATA     132,72            COLUMN FOR '*' AFTER  GRAPHICS              
BPL      GEN,16,16 32,16            DATA BYTES PER OUTPUT LINE                  
WPL      GEN,16,16 08,04            DATA WORDS PER OUTPUT LINE                  
*                           INDENT CP VALUES FOR DUP LINES INSERTS              
CPIN46   DATA     INDENT+46,2*INDENT+46+1                                       
CPIN53   DATA     INDENT+53,2*INDENT+53+1                                       
CPIN67   DATA     INDENT+67,2*INDENT+67+1                                       
CPIN74   DATA     INDENT+74,2*INDENT+74+1                                       
XDTITL   DATA     XDPMSG0,XDPMSG00  TITLE LINE FOR HEX DISPLAY LINES            
*                                                                               
*                                                                               
KWFROM   TEXT     'FROM'                                                        
KWTO     TEXT     'TO  '                                                        
         PAGE                                                                   
         SPACE    2                                                             
XDMP     RES      0                                                             
         PRNT                       INSURE LINE CLEARED; M:LO DCB OPEN          
         LI,R2    M:LO              GET TYPE OF DEVICE M:LO ASSIGNED            
         CAL1,1   GETAINFO          TO AND TEST FOR NOT A PRINTER               
         LI,R0    1                 ASSUME A TTY TYPE DEVICE                    
         LH,R15   MASDDEVA          GET DEVICE NAME AND EXTRACT OUT             
         AND,R15  M16               ITS TYPE                                    
         CI,R15   C'TY'             IS IT A TYPEWRITER TYPE ?                   
         BE       XDMP0               YES, SET TYPE = TTY                       
         CI,R15   C'LN'             IS IT A TERMINAL OF ANY SORT ?              
         BE       XDMP0               YES, ALSO A TTY TYPE                      
*                                                                               
         LI,R0    0                 NO, SET TYPE = PRINTER                      
*                                                                               
XDMP0    RES      0         SET TYPE OF OUTPUT LISTING DEVICE                   
         STW,R0   XDTTYSW           0 <== PRINTER; 1 <= TTY/TERMINAL            
         LD,R0    ZEROS             CLEAR AREA AND FILENAME TO NONE             
         STD,R0   FILENAME                                                      
         STW,R0   AREANAME                                                      
         STW,R0   TMCOUNT           SET NO E-O-F S FOUND YET                    
         STW,R0   XDFILESW          SET FILENAME NOT SPECIFIED TO XDMP          
         LI,R0    XDPMSG2           INIT MESSAGE TO PROCESSING                  
         STW,R0   XDPMSG             'RECORDS'                                  
         LI,R0    RDDISC            AND CAL TO READ BY SECTORS ON DISC,         
         STW,R0   XDMPCAL           RECORDS ON OTHER DEVICES                    
         LI,R13   -1                GET A CONSTANT NEEDED EVERYWHERE            
         BAL,LINK GETANY            GET DEVICE/OPLB/FILE ID                     
         CI,R6    -1                ERRORS ?                                    
         BLE      ERROR02             YES, GIVE 'ERROR ITEM XX'                 
         PAGE                                                                   
         SPACE    2                                                             
         LW,R0    GIOCT             GET BITS FOR INPUT SPECIFICATION            
         CW,R0    GIODBIT           IS IT A DEVICE ?                            
         BAZ      XDMP20              NO, TRY FILE OR OPLABEL                   
         CI,R6    0                 IF ANY SUBFIELD MODIFIERS OF NAME ?         
         BE       ERROR02             IT IS AN ERROR                            
*                                                                               
         LI,R2    F:BI              POINT AT DCB WE WILL USE                    
         CAL1,1   ASNDEV            ASSIGN DEVICE TO DCB, THEN GET NAME         
         CAL1,1   GETAINFO          OTHER INFO ON IT                            
*                                                                               
XDMP1    RES      0         TEST DEVICE FOR A DISC OR RAD                       
         STRNG    XDPMSGD           ENTER 'DEVICE ' PART OF MESSAGE             
         CHARS    6,MASDDEVA        AND THEN THE DEVICE'S NAME                  
         LH,R8    MASDDEVA                                                      
         AND,R8   M16                                                           
         CI,R8    C'DP'             IS IT A DISC ?                              
         BE       XDMP27              YES, XDMP DISCS DIFFERENTLY               
*                                                                               
         CI,R8    C'DC'             IS IT A RAD ?                               
         BE       XDMP27              YES, DO SAME AS A DISC                    
         PAGE                                                                   
         SPACE    2                                                             
XDMP2    RES      0         XDMP A DEVICE BY BLOCKS (RECORDS)                   
         BAL,RLNK XDMPLIMS          GET START, END, FILE PARAMS                 
         LI,R15   XDPEFN1           SET ERR FUNCTION FOR SKIPPING FILES         
         STW,R15  ERRFCN                                                        
         STEPCP   4                 SPACE AWAY FROM DEVICE NAME                 
         CHARS    5,XDPMSGF,1       ENTER 'FILE ' OF FILE NUMBER                
         LAW,R15  NFIL              GET ABS(FILE NUMBER),                       
         INTGR    DEC,SPAC,3         THEN ENTER THE FILE'S NUMBER               
         LI,R2    F:BI              RESET ADDR OF DCB WE ARE USING              
         LAW,R1   NFIL              GET WHICH FILE WE ARE TO XDMP               
         AW,R1    R13               ADJUST FOR FIRST = 0                        
         BLEZ     XDMP4             DO FIRST; NO SKIPS                          
         PAGE                                                                   
         SPACE    2                                                             
XDMP3    RES      0         SKIP OUT TO FILE 'NFIL'                             
         CAL1,1   SKIPFILE          SKIP THE FILE: R2 = DCB = F:BI              
         BAL,R8   XDMP16            SIMULATE AN END-FILE CONDITION              
         AW,R1    R13               DECREMENT COUNT                             
         BLEZ     XDMP4             NOW AT BEGIN OF DESIRED FILE: DO IT         
*                                                                               
         CAL1,1   RDDISC            READ NEXT RECORD TO TEST FOR E-O-F          
         MTW,+1   TMCOUNT           SET NO E-O-F FOUND                          
         B        XDMP3             AND TRY TO SKIP ANOTHER FILE                
*                                                                               
XDMP4    RES      0         POSITION TO SPECIFIED RECORD IN FILE                
         LI,R15   XDPEFN2           SET NEW ERR FUNCTION                        
         STW,R15  ERRFCN                                                        
         LW,R1    SRECVAL           GET BLOCK NUMBER                            
         BGZ      XDMP5               IF > 0 USE AS GIVEN                       
*                                                                               
         MTW,+1   SRECVAL           IF = 0, SET = 1 ==> 1ST BLOCK               
         LI,R1    1                 AND SET LOOP COUNTER = 1 TOO                
*                                                                               
XDMP5    RES      0         TEST IF BLOCK POSITIONING NEEDED                    
         AW,R1    R13               NUMBER OF BLKS-1 TO SKIP                    
         BLEZ     XDMP10            NONE NEEDED: BEGIN XDMPING                  
*                                                                               
XDMP6    RES      0         SKIP THE DESIRED BLOCKS                             
         CAL1,1   RDDISC            READ BLOCK, TEST FOR E-O-F                  
         MTW,+1   TMCOUNT           NO E-O-F: STEP COUNT                        
         BDR,R1   XDMP6             LOOP FOR ANOTHER BLOCK                      
         PAGE                                                                   
*                                                                               
*                                                                               
***********************************************************************         
***********************************************************************         
*                                                                               
XDMP10   RES      0         START OF XDMP A BLOCK LOOP                          
         SETCP    CPDATE            POINT WHERE THE DATE GOES                   
         DATE                       AND ENTER IT                                
         LI,R1    34                MOVE TITLE LINE TO TITLE BUFFER             
         LW,R0    %PL-1,R1                                                      
         STW,R0   %TITLINE-1,R1                                                 
         BDR,R1   %-2                                                           
*                                                                               
         PRTPAG                     SKIP TO NEW PAGE AND PRINT TITLE            
         PRTUP    3                 OF WHAT WE ARE DOING; SPACE 3 LINES         
         LI,R1    %TITLINE          SET TITLE LINE PRESENT SW & LOC             
         STW,R1   %19@4                                                         
         LI,R15   XDPEFN0           SET ERROR PROCESSING FUNCTION TABLE         
         STW,R15  ERRFCN                                                        
         LW,R7    XDTTYSW           SET INDEX TO M:LO'S OUTPUT CONSTANTS        
*                                                                               
*                                                                               
XDMP12   RES      0         GET A BLOCK                                         
         LW,R1    SRECVAL           GET BLOCK TO XDMP NEXT                      
         CW,R1    ERECVAL           ARE WE DONE ?                               
         BG       XDMP14              YES, EXIT                                 
*                                                                               
         STW,R1   RDDISC5           NO, SET BLOCK TO READ                       
         BAL,RLNK XDMPBLK           XDMP THE BLOCK                              
         MTW,+1   SRECVAL           STEP BLOCK NUMBER                           
         B        XDMP12            LOOP AND SEE IF DONE                        
         PAGE                                                                   
         SPACE    2                                                             
XDMP13   RES      0         OUT RECORD OR FILE AFTER WHICH WE STOPPED           
         AI,R15   -1                -1 FOR THE ZEROTH WE DON'T DO               
         STRNG                      OUT MESSAGE OF WHAT HAPPENED                
         INTGR    DEC,SPAC,3        OUT THE NUMBER IN QUESTION                  
         PRNT                       PRINT THE ERROR MESSAGE                     
*                                                                               
*                                                                               
XDMP14   RES      0         END OF XDMP: OUT STOP MESSAGE                       
         PRNT                       SPACE ANOTHER LINE                          
         PRTTXT   XDPMSGND                                                      
         LI,R0    0                 RESET TITLE LINE PRESENT SWITCH             
         STW,R0   %19@4                                                         
         PRTUP    2                                                             
         CAL1,1   CLFLEIN           INSURE DCB IS CLOSED                        
         B        EXEC1             AND GO GET A NEW COMMAND                    
         PAGE                                                                   
         SPACE    2                                                             
XDMP15   RES      0         XDMP ABORTED BY OPERATOR 'X' KEY-IN                 
         PRTTXT   XDPMSGX           SAY THAT ON THE LISTING                     
         B        XDMP14            AND EXIT                                    
*                                                                               
XDMP16   RES      0         E-O-F OR !EOD FOUND; MAKE NOTE, TEST FOR 2          
         CW,R13   TMCOUNT           IS THIS SECOND IN A ROW ?                   
         BGE      XDMP18              YES, SAY END OF INPUT                     
*                                                                               
         MTW,+1   MASDNFIL          STEP FILE COUNT                             
         STW,R13  TMCOUNT           NO, SET FIRST FOUND                         
         B        *R8               RETURN AFTER READ FOR NEXT                  
*                                                                               
XDMP17   RES      0         E-O-T FOUND; OUT MESSAGE AND STOP                   
         PRTTXT   XDPMSGM           SAY 'END-OF-TAPE' FOUND                     
         B        XDMP14            AND SAY END OF XDMP                         
*                                                                               
XDMP18   RES      0         DOUBLE E-O-F S FOUND; OUT MESSAGE AND STOP          
         LI,R2    XDPMSGT           POINT AT 'E-O-F FOUND' MSG                  
         LAW,R15  MASDNFIL          GET FILE NUMBER WE ARE AT                   
         B        XDMP13            AND GO OUT MESSAGE AND STOP                 
*                                                                               
XDMP19   RES      0         END OF FILE OR DATA ON RECORD SKIP IN A FILE        
         LI,R2    XDPMSGEF          POINT AT 'NO MORE FILES' MSG                
         LW,R15   SRECVAL           GET RECORD WE WERE SKIPPING TO              
         SW,R15   R1                MINUS NUMBER ALREADY SKIPPED                
         B        XDMP13            AND GO OUT MESSAGE AND STOP                 
         PAGE                                                                   
         SPACE    2                                                             
XDMP20   RES      0         PROCESS 2 CHARACTER NAMES                           
         CW,R0    GIOFBIT           IS A FILE OR AREA SPECIFIED ?               
         BAZ      XDMP30              NO, TRY OPLABEL                           
*                                                                               
XDMP22   RES      0         GET INFO ABOUT AN AREA OR FILE                      
         LW,R1    GIOFA             SET MASK FOR FILE & ACCOUNT NAMES           
         STS,R0   ASNFILE+1         PBITS AND SET AS PER NAMES GIVEN            
         LI,R2    F:BI              POINT AT THE DCB WE USE IN XDMP             
         CAL1,1   ASNFILE                                                       
         CAL1,1   GETFILNM          GET AREA NAME IF PUBLIC WAS SPECIFIED       
         CAL1,1   GETAINFO          GET DEVICE CONSTANTS                        
*                                                                               
XDMP23   RES      0         OUT FILE OR AREA NAME TO XDMP                       
         MTW,+0   FILENAME          IS A FILENAME PRESENT ?                     
         BEZ      XDMP26              NO, ASSUME AN AREA TO XDMP                
*                                                                               
         STRNG    XDPMSGF           ENTER 'FILE ' PART OF TITLE MSG             
         LB,R15   C' '              TRUNCATE OFF TRAILING BLANKS                
         LI,R1    7                  ON FILE NAME                               
*                                                                               
XDMP24   RES      0         LOOK FOR LAST NON-BLANK CHARACTER                   
         CB,R15   FILENAME,R1                                                   
         BNE      XDMP25              FOUND; OUT LENGTH IN R1                   
         BDR,R1   XDMP24            ANOTHER BLANK; CUT OFF AND LOOK ON          
*                                                                               
XDMP25   RES      0         NAME LENGTH IN R1: OUT R1 CHARACTERS                
         AI,R1    1                 INCLUDE LAST CHAR IN LENGTH                 
         CHARS    ,FILENAME                                                     
         CHAR     C'.'              FOLLOWED BY '.' SEPARATOR                   
         CHARS    2,AREANAME,2       AND AREA NAME                              
         MTW,+1   XDFILESW          MARK PROCESSING A FILE                      
         B        XDMP27            AND GO GET XDMP LIMITS                      
*                                                                               
XDMP26   RES      0         FORM TITLE LINE FOR AN AREA XDMP                    
         STRNG    XDPMSGA           ENTER 'AREA '                               
         CHARS    2,AREANAME,2       THEN THE AREA'S NAME                       
*                                                                               
XDMP27   RES      0         XDMP DISC/RAD DEVICES, AREAS, OR FILES              
         BAL,RLNK XDMPLIMS          GET OPTIONS, LIMITS, IF GIVEN               
         LI,R2    F:BI              POINT AT INPUT DCB                          
         MTW,+00  XDFILESW          ARE WE PROCESSING A FILE ?                  
         BEZ      XDMP28              NO, XDMP BY SECTORS                       
*                                                                               
         MTW,+00  XDRECSW           YES, IS IT TO BE BY RECORDS ?               
         BEZ      XDMP28              NO, BY SECTORS                            
*                                                                               
         CAL1,1   GETRSIZE          YES, BY RECORDS; GET RECORD SIZE            
         STW,R0   RDSDISC4          AND SET AS SIZE TO READ                     
         LI,R0    RDSDISC           AND SET READ-BY-RECORDS-CAL AS THE          
         STW,R0   XDMPCAL           CAL TO READ WITH                            
         B        XDMP10            AND THEN GO DO THE XDMP EDITS               
*                                                                               
XDMP28   RES      0         XDMP DISC/RAD, ETC, BY SECTORS                      
         LI,R0    XDPMSG1           SET MESSAGE TO SAY BY 'SECTOR' S            
         STW,R0   XDPMSG                                                        
         LI,R0    0                 AND RESET FILE SWITCH TO 'NO'               
         STW,R0   XDFILESW          TO INSURE USE OF CORRECT CAL                
         LW,R0    MASDWPS           SET SIZE OF RECORDS TO READ                 
         SLS,R0   2                 = SECTOR SIZE IN BYTES                      
         STW,R0   RDDISC4                                                       
         CAL1,1   SETGSIZ           SET GRANULE SIZE = SECTOR SIZE              
         LW,R0    MASDEOA           INSURE END OF XDMP LIMIT < END FILE         
         CW,R0    ERECVAL           ASKING TO XDMP TOO MUCH ?                   
         BGE      XDMP29              NO, USE GIVEN END REC                     
*                                                                               
         STW,R0   ERECVAL           YES, SET END FILE/DISC/AREA AS END          
*                                                                               
XDMP29   RES      0         READY TO START XDMP:                                
         B        XDMP10            GO START XDMPING                            
         PAGE                                                                   
         SPACE    2                                                             
XDMP30   RES      0         PROCESS AN OPLABEL                                  
         CW,R0    GIOOBIT           IS AN OPLABEL SPECIFIED ?                   
         BAZ      ERROR02             NO, NOTHING OR SOMETHING ILLEGAL: ERROR   
         CI,R6    0                 DOES ANOTHER SUBFIELD FOLLOW ?              
         BLE      ERROR02             YES, ERROR; 'ERROR ITEM XX'               
*                                                                               
         STRNG    XDPMSGO           ENTER 'OP ' PART OF OPLB TITLE              
         CHARS    2,OPLBASGN,2       THEN THE OPLABEL ITSELF                    
         STRNG    XDPMSGQ            AND FINALLY THE ' = ' SEPARATOR            
         LI,R2    F:BI              SET DCB                                     
         CAL1,1   ASNOPLB           ASSIGN OPLABEL                              
         LI,R0    0                 CLEAR AREA NAME RETURN SPOT                 
         STW,R0   AREANAME          AS IT IS ALSO OPLABEL ASSIGN SPOT           
         STW,R0   MASDDEVA          SET NO DEVICE NAME, => NULL DEVICE          
         CAL1,1   GETAINFO          GET DEVICE INFO                             
         CAL1,1   GETFILNM          AND FILE NAME IF ANY                        
         CW,R0    MASDDEVA          IS IT ASSIGNED TO 'NULL'  ?                 
         BEZ      XDMP36              YES, SAY END                              
*                                                                               
         CW,R0    AREANAME          WAS THE AREA NAME CHANGED ?                 
         BNE      XDMP23              YES, AREA OR FILE: GO PROCESS             
         B        XDMP1             GO TEST TYPE OF DEVICE                      
         PAGE                                                                   
         SPACE    2                                                             
XDMP36   RES      0         XDMP NULL DEVICE: SAY SAME AND STOP                 
         STRNG    XDPMSGN                                                       
         PRTUP    2                                                             
         B        XDMP14            GO STOP                                     
         PAGE                                                                   
         SPACE    2                                                             
XDMPLIMS RES      0         GET XDMP LIMITS                                     
         LI,R0    0                 SET DEFAULT VALUES                          
         STW,R0   SRECVAL                                                       
         STW,R0   XDRECSW           SET NOT TO XDMP FILES BY RECORDS            
         LI,R0    1                                                             
         STW,R0   MASDNFIL          SET FILE NOW POSITIONED AT = 1ST            
         LI,R0    -1                SET SKIPPING NO FILES, AND NOW AT           
         STW,R0   NFIL              BEGINNING OF 1ST FILE                       
         LI,R0    X'7FFFF'          SET LAST REC = VERY LARGE                   
         STW,R0   ERECVAL                                                       
         LW,R0    BPEND             SET BUFFER = BACKGROUND BUFFER SPACE        
         STW,R0   BIBUFF                                                        
         LW,R0    BCKSZE            SET BUFFER SPACE IN BYTES AS                
         STW,R0   RDDISC4           NUMBER OF BYTES TO READ                     
         CI,R0    65535             IS IT BIGGER THAN MAX READ POSSIBLE?        
         BLE      XDMPLIM1            NO, USE IT                                
*                                                                               
         LI,R0    65536             YES, SET READ TO MAX                        
         STW,R0   RDDISC4                                                       
*                                                                               
*                                                                               
XDMPLIM1 RES      0         PROCESS XDMP LIMITS                                 
         CI,R6    2                 ANY MORE PARAMS ?                           
         BE       XDMPLIM4            NO, CHECK SREC =< EREC                    
*                                                                               
         LI,R0    1                 SET TO SCAN IN EBCDIC FOR KEWWORD           
         STW,R0   SPARAMF1                                                      
         BAL,LINK SCAN              GET A KEWWORD                               
         PAGE                                                                   
         SPACE    2                                                             
         LW,R9    ML24              GET MASK FOR KEYWORD TESTS                  
         LI,R1    SRECVAL           ASSUME NAME IS 'FROM'                       
         CW,R8    KWFROM            IS IT                                       
         BE       XDMPLIM2            YES, GET ITS VALUE                        
*                                                                               
         LI,R1    ERECVAL           TRY 'TO'                                    
         CW,R8    KWTO              IS IT THAT ?                                
         BE       XDMPLIM2            YES, GET ITS VALUE                        
*                                                                               
         LI,R1    NFIL              NOW ASSUME 'FILE'                           
         CS,R8    KWFILE            NOW ASSUME 'FILE'                           
         BE       XDMPLIM2            YES, GET FILE NUMBER                      
*                                                                               
         CS,R8    KWRECS            IS IT 'RECS' FOR BY 'RECORDS' ?             
         BNE      ERROR02             NO, FATAL ERROR; 'ERROR ITEM XX'          
*                                                                               
         MTW,+1   XDRECSW           YES, SET 'BY RECORDS' SWITCH                
         B        XDMPLIM3          AND TEST IF OPTIONS ENDED OK                
*                                                                               
XDMPLIM2 RES      0         GET VALUE PARAMETER FOR GIVEN KEYWORD               
         CI,R6    0                 DOES ANY OPTION FOLLOW ?                    
         BNE      ERROR02             NO, ONE MUST; GIVE AN ERROR               
*                                                                               
         MTW,+3   SPARAMF1          SET TO SCAN IN DECIMAL                      
         BAL,LINK SCAN              GET THE NUMBER                              
         STW,R8   0,R1              SAVE VALUE OF PARAM                         
*                                                                               
XDMPLIM3 RES      0         TEST FOR ERRORS IN PARAM                            
         CI,R6    0                 IF NOT END OF CARD OR OPTION ?              
         BLE      ERROR02             GIVE 'ERROR ITEM XX'                      
*                                                                               
         B        XDMPLIM1          GO GET NEXT PARAM IF ANY                    
*                                                                               
XDMPLIM4 RES      0         CHECK FOR EREC > SREC                               
         LW,R0    SRECVAL                                                       
         CW,R0    ERECVAL           ARE THEY IN ORDER ?                         
         BLE      *RLNK               YES, RETURN OK                            
*                                                                               
         LW,R8    KWFROM            SET ERROR IN OPTION 'FROM'                  
         B        ERROR05                                                       
         PAGE                                                                   
         SPACE    2                                                             
*                 THIS ROUTINE NEED NOT BE A SUBROUTINE, AS IT IS               
*                 CALLED FROM ONLY ONE PLACE.  HOWEVER, IT MAKES THE            
*                 PROGRAM FLOW A BIT EASIER TO FOLLOW HERE THAN IT              
*                 WOULD IF IT WERE CODED IN-LINE.                               
*                                                                               
*                                                                               
*                                                                               
XDMPBLK  RES      0         XDMP A BLOCK OF DATA                                
         PUSH     R14               SAVE LINK                                   
         LW,R12   BPEND             COMPUTE BA (START OF BUFFER)                
         SLS,R12  2                                                             
         LW,R2    XDPMSG            GET ADDRESS OF MESSAGE                      
         STRNG                      OUT WHAT WE ARE XDMPING (SEC/BLK)           
         INTGR    DEC,SPAC,5,SRECVAL    AND ITS NUMBER                          
         CAL1,1   *XDMPCAL          READ NEXT RECORD/SECTOR                     
*                                                                               
         STRNG    XDPMSG5           OUT '   LENGTH = '                          
         PAGE                                                                   
         SPACE    2                                                             
XDMPBLK1 RES      0         ENTRY FOR BLOCK > BUFFER                            
         MTW,+1   TMCOUNT           SET TAPEMARK NOT FOUND                      
         LW,R15   RDDISC6           GET ACTUAL RECORD SIZE AND TYC              
         MTW,+00  XDFILESW          READING DISCS BY RECORDS ?                  
         BEZ      %+2                 NO, USE COUNT FROM SECTOR READ            
         LW,R15   RDSDISC6          YES, GET RECORD'S BYTE SIZE                 
*                                                                               
         AND,R15  M17               AND REMOVE TYC                              
         STW,R15  XDPEND            SAVE LENGTH                                 
         INTGR    DEC,SPAC,5        OUT LENGTH IN BYTES                         
         CHAR     C' '                                                          
         CHAR     C'('                                                          
         INTGR    HEX,,,XDPEND      AND LENGTH IN HEX                           
         STRNG    XDPMSG6           AND ') BYTES' PART OF MESSAGE               
         LW,R0    %19@3             START XDMP ON NEW PAGE IF LESS THAN         
         CI,R0    5                 5 LINES LEFT ON CURRENT PAGE                
         BG       XDPB0               MORE THAN 5; CONTINUE ON THIS PAGE        
*                                                                               
         EJECT                      SKIP TO NEW PAGE, OUT TITLE                 
         PRTUP    -3                SPACE AWAY FROM TITLE 2 LINES               
*                                                                               
XDPB0    RES      0         PRINT DATA HEADER; SET LIMITS                       
         PRTUP    2                 PRINT AND SPACE A LINE                      
         PRTTXT   XDTITL,R7         OUT APPROPRIATE COLUMN HEADERS              
         AWM,R12  XDPEND            COMPUTE BA(LAST BYTE+1) TO PRINT            
         MTW,-1   XDPEND            CONVERT TO LAST ADDR                        
         LW,R4    R12               SET ADDRESS OF 1ST BYTE                     
         PAGE                                                                   
         SPACE    2                                                             
XDPB1    RES      0         START DISPLAY OF A LINE                             
         STW,R4   XDPBEG            SAVE WHERE WE STARTED                       
         SETCP    CPHEX,R7          SET START COLUMN FOR HEX DATA               
         LH,R3    BPL,R7            AND SET BYTES PER LINE COUNT                
*                                                                               
XDPB2    RES      0         TEST IF SPACES BETWEEN WORDS NEEDED                 
         CW,R4    XDPEND            ARE WE DONE                                 
         BG       XDPB5               YES,                                      
*                                                                               
         CI,R3    X'3'              ARE WE STILL IN A WORD ?                    
         BANZ     XDPB4               YES, NO SPACES THERE                      
*                                                                               
         LI,R15   2                 NO, 2 SPACES BETWEEN WORDS                  
         CI,R3    X'F'              BETWEEN A GROUP OF 4 WORDS ?                
         BANZ     XDPB3               NO, JUST 2 SPACES                         
*                                                                               
         AI,R15   1                 YES, MAKE IT 3                              
*                                                                               
XDPB3    RES      0         INSERT SPACES BETWEEN WORDS                         
         STEPCP                                                                 
*                                                                               
XDPB4    RES      0         CONVERT A BYTE                                      
         LB,R15   0,R4              GET THE NEXT BYTE                           
         SLS,R15  -4                RIGHT JUSTIFY THE LEFT DIGIT                
         BAL,R14  XDPDIGIT          CONVERT AND ENTER IT                        
         LB,R15   0,R4              GET BYTE AGAIN                              
         BAL,R14  XDPDIGIT          CONVERT AND ENTER RIGHT DIGIT               
         AI,R4    1                 STEP TO NEXT BYTE                           
         BDR,R3   XDPB2             LOOP TO SEE IF ANOTHER BYTE TO GO           
*                                                                               
XDPB5    RES      0         HEX CONVERSION DONE; ENTER EBCDIC                   
         SETCP    CPSR1,R7          SET CP FOR LEADING '*'                      
         CHAR     C'*'              AND ENTER IT                                
         LW,R2    XDPBEG            GET WHERE WE STARTED                        
*                                                                               
XDPB6    RES      0         ENTER EBCDIC AND CONVERT NON-PRINTABLES             
         LI,R15   C'.'              SET CHAR FOR A NON-PRINTABLE                
         LB,R1    0,R2              GET THE BYTE                                
         CI,R1    X'40'             CAN IT BE PRINTABLE ?                       
         BAZ      XDPB8               NO, ENTER THE '.'                         
         CI,R1    X'C0'             ADJUST TO LOWER HALF OF TABLE ?             
         BL       XDPB7               NO                                        
         AI,R1    -X'C0'                                                        
*                                                                               
XDPB7    RES      0                                                             
         LB,R15   XDPXLATE,R1       CONVERT BYTE                                
*                                                                               
XDPB8    RES      0         ENTER (CONVERTED) BYTE                              
         CHAR                                                                   
         AI,R2    1                 STEP TO NEXT BYTE                           
         CW,R2    R4                HAVE WE FINISHED THE LINE ?                 
         BL       XDPB6               NO, GET ANOTHER BYTE                      
*                                                                               
         SETCP    CPSR2,R7          ENTER CLOSING '*'                           
         CHAR     C'*'                                                          
         SETCP    CPBYTE            SET CP FOR BYTE ADDRESS                     
         LW,R15   XDPBEG                                                        
         SW,R15   R12               COMPUTE AND                                 
         INTGR    HEX,ZERO,5        ENTER START BYTE ADDR FOR LINE              
         STEPCP   2                 SPACE OVER TO WORD ADDRESS                  
         LW,R15   XDPBEG                                                        
         SW,R15   R12               RECOMPUTE BYTE ADDRESS,                     
         SLS,R15  -2                CONVERT TO WORDS                            
         INTGR                      AND ENTER                                   
*                                                                               
XDPB10   RES      0         PRINT ONE LINE OF OUTPUT                            
         PRNT                                                                   
         CW,R4    XDPEND            ARE WE DONE WITH THIS BLOCK ?               
         BG       XDPB20              YES, EXIT                                 
*                                                                               
         LB,R2    K:PAGE            TEST IF WE HAVE JUST DONE A                 
         AI,R2    -1                PAGE, AND OUT HEADERS AGAIN                 
         CW,R2    %19@3             IF SO                                       
         BG       XDPB11              NOT A NEW PAGE; CONTINUE                  
*                                                                               
         PRTUP    2                 NEW PAGE: SPACE DOWN FROM TITLE             
         PRTTXT   XDTITL,R7         REPRINT APPROPRIATE COLUMN HEADERS          
*                                                                               
XDPB11   RES      0         LOOK FOR DUPLICATE LINES                            
         LW,R5    XDPEND            GET END ADDRESS AND                         
         SLD,R4   -2                CONVERT ADDRESSES TO WORD ADDRESSES         
         LW,R3    R4                COPY CURRENT ADDR TO LOOK FOR DUPS          
         LI,R0    -1                SET NO DUPLICATE LINES FOUND                
*                                                                               
XDPB12   RES      0         COMPARE LAST, NEXT LINE FOR MATCH                   
         AH,R3    WPL,R7            STEP TO WA(NEXT LINE+1)                     
         CW,R3    R5                IS THIS BEYOND BLOCK END ?                  
         BG       XDPB14              YES, TEST IF ANY DUPLICATES               
*                                                                               
         LCH,R2   WPL,R7            SET 4*NUMBER OF BYTES TO COMPARE            
*                                                                               
XDPB13   RES      0         COMPARE EACH BYTE OF THE LINES, 4-AT-A-TIME         
         LW,R15   *R2,R4            LAST LINE                                   
         CW,R15   *R2,R3            WITH NEXT                                   
         BNE      XDPB14              A NON-MATCH                               
         BIR,R2   XDPB13            STILL MATCHING, TRY NEXT                    
*                                                                               
         AI,R0    1                 STEP COUNT OF MATCHING LINES                
         B        XDPB12            AND TEST NEXT LINE                          
*                                                                               
XDPB14   RES      0         END OF MATCHES:                                     
         SH,R3    WPL,R7            POINT AT START OF NON-MATCHING LINE         
         SLS,R3   2                 RECONVERT ADDRESSES TO                      
         SLS,R4   2                 BYTE ADDRESSES                              
         MTW,+0   R0                ARE THERE AT LEAST 2 DUPLICATES ?           
         BLEZ     XDPB1               NO, JUST PRINT THE LINE                   
*                                                                               
         SETCP    INDENT            YES, OUT DUP MESSAGE                        
         STRNG    XDPMSGB           OUT DUP MSG SKELETON                        
         MTW,+00  R7                ARE WE OUTPUTTING TO A PRINTER ?            
         BEZ      XDPB15              YES, DO NOTHING SPECIAL                   
*                                                                               
         CHAR     X'15'             NO, ENTER NEW LINE CODE FOR TTYS            
         STEPCP   INDENT            AND INDENT FOR REST OF NEXT LINE.           
*                                                                               
XDPB15   RES      0         ENTER 'BYTES AND WORDS' PART OF MESSAGE             
         STRNG    XDPMSGBC          ON SAME OR WHAT WILL BE NEXT LINE.          
         SETCP    INDENT+6          POINT AT START ADDRESS SPOT                 
         LW,R15   R4                COPY BYTE ADDR,                             
         SW,R15   R12               RELATIVIZE,                                 
         INTGR    HEX,ZERO,5        OUT BA(START)                               
         SETCP    INDENT+15         SET CP TO SPOT FOR BA(END)                  
         LW,R15   R3                COPY END ADDRESS + 1                        
         SW,R15   R12                                                           
         AI,R15   -1                                                            
         INTGR                      AND ENTER                                   
         SETCP    CPIN53,R7         SET CP FOR LENGTH IN HEX BYTES              
         LW,R8    R3                COMPUTE LENGTH                              
         SW,R8    R4                                                            
         LW,R15   R8                                                            
         INTGR    ,,5               5 DIGITS (HEX, ZERO SAFE FROM BEFORE        
         SETCP    CPIN46,R7         SET CP FOR LENGTH IN DEC BYTES              
         LW,R15   R8                                                            
         INTGR    DEC               AND ENTER IN DECIMAL                        
         SETCP    CPIN67,R7         SET CP FOR LENGTH IN DEC WORDS              
         SLS,R8   -2                CONVERT BYTE ADDRESS TO WORDS               
         LW,R15   R8                ENTER DUP SIZE IN WORDS, DECIMAL            
         INTGR                                                                  
         SETCP    CPIN74,R7         SET CP FOR LENGTH IN HEX WORDS              
         INTGR    HEX,,,R8          ENTER WORD LEN IN HEX                       
         LW,R4    R3                SET NEW START OF NEXT LINE                  
         B        XDPB10            GO PRINT LINE                               
*                                                                               
*                                                                               
XDPB20   RES      0         END OF BLOCK (RECORD); RETURN TO CALLER             
         PRTUP    2                 SPACE 2 EXTRA LINES                         
         PULL     R14               RECOVER LINK                                
         B        *R14              AND RETURN                                  
         PAGE                                                                   
*                           ERROR ROUTINES FOR XDMPBLK                          
*                                                                               
XDPB30   RES      0         BLOCK GREATER THAN BUFFER PROCESSOR                 
         STRNG    XDPMSG7           ENTER MESSAGE                               
         B        XDMPBLK1          AND THEN XDMP BLOCK NORMALLY                
*                                                                               
XDPB31   RES      0         E-O-F OR !EOD FOUND                                 
         PRTTXT   XDPMSG4           ENTER 'TAPEMARK' MESSAGE                    
         CW,R13   TMCOUNT           IS THIS THE SECOND IN A ROW ?               
         BGE      XDPB33              YES, SAY WE ARE DONE                      
*                                                                               
         MTW,+0   NFIL              ARE WE XDMPING A SPECIFIC FILE ?            
         BGEZ     XDPB32              YES, E-O-F FOUND: STOP HERE.              
*                                                                               
         MTW,+1   MASDNFIL          STEP FILE COUNT                             
         STW,R13  TMCOUNT           MARK IT FOUND                               
         B        XDPB20            AND EXIT XDMPBLOCK                          
*                                                                               
XDPB32   RES      0         END OF SPECIFIED FILE FOUND: REPORT SIZE            
         PRTUP    2                 SPACE 2 LINES FROM TAPEMARK MESSAGE         
         LI,R2    XDPMSGEF          POINT AT E-O-F MESSAGE                      
         LW,R15   SRECVAL           GET LAST RECORD NUMBER READ + 1             
         PULL     R14               CLEAR STACK                                 
         B        XDMP13            REPORT FILE SIZE & THAT WE STOPPED          
*                                                                               
XDPB33   RES      0         DOUBLE E-O-F'S FOUND                                
         PRTUP    2                                                             
         PULL     R14               CLEAR STACK                                 
         B        XDMP18            AND GO STOP                                 
         PAGE                                                                   
         SPACE    2                                                             
XDPB34   RES      0         END OF TAPE FOUND:                                  
         PULL     R14               CLEAR STACK                                 
         B        XDMP17            GO REPORT IT AND STOP                       
*                                                                               
XDPB35   RES      0         IRRECOVERABLE ERROR READING A BLOCK                 
         PRTTXT   XDPMSG3           OUT MESSAGE SAYING WHAT HAPPENED            
         B        XDPB20            AND ASSUME DONE WITH THE BLOCK              
*                                                                               
*                                                                               
XDPDIGIT RES      0         ENTER A DIGIT IN PRINT LINE                         
         AND,R15  M4                GET JUST DIGIT TO OUTPUT                    
         AI,R15   X'F0'             CONVERT TO EBCDIC X'F0' - X'FF'             
         CI,R15   X'F9'             IS IT A PRINTABLE EBCDIC ?                  
         BLE      %4                  YES, ENTER IT                             
         AI,R15   -(X'FA'-X'C1')    NO CONVERT TO 'A' - 'F'                     
         B        %4                AND ENTER                                   
         PAGE                                                                   
*                                                                               
XDPMSG0  TXTC     ' BYTE  (WORD)   ',;                                          
                  ' 0 (0/8)   4 (1/9)   8 (2/A)   C (3/B)   ',;                 
                  '10 (4/C)  14 (5/D)  18 (6/E)  1C (7/F)   ',;                 
                  '*0   4   8   C   10  14  18  1C  *'                          
XDPMSG00 TXTC     ' BYTE  (WORD) ',;                                            
                  ' 0  (+0)   4  (+1)   8  (+2)   C  (+3)  ',;                  
                  '*0   4   8   C   *'                                          
XDPMSG1  TXTC     '   SECTOR '                                                  
XDPMSG2  TXTC     '   RECORD '                                                  
XDPMSG3  TXTC     '     UNABLE TO READ BLOCK: IRRECOVERABLE ERROR'              
XDPMSG4  TXTC     '     FILE MARK'                                              
XDPMSG5  TXTC     '   LENGTH = '                                                
XDPMSG6  TXTC     ') BYTES'                                                     
XDPMSG7  TXTC     '   LENGTH GREATER THAN BUFFER: '                             
*                                                                               
XDPMSGA  TXTC     'AREA   '                                                     
XDPMSGD  TXTC     'DEVICE '                                                     
XDPMSGF  TXTC     'FILE   '                                                     
XDPMSGO  TXTC     'OP '                                                         
XDPMSGQ  TXTC     ' = '                                                         
*                                                                               
XDPMSGB  TXTC     'BYTES XXXXX TO XXXXX IDENTICAL TO ABOVE LINE; '              
XDPMSGBC TXTC     'DDDDD (XXXXX) BYTES, DDDDD (XXXXX) WORDS.'                   
XDPMSGEF TXTC     '     END-OF-FILE FOUND AFTER RECORD '                        
XDPMSGM  TXTC     '     E-O-T FOUND:  XDMP STOPPED'                             
XDPMSGT  TXTC     '     DOUBLE  E-O-F''S FOUND AFTER FILE '                     
XDPMSGN  TXTC     '     NULL DEVICE --  CANNOT XDMP'                            
XDPMSGX  TXTC     '     REQUEST ABORTED BY OPERATOR'                            
XDPMSGND TXTC     '        END OF XDMP '                                        
*                                                                               
XDPXLATE TXT      '.ABCDEFGHI.......JKLMNOPQR......'                            
         TXT      '..STUVWXYZ......0123456789......'                            
         TXT      ' .........`.<(+|&.........!%*);~'                            
         TXT      '-/........^,%ž>?..........:#@''="'                           
         PAGE                                                                   
*                                                                               
*                 ERROR FUNCTION TABLES FOR  'XDMP'                             
*                                                                               
*                                                                               
XDPEFN0  RES      0           READING BLOCKS TO XDMP                            
         ERRP     X'07',XDPB30      DATA > BUFFER; REPORT IT                    
         ERRP     X'06',XDPB31      E-O-F (TM); REPORT AND REMEMBER IT          
         ERRP     X'05',XDPB31      !EOD; REPORT AND REMEMBER                   
         ERRP     X'1C',XDPB34      E-O-T; REPORT AND STOP                      
         ERRP     X'41',XDPB35      FATAL ERROR; REPORT NOT XDMPABLE            
         ERRP     X'4D',XDMP15      OPER ABORT; REPORT SAME                     
         ERRP     X'FF',0           ALL OTHERS; CONTINUE IN ROOT                
*                                                                               
*                                                                               
*                                                                               
XDPEFN1  RES      0           SKIP FILES (ON TAPE) TO GET TO FILE II            
         ERRP     X'07',0           DATA > BUFFER; IGNORE                       
         ERRP     X'06',XDMP16      E-O-F (TM); MAKE NOTE OF IT                 
         ERRP     X'05',XDMP16      !EOD; MAKE NOTE OF IT                       
         ERRP     X'1C',XDMP17      E-O-T; STOP                                 
         ERRP     X'41',0           IRRECOVERABLE ERROR; SKIP & CONTINU         
         ERRP     X'4D',XDMP15      OPER ABORT; TERMINATE XDMP                  
         ERRP     X'FF',0           ALL OTHERS; GO TO ROOT                      
*                                                                               
*                                                                               
XDPEFN2  RES      0           SKIP TO RECORD MM WITHIN FILE II                  
         ERRP     X'07',0           DATA > BUFFER; IGNORE IT                    
         ERRP     X'06',XDMP19      E-O-F (TM); MAKE NOTE OF IT                 
         ERRP     X'05',XDMP19      !EOD; MAKE LIKE AN E-O-F                    
         ERRP     X'1C',XDMP17      E-O-T; STOP                                 
         ERRP     X'41',XDPB35      FATAL ERROR; REPORT NOT XDMPABLE            
         ERRP     X'4D',XDMP15      OPER ABORT; REPORT SAME                     
         ERRP     X'FF',0           ALL OTHERS; GO TO ROOT                      
         PAGE                                                                   
         SPACE    2                                                             
SETGSIZ  GEN,1,7,24   1,X'22',R2    SET GSIZ = GRANULE SIZE FOR XDMP            
         DATA         P3                                                        
         PZE          *R0           GSIZE IN BYTES IN R0                        
         PAGE                                                                   
*                                                                               
*                          SEGMENT 1 ERROR ROUTINES                             
*                                                                               
*                                                                               
ERROR07  RES      0         ERROR 07 - 'DUPLICATE FILE'                         
         LI,R15   MESS7             POINT AT MESSAGE                            
         B        ERROROUT          GO TO COMMON ERROR OUT ROUTINE              
*                                                                               
*                                                                               
ERROR09  RES      0         ERROR 09 - 'AREA XX CANT HAVE RES FGD PGM...        
         LI,R15   MESS9             POINT AT MESSAGE                            
         B        ERRORINA          GO TO 'INSERT AREA NAME' ROUTINE            
*                                                                               
*                                                                               
ERROR42  RES      0         TRYING TO 'INIT' A DISC WITH MOUNTED AREAS          
         LI,R15   MESS42            POINT AT ERROR MESSAGE                      
         B        ERROROUT          GO REPORT THE ERROR                         
*                                                                               
*                                                                               
ERROR43  RES      0         DISC HAS NO VSN AND NONE GIVEN IN COMMAND           
         LI,R15   MESS43            POINT AT THE MESSAGE                        
         B        ERROROUT          GO TO COMMON ERROR OUT ROUTINE              
         PAGE                                                                   
         SPACE    2                                                             
ERROR44  RES      0         VSN'S ON DISC AND IN COMMAND DO NOT MATCH           
         CLRPL                      CLEAR PL BUFFER                             
         STRNG    MESS44            OUT START OF ERROR MESSAGE                  
         CHARS    8,R8              OUT THE DISC'S VSN                          
         CHAR     C''''             AND CLOSING QUOTE                           
         STEPCP   0                 GET NUMBER OF CHARACTERS IN MESSAGE         
         STB,R15  %PL               AND STORE AS LENGTH OF TEXTC STRING         
         LI,R15   %PL               POINT AT MESSAGE                            
         B        ERROROUT          GO TO COMMON ERROR OUT ROUTINE              
         PAGE                                                                   
SEG1END  EQU      ((%-RADSEG1)+511)/512   # PAGES REQUIRED FOR SEGMENT          
         END                                                                    
