         TITLE    '** RS1000 - RADEDIT SEGMENT 0 **'                            
         PCC      0                                                             
         SPACE    2                                                             
         SYSTEM   SIG7FDP                                                       
         SYSTEM   OPTIONS                                                       
         SYSTEM   CPR                                                           
*                                                                               
*                                                                               
*  NAME OF MODULE                                                               
         DEF      RADSEG0                                                       
*                                                                               
RADSEG0  EQU      %                                                             
RS1000   EQU      %                                                             
*                                                                               
*                                                                               
*                                                                               
*                                                                               
* FPT'S DEFINED IN ROOT1                                                        
         DEF      OPENC,OPENLL,OPENOC,OPENANY                                   
         DEF      OPENSI,OPENSO,OPENSL,OPFLEIN                                  
         DEF      CLOSESO,CLOSESI,CLOSEANY                                      
         DEF      CLFLEIN,CLOSEBI,CLOSEBO,CLOSEOC                               
         DEF      CLOSELL,CLOSELI,CLOSEX1,CLOSESL                               
         DEF      READBIH,READLI,READX1,RDDISCS                                 
         DEF      WRITEBOH,WRITEX1,WRDISCS                                      
         DEF      REWINDBI,REWINDBO,REWINFBI,REWINDSO                           
         DEF      UNLOADBO,SKIPFSO,FSKIPLI,SKIPFILE,SETX1                       
         DEF      REWIND,WEOF,UNLOAD                                            
         DEF      VFCSO0,VFCSO1,WEOFSO,WEOFBO                                   
         DEF      MODESI0,MODESO0,MODESI1,MODESO1                               
         DEF      MODESODD,MODESOND                                             
         DEF      ASNAREA,ASNDEV,ASNOPLB                                        
         DEF      GETAINFO,GETFILNM,GETRSIZE                                    
*                                                                               
* MESSAGES DEFINED IN ROOT1                                                     
         DEF      MESS1,MESS7,MESS8                                             
         DEF      MESS11,MESS16,MESS19,MESS28                                   
         DEF      MESS30,MESS31,MESS32,MESS35                                   
         PAGE                                                                   
*                                                                               
*  ROUTINES IN ROOT1                                                            
         DEF      EXEC,EXEC1                                                    
         DEF      SCAN,PROCSCN,TYPRNT,PROCKYIN                                  
         DEF      GETIOID,GETFID,GETDEV,GETOPLB,GETANY                          
         DEF      ABORT,END,ABNERR,ABNADDR,ERADDR,ABNABORT                      
         DEF      ABNCONT,ABNRETRY,WPERR,OPENERR,FATALMSG,DEVINOP               
         DEF      ERROROUT,ERRORINA,ERROR%PL,OUTFILNM,OUT%MSG                   
         DEF      ERROR01,ERROR02,ERROR04,ERROR05,ERROR06                       
         DEF      ERROR10,ERROR11,ERROR19,ERROR28,ERROR35,ERROR41               
         DEF      GETFSTSD,GETNXTSD,GET1SFIL,GETNXFIL                           
         DEF      GETAX,UNPKMASD,UNPKDIRE,GAN,PACKDIRE                          
         DEF      FNDROM                                                        
*                                                                               
         DEF      PAGERR                                                        
*                                                                               
*  GENERAL PRINT-LINE / PRINT ROUTINES                                          
         DEF      %1        CLEAR THE PRINT LINE                                
         DEF      %2        SET CP                                              
         DEF      %3        STEP CP                                             
         DEF      %4        STORE CHARACTER                                     
         DEF      %5        STORE TEXT STRING                                   
         DEF      %6        STORE TEXTC STRING                                  
         DEF      %7        STORE TIME                                          
         DEF      %8        CONVERT AND STORE INTEGER                           
         DEF      %9        ENTER DATE                                          
         DEF      %11       PRINT PRINT LINE                                    
         DEF      %12       PRINT PRINT LINE, UPSPACE CONTROL                   
         DEF      %13       PAGE PRINTER, PRINT TITLE IF ANY                    
         DEF      %14       PAGE PRINTER AND PRINT THE PRINT-LINE               
         DEF      %15       PRINT A TEXT STRING                                 
         DEF      %16       PRINT A TEXTC STRING                                
         PAGE                                                                   
*                                                                               
* DATA DEFINED IN ROOT1                                                         
         DEF      ZEROS,BLNK,DCW1,DCW2,DCTDATA,DCBOPENF                         
         DEF      FPSP,CKXA,CKXABT                                              
         DEF      ILLNMES,ILLTOTL                                               
         DEF      M1,M2,M3,M4,M5,M6,M7,M8,M9                                    
         DEF      M14,M15,M16,M17,M19,M24,M31                                   
         DEF      ML8,ML15,ML16,ML24                                            
         DEF      X200000,Y8                                                    
         DEF      KWFILE,KWLIB,KWALL                                            
         DEF      STATFLAG                                                      
         DEF      GIOBITS,GIOOBIT,GIODBIT,GIOFBIT,GIOABIT,GIOFA                 
*                                                                               
*                                                                               
* CONSTANTS USED THROUGH OUT THE SYSTEM                                         
*             AREA INDICIES                                                     
         DEF      SPINDEX,FPINDEX,BPINDEX,BTINDEX                               
         DEF      XAINDEX,CKINDEX                                               
*                                                                               
*            FILE DIRECTORY FORMAT INDEX DEFINITIONS                            
         DEF      DIRSIZE,DIRLHDR,LNDIRHDR                                      
         DEF      DIRINFO,DIRNEXT,DIRIDW1,DIRIDW2                               
         DEF      DIRNAM1,DIRNAM2,DIRFLGS,DIRLEN,DIRGRSZ,DIRFSIZ                
         DEF      DIRBOT,DIREOT,DIRXTNT,DIRESIZ,DIRACT1,DIRACT2                 
         DEF      DIRUNB,DIRBLK,DIRCOMP,DIRSEQN,DIRDIRC                         
         DEF      DIRUSEC,DIRDATE                                               
*                                                                               
*            VALUES SET AND USED BY 'UNPKDIRE'                                  
         DEF      ORGUNB,ORGBLK,ORGCOMP                                         
         DEF      FILDELTD,FILBDTRK,FILGOODF,FILENTRY,LDIREHDR                  
*                                                                               
*            VALUES USED TO BUILD LINKED CORE DIRECTORIES                       
         DEF      BACLINK,FWDLINK,XBACLINK,XFWDLINK,SIZEDIR                     
*                                                                               
*  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                                                          
         REF      M:SL                                                          
*  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                                              
         REF      SETRSIZE,SETRSIZ2,SETDCBAT                                    
         REF      STIMER,WAITTIME                                               
*                                                                               
*     FPTS NEEDED FOR MAPPED SYSTEM                                             
         DO1      #MAP                                                          
         REF      GVPN,GVPNL,GVPNH,RVPN,RVPNL,RVPNH                             
*                                                                               
*  ERROR MESSAGES                                                               
         REF      MESS0,MESS2,MESS4,MESS5,MESS9,MESS10                          
         REF      MESS14,MESS18,MESS20,MESS21,MESS22,MESS23                     
         REF      MESS40,MESS41                                                 
         PAGE                                                                   
*                                                                               
*  SCAN VARIABLES                                                               
         REF      SCAN90,SCAN91,SCAN92,SCAN93                                   
         REF      SCAN94,SCAN95,SCAN96                                          
         REF      SCAN97,SCAN98                                                 
         REF      SCAN99,MODEFLAG                                               
*                                                                               
*  SCNMOD VARIABLES                                                             
         REF      CRNTEBD,EBDBYTES,MODBYTES,DRFHWDS                             
         REF      SKIPCKS,NMENOS,EBDBA                                          
         REF      LINKSAVE,TEMP1,TEMPSAVE,TEMP1A                                
         REF      NDEFS,LBAEBC,FBAEBC,DUPDEF,SEQNO                              
*                                                                               
*  REFERENCED ENTRIES TO COMMAND PROCESSORS                                     
         REF      ALLOT                                                         
         REF      BDSECTOR                                                      
         REF      CATALOG                                                       
         REF      CLEAR                                                         
         REF      COPY                                                          
         REF      DELETE                                                        
         REF      DPCOPY                                                        
         REF      DUMP                                                          
         REF      GDSECTOR                                                      
         REF      LMAP                                                          
         REF      SPACE                                                         
         REF      MAP                                                           
         REF      RESTORE                                                       
         REF      SAVE                                                          
         REF      SMAP                                                          
         REF      SQUEEZE,SKWEZ                                                 
         REF      STDLB                                                         
         REF      TRUNCATE                                                      
         REF      UTILITY                                                       
         REF      INIT                                                          
         REF      ADD                                                           
         REF      XDMP                                                          
         PAGE                                                                   
*                                                                               
*  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,OPLBASGN,DEVASGN                                     
         REF      GIOCT                                                         
         REF      MAPSW,MAXMASD                                                 
         REF      ISINDEX,OSINDEX                                               
         REF      ERRFCN,ERRORSW,CONESW                                         
         REF      FREECELL,DIRCHAIN,ENDCHAIN                                    
*                                                                               
*  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      DIREUSEC,DIREDATE                                             
         REF      SQUZDATE                                                      
         REF      MODULE,EBCDIC,DEFREF,MODIR                                    
         PAGE                                                                   
*                                                                               
*                                                                               
*  REFERENCES USED ONLY BY ROOT1  (THIS SEGMENT)                                
         REF      ROOTEND,SEG1END,SEG2END,SEG3END,SEG4END                       
         REF      RADSEG1                                                       
         REF      OVNUMBR                                                       
         REF      CURINDCB                                                      
         REF      TEMP                                                          
         REF      WHOAMI,MYPRIO                                                 
*                                                                               
*                                                                               
         REF      SAVE91,REST91,SQUEZ95                                         
*                                                                               
*                                                                               
         DO1      #MAP                                                          
          REF      XBPEND           MAPPED VERSION'S SCRATCH AREA ADDRESS       
*                                                                               
*                                                                               
*                                                                               
*  REFERENCES FOR %PRINT ROUTINE VARIABLES                                      
         REF      %UP,%CP,%PL,%PLLEN                                            
         REF      %TITLINE,%19@3,%19@4                                          
         REF      %7TEMP,%TEMP,%TEMPEND                                         
         REF      %%#DIG,%9GETOD,%9TOD                                          
         PAGE                                                                   
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 REGISTER FOR NEW ROUTINES          
R15      EQU      15                GENERAL REGISTER 15                         
         PAGE                                                                   
K:SYSTEM EQU      X'2B'             SYSTEM ID, BIT31=1 FOR SYMBIONTS            
K:BCKEND EQU      X'141'            ENDING ADDRESS OF BACKGROUND                
K:MASTD  EQU      X'14A'            BEGINNING ADDR. OF MASTER DICTIONARY        
K:NUMDA  EQU      X'14B'            HIGHEST VALID INDEX VALUE (EVEN NO.)        
K:JCP1   EQU      X'150'            BIT 30=1 IF ATTEND MODE                     
K:BPEND  EQU      X'153'            CONTAINS THE ADDRESS OF LAST CELL           
*                                   OCCUPIED BY A PROGRAM                       
K:KEYIN  EQU      X'169'            RESPONSE TO A KEY-IN AFTER WAIT             
K:PAGE   EQU      X'174'            WORD WITH LINES PER PAGE IN BYTE 0          
K:RDBOOT EQU      X'175'            FWA AND DEV. NO. OF RAD BOOT                
K:DCT1   EQU      X'176'            NUMBER OF DEVICE ENTRIES                    
K:DCT16  EQU      X'177'            DEVICE TYPE INDEX ADDRESS                   
K:OPLBS1 EQU      X'178'            OP LABEL TABLE ADDRESS                      
K:OPLBS3 EQU      X'179'            DCT INDEX OF OP LABEL                       
K:RFT5   EQU      X'17B'            RECORD SIZE OF OPENED FILE                  
K:RFT12  EQU      X'203'            CURRENT REC. NO. OG FILE                    
K:RFT11  EQU      X'204'            FILE POSITION                               
K:BMEM   EQU      X'20F'            MAX NUMBER OF BACKGROUND PAGES              
K:MDNAME EQU      X'212'            ADDRESS OF MDNAME TABLE                     
K:FSMM   EQU      X'217'            FGD PARTITION UPPER BOUND                   
*                                                                               
*                                                                               
SPINDEX  EQU      00                INDEX OF SP AREA                            
FPINDEX  EQU      01                INDEX OF FP AREA                            
BPINDEX  EQU      02                INDEX OF BP AREA                            
BTINDEX  EQU      03                INDEX OF BT AREA                            
XAINDEX  EQU      04                INDEX OF XA AREA                            
CKINDEX  EQU      05                INDEX OF CK AREA                            
*                                                                               
*                                                                               
ALLOC    EQU      X'80'             AREA ALLOCATED FLAG IN MASTD                
         TITLE    '** RS1000 - EQUATES **'                                      
*                                                                               
*                      DIRECTORY FORMAT                                         
*                           HEADER AND CONTROL WORDS                            
DIRINFO  EQU      0                 LENGTH OF DATA; CONTINUED FLAG              
DIRNEXT  EQU      1                 NEXT FREE SECTOR; NEXT DIRE SECTOR          
DIRIDW1  EQU      2                 DIRECTORY IDENTIFICATION WORD 1             
DIRIDW2  EQU      3                                          WORD 2             
DIRLHDR  EQU      4                 LENGTH OF THE HEADER INFO                   
LNDIRHDR EQU      DIRLHDR                                                       
*                                                                               
*                           FILE DIRECTORY ENTRY FORMAT                         
DIRNAM1  EQU       0                NAME, WORD 1                                
DIRNAM2  EQU       1                NAME, WORD 2                                
DIRFLGS  EQU       2                CONTROL FLAGS WORD                          
DIRLEN   EQU       2                    ALSO HAS THE LENGTH                     
DIRGRSZ  EQU       3                GSIZE, RSIZE                                
DIRFSIZ  EQU       4                FILE SIZE                                   
DIRBOT   EQU       5                BEGIN FILE                                  
DIREOT   EQU       6                 END  FILE                                  
DIRXTNT  EQU       7                EXTENT NUMBER                               
DIRESIZ  EQU       8                EXTENSION SIZE AND SWITCH                   
DIRUSEC  EQU       11               USED SECTORS                                
DIRDATE  EQU      12                DATE LAST WRITTEN                           
DIRACT1  EQU       9                ACCOUNT NAME, WORD 1                        
DIRACT2  EQU      10                ACCOUNT NAME, WORD 2                        
DIRSIZE  EQU      11                LENGTH OF A MINIMUM LENGTH ENTRY            
*                                                                               
*                           LINKS FOR CHAINING ENTRIES DURING SQUEEZE           
BACLINK  EQU      DIRSIZE+3         LINK TO PREVIOUS ENTRY                      
FWDLINK  EQU      DIRSIZE+4         LINK TO NEXT ENTRY                          
XBACLINK EQU      DIRSIZE+5         LINK TO PREVIOUS EXTENT IN FILE             
XFWDLINK EQU      DIRSIZE+6         LINK TO NEXT EXTENT IN FILE                 
SIZEDIR  EQU      DIRSIZE+7         SIZE OF AN ENTRY IN THE CHAIN               
         PAGE                                                                   
         SPACE    2                                                             
*                    OLD FILE ORGANIZATION INDICATORS IN FILE DIRECTORY         
DIRUNB   EQU      X'00'             UNBLOCKED (NO BIT SET)                      
DIRBLK   EQU      X'01'             BLOCKED                                     
DIRCOMP  EQU      X'10'             COMPRESSED                                  
*                                                                               
*                          WRITE MODE INDICATORS IN DIRECTORY                   
DIRSEQN  EQU      X'01'             WRITTEN SEQUENTIALLY                        
DIRDIRC  EQU      X'02'             WRITTEN DIRECTLY                            
*                           TYPE OF DIRECTORY ENTRY (ENTRY STATUS)              
FILDELTD EQU      0                 ENTRY FOR A DELETED FILE                    
FILBDTRK EQU      1                 ENTRY FOR A BAD TRACK                       
FILGOODF EQU      2                 ENTRY FOR A FILE                            
*                                                                               
FILENTRY EQU      5                 SIZE OF A FILE'S ENTRY, OLD FORMAT          
LDIREHDR EQU      1                 LEN OF DIRE CTRL HDR, OLD FORMAT            
*                                                                               
EMPTYDIR EQU      X'10001'          1ST WRD OF CLEARED AREA, OLD FORMAT         
*                                                                               
*                           FILE ORGANIZATION (AS USED IN DIREORG)              
ORGUNB   EQU      0                 UNBLOCKED                                   
ORGBLK   EQU      1                 BLOCKED                                     
ORGCOMP  EQU      2                 COMPRESSED                                  
         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                                                          
         TITLE    '** RS1000 - PROCEDURE DEFINITIONS **'                        
         SPACE    5                                                             
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                                                                   
*                                                                               
BIFBKG   CNAME    4                                                             
         PROC                                                                   
LF       LC       *STATFLAG                                                     
         GEN,1,7,4,3,17  AFA(1),X'69',NAME,AF(2),AF(1)                          
         PEND                                                                   
*                                                                               
*                                                                               
BIFFGD   CNAME    4                                                             
         PROC                                                                   
LF       LC       *STATFLAG                                                     
         GEN,1,7,4,3,17  AFA(1),X'68',NAME,AF(2),AF(1)                          
         PEND                                                                   
         SPACE    5                                                             
GETPAGE  CNAME    7                                                             
RELPAGE  CNAME    7                                                             
DEACT    CNAME    7                                                             
ACT      CNAME    7                                                             
SEGLOAD  CNAME    8                                                             
CORRESP  CNAME    1                                                             
         PROC                                                                   
LF       CAL1,NAME   AF                                                         
         PEND                                                                   
*                                                                               
*                                                                               
ERRP     CNAME                      BUILD ERR FUNCTION TABLE ENTRIES            
         PROC                                                                   
         DO       NUM(AF)>0                                                     
LF        GEN,8,24 AF(1),AF(2)                                                  
         ELSE                                                                   
LF        GEN,32   0                END OF TABLE                                
         FIN                                                                    
         PEND                                                                   
*                                                                               
         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    1                                                             
OPENIT   CNAME    1                 OPEN IF NOT ALREADY OPENED                  
CLOSEIT  CNAME    0                 CLOSE IF NOT ALREADY CLOSED                 
         PROC                                                                   
LF       RES      0                                                             
         LW,R2    *AF               GET FIRST WORD OF DCB                       
         CW,R2    X200000           BIT 10 = 1 IF OPENED                        
         GEN,8,4,20  X'68'+NAME,4,%+2                                           
         CAL1,1   AF                DO IT IF NECESSARY                          
         PEND                                                                   
         SPACE    3                                                             
BIFNATT  CNAME    K:JCP1,2          B IF NOT ATTEND MODE                        
BIFNSYM  CNAME    K:SYSTEM,1        B IF NOT SYMBIONT SYSTEM                    
         PROC                                                                   
         LW,R2    NAME(1)           SEE IF BIT IS ON                            
         CI,R2    NAME(2)           FOR ATTEND/SYMBIONTS                        
         BAZ      AF                B IF NOT                                    
         PEND                                                                   
         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                                                                   
         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                                                             
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                                                             
PRTPAG   CNAME                                                                  
         PROC                                                                   
LF       BAL,R14  %14               PAGE THE PRINTER, PRINT PL                  
         PEND                                                                   
         SPACE    3                                                             
         CLOSE    ARG,ARGA                                                      
         LIST     1                                                             
         TITLE    '** RS1000 - COMMAND NAMES, SEGMENT ADDRESSES **'             
*                                                                               
DIR%TABL EQU      % NAME INDEX SEG  DIRECTORY TABLE                             
         TEXT     '    '    0   X   NULL ENTRY, NOT USED                        
         TEXT     'PFIL'    1   1                                               
         TEXT     'PREC'    2   1                                               
         TEXT     'SFIL'    3   1                                               
         TEXT     'REWI'    4   1                                               
         TEXT     'UNLO'    5   1                                               
         TEXT     'WEOF'    6   1                                               
*                                                                               
         TEXT     'COMM'    7   0   COMMENT                                     
         TEXT     'END '    8   0   END                                         
         TEXT     'ALLO'    9   1   ALLOT                                       
         TEXT     'DELE'   10   1   DELETE                                      
         TEXT     'COPY'   11   3   COPY                                        
         TEXT     'MAP '   12   2   MAP                                         
         TEXT     'SMAP'   13   2   SMAP                                        
         TEXT     'LMAP'   14   2   LMAP                                        
         TEXT     'SPAC'    14A   2    SPACE                                    
         TEXT     'CATA'   15   2   CATALOG                                     
         TEXT     'XDMP'   16   1   XDMP                                        
         TEXT     'TRUN'   17   1   TRUNCATE                                    
         TEXT     'DPCO'   18   2   DISK PACK COPY                              
         TEXT     'CLEA'   19   2   CLEAR                                       
         TEXT     'DUMP'   20   1   DUMP                                        
         TEXT     'CONE'   21   0   CONTINUE ON ERRORS                          
         TEXT     'TONE'   22   0   TERMINATE ON ERRORS (RESET CONE)            
         TEXT     'PIE '   23   0   PROCESS (COMMAND) IF ERRORS                 
         TEXT     'PINE'   24   0   PROCESS (COMMAND) IF NO ERRORS              
         TEXT     'STDL'   24A  1   STDLB                                       
*                                                                               
*                                                                               
*        INHIBIT THE FOLLOWING PROCEDURES FROM FOREGROUND RADEDIT               
         TEXT     'SAVE'   25   4   SAVE                                        
         TEXT     'REST'   26   4   RESTORE                                     
         TEXT     'BDSE'   27   2   BDSECTOR                                    
         TEXT     'GDSE'   28   2   GDSECTOR                                    
         TEXT     'SQUE'   29   3   SQUEEZE (NEW FORMAT SQUEEZE)                
         TEXT     'SKWE'   29A  3   SKWEZ   (OLD FORMAT SQUEEZE)                
         TEXT     'INIT'   30   1   INIT                                        
         TEXT     'ADD '   31   1   ADD                                         
DIRSTOTL EQU      %-DIR%TABL-1                                                  
DIR%TOTL EQU      %-DIR%TABL-1      NUMBER OF TABLE ENTRIES                     
         PAGE                                                                   
         SPACE    2                                                             
*             DEFINITION OF SEGMENT NUMBERS                                     
*                 THESE INDICATE WHICH SEGMENT CONTAINS WHICH ROUTINES          
*                                                                               
SEG0     EQU      0                                                             
SEG1     EQU      1001                                                          
SEG2     EQU      1002                                                          
SEG3     EQU      1003                                                          
SEG4     EQU      1004                                                          
*                                                                               
OV%TBL   RES      0         SEGMENT NUMBER TABLE                                
         DATA,2   0         0       THIS ENTRY IS NOT USED                      
         DATA,2   SEG1      1       PFIL                                        
         DATA,2   SEG1      2       PREC                                        
         DATA,2   SEG1      3       SFIL                                        
         DATA,2   SEG1      4       REWIND                                      
         DATA,2   SEG1      5       UNLOAD                                      
         DATA,2   SEG1      6       WEOF                                        
*                                   UTILITY SET MUST COME FIRST                 
         DATA,2   SEG0      7       COMMENT                                     
         DATA,2   SEG0      8       END                                         
         DATA,2   SEG1      9       ALLOT                                       
         DATA,2   SEG1     10       DELETE                                      
         DATA,2   SEG3     11       COPY                                        
         DATA,2   SEG2     12       MAP                                         
         DATA,2   SEG2     13       SMAP                                        
         DATA,2   SEG2     14       LMAP                                        
         DATA,2   SEG2      14A         SPACE                                   
         DATA,2   SEG2     15       CATALOG                                     
         DATA,2   SEG1     16       XDMP                                        
         DATA,2   SEG1     17       TRUNCATE                                    
         DATA,2   SEG2     18       DPCOPY                                      
         DATA,2   SEG3     19       CLEAR                                       
         DATA,2   SEG1     20       DUMP                                        
         DATA,2   SEG0     21       CONE                                        
         DATA,2   SEG0     22       TONE                                        
         DATA,2   SEG0     23       PIE                                         
         DATA,2   SEG0     24       PINE                                        
         DATA,2   SEG1     24A      STDLB                                       
*                                                                               
*        THE FOLLOWING ARE UNAVAILABLE TO THE FOREGROUND                        
         DATA,2   SEG4     25       SAVE                                        
         DATA,2   SEG4     26       RESTORE                                     
         DATA,2   SEG2     27       BDSECTOR                                    
         DATA,2   SEG2     28       GDSECTOR                                    
         DATA,2   SEG3     29       SQUEEZE (NEW FORMAT SQUEEZE)                
         DATA,2   SEG3     29A      SKWEZ   (OLD FORMAT SQUEEZE)                
         DATA,2   SEG1     30       INIT                                        
         DATA,2   SEG1     31       ADD                                         
         PAGE                                                                   
*                                                                               
         BOUND    4                                                             
B%TBL    EQU      %         BRANCH TABLE                                        
*                          SEG INDEX COMMENT/FUNCTION                           
         B        EXEC1     0    0  UNUSED ENTRY; CONTINUE IF IT ISN'T          
         B        UTILITY   1    1  POSITION FILE                               
         B        UTILITY   1    2  POSITION RECORD                             
         B        UTILITY   1    3  SKIP FILE                                   
         B        UTILITY   1    4  REWIND                                      
         B        UTILITY   1    5  UNLOAD                                      
         B        UTILITY   1    6  WRITE END-OF-FILE                           
*                                   UTILITY SET MUST COME FIRST                 
         B        EXEC1     0    7  COMMENT                                     
         B        END       0    8                                              
         B        ALLOT     1    9                                              
         B        DELETE    1   10                                              
         B        COPY      3   11                                              
         B        MAP       2   12                                              
         B        SMAP      2   13                                              
         B        LMAP      2   14                                              
         B        SPACE     2     14A                                           
         B        CATALOG   2   15                                              
         B        XDMP      1   16                                              
         B        TRUNCATE  1   17                                              
         B        DPCOPY    2   18                                              
         B        CLEAR     2   19                                              
         B        DUMP      1   20                                              
         B        CONE      0   21                                              
         B        TONE      0   22                                              
         B        PIE       0   23                                              
         B        PINE      0   24                                              
         B        STDLB     1   24A                                             
*                                                                               
*        THE FOLLOWING ARE UNAVAILABLE TO THE FOREGROUND                        
         B        SAVE      4   25                                              
         B        RESTORE   4   26                                              
         B        BDSECTOR  2   27                                              
         B        GDSECTOR  2   28                                              
         B        SQUEEZE   3   29  (NEW FORMAT SQUEEZE)                        
         B        SKWEZ     3   29A (OLD FORMAT SQUEEZE)                        
         B        INIT      1   30                                              
         B        ADD       1   31                                              
         TITLE    '** RS1000 - GLOBAL CONSTANTS **'                             
         SPACE    1                                                             
         BOUND    8                                                             
BLANKS   TXT      '        '        DOUBLE WORD OF BLANKS (SPACES)              
BLNK     EQU      BLANKS                                                        
SYSACNT  TXT      #SYSACNT          DEFAULT SYSTEM ACCOUNT NAME                 
ZEROS    DATA     0,0                                                           
ONES     DATA     -1,-1             ALL ONES                                    
DCW1     DATA     X'55555555'       DIRECTORY CODE WORD 1                       
DCW2     DATA     X'AAAAAAAA'       DIRECTORY CODE WORD 2                       
CKXABT   DATA     5,3               AREAS 5,4,3  CK,XA,BT                       
CKXA     DATA     5,4               AREAS 5,4  (CK,XA)                          
FPSP     DATA     1,0               AREAS 1,0  FP,SP                            
DCTDATA  DATA     X'155A5A00'       N/L!!                                       
*                                                                               
ILLNMES  RES      0                                                             
         DATA     'GO  ','OV  ','X1  ','X2  ','X3  ','X4  ','X5  '              
         DATA     'X6  ','X7  ','X8  ','X9  '                                   
ILLTOTL  DATA     (%-ILLNMES)                                                   
         PAGE                                                                   
         BOUND    8                                                             
DEC10    DATA     10                                                            
M1       DATA     X'00000001'                                                   
M2       DATA     X'00000003'                                                   
M3       DATA     X'00000007'                                                   
M4       DATA     X'0000000F'                                                   
M5       DATA     X'0000001F'                                                   
M6       DATA     X'3F'                                                         
M7       DATA     X'7F'                                                         
M8       DATA     X'FF'                                                         
M9       DATA     X'1FF'                                                        
M14      DATA     X'3FFF'                                                       
M15      DATA     X'7FFF'                                                       
M16      DATA     X'FFFF'                                                       
M17      DATA     X'1FFFF'                                                      
M19      DATA     X'7FFFF'                                                      
M24      DATA     X'FFFFFF'                                                     
M31      DATA     X'7FFFFFFF'                                                   
ML8      DATA     X'FF000000'                                                   
ML15     DATA     X'FFFE0000'                                                   
ML16     DATA     X'FFFF0000'                                                   
ML24     DATA     X'FFFFFF00'                                                   
X200000  DATA     X'200000'                                                     
DCBOPENF EQU      X200000           OPEN FLAG IN DCBS                           
Y8       DATA     X'80000000'                                                   
*                                                                               
*                                                                               
KWFILE   TEXT     'FILE'                                                        
KWLIB    TEXT     'LIB'                                                         
KWALL    TEXT     'ALL '                                                        
*                                                                               
TYPCOC   TEXT     'COC '            TAKE ONE INPUT LINE FROM C DEVICE           
         PAGE                                                                   
         SPACE    2                                                             
         BOUND    8                                                             
*                                                                               
BADTRACK TXT      ' BADSECS'        FILE NAME FOR BAD SECTOR AREAS              
*                                                                               
*                                                                               
ZZZZZ    RES      0         EXEC CONTROL'S ERROR FUNCTION TABLE                 
         ERRP     X'03',ERROR06     NON-EXIST FILE: OUT NAME                    
         ERRP     X'05',EXEC1       !EOD READ: READ NEXT COMMAND                
         ERRP     X'06',END         BANG CARD READ: STOP                        
         ERRP     X'07',ERROR28     BUFF LEN < DATA LEN:                        
         ERRP     X'0A',0           CLOSE A CLOSED DCB: IGNORE                  
         ERRP     X'1C',ERROR35     E-O-T: OUT DEVICE/FILE NAME                 
         ERRP     X'2E',OPENERR     OPEN AN OPENEN DCB: CLOSE, TRY AGAIN        
         ERRP     X'30',DEVINOP     DEVICE MANUAL: ALLOW OPER FIX               
         ERRP     X'42',WPERR       WRITE PROTECT: TEST FOR OPER'S 'SY'         
         ERRP                                                                   
         PAGE                                                                   
         SPACE    2                                                             
*  ERROR CODES AND THEIR MEANING.                                               
*                                                                               
*                                                                               
*  TYC   R10      MEANING                                                       
*                                                                               
*        01       DCB OPENED WITH INCORRECT PARAMETERS                          
*        03       ASSIGNED DISK FILE DOES NOT EXIST; DEVICE DOWN                
*  06    05       END-OF-DATA (!EOD) OR END-OF-FILE (TAPEMARK) FOUND            
*  07    06       END-OF-INPUT (!COMMAND) FOUND                                 
*  02    07       BUFFER SMALLER THAN DATA RECORD                               
*        0A       ATTEMPT TO CLOSE A CLOSED DCB                                 
*  05    1C       END-OF-TAPE FOUND  (WRITE OPERATIONS ONLY)                    
*  03    1D       BEGIN-OF-TAPE FOUND                                           
*        2E       ATTEMPT TO OPEN AN OPENED DCB                                 
*        2F       'DED DP...,R' KEY-IN IN EFFECT                                
*  04    30       REQUEST REQUIRES OPERATOR ACTION (DEVICE MANUAL, ETC)         
*        40       ATTEMPT TO READ AN OUTPUT DEVICE                              
*  08    41       UNRECOVERABLE ERROR                                           
*  0A    42       DISC WRITE RESTRICTION  (NEEDS 'SY' KEY-IN)                   
*        44       ATTEMPT TO WRITE TO AN INPUT DEVICE                           
*        46       INSUFFICIENT INFO TO OPEN A CLOSED DCB ON A READ              
*        47       INSUFFICIENT INFO TO OPEN A CLOSED DCB ON A WRITE             
*        48       NON-REAL-TIME REQUEST TO A BUSY DCB                           
*        4A       BUFFER ADDRESS OR BYTE COUNT IN ERROR                         
*  10    4B       PAPER POSTION LOST ON BDP PRINTER                             
*        4C       INCONSISTENT POSITION OR STATUS ON I/O                        
*  12    4D       REQUEST ABORTED BY USER OR SYSTEM                             
*        4E       ERROR WHICH SYMBIONT COOPERATIVE CANNOT RECOVER               
*        54       ATTEMPT TO READ MORE THAN 2 !CMNDS VIA SAME DCB               
*        55       CANNOT OPEN DCB: RFT FULL; RAD DOWN; OF NO RAD BUFFER         
*        58       FOREGROUND REQUEST TO 'C' DEVICE                              
*        59       DCB CHANGED SINCE IT WAS OPENED                               
*        5B       ILLEGAL JOB ID FOR A FILE CLOSE REQUEST                       
*        60       ATTEMPTED INPUT FROM SHARED DEVICE OR FILE                    
*        61       INTERRUPT LABEL UNDEFINED; ADDRESS INVALID                    
*        62       INVALID OR ILLEGAL TASK NAME                                  
*        63       INVALID OR ILLEGAL JOB NAME                                   
*        64       END ACTION INVALID FOR CALLER                                 
*        65       CONFLICT WITH LOWER PRIORITY TASK                             
*        66       SPACE NOT AVAILABLE IN TSPACE FOR A TABLE                     
*        67       OPERATION TIMED OUT (NON-I/O OPERATION)                       
*        68       RESPONSIBLE TASK TERMINATED WITHOUT COMPLETING REQ            
*        69       REQ DELETED BY RESPONSIBLE TASK OR 3RD PARTY                  
*        6A       REQ INVALID FOR CALLER BECAUSE OF JOB/TASK TYPE               
*        6B       WAIT NOT LEGAL FOR PRIMARY TASK                               
*        6C       REQUIRED CLOCK VALUE MISSING                                  
*        6D       SIGNALLING TASK TERMINATED                                    
*        6E       SIGNALLING TASK ABORTED                                       
*        6F       RESPONSIBLE TASK ABENDED WITHOUT COMPLETING REQ               
*        70       INVALID OR ILLEGAL AREA NAME                                  
*        71       UNDEFINED OR ILLEGAL FILE NAME                                
*        72       SPACE NOT AVAILABLE IN AREA                                   
*        73       DEBUG INITIALIZATION WHILE IN 'DEBUG'                         
*        74       INVALID OPLABEL                                               
*        75       DIRECTORY INCONSISTENT ON OPEN/ALLOT/DELETE/ETC               
*        76       INVALID RESOURCE                                              
*        77       ILLEGAL FILE FORMAT (ORGANIZATION)                            
*        78       TWO TASKS TRYING TO ACT ON SAME ITEM SIMULTANEOUSLY           
*        79       ILLEGAL COMBINATION OF PARAMETERS                             
*        7A       SYMBIONTS: ILLEGAL !JOB FORMAT OR PARAMETER ERROR             
*        7D       DCB TOO SMALL FOR ASSIGN INFORMATION                          
*        82       TASK ALREADY IDLE ON A STOP REQUEST                           
*        83       IMMEDIATE SERVICE REQUEST CANNOT BE SATISFIED                 
*        84       RESOURCE NEVER ACQUIRED ON A 'DEQ' REQUEST                    
*        86       INVALID IDENTIFICATION                                        
*        8A       CAL ALREADY CONNECTED                                         
*        8B       INVALID ADDRESS PARAMETER                                     
*        8C       INVALID STATUS FLAGS                                          
*        8D       INVALID DATA AREA                                             
         TITLE    '** RS1000 - FPT''S'                                          
         BOUND    4                                                             
OPENC    RES      0                 OPEN M:C                                    
         GEN,8,24 X'14',M:C                                                     
         GEN,32   X'C0000000'                                                   
         DATA     ABNERR,ABNERR                                                 
*                                                                               
OPENLL   RES      0                 OPEN M:LL                                   
         GEN,8,24 X'14',M:LL                                                    
         GEN,32   X'C0000000'                                                   
         DATA     ABNERR,ABNERR                                                 
*                                                                               
OPENOC   RES      0                 OPEN M:OC                                   
         GEN,8,24 X'14',M:OC                                                    
         GEN,32   X'C0000000'                                                   
         DATA     ABNERR,ABNERR                                                 
*                                                                               
OPENSI   RES      0                                                             
         GEN,8,24 X'14',F:SI        OPEN F:SI DCB                               
         GEN,32   X'C0000000'                                                   
         DATA     ABNERR                                                        
         DATA     ABNERR                                                        
*                                                                               
OPENSO   RES      0                                                             
         GEN,8,24 X'14',F:SO        OPEN F:SO DCB                               
         GEN,32   X'C0000000'                                                   
         DATA     ABNERR                                                        
         DATA     ABNERR                                                        
*                                                                               
OPFLEIN  RES      0                                                             
         GEN,8,24 X'14',F:BI        OPEN INPUT FILE                             
         GEN,32   X'C0000000'                                                   
         DATA     ABNERR                                                        
         DATA     ABNERR                                                        
*                                                                               
OPENSL   RES      0                                                             
         GEN,8,24 X'14',M:SL        FPT TO OPEN M:SL DCB                        
         DATA     X'C0000000'                                                   
         DATA     ABNERR                                                        
         DATA     ABNERR                                                        
*                                                                               
OPENANY  RES      0         OPEN ANY DCB: ADDR IN R2                            
         GEN,1,7,24  1,X'14',R2                                                 
         GEN,32   X'C0000000'                                                   
         DATA     ABNERR                                                        
         DATA     ABNERR                                                        
*                                                                               
CORRES   RES      0                 CORRESSPONDENCE, C/LL                       
         GEN,8,24 X'AB',RDSYM                                                   
         GEN,1,31 1,WRSYM                                                       
*                                                                               
CLOSEC   RES      0                                                             
         GEN,8,24 X'15',M:C         CLOSE M:C  DCB                              
         GEN,32   X'C0000000'                                                   
         DATA     ABNERR                                                        
         DATA     ABNERR                                                        
*                                                                               
CLOSELL  RES      0                                                             
         GEN,8,24 X'15',M:LL        CLOSE M:LL DCB                              
         GEN,32   X'C0000000'                                                   
         DATA     ABNERR                                                        
         DATA     ABNERR                                                        
*                                                                               
CLOSEOC  RES      0                 CLOSE M:OC DCB                              
         GEN,8,24 X'15',M:OC                                                    
         GEN,32   X'C0000000'                                                   
         DATA     ABNERR                                                        
         DATA     ABNERR                                                        
*                                                                               
CLOSEBI  RES      0                                                             
         GEN,8,24 X'15',M:BI                                                    
         GEN,32   X'C0000000'                                                   
         DATA     ABNERR                                                        
         DATA     ABNERR                                                        
*                                                                               
CLOSEBO  RES      0                                                             
         GEN,8,24 X'15',M:BO                                                    
         GEN,32   X'C0000000'                                                   
         DATA     ABNERR                                                        
         DATA     ABNERR                                                        
*                                                                               
CLOSEX1  GEN,8,24 X'15',M:X1                                                    
         GEN,2,30 3,0                                                           
         DATA     ABNERR                                                        
         DATA     ABNERR                                                        
*                                                                               
CLOSESI  RES      0                                                             
         GEN,8,24 X'15',F:SI        CLOSE F:SI DCB                              
         GEN,32   X'C0000000'                                                   
         DATA     ABNERR                                                        
         DATA     ABNERR                                                        
*                                                                               
CLOSESO  GEN,8,24 X'15',F:SO        CLOSE F:SO DCB                              
         GEN,32   X'C0000000'                                                   
         DATA     ABNERR                                                        
         DATA     ABNERR                                                        
*                                                                               
CLFLEIN  RES      0                                                             
         GEN,8,24 X'15',F:BI        CLOSE INPUT FILE                            
         GEN,32   X'C0000000'                                                   
         DATA     ABNERR                                                        
         DATA     ABNERR                                                        
*                                                                               
CLOSELI  GEN,8,24 X'15',F:LI                                                    
         GEN,2,30 3,0                                                           
         DATA     ABNERR                                                        
         DATA     ABNERR                                                        
*                                                                               
CLOSESL  RES      0                                                             
         GEN,8,24 X'15',M:SL      FPT TO CLOSE M:SL DCB                         
         GEN,32   X'C0000000'                                                   
          DATA    ABNERR                                                        
          DATA    ABNERR                                                        
*                                                                               
CLOSEANY RES      0         CLOSE ANY DCB: ADDR IN R2                           
         GEN,1,7,24  1,X'15',R2                                                 
         GEN,32   X'C0000000'                                                   
         DATA     ABNERR                                                        
         DATA     ABNERR                                                        
*                                                                               
RDSYM    RES      0                                                             
         GEN,8,24 X'10',M:C         READ SYMBOLIC INPUT                         
         GEN,32   X'F2000010'                                                   
         DATA     ABNERR                                                        
         DATA     ABNERR                                                        
         DATA     BUFF2                                                         
         DATA     80                BYTE COUNT                                  
         DATA     C':'              PROMPT CHARACTER                            
*                                                                               
RDSYMOC  RES      0                 READ SYMBOLIC INPUT                         
         GEN,8,24 X'10',M:OC                                                    
         DATA     X'F2000010'                                                   
         DATA     ABNERR                                                        
         DATA     ABNERR                                                        
         DATA     BUFF2                                                         
         DATA     80                                                            
         DATA     C':'              PROMPT CHARACTER                            
*                                                                               
READBIH  RES      0                 FPT TO READ HEADERS                         
         GEN,8,24 X'10',M:BI                                                    
         GEN,4,28 X'F',X'16'                                                    
         DATA     ABNERR                                                        
         DATA     ABNERR                                                        
         DATA     REST91                                                        
         DATA     4*6                                                           
*                                                                               
READX1   GEN,8,24   X'10',M:X1                                                  
         GEN,2,9,21 3,1,X'10'                                                   
         DATA       ABNERR                                                      
         DATA       ABNERR                                                      
         DATA       BUFF1           USE BUFF1 AS BLOCKING BUFFER                
*                                                                               
RDDISCS  RES      0                 READ DISC SEQUENTIALLY                      
         GEN,8,24 X'10',F:BI                                                    
         GEN,32   X'C0000010'                                                   
         DATA     ABNERR                                                        
         DATA     ABNERR                                                        
*                                                                               
READLI   GEN,8,24 X'10',F:LI        FPT TO READ LIB                             
         GEN,2,30 3,X'10'                                                       
         DATA     ABNERR                                                        
         DATA     ABNERR                                                        
*                                                                               
WRSYM    RES      0                                                             
         GEN,8,24 X'11',M:LL        WRITE SYMBOLIC                              
         GEN,32   X'F0000010'                                                   
         DATA     ABNERR                                                        
         DATA     ABNERR                                                        
         DATA     BUFF2                                                         
         DATA     80                                                            
*                                                                               
WRITEBOH RES      0                 FPT FOR SAVE HEADER                         
         GEN,8,24 X'11',M:BO                                                    
         GEN,4,28 X'F',X'14'                                                    
         DATA     ABNERR                                                        
         DATA     ABNERR                                                        
         DATA     SAVE91                                                        
         DATA     4*6                                                           
*                                                                               
WRITEX1  GEN,8,24   X'11',M:X1                                                  
         GEN,2,9,21 3,1,X'10'                                                   
         DATA       ABNERR                                                      
         DATA       ABNERR                                                      
         DATA       BUFF1           USE BUFF1 AS BLOCKING BUFFER                
*                                                                               
WRDISCS  RES      0                                                             
         GEN,8,24 X'11',F:BI        WRITE DISC SEQUENTIALLY                     
         GEN,32   X'C0000010'                                                   
         DATA     ABNERR                                                        
         DATA     ABNERR                                                        
*                                                                               
TYPESYM  RES      0                                                             
         GEN,8,24 X'11',M:OC        TYPE SYMBOLIC INPUT                         
         DATA     X'F0000010'                                                   
         DATA     TYPRERR           ERROR ADDRESS                               
         DATA     TYPRERR           ABNORMAL ADDRESS                            
         DATA     BUFF2             BUFFER ADDRESS                              
         DATA     80                BYTE COUNT                                  
*                                                                               
VFCSO0   RES      0                                                             
         GEN,8,24 X'05',F:SO        RESET VERTICAL FORMAT                       
         GEN,32   0                                                             
*                                                                               
VFCSO1   RES      0                                                             
         GEN,8,24 X'05',F:SO        SET VERTICAL FORMAT                         
         GEN,32   X'00000010'                                                   
*                                                                               
WEOFSO   RES      0                                                             
         GEN,8,1,23  2,1,F:SO       WRITE E-O-F TO  F:SO                        
         DATA        X'C0000010'    ERR, ABN ADDRESSES; WAIT                    
         DATA        ABNERR                                                     
         DATA        ABNERR                                                     
*                                                                               
REWIND   GEN,1,7,24     1,1,R2      REWIND DCB AT R2                            
*                                                                               
WEOF     GEN,1,7,24     1,2,R2      WRITE EOF'S TO DCB AT R2                    
*                                                                               
UNLOAD   GEN,1,7,24     1,3,R2      UNLOAD DCB AT R2                            
*                                                                               
*                                                                               
*                                                                               
*                                                                               
WEOFBO   RES      0                                                             
         GEN,8,24 2,M:BO            WRITE E-O-F TO BO DEVICE                    
*                                                                               
REWINDBI GEN,8,24 1,M:BI                                                        
*                                                                               
REWINDBO GEN,8,24 1,M:BO                                                        
*                                                                               
REWINDSO GEN,8,24 1,F:SO                                                        
*                                                                               
REWINFBI GEN,8,24 1,F:BI                                                        
*                                                                               
UNLOADBO GEN,8,24 3,M:BO            UNLOAD BO                                   
*                                                                               
SKIPFSO  RES      0                 SKIP FILE                                   
         GEN,8,24 X'1C',F:SO                                                    
         GEN,32   X'40000000'                                                   
         DATA     ABNERR                                                        
*                                                                               
FSKIPLI  GEN,8,24 X'1C',F:LI                                                    
         DATA     0                                                             
*                                                                               
SKIPFILE RES      0         SKIP FILE FOR DCB IN R2                             
         GEN,1,7,1,6,17  1,X'1C',1,0,R2                                         
         DATA     P2+F2+F4                                                      
         DATA     ABNERR      P2    ERROR ROUTINE                               
*                                                                               
*                                                                               
SETX1    GEN,8,24 X'22',M:X1                                                    
         GEN,2,30 3,0                                                           
         DATA     120                                                           
         DATA     1                                                             
*                                                                               
MODESI0  RES      0                                                             
         GEN,8,24 X'22',F:SI        SET MODE TO BCD                             
         GEN,32   X'40'                                                         
*                                                                               
MODESO0  RES      0                                                             
         GEN,8,24 X'22',F:SO        SET MODE TO BCD                             
         GEN,32   X'40'                                                         
*                                                                               
MODESI1  RES      0                                                             
         GEN,8,24 X'22',F:SI        SET MODE TO BINARY                          
         GEN,32   X'00000010'                                                   
*                                                                               
MODESO1  RES      0                                                             
MODESODD EQU      MODESO1           SET BINARY + PACKED (D1600)                 
         GEN,8,24 X'22',F:SO        SET MODE TO BINARY                          
         GEN,32   X'00000010'                                                   
*                                                                               
MODESOND RES      0                 SET BINARY + UNPACKED (D800)                
         GEN,8,24 X'22',F:SO                                                    
         GEN,32   X'00000050'                                                   
*****                                                                           
ASNAREA  RES      0         ASSIGN AN ENTIRE AREA TO A DCB                      
         GEN,1,7,1,6,17  1,X'08',1,0,R2     DCB LOC IN R2                       
         DATA            P1+P4              ERROR, AREA POINTER                 
         DATA            ABNERR             ERROR ROUTINE                       
         DATA            AREAASGN           AREA NAME, FILE NAME = 0            
*****                                                                           
ASNDEV   RES      0         ASSIGN A DEVICE TO A DCB                            
         GEN,1,7,1,6,17  1,X'08',1,0,R2                                         
         DATA            P1+P3              ERROR, DEVICE POINTER               
         DATA            ABNERR                                                 
         DATA            DEVASGN            DEVICE NAME POINTE                  
*****                                                                           
ASNOPLB  RES      0         ASSIGN AN OPLABEL TO A DCB                          
         GEN,1,7,1,6,17  1,X'08',1,0,R2                                         
         DATA            P1+P2                                                  
         DATA            ABNERR                                                 
         PZE             *OPLBASGN          LOCATION OF OPLABEL NAME            
*****                                                                           
GETAINFO RES      0         GET INFO ABOUT AN AREA                              
         GEN,1,7,1,6,17  1,X'09',1,0,R2                                         
         DATA            P1+P3+P5+P6+P7+P12+P15+P16                             
         DATA     ABNERR     P1     ERROR ROUTINE                               
         PZE      MASDDEVA   P3     DEVICE NAME                                 
         PZE      MASDMODL   P5     MODEL NUMBER                                
         PZE      *MASDBOA   P6     BEGIN OF AREA                               
         PZE      *MASDEOA   P7     END OF AREA                                 
         PZE      *MASDDCTI  P12    DEVICE INDEX                                
         PZE      *MASDWP    P15    WRITE PROTECT                               
         PZE      MASDTPC    P16    DEVICE CONSTANTS: TPC, SPT, WPS             
*****                                                                           
GETRSIZE RES      0         GET RECORD SIZE                                     
         GEN,1,7,1,6,17  1,X'09',1,0,R2                                         
         DATA            P1+P11                                                 
         DATA            ABNERR                                                 
         PZE             *R0        SIZE TO R0                                  
*****                                                                           
GETFILNM RES      0         GET AREA-, FILE- NAME, AND ACCOUNT NAME             
         GEN,1,7,1,6,17  1,X'09',1,0,R2                                         
         DATA            P1+P4+P14                                              
         DATA     ABNERR     P1     ERROR ROUTINE                               
         PZE      AREANAME   P4     AREA AND FILENAME                           
         PZE      ACNTNAME   P14    ACCOUNT NAME                                
         TITLE    '** RS1000 - ERROR MESSAGES **'                               
         SPACE    2                                                             
********************    ERROR MESSAGES    ********************                  
*                                                                               
MESS1    TXTC     'DISC OVERFLOW'                                               
MESS6    TXTC     'FILE '                                                       
MESS6A   TXTC     ' DOES NOT EXIST'                                             
MESS7    TXTC     'DUPLICATE FILE'                                              
MESS8    TXTC     'ILLEGAL FILE NAME'                                           
MESS11   TXTC     'AREA SPECIFIED IS NOT MAINTAINED BY RADEDIT'                 
MESS16   TXTC     'SPECIFIED ROM DOES NOT EXIST'                                
MESS19   TXTC     'NOT ENUF BCKG SPACE'                                         
MESS28   TXTC     'BUFFER SMALLER THAN DATA READ'                               
MESS30   TXTC     'ILLEGAL BINARY RECORD'                                       
MESS31   TXTC     'SEQ ERROR'                                                   
MESS32   TXTC     'CKSM ERROR'                                                  
MESS35   TXTC     'EOT ON '                                                     
MESS35A  TXTC     ', = '                                                        
MESS35B  TXTC     'DESTROYED DCB AT '                                           
MESS39   TXTC     'RADEDIT I/O ERROR '                                          
MESS39A  TXTC     ' AT LOCATION '                                               
MESS50   TXTC     'NO SCRATCH BUFFER SPACE'                                     
         TITLE    '** RS1000 - EXECUTIVE ROUTINE **'                            
******** ROUTINE EXECUTIVE ********                                             
*                                                                               
*        INPUT    DIRECTIVES                                                    
*                                                                               
*        OUTPUT                                                                 
*                                                                               
*        FUNCTION LOADS THE OVERLAY SEGMENTS NEEDED. CHECKS THE                 
*                 DIRECTIVE  FOR VALIDITY AND TRANSFERS CONTROL TO THE          
*                 ROUTINE TO PROCESS THE DIRECTIVE.                             
*                                                                               
*        CALL     B  EXEC                                                       
*                                                                               
*        SUBROUTINES USED  SCAN,TYPRNT                                          
*                                                                               
*                                                                               
EXEC     RES      0                                                             
         DO       #MAP              CP-R SYSTEM                                 
         LI,R0    XBPEND            FWA OF SCRATCH                              
         STW,R0   BPEND               AREA                                      
         STW,R0   BPEND1            FWA OF SCRATCH AREA                         
         MTW,1    BPEND1            +1                                          
*                                                                               
         SAS,R0   -9                PAGE # OF FWA OF SCRATCH AREA               
         STW,R0   GVPNL             FOR GET PAGE CAL                            
         AI,R0    1                                                             
         STW,R0   RVPNL             AND FOR RELPAGE CAL                         
*                                                                               
         LI,R1    SEG1END           GET LENGTH OF                               
         CI,R1    SEG2END           LONGEST                                     
         BGE      %+2               SEGMENT                                     
         LI,R1    SEG2END           --                                          
         CI,R1    SEG3END           --                                          
         BGE      %+2               --                                          
         LI,R1    SEG3END           --                                          
         CI,R1    SEG4END           --                                          
         BGE      %+2               --                                          
         LI,R1    SEG4END           --                                          
         AI,R1    ROOTEND           PLUS ROOT CONTEXT                           
         AI,R1    SEG0END           AND ROOT PROCEDURE                          
*                                   =LENGTH OF LONGEST PATH                     
         LH,R0    K:FSMM            R0= MAX NUMBER OF PAGES (SMM)               
         BIFFGD   %+2                                                           
         LH,R0    K:BMEM                                                        
*                                   ESTIMATE NEEDED MAX                         
         SW,R0    R1                NUMBER OF PAGES                             
         CI,R0    2                                                             
         BGE      %+2                                                           
         LI,R0    2                 MINIMUM USABLE                              
         CI,R0    39                                                            
         BLE      %+2               B IF .LE. MAX-1                             
         LI,R0    39                OTHERWISE USE MAX-1                         
         AW,R0    GVPNL             + 1ST PAGE #                                
         STW,R0   GVPNH             = LAST PAGE # FOR GETPAGE CAL               
         STW,R0   RVPNH             AND RELPAGE CAL                             
         MTW,1    RVPNH                                                         
*                                                                               
         SAS,R0   9                 CONVERT TO LWA                              
         AI,R0    X'1FF'            OF SCRATCH AREA                             
         STW,R0   BCKEND                                                        
*                                                                               
         GETPAGE  GVPN              GET PAGES FOR SCRATCH SEGMENT               
*                                                                               
         ELSE                       RBM SYSTEM                                  
         LW,R0    K:BPEND           USE SYSTEM SUPPLIED                         
         STW,R0   BPEND             SCRATCH PAD AREA                            
         STW,R0   BPEND1            ALSO SET FWA OF                             
         MTW,1    BPEND1            SCRATCH AREA +1                             
         LW,R0    K:BCKEND          AND END OF                                  
         STW,R0   BCKEND            SCRATCH AREA                                
         FIN      #MAP                                                          
*                                                                               
         SW,R0    BPEND             COMPUTE NUMBER OF WORDS AVAILABLE           
         AI,R0    1                 IN THE SCRATCH AREA                         
         STW,R0   BACKSZE                                                       
         SLS,R0   2                 CONVERT TO BYTES AND                        
         STW,R0   BCKSZE            SAVE THAT TOO                               
*                                                                               
         LW,R8    ISINDEX           FIND INDICIES FOR 'IS' AND 'OS'             
         BAL,RLNK GETAX             AREAS                                       
         LB,R1    K:MDNAME          NOT ALLOCATED: SET TOO BIG                  
         STW,R1   ISINDEX                                                       
         LW,R8    OSINDEX                                                       
         BAL,RLNK GETAX                                                         
         LB,R1    K:MDNAME                                                      
         STW,R1   OSINDEX                                                       
*                                                                               
         BIFBKG   EXEC1             SKIP IF BACKGROUND                          
         M:ASSIGN M:C,(OPLB,'SI')                                               
         PAGE                                                                   
         SPACE    2                                                             
EXEC1    RES      0                                                             
         LI,R0    RDSYM             SET FPT AND DCB TO USE TO READ CMND         
*                                                                               
*                                                                               
EXEC3    RES      0         PREPARE TO READ A NEW INPUT COMMAND                 
         STW,R0   CURINDCB          SAVE ADDRESS OF FPT TO USE                  
         LI,R0    ZZZZZ             RESET ERR FUNCTION TO DEFAULT               
         STW,R0   ERRFCN            PROCESSING FOR 'EXEC' CONTROL               
         CAL1,1   CLFLEIN           MAKE SURE F:BI ALWAYS CLOSED                
         LW,R1    M:SL              R1= 1ST WORD OF M:SL DCB                    
         CW,R1    X200000           IS IT CLOSED                                
         BANZ     %+2                                                           
         CAL1,1   OPENSL            YES, OPEN IT                                
*                                                                               
*        RESTORE STACK POINTER DOUBLEWORD                                       
         LW,R3    U:PCB+1           R3 = WORD COUNT                             
         AND,R3   M15               ZERO OUT BITS 0-16                          
         LCW,R3   R3                NEGATE VALUE                                
         MSP,R3   U:PCB             RESTORE TO ORIGINAL                         
*                                                                               
         BAL,RLNK PROCSCN           READ COMMAND AND LIST ON LL                 
         CLRPL                      CLEAR PRINT BUFFER                          
*                                                                               
         LD,R2    ZEROS             INIT. F:BI FILE NAME TO ZEROS               
         STD,R2   BIFNAME                                                       
         LI,R1    BUFF1             INIT. F:BI BUFFER ADDRESS TO BUFF1          
         STW,R1   BIBUFF                                                        
         LI,R3    8                                                             
         STS,R2   WRDISC+1          CLEAR CHECK WRITE BIT                       
         LI,R3    0                                                             
*                                                                               
         STW,R2   SQUEZ95           CLEAR SQUEEZE FLAG                          
*                                                                               
         LI,R7    SPARAM            SET UP SCAN ROUTINE PARAMETERS TO           
         LI,R1    1                 SCAN MNEMONIC FIELD.                        
         LCI      2                 F1=1, F2=0                                  
         STM,R1   SPARAMF1                                                      
*                                                                               
*                                                                               
EXEC4    RES      0         SCAN FOR COMMAND NAME                               
         BAL,LINK SCAN              SCAN MNEMONIC FIELD                         
         CI,R6    -1                ILLEGAL                                     
         BE       ERROR02             YES, GIVE 'ERROR ITEM XX'                 
*                                                                               
         LW,R10   R10                                                           
         BEZ      EXEC1             IF NULL ENTRY, REREAD                       
         LI,R1    1                 SET F2=CONTINUE                             
         STW,R1   SPARAMF2                                                      
*                                                                               
         LW,R9    ML24                                                          
         LI,R1    DIR%TOTL          TRANSFER CNTRL TO SPECIFIED ROUTINE         
         BIFBKG   EXEC5                                                         
         M:STATUS,CAL  WHOAMI                                                   
         LI,R0    X'FF'                                                         
         AND,R0   MYPRIO            EXTRACT SOFTWARE PRIORITY                   
         CI,R0    X'EF'                                                         
         BL       EXEC5             NONDFLT PRIO LETS US DO ANYTHING            
         LI,R1    DIRSTOTL          RESTRICTION ON FOREGROUND COMMANDS          
EXEC5    RES      0                                                             
         CS,R8    DIR%TABL,R1                                                   
         BE       EXEC15                                                        
         BDR,R1   EXEC5                                                         
         B        ERROR02           GIVE AN ERROR INDICATING NOT LEGAL          
*                                                                               
EXEC15   LH,R10   OV%TBL,R1         GET OVERLAY NUMBER                          
         BEZ      B%TBL,R1          SKIP IF IN ROOT                             
         CW,R10   OVNUMBR           IS IT ALREADY IN CORE                       
         BE       B%TBL,R1          YES, GO TO ENTRY POINT                      
*                                                                               
         DO       #MAP                                                          
         MTW,0    OVNUMBR           NO SEGMENT                                  
         BEZ      EXEC16            TO DEACTIVATE                               
         LI,R9    X'53'             DEACTIVATE SEGMENT                          
         STB,R9   OVNUMBR           FOR MAPPED SYSTEM                           
         DEACT    OVNUMBR                                                       
EXEC16   EQU      %                                                             
         FIN      #MAP                                                          
*                                                                               
         STW,R10  OVNUMBR           SAVE CURRENT OVERLAY #                      
*                                                                               
         DO       #MAP                                                          
         AW,R10   L(X'52000000')    FOR MAPPED SYSTEM                           
         ACT      R10               DO ACTIVATE OF SEGMENT                      
         ELSE                                                                   
         AW,R10   L(X'01000000')    FOR UNMAPPED SYSTEMLOAD                     
         SEGLOAD  R10               DO SEGLOAD OF SEGMEND                       
         FIN      #MAP                                                          
*                                                                               
         CAL1,1   CLOSESL           CLOSE M:SL FOR COPY, ETC.                   
         B        B%TBL,R1          GO TO ENTRY POINT                           
         PAGE                                                                   
******** SUBROUTINE PROCSCN ********                                            
*                                                                               
*        INPUT    NEXT DIRECTIVE                                                
*                                                                               
*        OUPUT    DIRECTIVE TO LL DEVICE                                        
*                                                                               
*        FUNCTION READS THE NEXT COMMAND LINE FROM THE CURRENT INPUT DCB        
*                 AND LISTS IT ON LL.  IT IS USED BY EXEC3 TO READ THE          
*                 NEW COMMAND AND BY SCAN TO READ A CONTINUATION LINE.          
*                                                                               
*        CALL     BAL,RLNK    PROCSCN                                           
*                                                                               
PROCSCN  RES      0                                                             
         PUSH     3,R8              SAVE POSSIBLY CHANGED REGISTERS             
         CAL1,1   *CURINDCB         READ THE INPUT COMMAND                      
         LW,R8    M:LL              TEST LL OPEN                                
         CW,R8    X200000                                                       
         BANZ     %+2                                                           
         CAL1,1   OPENLL            OPEN IT                                     
         CAL1,1   CORRES            CHECK C,LL THE SAME DEVICE                  
         CI,R8    1                                                             
         BE       %+2               IFSO, SKIP THE PRINT                        
         CAL1,1   WRSYM             WRITE TO LL DEVICE                          
         PULL     3,R8              RECOVER SAVED REGISTERS                     
         B        *RLNK             RETURN                                      
         TITLE    '** RS1000 - ERROR PROCESSING ROUTINES **'                    
         SPACE    2                                                             
*  ABNERR         PROCESS ABNORMAL AND ERROR CONDITIONS FOR CALS.               
*                                                                               
*        USE:     THE CELL 'ERRFCN' CONTAINS THE ADDRESS OF AN ERROR            
*                 FUNCTION TABLE. THIS ROUTINE SEARCHES THE TABLE               
*                 FOR A MATCH IN ERROR CODES FROM R10, AND TAKES THE            
*                 INDICATED ACTION.                                             
*                                                                               
*        TABLE FORMAT AND MEANING.                                              
*                                                                               
*                 BYTE 0:    ERROR CODE                                         
*                 BYTES 1-3: ADDR                                               
*                                                                               
*                 WHERE                                                         
*                       CODE  ADDR        ACTION                                
*                       >0     >0   GO TO ADDR FOR THIS CODE                    
*                       >0     =0   IGNORE ERROR, RETURN TO *R8                 
*                       =0     >0   GO TO ADDR FOR ALL OTHER ERRORS             
*                       =0     =0   GO TO GENERAL ABORT/ERROR ROUTINE           
*                       =FF    =0   CONTINUE SEARCH USING ZZZZZ TABLE           
*                       =FF    >0   CONTINUE SEARCH USING TABLE 'ADDR'          
*                                                                               
*                                                                               
ABNERR   RES      0         DECODE ERRFCN TABLE FOR ERROR CONDITION             
         PUSH     16,R0             SAVE ALL REGISTERS                          
         LW,R2    ERRFCN            GET ADDRESS OF FUNCTION TABLES              
*                                                                               
ABN1     RES      0         TEST NEXT ITEM IN LIST FOR ERROR CODE               
         LW,R0    *R2               GET THE ITEM                                
         BEZ      ABNABORT            IF 0, GO TO GENERAL ERROR/ABORT           
*                                                                               
         LB,R1    R0                GET ERROR CODE BYTE                         
         BEZ      ABN3              NONE, GO TO 'ALL OTHER ERROR' ROUT          
*                                                                               
         CB,R1    R10               IS THIS THE CODE WE GOT                     
         BE       ABN2                YES, TEST HOW TO PROCESS                  
*                                                                               
         AI,R2    1                   NO, STEP TO NEXT TABLE WORD               
         CI,R1    X'FF'             LINK TO ANOTHER TABLE NEEDED ?              
         BNE      ABN1                NO, CONTINUE IN THIS TABLE                
*                                                                               
         LW,R2    R0                COPY ADDRESS OF NEW TABLE                   
         AND,R2   M17               REMOVE LINK FLAG; IS TABLE GIVEN ?          
         BNEZ     ABN1                YES, CONTINUE, USING NEW TABLE            
*                                                                               
         LI,R2    ZZZZZ             SET TO USE ROOT'S TABLE                     
         B        ABN1              AND CONTINUE WITH IT                        
*                                                                               
ABN2     RES      0         CODE FOUND; GET WHERE TO GO                         
         AND,R0   M17               EXTRACT OUT THE ADDRESS                     
         BNEZ     ABN3              ADDRESS GIVEN, USE IT                       
*                                                                               
         LW,R0    R8                IGNORE ERROR; RETURN INLINE                 
*                                                                               
ABN3     RES      0         GO TO ERROR PROCESSOR / OR RETURN                   
         STW,R0   TEMP              SAVE RETURN ADDRESS                         
         PULL     16,R0             RECOVER ALL SAVED REGISTERS                 
         B        *TEMP             RETURN                                      
*                                                                               
ERADDR   EQU      ABNERR    TEMP DEFINITION OF OLD DCB/FPT ERROR ROUTINE        
ABNADDR  EQU      ABNERR    TEMP DEFINITION OF OLD DCB/FPT ABNORM ROUT          
         PAGE                                                                   
         SPACE    2                                                             
ABNCONT  RES      0         IGNORE AN ERROR - RETURN AND CONTINUE               
         PULL     16,R0             RECOVER ALL SAVED REGISTERS                 
         B        *R8               RETURN AFTER CAL                            
*                                                                               
*                                                                               
ABNRETRY RES      0         RETRY THE CAL GETTING THE ERROR                     
         AI,R8    -1                BACK UP TO THE CAL'S ADDRESS                
         B        *R8               RETRY IT                                    
*                                                                               
*                                                                               
OPENERR  RES      0         ERROR OPENING AN ALREADY OPEN DCB                   
         PUSH     16,R0             RESAVE ERROR REGISTERS                      
         LW,R2    R10               GET ADDRESS OF THE DCB                      
         AND,R2   M17                                                           
         CAL1,1   CLOSEANY          AND CLOSE IT                                
         PULL     16,R0             RESTORE REGISTERS                           
         B        ABNRETRY          AND THEN TRY AGAIN TO OPEN IT               
         PAGE                                                                   
         SPACE    2                                                             
WPERR    RES      0         WRITE PROTECT ERROR; TEST FOR OPER 'SYC'            
         PUSH     16,R0             RESAVE ERROR REGISTERS                      
         LCI      2                 GET DEVICE NAME                             
         LM,R2    MASDDEVA                                                      
         SLD,R2   -24               RIGHT JUSTIFY IT                            
         OR,R2    DCTDATA           ADD IN THE N/L, BANG, BANG                  
         LB,R0    MESS0             GET LENGTH OF THE MESSAGE; STORE            
         STB,R0   R2                OVER THE NEW/LINE IN DEVICE NAME            
         LCI      2                 STORE THE NAME AND LENGTH BACK IN           
         STM,R2   MESS0             ITS SPOT                                    
         LI,R15   MESS0             SET LOC OF MSG AND                          
         BAL,LINK TYPRNT            GO OUT IT                                   
         LW,R2    K:JCP1                                                        
         CI,R2    2                 IS THE SYSTEM ATTENDED ?                    
         BANZ     WPERRA              YES, ALLOW OPERATOR TO DECIDE             
*                                                                               
         MTW,+00  CONESW            NO, CONTINUE ON ERRORS ?                    
         BNEZ     EXEC1               YES, GO GET NEXT COMMAND                  
*                                                                               
WPERRA   RES      0         ALLOW OPERATOR TO DECIDE IF WRITE IS OK             
         M:WAIT                     TRY WAIT: ABORT IF NOT ATTENDED             
         PULL     16,R0             RESTORE REGISTERS                           
         B        ABNRETRY          GO RETRY                                    
         PAGE                                                                   
         SPACE    2                                                             
DEVINOP  RES      0         ROUTINE TO PROCESS DEVICES IN MANUAL STATE          
         PUSH     R8                SAVE RETURN                                 
         LI,R8    10                SET WAIT TIME                               
         STW,R8   WAITTIME                                                      
         PULL     R8                                                            
         CAL1,7   STIMER             DO THE WAIT                                
         B        ABNRETRY                                                      
*                                                                               
         PAGE                                                                   
         SPACE    2                                                             
ABNABORT RES      0         ABORT USER WITH UNRECOVERABLE ERROR                 
         PUSH     16,R0                                                         
         BAL,RLNK FATALMSG          OUT MESSAGE GIVING WHAT HAPPENED            
         MTW,+1   ERRORSW           INSURE ERROR SWITCH SET                     
         MTW,+00  CONESW            ARE WE TO CONTINUE ON ERRORS ?              
         BGZ      EXEC1               YES, READ A NEW COMMAND                   
*                                                                               
         PULL     16,R0             RECOVER REGS FOR POST MORTEM DUMP           
         B        ABORT             ELSE GO ABORT AND TERMINATE                 
*                                                                               
*                                                                               
*                                                                               
ABORT    RES      0         ABORT JOB;                                          
         BIFFGD   END               IF FOREGROUND, JUST STOP NOW                
         M:WAIT                     IF BKG, TEST IF ATTENDED, WE RETURN         
*                                   AND STOP NORMALLY IF SPECIFIED              
*                                                                               
*                                                                               
END      RES      0         NORMAL TERMINATION                                  
         M:TERM                     RETURN TO JCP/TEL                           
*                                                                               
*                                                                               
PAGERR   EQU      %                 GETPAGE CAL ERROR                           
         LI,R15   MESS50            TYPE MESSAGE                                
         BAL,LINK TYPRNT            AND                                         
         B        ABORT             ABORT                                       
         PAGE                                                                   
         SPACE    2                                                             
FATALMSG RES      0         FORM AND PRINT MESSAGE FOR A FATAL ERROR            
         PUSH     RLNK              SAVE RETURN                                 
         CLRPL                      INSURE THE MESSAGE BUFFER IS CLEAR          
         STRNG    MESS39            OUT 'RADEDIT I/O ERROR '                    
         LB,R15   R10               GET THE ERROR CODE                          
         INTGR    HEX,ZERO,2        AND OUT IT IN HEX                           
         STRNG    MESS39A           OUT REST OF MESSAGE TEXT                    
         LW,R15   R8                COPY ADDRESS + 1 OF ERROR                   
         AI,R15   -1                ADJUST TO TRUE ADDRESS OF CAL               
         INTGR    ,SPAC,5           OUT AS A 5 DIGIT HEX NUMBER                 
         BAL,RLNK OUT%MSG           OUT MESSAGE TO LL (OC, ETC.)                
         PULL     RLNK              RECOVER CALLER'S LINK                       
         B        *RLNK             AND RETURN FOR ANY PROCESSING               
         PAGE                                                                   
         SPACE    2                                                             
*                                                                               
ERROR01  RES      0         ERROR 01 - 'DISC OVERFLOW'                          
         LI,R15   MESS1             POINT AT THE MESSAGE                        
         B        ERROROUT          GO OUT IT                                   
*                                                                               
ERROR02  RES      0         ERROR 02 - 'ERROR IN ITEM XX'                       
         STW,R11  MESS2+3           SET ITEM NUMBER IN MESSAGE                  
         LI,R15   MESS2             SET ADDRESS OF MESSAGE                      
         B        ERROROUT          GO TO COMMON ERROR OUT ROUTINE              
*                                                                               
ERROR04  RES      0         ERROR 04 - 'AREA XX NOT ALLOCATED'                  
         LI,R15   MESS4             POINT AT MODIFIED MESSAGE                   
         B        ERRORINA          GO INSERT AREA NAME & OUT MESSAGE           
*                                                                               
ERROR05  RES      0         ERROR 05 - 'ERROR IN OPTION XXXX   '                
         LW,R9    BLNK              PUT BLANKS IN SECOND WORD                   
         SCD,R8   -8                MOVE ONE TO 1ST CHAR POSITION               
         LCI      2                                                             
         STM,R8   MESS5+4           STORE IN END OF MESSAGE                     
         LI,R15   MESS5             POINT AT THE MESSAGE                        
         B        ERROROUT          GO TO COMMON ERROR OUT ROUTINE              
*                                                                               
ERROR06  RES      0         ERROR 06 - 'FILE XXXXXXXX DOES NOT EXIST'           
         CLRPL                      INSURE OUTPUT LINE IS CLEAR                 
         STRNG    MESS6             OUT 'FILE '                                 
         BAL,RLNK OUTFILNM          INSERT FILENAME.AREA.ACCOUNT                
         STRNG    MESS6A            AND THEN ' DOES NOT EXIST'                  
         B        ERROR%PL          OUT MESSAGE FORMED IN %PL                   
         PAGE                                                                   
         SPACE    2                                                             
ERROR10  RES      0         ERROR 10 - 'AREA XX DOES NOT CONTAIN A LIB'         
         LI,R15   MESS10            POINT AT THE MESSAGE                        
         B        ERRORINA          GO INSERT AREA NAME IN MESSAGE              
*                                                                               
ERROR11  RES      0         ERROR 11 - 'AREA NOT MAINTAINED BY RADEDIT'         
         LI,R15   MESS11            POINT AT THE MESSAGE                        
         B        ERROROUT          GO OUT IT                                   
*                                                                               
ERROR19  RES      0         ERROR 19 - 'NOT ENUF BCKG SPACE'                    
         LI,R15   MESS19            SET LOCATION OF MESSAGE                     
         B        ERROROUT          GO TO COMMON ERROR OUT ROUTINE              
*                                                                               
ERROR28  RES      0         ERROR 28 - 'BUFFER SMALLER THAN DATA READ'          
         LI,R15   MESS28            POINT AT THE MESSAGE                        
         B        ERROROUT          GO TO COMMON ERROR OUT ROUTINE              
*                                                                               
*                                                                               
*                                                                               
ERROR41  RES      0         ERROR 41 - 'AREA XX HAS A BAD DIRECTORY'            
         LI,R15   MESS41            POINT AT THE MESSAGE                        
         B        ERRORINA          GO INSERT AREA NAME AND OUT MESSAGE         
         PAGE                                                                   
         SPACE    2                                                             
ERROR35  RES      0         ERROR 35 - 'EOT ON XXXXXXXX'                        
         PRNT                       INSURE LINE CLEAR; SPACE 1 LINE             
         STRNG    MESS35            OUT 'EOT ON ' PART OF MESSAGE               
         AND,R10  M17               GET DCB ADDRESS                             
         LW,R0    *R10              GET ASN FIELD FROM THE DCB                  
         AND,R0   M4                TEST WHERE DCB IS ASSIGNED                  
         CI,R0    1                 IS IT TO A FILE ?                           
         BE       ERROR35B            YES, GET FILENAME                         
*                                                                               
         CI,R0    3                 IS IT TO A DEVICE OR OPLABEL ?              
         BNE      ERROR35E            NO, TERRIBLE ERROR                        
*                                                                               
         LI,R1    1                 TEST 'DEV/OPLB/RFILE' FIELD FOR TYPE        
         LW,R3    *R10,R1           OF ASSIGNMENT                               
         CI,R3    X'8000'           IS ASSIGNMENT THROUGH AN OPLABEL ?          
         BANZ     ERROR35A            NO, GET DEVICE NAME                       
*                                                                               
         AND,R3   M8                YES, DECODE OPLABEL NAME                    
         LH,R8    *K:OPLBS1,R3      GET NAME IN EBCDIC                          
         CHARS    2,R8,2            AND ENTER IN 'EOT' MESSAGE                  
         STRNG    MESS35A           FORM MESSAGE TO BE 'EOT ON OP, = '          
         LB,R3    *K:OPLBS3,R3      GET OPLABEL ASSIGNMENT                      
         CI,R3    X'80'             IS IT ASSIGNED TO A FILE ?                  
         BANZ     ERROR35B            YES, GET FILE, AREA, ACCOUNT NAME         
         PAGE                                                                   
         SPACE    1                                                             
ERROR35A RES      0         DCB ASSIGNED TO A DEVICE  (MAYBE VIA OPLBL)         
         AND,R3   M7                GET DCT INDEX                               
         LD,R8    *K:DCT16,R3       MOVE NAME TO R8, 9 IN FORM ...YYNDD         
         CHARS    5,R8,3            OUT NAME WITHOUT LEADING CHARS              
         B        ERROR35C          CLEAN UP AND GO PRINT ERROR                 
*                                                                               
ERROR35B RES      0         DCB ASSIGNED TO A FILE  (MAYBE VIA OPLABEL)         
         LD,R0    BLNK              SET NO ACCOUNT NAME SO WE WILL              
         STD,R0   ACNTNAME          KNOW IF IT IS PRESENT                       
         LW,R2    R10               SET DCB LOC                                 
         CAL1,1   GETFILNM          GET THE FILE, AREA, ACCOUNT NAMES           
         BAL,RLNK OUTFILNM          INSERT 'FILE.AREA.ACCOUNT'                  
*                                                                               
ERROR35C RES      0         CLEAN UP THE DCB                                    
         LW,R2    R10               SET LOC                                     
         CAL1,1   CLOSEANY          CLOSE IT                                    
         B        ERROR%PL          OUT ERROR MESSAGE FORMED IN %PL             
*                                                                               
*                                                                               
ERROR35E RES      0         EOT ON A NOW DESTROYED DCB                          
         STRNG    MESS35B           OUT 'DESTROYED DCB AT '                     
         LW,R15   R10                                                           
         INTGR    HEX,ZERO,5                                                    
         STRNG    MESS35A           ADD ', = ' AFTER ADDRESS                    
         LW,R2    R10               SET ADDRESS OF DCB                          
         CHARS    4,,-4             OUT 4 CHAR NAME PRECEEDING DCB              
         B        ERROR35C          GO OUT MESSAGE ???                          
         PAGE                                                                   
         SPACE    2                                                             
ERRORINA RES      0         INSERT AREA NAME IN A MESSAGE AT R15                
         LI,R1    3                 SET LOC OF NAME INSERT                      
         LW,R8    MASDNAME          GET NAME                                    
         STH,R8   *R15,R1           INSERT IT                                   
         B        ERROROUT          GO TO COMMON ERROR OUT ROUTINE              
*                                                                               
*                                                                               
*                                                                               
ERROROUT RES      0         COMMON ERROR MESSAGE OUTPUT ROUTINE                 
         LI,R0    ZZZZZ             RESET ERR FUNCTION JUST TO BE SURE          
         STW,R0   ERRFCN            WE PROCESS CLOSES OK                        
         CAL1,1   CLFLEIN           CLOSE FILE IF IT WAS OPENED                 
         BAL,LINK TYPRNT            TYPE/PRINT MSG WHERE NECESSARY              
         B        PROCKYIN          ALLOW RECOVERY OR ABORT                     
*                                                                               
*                                                                               
*                                                                               
ERROR%PL RES      0         OUT ERROR MESSAGE FORMED IN %PL                     
         LW,R15   %CP               GET CURRENT LENGTH OF MESSAGE               
         STB,R15  %PL               MAKE LOOK LIKE A TEXTC STRING               
         LI,R15   %PL               POINT AT IT AS IS USUAL                     
         B        ERROROUT          AND GO TO COMMON ERROR ROUTINE              
         PAGE                                                                   
         SPACE    2                                                             
OUTFILNM RES      0          INSERT FILENAME.AREA.ACCOUNT IN PRINT LINE         
         PUSH     RLNK              SAVE RETURN LINK                            
         LI,R1    7                 FIND LAST NON-BLANK CHAR IN NAME            
         LI,R15   C' '                                                          
*                                                                               
         CB,R15   FILENAME,R1       IS LAST CHAR BLANK                          
         BNE      %+2                 YES, LAST NON-BLANK FOUND                 
         BDR,R1   %-2                 NO, LOOK AT NEXT                          
*                                                                               
         AI,R1    1                 STEP LENGTH TO INCLUDE LAST CHAR            
         CHARS    ,FILENAME         OUT 'FILENAME'                              
         LW,R0    AREANAME          IS AREA NAME A 'PUBLIC' AREA                
         BEZ      OUTFILN1            YES, DON'T TRY TO PRINT IT                
*                                                                               
         CH,R0    BLNK              IS IT BLANKS (NOT GIVEN) ?                  
         BE       OUTFILN1            YES, SKIP OUTTING THIS TOO                
*                                                                               
         CHAR     C'.'                  'FILENAME.'                             
         CHARS    2,AREANAME,2          'FILENAME.AA'                           
OUTFILN1 RES      0         OUT ACCOUNT NAME, IF PRESENT                        
         LD,R0    ACNTNAME          IS THERE AN ACCOUNT NAME                    
         BEZ      OUTFILN2            NO, ALL ZEROS MEANS NOT PRESENT           
         CD,R0    BLNK              IS IT ALL BLANKS ?                          
         BE       OUTFILN2            YES, NO NAME. DON'T OUTPUT ANY            
*                                                                               
         CHAR     C'.'                  'FILENAME.AA.'                          
         CHARS    8,ACNTNAME            'FILENAME.AA.ACNTNAME'                  
OUTFILN2 RES      0         ALL DONE; EXIT                                      
         PULL     RLNK              RECOVER LINK                                
         B        *RLNK             RETURN TO CALLER                            
*                                                                               
*                                                                               
**********************************************************************          
*                                                                               
*                                                                               
OUT%MSG  RES      0         OUT A MESSAGE ON OC AND/OR LL, LO                   
         PUSH     RLNK              SAVE RETURN                                 
         LW,R15   %CP               GET SIZE OF THE MESSAGE                     
         STB,R15  %PL               FORM A TEXTC FORMAT STRING                  
         LI,R15   %PL                                                           
         BAL,LINK TYPRNT            OUT MESSAGE IN %PL                          
         CLRPL                      INSURE THE LINE IS LEFT EMPTY               
         PULL     RLNK                                                          
         B        *RLNK                                                         
         TITLE    '** RS1000 - SYSTEM SUBROUTINES **'                           
         SPACE    5                                                             
******** SUBROUTINE GETFSTSD ********                                           
*                                                                               
*        INPUT                                                                  
*                                                                               
*        OUTPUT   FIRST SECTOR OF DIRECTORY INTO BUFF1                          
*                 CC2=1 IF FIRST SECTOR OF DIRECTORY HAS NO ENTRIES             
*                 CC1=1 IF LAST SECTOR OF DIR.                                  
*                 CC1=0 IF NOT LAST SECTOR                                      
*                                                                               
*        FUNCTION READ FIRST SECTOR OF SPECIFIED AREA INTO BUFF1                
*                                                                               
*        CALL     BAL,LINK  GETFSTSD                                            
*                                                                               
*        SUBROUTINES USED  NONE                                                 
*                                                                               
*                                                                               
GETFSTSD RES      0                                                             
         PUSH     R10               SAVE     REGISTER R10                       
         LI,R10   0                 INIT GRANULE NO. IN FPT                     
         STW,R10  RDDISC5                                                       
         STW,R10  WRDISC5                                                       
         LW,R10   MASDWPS           SET BYTE COUNTS = SECTOR SIZE               
         SLS,R10  2                                                             
         STW,R10  RDDISC4                                                       
         STW,R10  WRDISC4                                                       
         CAL1,1   RDDISC            READ FIRST SECTOR FROM DISC                 
         PULL     R10               RESTORE     REGISTER R10                    
*                                                                               
         MTW,0    *BIBUFF                                                       
         BLZ      GETFST2                                                       
         BEZ      GETFST1                                                       
         LCI      8                 LAST SECTOR OF DIR.                         
         B        *LINK                                                         
GETFST1  RES      0                                                             
         LCI      4                 FIRST SECTOR HAS NO EXTRIES                 
         B        *LINK                                                         
GETFST2  RES      0                                                             
         LCI      0                 NOT LAST SECTOR OF DIR                      
         B        *LINK                                                         
         PAGE                                                                   
******** SUBROUTINE GETNXTSD ********                                           
*                                                                               
*        INPUT    IDENT. ENTRY 'ADDRESS' (FIRST WORD OF BUFF1)                  
*                                                                               
*        OUTPUT   NEXT SECTOR OF DIRECTORY INTO BUFF1                           
*                 CC1=1 IF LAST SECTOR OF DIRECTORY                             
*                 CC1=0 IF NOT LAST                                             
*                                                                               
*        FUNCTION READS NEXT SECTOR OF DIRECTORY INTO BUFF1                     
*                                                                               
*        CALL     BAL,LINK  GETNXTSD                                            
*                                                                               
*        SUBROUTINES USED   NONE                                                
*                                                                               
*                                                                               
GETNXTSD RES      0                                                             
         PUSH     R10               SAVE     REGISTER R10                       
         MTW,+1   MASDNDS           STEP COUNT OF EXTRA DIRE SECTORS            
         LW,R10   BUFF1+1           GET LINK TO NEXT DIRE SECTOR                
         MTW,+0   MASDFRMT          IS THIS A POST-D00 DIR?                     
         BGEZ     GETNXT0           YES, USE THE ADDRESS                        
*                                                                               
         LH,R10   BUFF1             NO, OLD; GET ITS LINK ADDRESS               
         AND,R10  M15               AND REMOVE LINK FLAG                        
*                                                                               
GETNXT0  RES      0         NEXT SECTOR IN R10; READ THE SECTOR                 
         STW,R10  RDDISC5                                                       
         STW,R10  WRDISC5                                                       
         CAL1,1   RDDISC            READ NEXT SECTOR FROM DISC                  
         PULL     R10               RESTORE     REGISTER R10                    
         MTH,0    *BIBUFF           CHECK IF LAST SECTOR OF DIR.                
         BLZ      GETNXT1           NOT LAST                                    
         LCI      8                                                             
         B        *LINK                                                         
GETNXT1  RES      0                                                             
         LCI      0                 LAST                                        
         B        *LINK                                                         
******** SUBROUTINE GETAX ********                                              
*                                                                               
*        INPUT    AREA NAME IN EBCDIC IN R8 (BITS 0-15)                         
*                                                                               
*        OUTPUT   AREA INDEX IN R1, R8 UNCHANGED.                               
*        RETURNS: LINK+1 IF AREA IS OK;  ELSE LINK+0                            
*                                                                               
*        FUNCTION SEARCHES THE MDNAME TABLE FOR A MATCH AND                     
*                 RETURNS THE MASTER DICTIONARY INDEX FOR THE AREA.             
*                                                                               
*        CALL     BAL,RLNK  GETAX                                               
*                                                                               
*        SUBROUTINES USED     NONE                                              
*                                                                               
GETAX    RES      0                                                             
         PUSH     R8                SAVE INPUT NAME                             
         LH,R8    R8                SIGN EXTEND                                 
         BEZ      GETAX30           NAME OF ALL ZEROS ==> PUBLIC AREA           
         CH,R8    BLNK              IS IT A BLANK NAME ?                        
         BE       GETAX30             YES, ALSO PUBLIC AREA                     
*                                                                               
         LI,R1    1                 STORE AREA NAME IN MASDNAME IN CASE         
         STH,R8   MASDNAME,R1       IT IS NOT FOUND                             
         LB,R1    K:MDNAME          R1= MAX # OF AREAS                          
GETAX10  AI,R1    -1                DECREMENT                                   
         BLZ      GETAX20           B IF NO MATCH                               
         CH,R8    *K:MDNAME,R1      IS THIS THE AREA                            
         BNE      GETAX10           NO, TRY NEXT                                
         CW,R1    K:NUMDA           YES, IS INDEX TOO BIG                       
         BG       GETAX20            YES, ERROR                                 
*                                                                               
GETAX15  RES      0         SET UP TO RETURN AT NORMAL OR OK EXIT               
         STW,R1   AREA              SET AREA INDEX FOR EVERYONE ELSE            
         AI,RLNK  1                 SET FOR 'FOUND', (+1) EXIT                  
*                                                                               
GETAX20  RES      0         RETURN NORMAL OR ERROR                              
         PULL     R8                RECOVER INPUT NAME                          
         B        *RLNK             RETURN HOWEVER...                           
*                                                                               
*                                                                               
GETAX30  RES      0         PUBLIC AREA SPECIFIED: SET AREA, NAME               
         LW,R8    BLNK              SET NAME = ALL BLANKS                       
         STW,R8   MASDNAME          SO IT WILL DEFAULT AND ALSO BE              
         STW,R8   AREANAME          PRINTABLE                                   
         LI,R1    -1                SET PUBLIC AREA'S AREA INDEX                
         B        GETAX15           AND EXIT NORMALLY                           
         PAGE                                                                   
******** SUBROUTINE PROCKYIN ********                                           
*                                                                               
*        INPUT    OPERATOR KEY-IN (K:KEYIN)                                     
*                                                                               
*        FUNCTION                                                               
*           FOREGROUND:  RECYCLES FOR COMMAND AT EXEC1                          
*           BACKGROUND:  CHECKS OPERATOR RESPONSE FOR LEGALITY.                 
*                 IF RESPONSE=C   RETURNS TO EXEC FOR NEXT DIRECTIVE            
*                 IF RESPONSE=COC READS NEXT RECORD FROM OC DEVICE AND          
*                                 RETURNS TO EXEC                               
*                                                                               
*                 IF RESPONSE=X   MONITOR INTERCEPTS RESPONSE AND ABORTS PROGRAM
*        CALL     B  PROCKYIN                                                   
*                                                                               
*        REGISTERS USED  R0,R1,R8                                               
*                                                                               
*                                                                               
PROCKYIN RES      0                                                             
         BIFFGD   EXEC1             FOREGOUND, RECYCLE FOR COMMAND              
         MTW,+1   ERRORSW           SET AND STEP ERROR SW/COUNT                 
         MTW,+00  CONESW            ARE WE TO IGNORE ERRORS & CONTINUE          
         BGZ      EXEC1               YES, GO GET NEXT COMMAND                  
*                                                                               
         M:WAIT                                                                 
*                                                                               
         LW,R1    K:KEYIN+2                                                     
         CW,R1    TYPCOC            IF COC READ NEXT DIR. FROM OC DEVICE        
         BNE      EXEC1               NO, READ FROM NORMAL INPUT, = C           
*                                                                               
         LI,R0    RDSYMOC             YES, SET TO READ FROM OC                  
         B        EXEC3             AND GO READ FROM THERE                      
         PAGE                                                                   
         SPACE    2                                                             
*        'CONE' ALLOWS THE USER TO CONTINUE IN RADEDIT AFTER A NORMALLY         
*        FATAL ERROR HAS OCCURRED. THE ABORT IS INTERCEPTED AND CONTROL         
*        RETURNED TO EXEC1 TO READ A NEW COMMAND. THE INTERCEPTS ARE IN         
*        1) WRITE PROTECT BEFORE THE UNATTENDED WAIT;                           
*        2) PROCKYIN      BEFORE THE WAIT; AND                                  
*        3) ABNABORT      BEFORE THE CALL TO ABORT.                             
*        'TONE' RESETS THE 'CONE' MODE AND CLEARS THE 'ERROR OCCURRED'          
*        SWITCH.  THE NORMAL MODE IS 'TONE'.                                    
*                                                                               
*                                                                               
CONE     RES      0         CONTINUE ON (FATAL) ERRORS                          
         LI,R0    1                 SET CONTINUE ON                             
         STW,R0   CONESW                                                        
         B        EXEC1             GO GET NEXT COMMAND                         
*                                                                               
*                                                                               
TONE     RES      0         RESET CONTINUE ON (FATAL) ERRORS                    
         LI,R0    0                 SET CONTINUE OFF                            
         STW,R0   CONESW                                                        
         STW,R0   ERRORSW           AND NO PREVIOUS ERRORS                      
         B        EXEC1             GO GET NEXT COMMAND                         
         PAGE                                                                   
         SPACE    2                                                             
*        THE 'PIE' AND 'PINE' COMMANDS ALLOW CONDITIONAL EXECUTION OF           
*        NORMAL RADEDIT COMMANDS BASED ON THE OCCURRENCE OF ERRORS IN           
*        PREVIOUS COMMANDS.  THEY ARE USED BY PRECEDING ANY RADEDIT             
*        COMMAND WITH 'PIE' (PROCESS IF ERRORS) OR 'PINE' (PROCESS IF           
*        NO ERRORS).  FOR EXAMPLE,  :PINE COPY (ON,SI),(OUT,SO)                 
*        THE REST OF SUCH A COMMAND WILL BE EXECUTED ONLY IF THERE HAS          
*        BEEN NO PREVIOUS ERRORS (PINE), OR ONLY IF THERE HAVE BEEN AT          
*        LEAST ONE ERROR (PIE).  IF THE CONDITIONS ARE NOT MET, THE REST        
*        OF THE COMMAND IS IGNORED.                                             
*        THESE COMMANDS ARE USED IN CONJUNCTION WITH 'CONE' AND 'TONE'          
*        AS DESCRIBED ABOVE.  THE ERRORS TESTED BY 'PIE' AND 'PINE' ARE         
*        THE FATAL ONES THAT WOULD CAUSE THE PROGRAM TO TERMINATE IN            
*        THE 'TONE' MODE.                                                       
*                                                                               
*                                                                               
PIE      RES      0         PROCESS REST OF COMMAND IF PREVIOUS ERRORS          
         MTW,+00  ERRORSW           WERE THERE ANY ERRORS ?                     
         BEZ      EXEC1               NO, SKIP THIS COMMAND, GET NEXT           
         B        EXEC4             YES, CONTINUE PROCESSING THIS ONE           
*                                                                               
*                                                                               
PINE     RES      0         PROCESS REST OF COMMAND IF NO ERRORS                
         MTW,+00  ERRORSW           WERE THERE ANY ERRORS ?                     
         BNEZ     EXEC1               YES, SKIP THIS COMMAND; GET NEXT          
         B        EXEC4             NO, CONTINUE PROCESSING THIS ONE            
         PAGE                                                                   
******** SUBROUTINE TYPRNT   ********                                           
*                                                                               
*        INPUT    MESSAGE ADDRESS IN R15                                        
*                                                                               
*        OUTPUT   MESSAGE ON OC AND/OR  LL DEVICES                              
*                                                                               
*        FUNCTION OUTPUTS A MESSAGE TO THE DEVICES ASSIGNED TO THE              
*                 LL AND OC OP LABELS.                                          
*                 FOR FOREGROUND, OUTPUTS TO THE LL DEVICE ONLY.                
*                 FOR BACKGROUND, IF BOTH ASSIGNED TO THE SAME                  
*                 DEVICE, OUTPUTS TO THE OC DEVICE ONLY.                        
*                                                                               
*        CALL     BAL,LINK  TYPRNT                                              
*                                                                               
*        REGISTERS USED    R8                                                   
*                                                                               
TYPRNT   RES      0                                                             
         PUSH     0,R0              SAVE ALL REGISTERS                          
         DO       #MAP                                                          
         BIFFGD   TYPRLL            IF FOREGROUND                               
         BIFNATT  TYPRLL             OR NOT ATTEND                              
*  HERE IF MAP, BKG, AND ATTEND                                                 
         OPENIT   OPENOC            IF OC=LL                                    
         OPENIT   OPENLL             TYPE MESSAGE ON LL                         
         M:CORRES  (DCB1,M:OC),(DCB2,M:LL)                                      
         CI,R8    1                                                             
         BE       TYPRLL                                                        
*                                                                               
         OPENIT   OPENC             IF OC=C, JUST TYPE MESSAGE                  
         M:CORRES  (DCB1,M:OC),(DCB2,M:C)                                       
         CI,R8    1                                                             
         BE       TYPROC                                                        
*                                                                               
         CAL1,1   TYPESYM           ELSE, TYPE SYMBOLIC TO OC                   
         FIN      #MAP                                                          
         SPACE    2                                                             
TYPROC   RES      0                                                             
         STW,R15  TYPE1                                                         
         LB,R2    *R15              GET BYTE COUNT                              
         STW,R2   TYPE2             STORE IN WRITE FPT                          
         CAL1,1   TYPE              OUTPUT MESSAGE TO OC                        
*                                                                               
         OPENIT   OPENLL            IF LL=OC                                    
         OPENIT   OPENOC             SKIP PRINT TO LL                           
         M:CORRES  (DCB1,M:LL),(DCB2,M:OC)                                      
         CI,R8    1                                                             
         BE       TYPR10                                                        
TYPRLL   RES      0                                                             
         STW,R15  PRINT1            NOT SAME                                    
         LB,R2    *R15              GET BYTE COUNT                              
         STW,R2   PRINT2            STORE IN WRITE FPT                          
         CAL1,1   PRINT             OUTPUT MSG TO LL                            
TYPR10   RES      0                 CLOSE ALL DCB'S USED                        
         CLOSEIT  CLOSEC                                                        
         CLOSEIT  CLOSEOC                                                       
         CLOSEIT  CLOSELL                                                       
         PULL     0,R0              RESTORE ALL REGISTERS                       
         B        *LINK                                                         
*                                                                               
         PAGE                                                                   
********FNDROM ********                                                         
*                                                                               
*        FUNCTION SEARCH MODIR FILE FOR SPECIFIED ROM AND RETURN ITS            
*                 POSITION IN MODIR IF FOUND.                                   
*                                                                               
*        INPUT    F:BI    = ASSIGNED TO AREA CONTAINING LIBRARY                 
*                 FILENAME= ROM TO FIND                                         
*                                                                               
*        CALL     BAL,RLNK    FNDROM                                            
*                                                                               
*        OUTPUT   R2 = POSITION OF ROM'S ENTRY IN MODIR IF FOUND                
*                 EXITS TO LINK+1                                               
*                 R15 = ADDRESS OF ERROR MESSAGE IF NOT FOUND                   
*                 EXITS TO LINK TO INDICATE ERROR.                              
*                                                                               
*        REGISTERS ALTERED: R2, R14; R15 IF ANY ERRORS                          
*                                                                               
FNDROM   RES      0                                                             
         PUSH     2,R0              SAVE WORK REGISTERS                         
         LI,R2    F:BI              POINT AT DCB TO USE                         
         LW,R0    BPEND             SET BUFFER ADDRESS FOR MODIR FILE           
         STW,R0   BIBUFF                                                        
         LD,R0    MODIR             SET DCB TO GET CORRECT FILE                 
         STD,R0   BIFNAME                                                       
         CAL1,1   OPENANY           OPEN FILE                                   
         CAL1,1   GETRSIZE          GET SIZE OF THE FILE                        
         CI,R0    0                 IS THE FILE EMPTY ?                         
         BNE      FNDROM5             NO, SEE IF ROM IN IT                      
*                                                                               
         LI,R15   MESS16              YES, GIVE 'ROM DOES NOT EXIST'            
         B        FNDROM20                                                      
*                                                                               
FNDROM5  RES      0                                                             
         CW,R0    BCKSZE            WILL FILE FIT IN BACKGROUND SPACE ?         
         BLE      FNDROM10            YES, GO READ IT                           
*                                                                               
         LI,R15   MESS19            NO--'NOT ENUF BCKG SPACE'                   
         B        FNDROM20                                                      
*                                                                               
FNDROM10 RES      0                                                             
         STW,R0   SETRSIZ2          SET SIZE OF RECORD TO READ                  
         CAL1,1   SETRSIZE          SET BYTE COUNT TO READ                      
         LW,R2    SETRSIZ2          RECOVER SIZE                                
         CAL1,1   RDDISCS           READ IN MODIR                               
         CAL1,1   CLFLEIN                                                       
         SLS,R2   -2                WORDS                                       
FNDROM15 RES      0                                                             
         AI,R2    -1                                                            
         LW,R1    *BPEND,R2         GET 2ND HALF OF ROM NAME                    
         AI,R2    -1                                                            
         LW,R0    *BPEND,R2         AND THEN 1ST HALF                           
         CD,R0    FILENAME          IS THIS THE ROM WE WANT ?                   
         BE       FNDROM17                                                      
         BDR,R2   FNDROM15                                                      
         LI,R15   MESS16            ROM NOT FOUND                               
         B        FNDROM20                                                      
*                                                                               
FNDROM17 RES      0         SPECIFIED ROM FOUND; RETURN TO OK EXIT              
         AI,R2    -1                POINT AT 1ST WORD OF ENTRY                  
         AI,RLNK  +1                SET EXIT TO 'OK, ROM FOUND'                 
*                                                                               
FNDROM20 RES      0         ENTRY TO EXIT CODE FOR ERRORS                       
         PULL     2,R0              RECOVER WORK REGISTERS                      
         B        *RLNK             RETURN EITHER OK OR WITH ERROR              
         PAGE                                                                   
         SPACE    3                                                             
*                 OPEN %ROUTINE INTERNAL SYMBOLS                                
         OPEN     %1A,%4A,%4B,%5A,%5B                                           
         OPEN     %7A,%7B,%73600,%760                                           
         OPEN     %8A,%8B,%8C,%8D,%8E,%8F,%9A                                   
         OPEN     %11A,%12A,%12B,%12C,%12D                                      
         OPEN     %12E,%12F,%12G,%12H,%12I,%12J,%12K,%12L                       
         OPEN     %13A,%13B,%13C                                                
         OPEN     TRM                                                           
         SPACE    3                                                             
TRM      CNAME                                                                  
         PROC                                                                   
         DO       NUM(AF)=1                                                     
LF(1)    BAL,14   AF(1)                                                         
         ELSE                                                                   
LF(1)    BAL,AF(2) AF(1)                                                        
         FIN                                                                    
         PEND                                                                   
         TITLE    '** RS1000 - CLEAR PL / SET CP **'                            
***********************************************************************         
*                                                                               
*                            C L E A R   T H E   P R I N T   L I N E            
*                                                                               
*                                                                               
%1       RES      0         CLEAR PRINT LINE                                    
         PUSH     6,R14             SAVE WORKING REGISTERS                      
%1A      LI,R1    %PLLEN            NUMBER OF WORDS TO BLANK                    
         LI,R15   ' '                                                           
         STB,R15  %PL,R1            BLANK IT A CHARACTER  AT A TIME             
         BDR,R1   %-1                                                           
         LI,R1    1                 SET %CP  TO COLUMN 1                        
         STW,R1   %CP               SET THE CP TO 1ST CHAR, CHAR 0              
*                                                                               
%EXIT    EQU      %         NORMAL EXIT FROM MOST ROUTINES                      
         PULL     6,R14                                                         
         B        *R14              RETURN                                      
***********************************************************************         
*                                                                               
*                            S E T   C P   T O   (15)                           
*                                                                               
*                                                                               
%2       RES      0         SET CP TO (15)                                      
         CI,R15   %PLLEN            AT OR BEYOND END OF LINE ?                  
         BG       %+3                 YES, SET AT BEGINNING                     
         CI,R15   1                 BEFORE BEGINNING ?                          
         BGE      %+2                 NO, OK                                    
         LI,R15   1                 SET AT FIRST CHARACTER                      
         STW,R15  %CP               SET POINTER                                 
         B        *R14              RETURN WITH CP SET                          
         TITLE    '** RS1000 - STEP CP / STORE CHAR **'                         
***********************************************************************         
*                                                                               
*                            S T E P   C P   B Y   (15)                         
*                                                                               
*                                                                               
%3       RES      0         STEP CP BY (15)                                     
         AW,R15   %CP               ADD CURRENT POINTER TO GET NEW              
         B        %2                SET TO THAT VALUE, WITH TESTS               
***********************************************************************         
*                                                                               
*                            S T O R E   C H A R   I N   (15)  I N   P L        
*                                                                               
*                                                                               
%4A      PUSH     R14               SAVE RETURN ADDRES                          
         TRM      %11               PRINT CURRENT LINE                          
         TRM      %1                INSURE LINE IS CLEARED                      
         PULL     R14               RECOVER RETURN ADDRESS                      
         B        %4B               AND RE-ENTER STORE CHAR LOOP                
*                                                                               
%4       RES      0         STORE CHARACTER INTO PRINT LINE                     
         PUSH     R1                SAVE WORK REGISTER                          
%4B      LW,R1    %CP               FETCH CURRENT CP                            
         BLEZ     %4A               IF CP < 1, PRINT LINE NOW                   
         CI,R1    %PLLEN            IS LINE AT END ?                            
         BG       %4A                 YES, PRINT CURRENT LINE FIRST             
*                                                                               
         STB,R15  %PL,R1            STORE THE CHARACTER                         
         MTW,+1   %CP               STEP CP TO NEXT CHARACTER                   
         PULL     R1                RESTORE THE WORK REGISTER                   
         B        *R14              RETURN                                      
         TITLE    '** RS1000 - STORE STRING, TEXTC **'                          
*                                                                               
*                                                                               
*                                                                               
%5       RES      0         STORE STRING IN PRINT LINE                          
         PUSH     6,R14             SAVE REGISTERS                              
%5A      XW,R1    R0                SET GET INDEX TO FIRST CHARACTER            
*                                                                               
%5B      LB,R15   *R2,R1            FETCHA CHARACTER                            
         TRM      %4                STORE IT                                    
         AI,R1    1                 STEP FETCH POINTER                          
         BDR,R0   %5B               STEP COUNT AND LOOP IF MORE                 
         B        %EXIT             RETURN                                      
*                                                                               
*                                                                               
*                                                                               
%6       RES      0         STORE STRING IN LINE TEXTC FORM                     
         PUSH     6,R14             SAVE REGISTERS                              
         LB,R1    *R2               FETCH COUNT TO STORE                        
         LI,R0    1                 SET INDEX OF 1ST IN 1ST WORD                
         B        %5A               ENTER %5  LOOP                              
         TITLE    '** RS1000 - STORE (15) AS TIME **'                           
*                                                                               
*                                                                               
*                                                                               
%7       RES      0         STORE (15) AS TIME IN PRINT LINE                    
         PUSH     6,R14             SAVE REGISTERS                              
         LW,R1    R15               COPY AND TEST NUMBER OF SECS                
         BGEZ     %7A               POSITIVE, SO OK                             
         LI,R15   '-'               NEGATIVE, ENTER MINUS SIGN                  
         TRM      %4                                                            
%7A      LAW,R15  R1                SET ABSOLUTE VALUE                          
         LI,R14   0                 CLEAR LEFT HALF OF NUMBER                   
         DW,R14   %73600            COMPUTE NUMBER OF HOURS                     
         STW,R14  %7TEMP+1          SAVE MINUTES, SECS                          
         LI,R0    10                ENTER IN PRINT LINE IN DECIMAL              
         LI,R1    '0'               WITH LEADING ZEROS                          
         LI,R2    2                 IN A 2 PLACE FIELD                          
         TRM      %8                                                            
         LI,R15   C':'              ENTER THE COLON                             
         TRM      %4                                                            
         LD,R14   %7TEMP            FETCH MIN, SEC; CLR LEFT HALF               
         DW,R14   %760              COMPUTER MINUTES                            
         STW,R14  %7TEMP+1          SAVE SECONDS                                
         TRM      %8                ENTER THE MINUTES                           
         LI,R15   C':'              ENTER THE COLON                             
         TRM      %4                                                            
         LW,R15   %7TEMP+1          FETCH SECONDS                               
         TRM      %8                ENTER THEM                                  
         B        %EXIT             RETURN                                      
*                                                                               
%73600   DATA     3600              SECONDS PER HOUR                            
%760     DATA     60                SECONDS PER MINUTE                          
         TITLE    '** RS1000 - STORE INTEGER **'                                
*                                                                               
*                                                                               
*                                                                               
%8       RES      0         CONVERT AN INTEGER TO DEC/HEX NUMBER                
         PUSH     6,R14             SAVE SOME REGISTERS                         
         AI,R2    -%%#DIG           ADJUST WIDTH FOR INTERNAL COUNTING          
         LI,R3    %%#DIG-1          SET MAX DIGITS TO GENERATE                  
%8A      LI,R14   0                 STRIP OFF HIGH ORDER DIGITS                 
         DW,R14   R0                ACCORDING TO BASE IN R0                     
         STB,R14  %TEMP,R3          1 AT A TIME AND SAVE                        
         BDR,R3   %8A               UNTIL 12 ARE DONE                           
         STB,R15  %TEMP             SAVE LAST DIGIT                             
*                                                                               
         LI,R3    -%%#DIG           SET LOOP COUNT FOR CONVERSION               
*                                                                               
%8B      RES      0         PROCESS EACH DIGIT, TEST FOR 0, LEADING             
*                                   ZERO/CHAR, SIGNIFICANCE, ETC                
         LB,R15   %TEMPEND,R3       FETCH NEXT DIGIT FROM LEFT                  
         CI,R15   0                 A ZERO ?                                    
         BNEZ     %8C                 NO, SET SIGNIFICANCE, OUT IT              
         CI,R3    -1                ON LAST DIGIT ?                             
         BE       %8C                 YES, INSURE A PRINTABLE CHAR              
         CI,R2    0                   YES, HAVE SIG YET ?                       
         BGE      %8D                 YES, OUT DIGIT                            
         B        %8F                 NO, SKIP IT                               
*                                                                               
%8C      LAW,R2   R2                DIGIT FOUND; SET SIGNIFICANCE               
         LI,R1    '0'               AND ZEROS = 0'S                             
%8D      OR,R15   R1                INSERT LEADING ZERO/FILLER                  
         CI,R15   X'FA'             HEX DIGIT ?                                 
         BL       %8E                 NO, NORNAL DECIMAL                        
         AI,R15   -(X'FA'-X'C1')      YES, ADJUST -X'39'                        
%8E      BAL,R14  %4                OUT THE CHARACTER                           
%8F      AI,R2    1                 STEP SIGNIFICANCE COUNTER                   
         BIR,R3   %8B               GET NEXT DIGIT IF ANY MORE                  
         B        %EXIT             RETURN                                      
*                                                                               
*                                                                               
         SPACE    3                 E N T E R   D A Y S   D A T E               
*                                                                               
*                                                                               
*                                                                               
%9       RES      0         GET AND ENTER TODAY'S DATE IN PRINT LINE            
         PUSH     6,R14             SAVE REGISTERS                              
         CAL1,8   %9GETOD           GET DATE AND FUNNY TIME                     
         LI,R0    2                 SET POS OF 1ST CHAR IN LAST WRD             
         LI,R1    2                 OUT ONLY 2 CHARS, THE YEAR                  
         LI,R2    %9TOD+3           FROM THE LAST WORD                          
         TRM      %5                ENTER                                       
*                                                                               
%9A      LI,R0    1                 SET TO GET ' MON DD'                        
         LI,R1    7                 GET THE 7 CHARS ' MON DD'                   
         LI,R2    %9TOD+1           FROM THE 1ST WRD FF                         
         B        %5A               ENTER THE STRING AND EXIT                   
         TITLE    '** RS1000 - PRINT THE PRINT LINE **'                         
*                                                                               
         SPACE    2                                                             
%11      RES      0         PRINT THE CURRENT LINE                              
         PUSH     6,R14             SAVE REGISTERS                              
%11A     EQU      %         ENTRY FOR %15,  %16  PRINT ROUTINES                 
         LI,R15   1                 SET UPSPACE 1 LINE AFTER PRINT              
         B        %12A              DO COMMON PRINT PROCESSING                  
*                                                                               
         SPACE    2                                                             
%12      RES      0          PRINT AND UPSPACE (15)  LINES                      
         PUSH     6,R14             SAVE REGISTERS                              
%12A     RES      0         ENTRY TO %12 FROM %11                               
         PUSH     3,R8              SAVE REGISTERS CHANGED ON ERRORS            
*                                                                               
*                                                                               
%12C     RES      0         PROCESS AN OUTPUT LINE REQUEST                      
         LI,R0    0                 INIT A WORD OF ZEROES                       
         LW,R1    %UP               R1 (VFC) <= PREVIOUS UPSPACE COUNT          
         LW,R15   R15               IS UPSPACE AFTER PRINT REQUESTED?           
         BGZ      %12H                YES, PROCESS QUICKLY                      
*                                                                               
*                           INHIBIT UPSPACE AFTER PRINT                         
         STW,R0   %UP                 NO, RESET PREVIOUS UPSPACE                
         AWM,R15  %19@3             DECR LINES LEFT ON PAGE; AT END ?           
         BLEZ     %12E                YES, PROCESS PAGE OVERFLOW                
*                                                                               
         SW,R1    R15               ADD CURR UPSPACE TO PREVIOUS                
         BEZ      %12D              TOTAL = 0  ==> OVERPRINT                    
*                                                                               
         AI,R1    X'C0'             MAKE VFC = UPSPACE BEFORE PRINT             
         STB,R1   %PL               AND SET IN VFC BYTE OF PRINT LINE           
         LI,R8    %PL               SET LOCATION AND LENGTH OF THE              
         STW,R8   WRITELO+4         LINE TO WRITE                               
         LI,R8    1                 WRITE ONLY THE VFC BYTE                     
         STW,R8   WRITELO+5                                                     
*                                   SPACE THE N-1 BLANK LINES                   
         CAL1,1   WRITELO           WRITE THE LINE                              
*                                                                               
%12D     RES      0         SET TO PRINT WITH UPSPACE INHIBITED                 
         LI,R1    X'E0'             UPSPACE 0 LINES AFTER PRINT                 
         LI,R15   0                 SET NO UPSPACE AFTER LEFT TO DO             
         B        %12I              NOW PRINT USER'S LINE                       
*                                                                               
%12E     RES      0         UPSPACE BEFORE OVERFLOWS PAGE; SKIP TO NEXT         
         LI,R15   0                 SET UPSPACE 0 AFTER PAGE EJECT              
         B        %12G              GO EJECT AND OUT TITLE, IF ANY              
*                                                                               
%12F     RES      0         CONVERT UPSPACE REQUEST TO 1 LINE AFTER             
         LI,R15   1                 TO START NEXT PAGE ON 1ST LINE.             
*                                                                               
%12G     RES      0         OUT TITLE LINE ON A NEW PAGE                        
         TRM      %13               SKIP TO NEW PAGE; PRINT TITLE               
         B        %12C              AND REPROCESS THE LINE                      
*                                                                               
*                                                                               
%12H     RES      0         UPSPACE AFTER PRINT                                 
         STW,R15  %UP               SET NEW 'PREVIOUS UPSPACE COUNT'            
         MTW,-1   %UP               -1 FOR AUTO UPSPACE AFTER PRINT             
         AI,R1    X'C0'             SET UPSPACE BEFORE PRINT CONTROL            
         CI,R15   X'F0'             PAGE CONTROL SPECIFIED ?                    
         BGE      %12F                YES, GO OUT TITLE FIRST                   
*                                                                               
%12I     RES      0         SET VFC,  WRITE THE LINE                            
         STB,R1   %PL               STORE VFC AT START OF LINE                  
         LI,R8    %PL               SET LOCATION AND LENGTH OF THE              
         STW,R8   WRITELO+4         LINE TO WRITE                               
         LI,R1    %PLLEN            SCAN FOR TRAILING BLANKS AND                
         LI,R8    C' '              TRUNCATE THEM OFF                           
*                                                                               
%12J     RES      0         SEARCH FOR LAST NON-BLANK CHARACTER                 
         CB,R8    %PL,R1            IS THE CHARACTER A BLANK ?                  
         BNE      %12K                NO, END OF LINE FOUND                     
         BDR,R1   %12J                YES, TEST NEXT CHARACTER                  
*                                                                               
         AI,R1    1                 INSURE AT LEAST 1 CHARACTER                 
*                                                                               
%12K     RES      0         SET LENGTH AND PRINT THE LINE                       
         AI,R1    1                 INCLUDE LAST NON-BLANK CHAR                 
         STW,R1   WRITELO+5         SET BYTE COUNT IN FPT                       
         CAL1,1   WRITELO           AND WRITE THE LINE                          
*                                                                               
         LCW,R15  R15               SUBTRACT UPSPACE COUNT FROM LINES           
         AWM,R15  %19@3             REMAINING ON PAGE; AT BOTTOM ?              
         BGZ      %12L                NO, SKIP ON                               
*                                                                               
         TRM      %13               YES, EJECT TO A NEW PAGE                    
*                                                                               
%12L     RES      0         LINE COMPLETELY PROCESSED; CLEAN UP; EXIT           
         PULL     3,R8              RECOVER POSSIBLE LOST REGS                  
         B        %1A               CLEAR THE LINE                              
         TITLE    '** RS1000 - PRINT/PAGE ROUTINES **'                          
*                                                                               
*                                                                               
%13      RES      0        EJECT TO TOP OF FORM; OUT TITLE LINE IF ANY          
         PUSH     6,R14             SAVE REGISTERS                              
         LB,R2    K:PAGE            GET LINES PER PAGE AS PER SYSGEN            
         MTW,+00  %19@4             IS THERE A PAGE HEADER ?                    
         BLEZ     %13A                NO, A FULL PAGE                           
*                                                                               
         AI,R2    -1                  YES, AVAILABLE LINES IS 1 LESS            
*                                                                               
%13A     RES      0         SUPPRESS TOP OF FORM SKIP IF FULL PAGE              
         STW,R2   %19@3             SET LINES REMAINING = FULL PAGE             
         PUSH     3,R8              SAVE REGS ALTERED ON WRITE ERRORS           
         LI,R1    133               SET LENGTH OF MAX TITLE LINE                
         LW,R2    %19@4             IS A TITLE LINE GIVEN ?                     
         BNEZ     %13B                YES, PRINT THE GIVEN TITLE LINE           
*                                                                               
         LI,R2    %PL               USE 1ST CHAR OF %PL ONLY                    
         LI,R1    1                 SET LENGTH TO JUST VFC CHARACTER            
*                                                                               
%13B     RES      0         DO THE SKIP TO TOP OF NEW PAGE                      
         LI,R0    X'F1'             SET PAGE EJECT VFC                          
         STB,R0   *R2               SET VFC                                     
         STW,R1   WRITELO+5         SET LENGTH                                  
         STW,R2   WRITELO+4         SET LOCATION                                
         CAL1,1   WRITELO           WRITE LINE OR VFC TO EJECT PAPER            
         PULL     3,R8              RECOVER REGS LOST ON CAL ERRORS             
         LI,R0    0                 CLEAR %UP TO                                
         STW,R0   %UP               NO UPSPACE LINES BACKED UP                  
         B        %EXIT             RETURN TO CALLER                            
*                                                                               
*                                                                               
*                                                                               
%14      RES      0         PAGE PRINTER WITH LINE AS HEADER                    
         PUSH     6,R14             SAVE REGISTERS                              
         TRM      %13               PAGE PRINTER & PRINT TITLE, IF ANY          
         B        %11A              AND PRINT A NORMAL LINE                     
*                                                                               
*                                                                               
*                                                                               
%15      RES      0          PRINT STRING OF LEN (1) AT (2)                     
         PUSH     6,R14                                                         
         TRM      %1                CLEAR PRESENT LINE                          
         TRM      %5                ENTER STRING                                
         B        %11A              PRINT THE STRING AS USUAL                   
*                                                                               
*                                                                               
*                                                                               
%16      RES      0          PRINT STRING                                       
         PUSH     6,R14             SAVE REGISTERS                              
         TRM      %1                CLEAR THE LINE                              
         TRM      %6                STORE THE STRING IN THE LINE                
         B        %11A              PRINT THE STRING AS USUAL                   
         TITLE    '** RS1000 - END OF % ROUTINES **'                            
         SPACE    3                                                             
         CLOSE    %1A,%4A,%4B,%5A,%5B                                           
         CLOSE    %7A,%7B,%73600,%760                                           
         CLOSE    %8A,%8B,%8C,%8D,%8E,%8F,%9A                                   
         CLOSE    %11A,%12A,%12B,%12C,%12D                                      
         CLOSE    %12E,%12F,%12G,%12H,%12I,%12J,%12K,%12L                       
         CLOSE    %13A,%13B,%13C                                                
         CLOSE    TRM                                                           
         PAGE                                                                   
*                                                                               
*        ENVIRONMENT FOR GETIOID                                                
*                                                                               
GIOSCAN  CNAME                                                                  
         PROC                                                                   
         LI,R0    1                                                             
         STW,R0   SCAN97            SCAN POSSIBLE FILE ID                       
         STW,R0   1,R7              SCAN EBCDIC                                 
         BAL,R8   SCAN              GET NEXT SUBFIELD                           
         CI,R6    0                                                             
         BL       GIOEXIT           B IF SCAN ERROR                             
         PEND                                                                   
*                                                                               
GIOBITS  DATA     1**(31-1)+1**(31-2)+1**(31-3)+1**(31-13)  P2+P3+P4+P14        
GIOOBIT  DATA     1**(31-1)         P2 (OPLABEL)                                
GIODBIT  DATA     1**(31-2)         P3 (DEVICE)                                 
GIOFBIT  DATA     1**(31-3)         P4 (FILE ID)                                
GIOABIT  DATA     1**(31-13)        P14 (ACCOUNT NAME)                          
GIODEV0  DATA     '0   '            NULL DEVICE NAME                            
GIOFA    DATA     1**(31-3)+1**(31-13)   P4 AND P14                             
NULLDEV  EQU      ZEROS                                                         
BLBLBL   DATA     X'00404040'       3 TRAILING BLANKS                           
NLBB     EQU      DCTDATA           NEW-LINE, BANG, BANG                        
         PAGE                                                                   
*                                                                               
*        GETFID:  SETS UP R9 FOR FILE/ACCOUNT AND CALLS GETIOID                 
*                                                                               
GETFID   RES      0                                                             
         LW,R9    GIOFA             FLAGS FOR FILE/ACCOUNT PERMITTED            
GET10    RES      0                 COMMON CODE FOR ALL GETXXXS                 
         PUSH     R8                SAVE RETURN POINTER                         
         STW,R9   GIOCT             SET FLAGS IN CONTROL TABLE                  
         LI,R9    GIOCT             GET TABLE ADDRESS                           
         BAL,R8   GETIOID                                                       
         PULL     R8                                                            
         B        *R8                                                           
*                                                                               
*                                                                               
*        GETDEV: SETS UP R9 FOR DEVICE AND CALLS GETIOID                        
*                                                                               
GETDEV   RES      0                                                             
         LW,R9    GIODBIT           FLAG FOR DEVICE PERMITTED                   
         B        GET10                                                         
*                                                                               
*                                                                               
*        GETOPLB:  SETS UP R9 FOR OPLABEL AND CALLS GETIOID                     
*                                                                               
GETOPLB  RES      0                                                             
         LW,R9    GIOOBIT           FLAG FOR OPLABEL PERMITTED                  
         B        GET10                                                         
*                                                                               
*                                                                               
*        GETANY:  SETS UP R9 FOR ANY IO ID AND CALLS GETIOID                    
*                                                                               
GETANY   RES      0                                                             
         LW,R9    GIOBITS           SET FLAGS FOR ANY IO ID TYPE                
         B        GET10                                                         
         TITLE    '** RS1000 - GETIOID **'                                      
*                                                                               
*        NAME:    GETIOID                                                       
*                                                                               
*        PURPOSE: SCAN A DEVICE, OPLABEL, OR FILE IDENTIFIER                    
*                 FROM A COMMAND                                                
*                                                                               
*        CALL:    BAL,R8  GETIOID                                               
*                                                                               
*        INPUT:   R9 = ADDRESS OF A MEMORY AREA, THE FIRST                      
*                      WORD OF WHICH INDICATES PERMISSIBLE FORMS AS             
*                      FOLLOWS:                                                 
*                      BIT 1 SET IF AN OPLABEL NAME IS PERMITTED                
*                      BIT 2 SET IF A DEVICE NAME IS PERMITTED                  
*                      BIT 3 SET IF A FILE AND AREA IS PERMITTED                
*                      BIT 13 SET IF AN ACCOUNT NAME IS PERMITTED               
*                      NOTE THAT THESE ARE THE CORRESPONDING                    
*                      P-BITS FOR AN ASSIGN CAL.                                
*                      FOLLOWING THE FIRST WORD MUST BE ENOUGH                  
*                      SPACE FOR THE RETURN AS INDICATED BELOW                  
*                      (SPACE NEED NOT BE ALLOWED FOR NON-                      
*                      PERMISSIBLE NAME TYPES)                                  
*                 R7 = R7 VALUE FOR SCAN                                        
*                                                                               
*        RETURN:  R6 = -1 IF A NON-ALLOWED OR UNRECOGNIZED FORM                 
*                      IS FOUND.  OTHERWISE, AS RETURNED FROM                   
*                      THE LAST SCAN CALL.                                      
*                 R10,R11 AS RETURNED FROM LAST SCAN CALL                       
*                 OTHER REGISTERS UNCHANGED                                     
*                 AREA POINTED BY R9:                                           
*                   FIRST WORD BITS 1, 2, 3, AND 13 SET TO INDICATE             
*                   THE FORM FOUND. OTHER BITS UNCHANGED.                       
*                   FOLLOWING WORDS AS INDICATED BELOW:                         
*                      OPLABEL:  RIGHT-ALIGNED IN ONE WORD                      
*                      DEVICE:  LEFT-ALIGNED WITH TRAILING BLANKS               
*                      IN TWO WORDS                                             
*                      FILE AND AREA:  AREA NAME IN ONE WORD, RIGHT             
*                      ALIGNED, AND FILE NAME IN FOLLOWING TWO                  
*                      WORDS, LEFT-ALIGNED WITH TRAILING BLANKS                 
*                      ACCOUNT NAME: IN TWO WORDS FOLLOWING THE                 
*                      SPACE FOR FILE AND AREA NAMES (WORDS 4                   
*                      AND 5 FOLLOWING THE P-BIT WORD), LEFT-ALIGNED            
*                      WITH TRAILING BLANKS                                     
*                      THIS FORMAT MAY BE USED IN AN ASSIGN CAL FPT.            
*                                                                               
GETIOID  RES      0                                                             
         PUSH     R8                                                            
         PUSH     4,R0                                                          
*                                                                               
         LW,R1    R9                SAFER AND MORE USABLE PLACE                 
         GIOSCAN                    GET NEXT SUBFIELD                           
*                                                                               
*        CHECK TO SEE IF A DEVICE NAME COULD BE IN R8, R9                       
         LW,R0    GIODBIT                                                       
         CW,R0    *R1                                                           
         BAZ      GIO10             B IF NOT PERMITTED                          
         CI,R6    2                                                             
         BG       GIO10             B IF NEW-FORMAT FILE ID                     
         CW,R8    GIODEV0                                                       
         BNE      GIO01             B IF NOT NULL DEVICE                        
         LD,R8    NULLDEV           GET NULL DEVICE ID                          
         B        GIO05                                                         
*****                                                                           
GIO01    RES      0                                                             
         CI,R10   5                                                             
         BNE      GIO10             B IF WRONG LENGTH                           
         SLD,R8   -24               ADJUST TO DCT16 FORMAT                      
         OR,R8    NLBB                                                          
         LH,R2    *K:DCT1           GET DCT NR OF ENTRIES                       
GIO02    RES      0                 SEARCH FOR NAME IN DCT                      
         CD,R8    *K:DCT16,R2                                                   
         BE       GIO03             B IF FOUND                                  
         BDR,R2   GIO02                                                         
         SLD,R8   24                NOT FOUND.  RESTORE NAME                    
         OR,R9    BLBLBL                                                        
         B        GIO10                                                         
*****                                                                           
GIO03    RES      0                                                             
         SLD,R8   24                NAME FOUND. RESTORE TO INPUT FORMAT         
         OR,R9    BLBLBL                                                        
GIO05    RES      0                                                             
*                                                                               
*        DEVICE ID SCANNED. PACK IT AWAY.                                       
         STW,R8   1,R1                                                          
         STW,R9   2,R1                                                          
         LW,R3    GIODBIT                                                       
         B        GIOOKEX           SPLIT                                       
*****                                                                           
GIO10    RES      0                                                             
*                                                                               
*        CHECK TO SEE IF AN OPLABEL NAME COULD BE IN R8                         
         LW,R0    GIOOBIT                                                       
         CW,R0    *R1                                                           
         BAZ      GIO20             B IF NOT PERMITTED                          
         CI,R6    2                                                             
         BG       GIO20             B IF NEW-FORMAT FILE ID                     
         CI,R10   2                                                             
         BG       GIO20             B IF NAME IS TOO LONG                       
         LH,R2    *K:OPLBS1         GET OPLBS1 NR OF ENTRIES                    
         LH,R0    R8                                                            
GIO15    RES      0                 SEARCH FOR NAME IN OPLB                     
         CH,R0    *K:OPLBS1,R2                                                  
         BE       GIO17             B IF FOUND                                  
         BDR,R2   GIO15                                                         
         B        GIO20             B IF NOT FOUND                              
*****                                                                           
GIO17    RES      0                                                             
*                                                                               
*        OPLABEL NAME SCANNED. PACK IT AWAY.                                    
         SLS,R8   -16                                                           
         STW,R8   1,R1                                                          
         LW,R3    GIOOBIT                                                       
         B        GIOOKEX                                                       
*****                                                                           
GIO20    RES      0                                                             
*                                                                               
*        CHECK TO SEE IF AN OLD-FORMAT AREA NAME COULD BE IN R8, R9             
         LW,R0    GIOFBIT                                                       
         CW,R0    *R1                                                           
         BAZ      GIO30             B IF NOT PERMITTED                          
         CI,R6    0                                                             
         BG       GIO30             B IF NEW-FORMAT FILE ID                     
         CI,R10   2                                                             
         BNE      GIO30             B IF WRONG LENGTH                           
*                                                                               
*        OLD FORMAT AREA NAME FOUND. PACK IT AWAY.                              
*                                                                               
         SLS,R8   -16                                                           
         STW,R8   1,R1                                                          
         LW,R3    GIOFBIT           FLAG FOR FILE ID FOUND                      
*                                                                               
*        FILE NAME FOLLOWS AREA NAME                                            
         GIOSCAN                    GET NEXT SUBFIELD                           
         CI,R6    2                                                             
         BG       GIOEREX           B IF A NEW-FORMAT TERMINATOR                
*                                                                               
*        FILE NAME FOUND. PACK IT AWAY.                                         
         STW,R8   2,R1                                                          
         STW,R9   3,R1                                                          
*                                                                               
         LW,R0    GIOABIT                                                       
         CW,R0    *R1               IS AN ACCOUNT NAME REQUESTED                
         BAZ      GIOOKEX           NO, SKIP THIS                               
*                                   YES                                         
         LI,R0    0                                                             
         STW,R0   4,R1                                                          
         STW,R0   5,R1              ZERO IS THE DEFAULT ACCOUNT NAME            
         B        GIOOKEX           DONE.                                       
*****                                                                           
*        ASSUME SCANNED FIELD IS A NEW-FORMAT FILE NAME                         
GIO30    RES      0                                                             
         LW,R3    GIOFBIT                                                       
         CW,R3    *R1                                                           
         BAZ      GIOEREX           B IF FILE ID NOT PERMITTED                  
         STW,R8   2,R1                                                          
         STW,R9   3,R1              SET FILE NAME                               
         LI,R0    0                                                             
         STW,R0   1,R1              SET AREA NAME UNSPECIFIED FOR NOW.          
*                                                                               
         LW,R0    GIOABIT                                                       
         CW,R0    *R1               IS AN ACCOUNT NAME REQUESTED                
         BAZ      GIO31             NO, SKIP THIS                               
*                                   YES                                         
         LI,R0    0                                                             
         STW,R0   4,R1                                                          
         STW,R0   5,R1              ZERO IS THE DEFAULT ACCOUNT NAME            
*                                                                               
GIO31    RES      0                                                             
         CI,R6    3                                                             
         BNE      GIOOKEX           B IF NO MORE FILE ID FIELDS                 
         GIOSCAN                    GET NEXT SUBFIELD                           
*                                                                               
*        CHECK TO SEE IF A NEW-FORMAT AREA NAME COULD BE IN R8, R9              
         CI,R10   0                                                             
         BE       GIO34             B IF NULL (DEFAULT) AREA                    
         CI,R10   2                                                             
         BNE      GIO35             B IF WRONG LENGTH                           
         LB,R2    K:MDNAME          NR OF AREA NAMES                            
GIO33    RES      0                                                             
         AI,R2    -1                                                            
         BLZ      GIO35             B IF NOT AN AREA NAME                       
         LH,R0    *K:MDNAME,R2      GET NEXT NAME FROM TABLE                    
         CH,R0    R8                                                            
         BNE      GIO33             B IF NOT MATCHED                            
*                                                                               
*        AREA NAME FOUND. SET IT.                                               
         SLS,R8   -16                                                           
         STW,R8   1,R1                                                          
*                                                                               
GIO34    RES      0                                                             
         CI,R6    3                                                             
         BNE      GIOOKEX           B IF NO MORE FILE ID FIELDS                 
         GIOSCAN                    GET NEXT SUBFIELD                           
*                                                                               
GIO35    RES      0                                                             
*                                                                               
*        CHECK TO SEE IF AN ACCOUNT NAME COULD BE IN R8, R9                     
         LW,R0    GIOABIT                                                       
         CW,R0    *R1                                                           
         BAZ      GIOEREX           B IF NOT PERMITTED                          
*                                                                               
*        ACCOUNT NAME FOUND. SET IT                                             
         STW,R8   4,R1                                                          
         STW,R9   5,R1                                                          
         OR,R3    GIOABIT           SET ACCOUNT NAME BIT.                       
         CI,R6    3                                                             
         BNE      GIOOKEX           B IF END OF FILE ID                         
*        OTHERWISE, TOO MANY FILE ID FIELDS                                     
*                                                                               
*        NON-SCAN ERROR ENCOUNTERED. SET R6 AND EXIT.                           
GIOEREX  RES      0                                                             
         LI,R6    -1                                                            
         B        GIOEXIT                                                       
*****                                                                           
*        NORMAL EXIT                                                            
*        R1 IS PARAM TABLE POINTER                                              
*        R2 IS P-BITS FOR TYPE OF I/O STREAM NAME FOUND                         
GIOOKEX  RES      0                                                             
         LW,R9    R1                RESTORE R9                                  
         LW,R0    R3                GET NEW P-BIT SETTING                       
         LW,R1    GIOBITS                                                       
         STS,R0   *R9               SET EM                                      
*                                                                               
*        ALL EXIT PATHS MEET HERE                                               
GIOEXIT  RES      0                                                             
         PULL     4,R0              RESTORE OTHER STUFF                         
         PULL     R8                RESTORE LINK                                
GIOEX    B        *R8               RETURN                                      
*****                                                                           
*****                                                                           
         TITLE    '** RS1000 - SCAN ROUTINE 88'                                 
*                                                                               
*                                                                               
*                                   SCANS ONE SUBFIELD AT A TIME                
*                                                                               
*                                   CALL IS   BAL,R8   SCAN                     
*                                     WHERE  R7=ADD. OF INPUT PARAM.            
*                                     WHICH ARE                                 
*                                                                               
*                                       WORD 1= ADD. OF INPUT BUFFER            
*                                               (MUST START ON WORD BND)        
*                                       WORD 2=1, LEAVE FIELD IN EBCDIC         
*                                             =2, CONVERT TO HEX                
*                                             =4, CONVERT TO DECIMAL            
*                                             =3, CONVERT TO HEX OR BCD         
*                                             =5, CONVERT TO DEC OR BCD         
*                                                                               
*                                       WORD 3=0, FIRST TIME FOR CARD           
*                                             =1, CONTINUE ON CARD              
*                                                                               
*                                   EXITS WITH FOLLOWING:                       
*                                                                               
*                                     R7- UNCHANGED                             
*                                     R8,R9- CONTAIN VALUE                      
*                                       IF R9=0, R8 CONTAINS DEC OR HEX         
*                                            =NONZERO, R8 AND R9 CONTAIN        
*                                               EBCDIC(UNUSED CHAR. HAVE        
*                                               BLANKS)                         
*                                                                               
*                                     R6=0, END OF SUBFIELD                     
*                                       =1, END OF FIELD                        
*                                       =2, END OF CARD                         
*                                       =3, END OF FILE ID FIELD                
*                                           (ONLY IF SCAN97=1)                  
*                                       =-1,ERROR IN SUBFIELD OR FIELD          
*                                         ERRORS ARE:                           
*                                           ILLEGAL CHAR.                       
*                                           MORE THAN 8 CHARS.                  
*                                           COL. 80 SCANNED                     
*                                           ILLEGAL PARENTHSES                  
*                                           NO : IN COL. ONE                    
*                                     R10= NO. CHARS. IN FIELD OR SUBF.         
*                                     R11= SUBFIELD NO. IN EBCDIC FOR           
*                                          ERROR FIELD XX ALARM; CHARS.         
*                                          ARE IN BITS 8-23, OTHER CHARS        
*                                          ARE BLANKS                           
*                                                                               
*                                   REGISTERS USED:  R12-R5 SAVED               
*                                                    R6-R11 OUTPUT PARAMETERS   
*                                                    R7 IS UNCHANGED            
*                                   AFTER AN ERROR RETURN, WORD 3 OF            
*                                     INPUT PARAM. MUST BE ZERO                 
*                                                                               
*                                                                               
*                                                                               
*                                                                               
*                                                                               
SCAN     RES      0                 SAVE RETURN ADDRESS                         
         PUSH     R0                SAVE R0 AND R5                              
         PUSH     R5                                                            
         STW,LINK SCAN99            SAVE LINK                                   
         LW,R0    *R7                                                           
         STW,R0   SCAN96            SAVE ADD. OF BUFFER                         
         LW,R0    SCAN92            IS IT A CONT. CARD                          
         BNEZ     SCAN0             NO                                          
         PUSH     RLNK              SAVE LINK TO READ CMND ROUTINE              
         BAL,RLNK PROCSCN           READ THE CONTINUATION LINE                  
         PULL     RLNK              RECOVER THE SAVED REGISTER                  
*                                                                               
SCAN0    LW,R8    SCAN89A           HOUSEKEEP R8,R9 TO ALL BLANKS               
         STW,R8   R9                                                            
         LI,R0    -9                                                            
         STW,R0   SCAN93            HOUSEKEEP CHAR. COUNT                       
         LI,R0    0                                                             
         STW,R0   SCAN95            CLEAR COUNT OF HEX CHARS.                   
         LW,R0    2,R7              IS THIS A CONTINUATION                      
         BNEZ     SCAN4             YES                                         
         STW,R0   SCAN90            HOUSEKEEP FIELD FLAG AND                    
         STW,R0   MODEFLAG          SET APPROPRIATE SCAN MODE                   
*                                                                               
         LI,R0    -1                  PARENTHESES FLAG                          
         STW,R0   SCAN91                                                        
SCAN1    LI,R0    X'F0F0'                                                       
         STW,R0   SCAN94            HOUSEKEEP FIELD COUNT                       
         LI,R6    0                                                             
         LB,R0    *SCAN96           IS COLUMN ONE A COLON                       
         CI,R0    X'7A'                                                         
         BNE      %+2               ACCEPT IF NOT ; OTHERWISE                   
         LI,R6    1                 SET TO COL. 2                               
         LI,R0    X'40'                                                         
SCAN2    CB,R0    *SCAN96,R6        SCAN OFF LEADING BLANKS                     
         BNE      SCAN6             NOT BLANK                                   
         AI,R6    1                 STEP INDEX                                  
         CI,R6    80                                                            
         BL       SCAN2             NOT COL. 80 YET                             
         LI,R10   0                 BLANK CARD, SET NO. CHARS=0                 
         LI,R6    2                 SET TO END OF CARD                          
         B        SCAN33            EXIT                                        
*                                                                               
* * * * * * * * * * * * * * * *                                                 
SCAN4    LW,R0    MODEFLAG                                                      
         BGZ      %+3                                                           
         LI,R0    1                                                             
         STW,R0   PARENFLG                                                      
         LW,R0    SCAN92            IS THIS CONTINUATION FLAG                   
* * * * * * * * * * * * * * * * *                                               
         BEZ      SCAN1             YES                                         
         LW,R6    SCAN98            GET COL. INDEX                              
         AI,R6    1                 STEP TO NEXT COL.                           
SCAN6    LW,R11   1,R7              GET INPUT CONVERSION TYPE IN R11            
         LI,R0    0                                                             
         STW,R0   SCAN98            HOUSEKEEP                                   
         MTW,1    SCAN94            STEP FIELD COUNTER IN EBCDIC                
         LI,R5    3                 CHECK FOR OVERFLOW AND RESET IF             
         LI,R0    X'FA'             OVERFLOW                                    
         CB,R0    SCAN94,R5                                                     
         BG       SCAN7             NO OVERFLOW                                 
         LI,R0    X'F0'             RESET FOR OVERFLOW                          
         STB,R0   SCAN94,R5                                                     
         LI,R5    2                                                             
         MTB,1    SCAN94,R5                                                     
SCAN7    LB,R10   *SCAN96,R6        GET NEXT BYTE                               
         CI,R10   X'C1'                                                         
         BL       SCAN25            SPECIAL CHAR.                               
         MTW,1    SCAN93            STEP CHAR. COUNT                            
         BNEZ     SCAN9             NOT TOO MANY CHARS.                         
SCAN8    EQU      %                 ERROR EXIT                                  
         STW,R6   SCAN98            SAVE COLUMN IN ERROR                        
         LI,R6    -1                SET ERROR INDICATOR                         
         B        SCAN33            GO TO EXIT                                  
*                                                                               
SCAN9    CI,R10   X'C7'                                                         
         BL       SCAN19            HEX CHAR.                                   
         CI,R10   X'F0'                                                         
         BL       SCAN14            EBCDIC CHAR.                                
         CI,R10   X'FA'                                                         
         BGE      SCAN8             ERROR, ILLEGAL CHAR.                        
         CI,R11   4                 IS FIELD DECIMAL                            
         BL       SCAN19            NO DECIMAL CONVERSION                       
         LI,R11   4                 SET FLAG SO ONLY DECIMAL CONVERSION         
         CW,R8    SCAN89A           IS THIS FIRST CHAR.                         
         BNE      %+2               NO                                          
         LI,R8    0                 YES, CLEAR R8                               
         LW,R9    R8                                                            
         MI,R9    10                CHANGE TO DECIMAL                           
         AI,R10   -X'F0'                                                        
         AW,R9    R10               ADD INTO ACC. SUM                           
         LW,R8    R9                MOVE VALUD TO R8                            
SCAN10   LI,R9    0                 SET EXIT VALUE TO DEC OR HEX                
SCAN11   LW,R0    SCAN91            WAS ) PREVIOUS CHAR.                        
         BEZ      SCAN8             YES, ERROR IN FIELD                         
SCAN12   AI,R6    1                 STEP COL. COUNT                             
         CI,R6    80                COL. 80                                     
         BL       SCAN7             NO                                          
         B        SCAN37C           YES, ERROR                                  
*                                                                               
SCAN14   LW,R0    R10               CHECK FOR LEGAL EBCDIC CHAR.                
         AND,R0   M4                                                            
         BEZ      SCAN8             ILLEGAL CHAR.                               
         CI,R0    'A'                                                           
         BGE      SCAN8             ILLEGAL CHAR.                               
         CI,R10   X'E1'                                                         
         BE       SCAN8             ILLEGAL CHAR.                               
SCAN14A  LI,R0    1                                                             
         AND,R11  R0                EBCDIC CONV. REQUESTED                      
         BEZ      SCAN8             NO, ERROR                                   
         LW,R5    SCAN93            GET CHAR. COUNT                             
         AI,R5    8                 GET PROPER BYTE FOR CHAR.                   
         STB,R10  R8,R5             STORE CHAR. IN PROPER BYTE                  
         B        SCAN11                                                        
*                                                                               
SCAN19   RES      0                                                             
SCAN20   LI,R0    2                                                             
         AND,R0   R11                                                           
         BEZ      SCAN14A           NOT HEX CONV.                               
         LI,R11   2                 SET TO HEX ONLY                             
         CW,R8    SCAN89A           IS THIS FIRST CHAR.                         
         BNE      SCAN22            NO                                          
         LI,R8    0                 YES, CLEAR R8                               
SCAN22   SLS,R8   4                                                             
         CI,R10   X'F0'                                                         
         BGE      %+2                                                           
         AI,R10   X'39'             CHANGE TO HEX                               
         AI,R10   -X'F0'                                                        
         AW,R8    R10                                                           
         MTW,1    SCAN95            STEP COUNT OF HEX                           
         B        SCAN10            GET NEXT CHAR.                              
*                                                                               
SCAN25   RES      0                                                             
SCAN27   CI,R10   X'6B'             CHECK FOR COMMA                             
         BNE      SCAN35            NO                                          
         LW,R0    SCAN91            YES,GET PARENTHESES FLAG                    
         BGZ      SCAN29            NOT END OF FIELD                            
         LI,R0    -1                                                            
         STW,R0   SCAN91            RESET PARENTHESES FLAG                      
SCAN28   MTW,1    SCAN98            SET EXIT PARAM. FOR END OF FIELD            
SCAN29   MTW,1    SCAN90            STEP FIELD FLAG                             
         LW,R10   SCAN93            GET CHAR. COUNT ON EXIT                     
         AI,R10   9                 CHANGE TO POSITIVE                          
SCAN32   XW,R6    SCAN98            SAVE CHAR COUNT AND SET EXIT PM.            
SCAN33   MTW,1    SCAN92            STEP CONT. CARD FLAG                        
         LW,R11   SCAN94            SET R11 TO FIELD NO.                        
         SLS,R11  8                 POSITION TO PROPER BITS                     
         AW,R11   SCAN89            ADD IN BLANKS                               
         LW,R0    2,R7              TEST IF MNEMONIC SCAN                       
         BNEZ     SCAN33X           NO, EXIT                                    
         LI,R0    0                 OTHERWISE, LEAVE MODE UNDECIDED             
         STW,R0   MODEFLAG                                                      
SCAN33X  RES      0                                                             
         LI,R0    0                                                             
         STW,R0   SCAN97            RESET FILE ID SCAN FLAG                     
         PULL     R5                RECOVER EXTRA SAVED REGS                    
         PULL     R0                                                            
         B        *SCAN99           EXIT                                        
*                                                                               
SCAN35   CI,R10   X'5D'             RIGHT PARENTH.                              
         BNE      SCAN36            NO                                          
         LW,R0    SCAN91            YES, CHECK LEGALITY                         
         BLEZ     SCAN8             ERROR, RT.PARENTH., BUT NO LEFT             
         MTW,-1   SCAN91            SET PARENTH. FLAG TO RT. PARENTH.           
         B        SCAN12            GET NEXT CHAR.                              
SCAN36   CI,R10   X'4D'             LEFT PARENTHSES                             
         BNE      SCAN37            NO                                          
* * * * * * * * * * * * * *                                                     
         LW,R0    MODEFLAG          TEST IF ALTERNATE MODE                      
         BLZ      ERREXIT           IF SO, ERROR ON INPUT                       
         BGZ      %+4               NO, SKIP IF MODE DETERMINED                 
         LI,R0    1                 OTHERWISE SET TO NORMAL MODE                
         STW,R0   MODEFLAG          AND SKIP DOUBLE LEFT PAREN TEST             
         B        %+3                                                           
* * * * * * * * * * * * * * * * * *                                             
         MTW,0    SCAN91            YES                                         
         BGZ      SCAN8             ERROR, 2 LFT. PARENTH. IN A ROW             
         LI,R0    1                                                             
         STW,R0   SCAN91            SET TO LEFT PARENTH.                        
         B        SCAN12            GET NEXT CHAR.                              
SCAN37   CI,R10   X'40'             BLANK                                       
         BNE      SCAN38            NO                                          
* * * * * * * * * * * **** * *                                                  
         LW,R0    MODEFLAG          CHECK EOF(IELD) OR EOC(ARD)                 
         BGZ      SCAN37Y           OUT ON NORMAL MODE, EOC                     
SCAN37X  AI,R6    1                 STRIP OFF MULTIPLE BLANKS                   
         CI,R6    COLEXTNT          TEST ENDING                                 
         BE       SCAN37C           END-OF-CARD                                 
         CB,R10   *SCAN96,R6                                                    
         BE       SCAN37X           ANOTHER BLANK                               
         AI,R6    -1                REPOSITION TO LAST BLANK                    
         LI,R0    -1                                                            
         STW,R0   MODEFLAG          SET TO ALTERNATE SCAN MODE                  
         B        SCAN28            GOTO EXIT WITH END-OF-FIELD                 
SCAN37Y  RES      0                                                             
* * * * * * * * * * * * * * * * * * *                                           
         LW,R0    SCAN91            GET PARENTH. FLAG                           
         BGZ      SCAN8             ERROR, LFT. BUT NO RIGHT                    
         LW,R0    SCAN90            YES, CHECK FIELD                            
         BNEZ     SCAN37C           SPEC. FIELD, SO EXIT                        
         LI,R0    '.'                                                           
SCAN37A  AI,R6    1                                                             
         CI,R6    80                STRIP OFF BLANKS AFTER MNE. FIELD           
         BE       SCAN37C           END OF CARD, NO SPEC. FIELD                 
         CB,R10   *SCAN96,R6                                                    
         BE       SCAN37A           A BLANK                                     
         CB,R0    *SCAN96,R6        IS IT A PERIOD                              
         BE       SCAN37C           YES,TREAT AS END OF CARD                    
         AI,R6    -1                RESET TO LAST BLANK                         
         B        SCAN28            GO TO EXIT WITH END OF FIELD                
SCAN37C  MTW,2    SCAN98                                                        
         B        SCAN29                                                        
SCAN38   CI,R10   X'5E'             ;                                           
         BNE      SCAN39            NO                                          
         LW,R0    SCAN90                                                        
         BEZ      SCAN8             NOT ALLOWED IN MNEMONIC FIELD               
         LW,R0    SCAN91                                                        
         BGZ      SCAN8             ERROR, LFT. PARENTH., BUT NO RIGHT          
         LI,R0    -1                                                            
         STW,R0   SCAN92            SET CONT. CARD FLAG                         
         B        SCAN28                                                        
SCAN39   RES      0                                                             
         CI,R10   '.'                                                           
         BNE      SCAN40            B IF NOT PERIOD                             
         MTW,0    SCAN97                                                        
         BEZ      SCAN37Y           B IF NOT FILE ID SCAN                       
         MTW,3    SCAN98            SET RETURN TYPE TO END FILE ID              
         B        SCAN29                                                        
*                                                                               
SCAN40   RES      0                                                             
         CI,R10   '%'               CHECK FOR LEGAL EBCDIC CHARACTER            
         BE       SCAN41            OK                                          
         CI,R10   X'6D'             - CHAR OK                                   
         BE       SCAN41            YES                                         
         CI,R10   ':'                                                           
         BL       SCAN8             ILLEGAL CHAR.                               
         CI,R10   X'7C'                                                         
         BG       SCAN8             ILLEGAL CHAR.                               
SCAN41   MTW,1    SCAN93            OK, STEP CHAR. COUNT                        
         BNEZ     SCAN14A                                                       
         B        SCAN8             ERROR,TOO MANY CHARS.                       
*                                                                               
SCAN89   DATA     X'40000040'       BLANKS                                      
SCAN89A  DATA     X'40404040'       EBCDIC BLANKS                               
STATFLAG DATA     X'4E'             POINTS TO PCBPOINT                          
*                                                                               
*  FOLLOWING ARE DEFINED IN CONTEXT SEGMENT                                     
*SCAN90    DATA   0                 FIELD FLAG                                  
*SCAN91    DATA   0                 PARENTHESES FLAG                            
*SCAN92    DATA   1                 CONT. CARD FLAG                             
*SCAN93    DATA   0                 CHAR. COUNT                                 
*SCAN94    DATA   0                 FIELD COUNT                                 
*SCAN95    DATA   0                 COUNT OF HEX CHARS.                         
*SCAN96    DATA   0                 ADD. OF CARD BUFFER                         
*SCAN97  DATA     0                 =0 IF PERIOD MEANS END CMND                 
*                                   =1 IF PERIOD MEANS END FILE ID FIELD        
*SCAN98    DATA   0                 COL. INDEX AND EXIT PM. R6                  
*COLPTR  EQU      SCAN98                                                        
*MODEFLAG  DATA   0                 O-UNDECIDED,1-NORMAL,-1-ALTERNATE           
*%*SCAN99   DATA  0                 LINK-RETURN                                 
COLEXTNT EQU      72                LIMIT OF 72 COL IN ALTERNATE                
ERREXIT  EQU      SCAN8                                                         
PARENFLG EQU      SCAN91                                                        
* * * * * * * * * * * * *** * * *                                               
* * * * * * * * * * * * * * * * * *                                             
         TITLE    '** RS1000 - GET AREA NAMES PROCESSOR **'                     
         SPACE    2                                                             
*        GAN      PROCESS LIST OF AREA NAMES AND/OR THE 'ALL' OPTION            
*                                                                               
*        CALLED VIA STANDARD CALLING SEQUENCE:   BAL,RLNK    GAN                
*                                                                               
*        INPUT:   R6:      RETURN PARAM FROM SCAN                               
*                 RLNK+1   0 IF BT, CK, IS, OS AREAS NOT ALLOWED                
*                          1 IF BT, CK, IS, OS ARE ALLOWED                      
*                                                                               
*        OUTPUT:  R6:  LAST RETURN PARAM FROM SCAN                              
*                 R10: LAST CHARACTER SCANNED BY SCAN                           
*                 R15: ADDRESS OF ERROR MESSAGE IF ERROR DETECTED               
*                 AREASWS:  TABLE OF AREAS SPECIFIED                            
*                                                                               
*        EXITS:   LINK:    ERROR DETECTED, ERROR MESSAGE ADDR IN R15            
*                 LINK+1:  NORMAL EXIT, NO ERRORS                               
*                                                                               
***********************************************************************         
*                                                                               
GAN      EQU      %         GET AREA NAMES FOR SAVE AND RESTORE                 
         PUSH     2,RLNK            SAVE RETURN LINK, CONTROL SWITCH            
         CI,R6    2                 ERROR OR END-OF-CARD AFTER NAME ?           
         BANZ     GANERR1             YES, REPORT ERROR                         
*                                                                               
         LI,R0    0                 CLEAR TABLE; SET NO NAMES GIVEN             
         LI,R1    -(AREASWSX-AREASWS)        CLEAR ENTIRE TABLE                 
*                                                                               
GAN1     EQU      %         RESET SWITCHES FOR ALL AREA NAMES                   
         STW,R0   AREASWSX,R1                                                   
         BIR,R1   GAN1              DO ENTIRE TABLE, EVEN UNUSED ONES           
         PAGE                                                                   
         SPACE    2                                                             
GAN2     EQU      %         PROCESS AN AREA NAME                                
         BAL,LINK SCAN              GET NEXT WORD IN PARAM LIST                 
         CI,R6    0                 ERROR DETECTED ?                            
         BL       GAN10               YES, TEST IF MESSAGE FOLLOWS              
*                                                                               
         CW,R8    KWALL             IS THE WORD 'ALL' ?                         
         BE       GAN20               YES, PROCESS 'ALL' SPECIFICATION          
*                                                                               
         CI,R10   2                 CAN IT BE AN AREA NAME ?                    
         BG       GANERR1             NO, RETURN ERROR                          
*                                                                               
         BAL,RLNK GETAX             TEST IF IT IS A LEGAL AREA NAME             
         B        GANERR1             IT ISN'T, ERROR; ERROR IN FILED XX        
*                                                                               
GAN3     EQU      %         TEST IF AREA ALLOCATED; MARK IF THEY ARE            
         BAL,RLNK UNPKMASD          CHECK ALLOCATION                            
         B        GANERR2           NOT ALLOCATED; GIVE ERROR                   
*                                                                               
         LI,R0    X'FF'             SET NAME GIVEN EXPLICITLY                   
         STB,R0   AREASWS,R1                                                    
*                                                                               
GAN4     EQU      %         TEST IF MORE NAMES TO PROCESS                       
         CI,R6    2                 AT END OF INPUT ?                           
         BNE      GAN2                NO, GET NEXT NAME                         
         PAGE                                                                   
         SPACE    2                                                             
         LI,R10   0                 YES, SET NO TEXT MESSAGE FOLLOWS            
*                                                                               
GAN5     EQU      %         VERIFY THAT AT LEAST ONE AREA REQUESTED             
         LB,R1    K:MDNAME          GET NUMBER OF AREAS TO CHECK                
         AI,R1    -1                ADJUST AS ABOVE                             
*                                                                               
GAN6     EQU      %         TEST EACH AREA FOR A REQUEST FLAG                   
         LB,R0    AREASWS,R1        IS IT REQUESTED ?                           
         BNEZ     GAN7                YES, AT LEAST 1; ALL OK                   
*                                                                               
         BDR,R1   GAN6                NO, TRY ANOTHER AREA                      
         LB,R0    AREASWS,R1        TEST SP TOO                                 
         BEZ      GANERR1           GIVE ERROR IN FIELD XX                      
*                                                                               
GAN7     EQU      %         AT LEAST ONE AREA FOUND; EXIT OK                    
GANEXIT  EQU      GAN7                                                          
         PULL     2,RLNK            RECOVER RETURN ADDRESS & SWITCH             
         AI,RLNK  1                 SET RETURN = OK EXIT                        
         B        *RLNK             AND GO                                      
         PAGE                                                                   
         SPACE    2                                                             
GAN10    EQU      %          END OF AREAS; CHECK FOR MESSAGE                    
         CI,R10   C''''             IS ERROR CHARACTER A SINGLE QUOTE ?         
         BE       GAN5                YES, RETURN NORMAL, NO ERROR              
*                                                                               
         CI,R10   C'.'              CAN IT BE AN AREA PREFIX '.' ?              
         BE       GAN2                YES, SKIP IT AND TRY AGAIN                
*                                                                               
*                                                                               
*                                                                               
*                                                                               
GANERR1  EQU      %         ERROR:  ERROR IN ITEM XX  MESSAGE                   
         LI,R15   MESS2             SET ERROR MESSAGE                           
         STW,R11  MESS2+3           STORE ITM NUMBER IN MESSAGE                 
         B        GANERRX           EXIT AT ERROR EXIT                          
*                                                                               
GANERR2  EQU      %         ERROR:  AREA XX NOT ALLOCATED                       
         SLS,R8   -16               MOVE AREA NAME                              
         LI,R1    1                                                             
         STH,R8   MESS4+1,R1        STORE AREA NAME IN MESSAGE                  
         LI,R15   MESS4             SET MESSAGE TO OUTPUT                       
         B        GANERRX           EXIT VIA ERROR EXIT                         
*                                                                               
GANERRX  EQU      %         ERROR EXIT                                          
         PULL     RLNK              REMOVE AREA SWITCH FROM STACK               
         PULL     RLNK              THEN GET RETURN ADDRESS                     
         B        *RLNK             AND RETURN AT ERROR EXIT                    
         PAGE                                                                   
         SPACE    2                                                             
GAN20    EQU      %         PROCESS THE 'ALL' OPTION                            
         LI,R0    X'0F'             SET REQUESTED BY 'ALL' FLAG                 
         LW,R1    K:NUMDA           GET NUMBER OF AREAS TO TEST                 
*                                                                               
GAN21    EQU      %         SET AREA REQUESTED IF ALLOCATED AND OK              
         STW,R1   AREA              SET AREA INDEX FOR UNPKMASD                 
         BAL,RLNK UNPKMASD          CHECK AREA ALLOCATION                       
         B        GAN23               NOT ALLOCATED; SKIP IT                    
*                                                                               
         MTW,00   *U:PCB            ARE BT, CK ALLOWED ?                        
         BNEZ     GAN22               YES, MARK AS REQUESTED                    
*                                                                               
         CI,R1    BTINDEX           IS THE AREA THE 'BT' OR 'CK' AREA ?         
         BE       GAN23               BT, SKIP OVER IT                          
         CI,R1    CKINDEX                                                       
         BE       GAN23               CK, SKIP OVER IT                          
         CW,R1    ISINDEX           SKIP OVER IS AND OS, TOO                    
         BE       GAN23               IS, SKIP IT                               
         CW,R1    OSINDEX                                                       
         BE       GAN23               OS, SKIP IT                               
*                                                                               
GAN22    EQU      %         MARK BT, CK, IS, OS AS LEGAL AREA NAMES             
         STB,R0   AREASWS,R1        LEGAL; SET REQUESTED                        
*                                                                               
GAN23    EQU      %         STEP TO NEXT AREA TO TEST                           
         BDR,R1   GAN21             IF NOT LAST, TEST NEXT                      
*                                                                               
         STB,R0   AREASWS,R1        'SP' AREA ALWAYS ALLOCATED; SET IT          
         B        GAN4              SCAN NEXT PARAMETER IN LIST                 
         PAGE                                                                   
*%**                                                                            
*%** AREASWS TABLE: MEANING OF BYTE SETTINGS                                    
*%**              00  => NOT REQUESTED                                          
*%**              0F  => REQUESTED BY 'ALL' OPTION                              
*%**              FF  => REQUESTED EXPLICITLY                                   
*%**                                                                            
*%*AREASWS RES   10    AREA REQUEST TABLE. ROOM FOR 40 AREAS.                   
*%*AREASWSX EQU   %         END OF AREASWS TABLE                                
         TITLE    '** RS1000 - UNPACK DICTIONARIES AND DIRECTORIES **'          
         SPACE    2                                                             
UNPKMASD EQU      %         UNPACK MASTER DICTIONARY FOR AREA IN 'AREA'         
         PUSH     5,R0              SAVE WORK REGISTERS R0 TO R4                
         LW,R4    AREA              GET AREA INDEX                              
         BLZ      UNPKMAD5          NEGATIVE ==> PUBLIC AREA: FAKE IT           
*                                                                               
         LB,R2    *K:MASTD,R4       GET DICTIONARY FLAG ENTRY                   
         CI,R2    ALLOC             IS THE ALLOTTED BIT SET ?                   
         BAZ      UNPKMAD2            NO, SAY NOT ALLOTED                       
*                                                                               
         LH,R0    *K:MDNAME,R4      GET AREA NAME IN TEXT FORMAT                
         AND,R0   M16                                                           
         OR,R0    BLNK              RIGHT JUSTIFIED IN WORD                     
         STW,R0   MASDNAME          AND STORE IN BLOCK                          
         STW,R0   AREAASGN          SET AREA NAME FOR ASSIGN                    
         LI,R2    F:BI              USE F:BI TO DO ASSIGN, GET INFO             
         CAL1,1   ASNAREA           ASSIGN AREA TO DCB                          
         CAL1,1   GETAINFO          GET ALL THE INFO WE NEED                    
         CAL1,1   CLOSEANY          AND INSURE THE DCB IS CLOSED                
         LW,R0    MASDEOA           COMPUTE SIZE OF AREA                        
         SW,R0    MASDBOA           = END-OF-AREA - BEGIN-OF-AREA + 1           
         AI,R0    1                                                             
         STW,R0   MASDSIZE                                                      
         LI,R0    0                 CLEAR OUT AREA STATISTICS WORDS             
         LI,R1    -(MASDEND-MASDZERO)                                           
         STW,R0   MASDEND,R1                                                    
         BIR,R1   %-1               CLEAR THEM                                  
         LW,R1    MASDWPS           SET ADDR OF LAST WORD IN SECTOR             
         AI,R1    BUFF1-1           USABLE FOR A DIRECTORY ENTRY.               
         STW,R1   MASDEND                                                       
*                                                                               
*                                                                               
UNPKMAD1 RES      0         RETURN TO OK EXIT                                   
         AI,R14   1                 SET TO EXIT TO OK RETURN                    
*                                                                               
UNPKMAD2 RES      0         RETURN                                              
         PULL     5,R0              RECOVER USED REGISTERS                      
         B        *R14              AND RETURN                                  
*                                                                               
*                                                                               
UNPKMAD5 RES      0         PUBLIC AREA SPECIFIED: SET NAME ONLY                
         LW,R0    BLNK              SET NAME = ALL BLANKS                       
         STW,R0   AREANAME                                                      
         STW,R0   MASDNAME                                                      
         B        UNPKMAD1          AND RETURN TO OK EXIT                       
         PAGE                                                                   
         SPACE    1                                                             
UNPKDIRE RES      0         UNPACK A FILE DIRECTORY ENTRY AT (R5)               
         PUSH     8,R7              SAVE R7-R14 FOR WORK REGISTERS              
         MTW,+0   MASDFRMT          IS THIS PRE-D00 DIRECTORY?                  
         BLZ      UNPKDIR9          YES                                         
*                                                                               
*                           UNPACK A NEW FORMAT DIRECTORY                       
*                                                                               
*                      UNPACK (D00,E00,G00,H00) FORMAT DIRECTORY                
         LW,R7    DIRBOT,R5         GET BOT                                     
         LW,R8    DIREOT,R5         GET EOT                                     
         LW,R9    R8                COMPUTE NSEC                                
         SW,R9    R7                = EOT - BOT + 1                             
         AI,R9    1                 SET NSEC                                    
         LW,R10   DIRFSIZ,R5        GET FSIZ                                    
         LW,R11   DIRGRSZ,R5        GET WORD WITH GSIZ/RSIZ                     
         LH,R12   R11               GET GSIZ                                    
         AND,R11  M16               INSURE BOTH RSIZ AND GSIZ ARE               
         AND,R12  M16               HALFWORDS WITH NO SIGN EXTENSION            
         LW,R13   DIRFLGS,R5        GET WORD WITH THE FLAGS                     
         LB,R14   R13               GET FLAG 1                                  
         LH,R13   R13               AND FLAG 2                                  
         AND,R13  M1                SET 'RF' FLAG FROM FLAG1                    
         AND,R14  M2                AND 'ORG' FROM FLAG2                        
         LCI      8                 STORE BOT, EOT, NSEC, FSIZ, RSIZ,           
         STM,R7   DIREBOT           GSIZ, RF, AND ORG IN DIRE BLOCK             
         LW,R8    DIRFLGS,R5        REFETCH FLAGS                               
         LB,R7    R8                GET FLAG1 WITH SEQ/DIR FLAGS                
         SLS,R7   -6                AND EXTRACT THEM                            
         AND,R8   M8                EXTRACT 'LEN' FIELD                         
         LW,R9    DIRXTNT,R5        GET 'XTNT'                                  
         LW,R10   DIRESIZ,R5        GET 'ESIZ'                                  
         LCI      2                 SET NO ACCOUNT NAME IN CASE THE             
         LM,R11   BLNK              DIRE DOESN'T HAVE ONE IN IT                 
*        CI,R8    DIRSIZE           BIG ENOUGH TO HAVE AN ACCOUNT               
         CI,R8    9                 9= LENGTH W.O. ACC (D-G00)                  
         BLE      UNPKDIR2            NO, USE DEFAULT                           
*                                                                               
         LW,R11   DIRACT1,R5        GET 'ACNT' NAME, PART 1                     
         LW,R12   DIRACT2,R5        AND PART 2                                  
*                                                                               
UNPKDIR2 RES      0          GET REST OF DIRE INFO                              
         LW,R13   DIRFLGS,R5        REFETCH WORD WITH FLAGS 1 & 2               
         SLS,R13  -28               RIGHT JUSTIFY THE 'FIX' FLAG                
         AND,R13  M1                AND EXTRACT IT                              
         LW,R14   DIRFLGS,R5        GET FLAGS 1 MORE TIME                       
         SLS,R14  -20               RIGHT JUSTIFY SYMBIONT PRIORITY             
         AND,R14  M4                AND EXTRACT IT OUT                          
         LCI      7                 AND STORE IN BLOCK                          
         STM,R7   DIRESD            SD,LEN,XTNT,ESIZ,ACCOUNT,FIX,PRIO           
*                                   R7,R8, R9,  R10, R11,R12,R13,R14            
*        LW,R7    DIREEOT           DEFAULTS = USEC = EOT - BOT +1              
*        SW,R7    DIREBOT                                                       
*        AI,R7    1                                                             
         LI,R7    0                 DEFAULTS: USEC = 0                          
         LI,R8    0                           DATE = 0                          
         MTW,+0   MASDFRMT          H00 DIR                                     
         BNEZ     %+3               NO                                          
         LW,R7    DIRUSEC,R5        YES, USE  DIR VALUES                        
         LW,R8    DIRDATE,R5                                                    
         STW,R7   DIREUSEC                                                      
         STW,R8   DIREDATE                                                      
         PAGE                                                                   
         SPACE    2                                                             
UNPKDIR5 RES      0         COMMON PROCESSING FOR NEW/OLD FORMAT DIRE           
         LCI      2                 GET FILE NAME                               
         LM,R8    0,R5              FROM 1ST TWO WORDS OF ENTRY                 
         CI,R8    0                 IS IT A DELETED ENTRY ?                     
         BE       UNPKDIR7            YES, SET STATUS = DELETED                 
*                                                                               
         LI,R7    FILGOODF          SET FILE AS A GOOD FILE                     
         CI,R8    -1                IS IT A BAD TRACK ENTRY ?                   
         BNE      UNPKDIR6            NO, SET FILE GOOD                         
*                                                                               
         LD,R8    BADTRACK          SET NAME = 'BADTRACK'                       
         LI,R7    FILBDTRK          SET STATUS THE SAME                         
*                                                                               
UNPKDIR6 RES      0         SET FILE NAME, STATUS WORD                          
         STD,R8   DIRENAME          STORE NAME                                  
         STW,R7   DIRESTAT          AND STATUS                                  
         PULL     8,R7              RECOVER WORK REGISTERS                      
         B        *R14                EXIT                                      
*                                                                               
*                                                                               
UNPKDIR7 RES      0         DELETED FILE                                        
         LD,R8    BLNK              SET NAME TO BLANKS                          
         LI,R7    FILDELTD          SET STATUS     => DELETED                   
         B        UNPKDIR6          AND EXIT                                    
         PAGE                                                                   
         SPACE    2                                                             
UNPKDIR9 RES      0          UNPACK A PRE-D00 DIR ENTRY                         
         LD,R8    SYSACNT           INITIALIZE DIRE INFO NOT IN OLD             
         STD,R8   DIREACNT          DIRE TO NEW DEFAULT VALUES                  
         LD,R8    ZEROS                                                         
         STD,R8   DIREXTNT          ZERO 'XTNT' AND 'ESIZ'                      
         LI,R9    FILENTRY          SET LENGTH OF ENTRY = STANDARD              
         STW,R9   DIRELEN           LENGTH                                      
         LW,R8    4,R5              GET BOT/EOT WORD                            
         LH,R7    R8                GET BOT                                     
         AND,R7   M16                                                           
         AND,R8   M16               REMOVE EXTRA BITS                           
         LW,R9    R8                COMPUTE NUMBER OF SECTORS ALLOCATED         
         SW,R9    R7                TO FILE: END SEC - BEGIN SEC + 1            
         AI,R9    1                                                             
         LW,R11   3,R5              GET FSIZE/RSIZE WORD                        
         LH,R10   R11               GET FSIZE                                   
         AND,R10  M16                                                           
         AND,R11  M16               REMOVE EXTRA BITS                           
         LW,R12   2,R5              GET FLAG BITS/GSIZE WORD                    
         LH,R13   R12               COPY FLAGS                                  
         AND,R12  M16               GET GSIZE BY ITSELF                         
         AND,R13  M1                AND RESIDENT FOREGROUND INDICATOR           
         LCI      7                 STORE BOT, EOT, FSIZE,                      
         STM,R7   DIREBOT           GSIZE, AND RF                               
         LW,R8    2,R5              GET FLAGS AGAIN                             
         SLD,R8   -30               RIGHT JUSTIFY SEQUEN/DIRECT FLAGS           
         STW,R8   DIRESD            AND SAVE THEM                               
         SLS,R9   -26               RIGHT JUSTIFY THE 'ORG' BITS                
         CI,R9    DIRCOMP           IS FORMAT 'COMPRESSED' ?                    
         BAZ      %+2                 NO, 'UNB' & 'BLK' BITS OK AS IS           
         LI,R9    ORGCOMP           YES, SET NEW 'COMPRESSED' ORG BIT           
         AND,R9   M2                EXTRACT OUT JUST ORG CODE                   
         STW,R9   DIREORG           SET ORG                                     
         B        UNPKDIR5          GO SET NAME AND STATUS                      
         PAGE                                                                   
*                                                                               
* GET1SFIL        GET THE FIRST FILE'S DIRECTORY ENTRY IN A DIRECTORY           
* GETNXFIL        GET THE NEXT  FILE'S DIRECTORY ENTRY IN A DIRECTORY           
*                                                                               
*           SETS R5 TO THE ADDRESS OF THE ENTRY                                 
*                                                                               
*        READS THE DIRECTORY SECTORS VIA GETFSTSD AND GETNXTSD ROUTINES.        
*        USES RDDISC FPT AND F:BI DCB.                                          
*        UPDATES MASDEND TO POINT AT 1ST WORD AFTER LAST DIRE ENTRY             
*        AND MASDFREE TO HAVE BEGINNING OF UNUSED SPACE IN THE AREA.            
*        IT ASSUMES THAT THE MASTDICT TABLES HAVE BEEN SET FOR THE AREA         
*        AND THE FILE DIRE TABLES HAVE BEEN SET FOR THE FILE.                   
*                                                                               
*                                                                               
*        CALL     BAL,RLNK    GETNXFIL                                          
*                                                                               
*        RETURNS: LINK+0:   ERROR FOUND IN DIRE INFO OR CONSISTENCY             
*            1ST  LINK+1:   DIRE EMPTY                                          
*            NXT  LINK+1:   REACHED END OF DIRE (ALL ENTRIES PROCESSED)         
*                 LINK+2:   NEXT ENTRY'S ADDRESS IN R5                          
*                                                                               
*                                                                               
GET1SFIL RES      0         GET POINTER TO 1ST FILE ENTRY IN DIRECTORY          
         PUSH     3,R1              SAVE WORK REGISTERS                         
         PUSH     LINK              SAVE LINK TO READ DIRE SECTOR               
         LI,LINK  BUFF1             INSURE WE READ INTO BUFF1                   
         STW,LINK BIBUFF                                                        
         BAL,LINK GETFSTSD          READ IN FIRST SECTOR OF DIRECTORY           
         BCS,4    GNXFMPTY          DIRE SPACE POINTER ZEROD; DIRE EMPTY        
*                                                                               
         SPACE                                                                  
*        CALCULATE SQUEEZE DATE FOR CASE OF GOING FROM PRE-H00                  
*        TO H00 DIRECTORY                                                       
         SPACE                                                                  
K:TIME   EQU      X'1F8'                                                        
K:DATE1  EQU      X'1F6'                                                        
K:DATE2  EQU      X'1F7'                                                        
K:MONTH  EQU      X'1EA'                                                        
         PUSH     4,R6                                                          
         LI,R8    0                                                             
         LW,R9    K:TIME            R9  = TIME OF DAY IN SEC                    
         DW,R8    XD60              R9  = TIME OF DAY IN MIN                    
         LI,R8    0                                                             
         DW,R8    XD60              R8  = MIN IN HOUR                           
*                                   R9  = HOUR OF DAY                           
         XW,R8    R9                                                            
         SLS,R9   24                                                            
         SLD,R8   8                 R8  = MIN ,HOUR                             
         LW,R9    K:DATE2           R9  = DAY OF YEAR                           
         LI,R6    0                                                             
         LB,R7    K:MONTH,R6                                                    
         SW,R9    R7                                                            
         BLEZ     %+3                                                           
         AI,R6    4                                                             
         B        %-4                                                           
         AW,R9    R7                DAY OF MONTH                                
         STH,R9   R8                R8  = DAY,HOUR,MIN                          
         SLS,R6   -2                                                            
         AI,R6    1                 MONTH (1-12)                                
         STB,R6   R8                R8  = MON,DAY,HOUR,MIN                      
         LW,R9    K:DATE1                                                       
         AI,R9    -80                                                           
         SLS,R9   28                                                            
         AW,R8    R9                                                            
         STW,R8   SQUZDATE          R8  = YEAR,MON,DAY,HOUR,MIN                 
*                                            4   4   8    8   8 BITS            
         PULL     4,R6                                                          
*                 SET FORMAT TYPE:                                              
*                                   MASDFRMT = 0, H00                           
*                                            = 1, D00,E00,G00                   
*                                            =-1, PRE D00                       
*                                                                               
         LI,R1    0                                                             
         STW,R1   MASDFRMT                                                      
         LD,R2    BUFF1+2           GET DIR ID WORDS                            
         CD,R2    DCW1              H00 FORMAT?                                 
         BE       GET2              YES                                         
         XW,R2    R3                                                            
         CD,R2    DCW1              D00,E00,G00 FORMAT?                         
         BE       GET1                                                          
         B        GNXFIL4           PRE D00 FORMAT                              
XD60     DATA     60                CONSTANT                                    
*                                                                               
GET1     MTW,+1   MASDFRMT          SET TO D00-G00                              
GET2     RES      0                                                             
*                                                                               
         LI,R2    4                 TEST NEW FORMAT FOR INITIALIZED             
         LI,R3    1                 WITH NO ENTRIES IN 1ST 2 WORDS              
         CD,R2    BUFF1             IS THIS ITS STATE ?                         
         BE       GNXFMPTY            YES, EMPTY DIRECTORY                      
*                                                                               
         B        GNXFIL1           GO GET 1ST ENTRY                            
         PAGE                                                                   
         SPACE    2                                                             
GETNXFIL RES      0         GET POINTER TO NEXT FILE'S DIRECTORY ENTRY          
         PUSH     3,R1              SAVE WORK REGISTERS                         
         PUSH     LINK              SAVE LINK TO READ NEXT DIRE SECTOR          
         AW,R5    DIRELEN           STEP POINTER BY LENGTH OF ENTRY             
         CW,R5    MASDEND           REACHED END OF THE SECTOR YET ?             
         BL       GNXFOK              NO, HAVE NEXT ENTRY OK                    
*                                                                               
         LW,R1    BUFF1             YES, IS THIS THE LAST DIRE SECTOR ?         
         BGEZ     GNXFEND             YES, RETURN AT ALL DONE EXIT              
*                                                                               
         BAL,LINK GETNXTSD          NO, READ NEXT DIRE SECTOR                   
*                                                                               
GNXFIL1  EQU      %         TEST IF LAST SECTOR OF DIRECTORY PROCESSED          
         MTW,+0   MASDFRMT          POST D00 DIRECTORY                          
         BLZ      GNXFIL5           NO, PICK APART DIFFERNTLZ                   
*                                                                               
         LW,R1    BUFF1             GET POINTER TO NEXT FREE WORD               
         AND,R1   M31               IN SECTOR                                   
         CW,R1    MASDWPS           IS IT A VALID POINTER ?                     
         BG       GNXFERR             NO, DIRECTORY FORMAT ERROR                
*                                                                               
         AI,R1    BUFF1             COMPUTE ADDRESS OF LAST+1 WORD IN           
         STW,R1   MASDEND           DIRECTORY TO SCAN                           
         LW,R1    BUFF1+1           TEST IF LAST SECTOR IN DIRE                 
         LW,R2    BUFF1             IS CONTINUED FLAG SET ?                     
         BLZ      GNXFIL2             YES, TEST IF LINK IN R1 VALID             
*                                                                               
         STW,R1   MASDFREE          SET FIRST SECTOR AVAIL FOR NEW FILE         
*                                                                               
GNXFIL2  RES      0         VALIDATE SECTOR ADDRESS WITHIN AREA                 
         CW,R1    MASDSIZE          IS IT WITHIN LEGAL LIMITS ?                 
         BG       GNXFERR             NO, REPORT INVALID DIRECTORY              
*                                                                               
         LI,R5    BUFF1+LNDIRHDR    SET POINTER TO 1ST POSSIBLE ENTRY           
*                                                                               
*                                                                               
GNXFOK   AI,RLNK  1                 EXIT+2: OK EXIT - R5 = NEXT DIRE            
GNXFEND  RES      0                 EXIT+1: END OF DIRECTORY                    
GNXFMPTY AI,RLNK  1                 EXIT+1: DIRECTORY EMPTY                     
GNXFERR  RES      0                 EXIT+0: ERROR IN DIRE                       
         PULL     LINK              RECOVER LINK TO READ DIRE SECTOR            
         PULL     3,R1              RECOVER WORK REGISTERS                      
         B        *RLNK             EXIT AT PROPER EXIT                         
         PAGE                                                                   
         SPACE    1                                                             
GNXFIL4  RES      0                 PROCESS 1 SEC - PRE D00 DIR                 
         MTW,-1   MASDFRMT          SET FORMAT = PRE-D00                        
         LW,R1    BUFF1             GET 1ST WORD OF DIRE                        
         CI,R1    EMPTYDIR          IS POINTER IN CLEARED STATE ?               
         BE       GNXFMPTY            YES, ALSO EMPTY                           
*                                                                               
         LW,R1    MASDWPS           SET END OF INFO IN DIRE = END               
         AI,R1    BUFF1             OF SECTOR                                   
         STW,R1   MASDEND                                                       
*                                                                               
GNXFIL5  RES      0         OLD FORMAT DIRE; VALIDATE HEADER INFO               
         LH,R1    BUFF1             TEST END-OF-DIRECTORY, NEXT FLAGS           
         BLZ      GNXFIL6           NOT LAST, TEST ENTIRE SECTOR                
*                                                                               
         CW,R1    MASDWPS           IS NEXT FREE WORD WITHIN SECTOR ?           
         BG       GNXFERR             NO, NOT A GOOD DIRECTORY                  
*                                                                               
         AI,R1    BUFF1             SET ADDRESS OF FIRST WORD AFTER             
         STW,R1   MASDEND           LAST DIRECTORY ENTRY                        
         LI,R1    1                 GET NEXT FREE SECTOR IN AREA                
         LH,R1    BUFF1,R1          AND SET IT                                  
         STW,R1   MASDFREE          AS FIRST FREE SECTOR                        
*                                                                               
GNXFIL6  EQU      %         START SCANNING DIRECTORY SECTOR FROM START          
         AND,R1   M15               GET DIRE LINK/ NEXT FREE SECTOR             
         CW,R1    MASDSIZE          IS IT LARGER THAN THE AREA ?                
         BG       GNXFERR             YES, NOT A GOOD DIRECTORY                 
*                                                                               
         LI,R5    BUFF1+LDIREHDR    POINT AT ENTRY 1                            
         B        GNXFOK            AND EXIT                                    
         PAGE                                                                   
         SPACE    1                                                             
PACKDIRE RES      0         PACK TABLE INFO INTO DIRECTORY AT (R6)              
         PUSH     8,R7              SAVE WORK REGISTERS R7 - R14                
         LD,R8    DIRENAME    -(2)  SET ACTIVE FILE'S ENTRY NAME                
         LD,R10   ONES        -(1)  SET BAD SECTORS ENTRY NAME                  
         LD,R12   ZEROS       -(0)  SET DELETED ENTRY NAME                      
         LCW,R7   DIRESTAT          GET STATUS TO INDEX CORRECT NAME.           
         LD,R8    R12,R7            BUILD ENTRY IN REGS: GET FILENAME           
         LI,R10   DIRSIZE+(2*#DFACNT)   YES, SET NEW DEFAULT LENGTH             
*                                   ENTER LENGTH IN BYTE 3, WORD 2              
         LW,R11   DIREPRIO          GET 'PRIO' FIELD                            
         SLS,R11  4                 SHIFT TO POSITION IN BYTE                   
         OR,R11   DIRERF            PUT 'RF' FLAG IN 'FLAG2'                    
         STH,R11  R10               PUT 'FLAG2' IN POSITION                     
         LW,R11   DIRESD            GET 'SEQ/DIR' FLAGS                         
         SLS,R11  2                 SHIFT TO POSITION IN 'FLAG1' BYTE           
         OR,R11   DIREFIX           INSERT THE POSSIBLE 'FIX' FLAG,             
         SLS,R11  4                 MOVE 'S/D' AND 'FIX' TO POSITION            
         OR,R11   DIREORG           INSERT 'ORG' INDICATORS                     
         STB,R11  R10               FORM COMPLETED WORD 2 OF ENTRY              
         LW,R11   DIRERSIZ          GET 'RSIZ' FOR WORD 3                       
         LW,R12   DIREGSIZ          GET 'GSIZ' FOR LEFT HALF OF WORD 3          
         STH,R12  R11               COMBINE TO FORM WORD 3                      
         LW,R12   DIREFSIZ          SET 'FSIZ'                                  
         LW,R13   DIREBOT           SET 'BOT'                                   
         LW,R14   DIREEOT           SET 'EOT'                                   
         LCI      7                 STORE FIRST 7 WORDS OF ENTRY; NAME          
         STM,R8   DIRNAM1,R6        FLAGS, GSIZ, RSIZ, FSIZ, BOT, EOT           
         LCI      2                 MOVE THE REMAINING ENTRIES                  
         LM,R8    DIREXTNT          XTNT, ESIZ                                  
         STM,R8   DIRXTNT,R6                                                    
         LCI      2                 MOVE USEC, DATE                             
         LM,R8    DIREUSEC                                                      
         STM,R8   DIRUSEC,R6                                                    
         AND,R10  M8                IS THE ENTRY LARGE ENOUGH FOR AN            
         CI,R10   DIRSIZE           ACCOUNT NAME FIELD ?                        
         BLE      PACKDIR5            NO, DO NOT TRY TO MOVE IT                 
*                                                                               
         LCI      2                 YES, MOVE ACCOUNT NAME IN                   
         LM,R8    DIREACNT                                                      
         STM,R8   DIRACT1,R6                                                    
*                                                                               
PACKDIR5 RES      0         ENTRY COMPLETELY FORMED: RETURN TO CALLER           
         PULL     8,R7              RECOVER WORK REGISTERS                      
         B        *R14              RETURN                                      
         SPACE    2                                                             
SEG0END  EQU      ((%-RS1000)+511)/512      PAGES REQUIRED FOR SEGMENT          
         END                                                                    
