 TITLE 'TELEFILE ASSEMBLY PROGRAM - APROOT'
         PCC      0
         SPACE    6
*   %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
*   %%%%%     MODULE NAME:     APROOT                  %%%%%
*   %%%%%     LAST UPDATED:    MAR 07, 1984            %%%%%
*   %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
         SPACE    2
         SPACE    12
*        T E L E F I L E    P R O P R I E T A R Y    P R O D U C T
         SPACE    2
*        THIS DOCUMENT INCLUDES DATA AND INFORMATION WHICH IS CONSIDERED
*        PROPRIETARY TO TELEFILE COMPUTER PRODUCTS, INC. REPRODUCTION,
*        DUPLICATION, DISCLOSURE OR DISSEMINATION, IN WHOLE OR IN PART,
*        TO OTHERS THAN REPRESENTATIVES OF THE UNITED STATES GOVERNMENT
*        SHALL NOT BE MADE WITHOUT PRIOR WRITTEN AUTHORIZATION OF TELEFILE
*        COMPUTER PRODUCTS, INC. NOTWITHSTANDING THE FOREGOING, USE OF
*        THE DATA OR INFORMATION IN WHOLE OR IN PART FOR DESIGN,
*        PROCUREMENT OR MANUFACTURE IS STRICTLY FORBIDDEN.
         PAGE
         SPACE    12
*        T E L E F I L E    P R O P R I E T A R Y    P R O D U C T
         SPACE    2
*        THIS DOCUMENT INCLUDES DATA AND INFORMATION WHICH IS CONSIDERED
*        PROPRIETARY TO TELEFILE COMPUTER PRODUCTS, INC. REPRODUCTION,
*        DUPLICATION, DISCLOSURE OR DISSEMINATION, IN WHOLE OR IN PART,
*        TO OTHERS THAN REPRESENTATIVES OF THE UNITED STATES GOVERNMENT
*        SHALL NOT BE MADE WITHOUT PRIOR WRITTEN AUTHORIZATION OF TELEFILE
*        COMPUTER PRODUCTS, INC. NOTWITHSTANDING THE FOREGOING, USE OF
*        THE DATA OR INFORMATION IN WHOLE OR IN PART FOR DESIGN,
*        PROCUREMENT OR MANUFACTURE IS STRICTLY FORBIDDEN.
         PAGE
BPMUTS   EQU      2
RBM      EQU      3
SYS      EQU      BPMUTS
XAPDATA  DSECT    0                 OVERLAY DATA AREA
*  FOR RBM, THE LARGEST DSECT MUST BE IN THE ROOT
         DO1      SYS=RBM
         RES      X'D0'             LARGEST AREA IS IN DG OR CD
XAPD1    DSECT    0
         DO1      SYS=RBM
         RES      X'60'             USED ONLY BY CD & DG
CCI4     CSECT    0                 PERMANENT DATA
XAPCODE  CSECT    1                 CODE SECTION
         DO       SYS=BPMUTS
         SYSTEM   BPM
         FIN
         DO       SYS=RBM
         SYSTEM   RBM
         FIN
*
         SYSTEM   AP%IL
*
         DEF      XAPCODE
         DEF      VAL%S:IVAL
         DEF      SYSLEVEL
         DEF      DEDIT
         DEF      LSTBF,TITLEBUF
         DEF      PGLINES,PGNUM
         DEF      PAGENUM
         DEF      RD%STD
         DEF      SDFCON,SDFSYS
         DEF      LOWCORE
         DEF      ENDCORE
         DEF      MAJLINE,SUBLINE   ASSEMBLY LINE NUMBER
         DEF      SEGMENT#          AP OVERLAY SEGMENT
*
         DO       SYS=BPMUTS
         DEF      INIT%TUNITS       CHARGEABLE TIME @ START OF ASSEM.
         DEF      PAGETBL
         DEF      REPORT%STATUS     ON-LINE BREAK RECEIVER
         DEF      SO%ADJ%FPT
         DEF      SO%ADJ%NAME
         DEF      SO%KEY            FLAG/KEY FOR 'SO' TO FILE
         FIN
*
         DEF      ACCOUNTS,#ACCTS
         DEF      TRAPLOC
         DEF      NEXTST,NXSYMB
         DEF      X1BUF,X3BUF
         DEF      ASSEMBLE%FLAG
         DEF      NUM%PAGE%LINES
         DEF      SDFSYS%SIZE
         DEF      OPTION%FLAGS
         DEF      AC%FLAG
         DEF      PD%FLAG
         DEF      ABN%%STD
         DEF      ABN%%X2
         DEF      ABN%%X4
         DEF      ABORT,MPX1,CLRLSTBF,SYSNAME
         DEF      BO%SIZE           BYTE SIZE OF BO RECORD
         DEF      CO%SIZE           BYTE SIZE OF CO RECORD
         DEF      CORRESWD          FLAGS INDIC. IDEN. DCB ASSIGNMENTS
         DEF      READX1,WRITEX1,REWX1,POSITIONX1
         DEF      READX3,WRITEX3,REWX3,POSITIONX3
         DEF      BYX1SIZE,HWX1SIZE,WDX1SIZE
         DEF      BYX3SIZE,HWX3SIZE,WDX3SIZE
         DEF      OPENX5,CLOSEX5
         DEF      READX5,WRITEX5
         DEF      WRITEBO
         DEF      WRITEDO
         DEF      WRITEGO
         DEF      WRITELO
         DEF      READSTD,WRITESTD,REWSTD
         DEF      POSITIONSTD
         DEF      ERR%%C
         DEF      ERR%%BO,ERR%%CI,ERR%%CO,ERR%%DO
         DEF      ERR%%GO,ERR%%LO,ERR%%SI,ERR%%SO
         DEF      ERR%%X2,ERR%%X4
         DEF      ERR%%STD                                            *D-ROOT
         DEF      EODCNT,EODCNTCI
         DEF      BLANC
         DEF      NIVO
         DEF      ERR%%X1,ERR%%X3
         DEF      ABN%%X1,ABN%%X3
         DEF      ADRDCB
         DEF      CI%DCB
         DEF      1ERLECTURE%LI
          DEF       IM@NAME
          DEF       SAVAREA,LINE%TYPE
         DEF      FINMAJ,CLOSE%FILES
         DEF      ROOTEXIT
         DEF      DGWRITELO
         DEF      ROOTRTN
         DEF      UPDT%ERROR
         DEF      BO%IDWDS,CO%IDWDS,CARDSEQ
         DO       SYS=BPMUTS
         DEF      DO%ONLINE,LO%ONLINE
         SREF     J:JIT,JOPT
         SREF     TPEXT
         SREF     TPOVT
         SREF     TUEXT
         SREF     TUOVT
         FIN
         REF      M:SI,M:CI,M:CO
         REF      M:BO
         REF      M:GO
         REF      M:LL                                         /27953/*D-ROOT
         REF      M:LO
         REF      M:DO,M:SO
         REF      SYSABN            ABNORMAL RETURN ON F:SYS OPEN
         REF      BOBUF
         DO       SYS=RBM
         DEF      F:SYS,F:STD
         REF      M:X1
F:X1     EQU      M:X1
         REF      M:X3
F:X3     EQU      M:X3
         REF      M:X5
F:X5     EQU      M:X5
         FIN
         REF      CTL%CARD%INTERPRETER
         REF      IM@INIT
         REF      CONCORD
         REF      DEFGEN
         REF      DGEND
         REF      NCDR
         REF      STDERROR
         REF      SYSOPNER
         REF      AP%ABORT
         REF      DGINIT,ENDDEF,ENDGEN
*
OPTION   CNAME
         PROC
         DEF      LF
LF       DATA     0
         PEND
*
*  EQUATES FOR ABORT
AR       EQU      0                 ABORT REGISTER
ABORT5   EQU      5
ABORT6   EQU      6
ABORT7   EQU      7
ABORT8   EQU      8
*
*   CP-R SYSTEM PARAMETERS
*
D1       EQU      6                 TYPE CODE FOR 'D1' AREA ON DISK
         PAGE
         USECT    CCI4
OPTION%FLAGS  RES  0
BA%FLAG  OPTION   'BA'
BO%FLAG  OPTION   'BO'
CI%FLAG  OPTION   'CI'
CO%FLAG  OPTION   'CO'
DC%FLAG  OPTION   'DC'
GO%FLAG  OPTION   'GO'
LO%FLAG  OPTION   'LO'
LS%FLAG  OPTION   'LS'
LU%FLAG  OPTION   'LU'
ND%FLAG  OPTION   'ND'
NS%FLAG  OPTION   'NS'
SD%FLAG  OPTION   'SD'              SYMBOLIC DEBUGGING OUTPUT
SI%FLAG  OPTION   'SI'
SO%FLAG  OPTION   'SO'
SU%FLAG  OPTION   'SU'
PD%FLAG  DATA     0
AC%FLAG  DATA     0
*
CORRESWD DATA     0                 (LO=DO)  (LO=C)  (SI=C)  (----)
BYX1SIZE EQU      2048                     # BYTES IN X1BUF    /27493*D-ROOT/
BYX3SIZE EQU      1024+1024*(SYS=BPMUTS)   # BYTES IN X3BUF
HWX1SIZE EQU      BYX1SIZE/2        # OF HALFWORDS IN X1BUF
HWX3SIZE EQU      BYX3SIZE/2        # OF HALFWORDS IN X3BUF
WDX1SIZE EQU      BYX1SIZE/4        # WORDS IN X1BUF
WDX3SIZE EQU      BYX3SIZE/4        # WORDS IN X3BUF
SDFSYS%SIZE  EQU  20*4              SIZE OF SYSTEM FILE NAME TABLE
VAL%S:IVAL  RES   1                 S:IVAL FOR SYSTEM SIG7'S
LOWCORE  RES      1                 CONTAINS LOWEST DYNAMIC TABLE LOC
ENDCORE  RES      1                 LAST DYNAMIC STORAGE ADDRESS +1
MPX1     RES      1
EODCNT   RES      1                 COUNT OF # OF EOD'S ENCOUNTERED
EODCNTCI RES      1                 # OF EOD'S ENCOUNTERED IN CI
USERPSW1 RES      1
NEXTST   RES      1                 INDEX TO NEXT AVAIL SYM TAB LOC
NXSYMB   RES      1                 NEXT SYMBOL SEQUENCE NUMBER
MAJLINE  DATA     0                 MAJOR PART OF A LINE NUMBER       *D-ROOT
SUBLINE  DATA     0                 INSERT PART OF A LINE NUMBER      *D-ROOT
SEGMENT# DATA     0                 AP SEGMENT # IN CORE       /27453/*D-ROOT
*
         DO       SYS=BPMUTS
INIT%TUNITS  RES  1                 TIMER UNITS @ START OF ASSEM.
PAGETBL  RES      4                 BITS CORRESPOND TO CORE PAGES IN USE
SO%ADJ%FPT        ;                 ADJUST-DCB FPT SETS M:SO KEYED
         GEN,8,24 X'14',M:SO
         GEN      X'E000'           VARPS PRESENT
         GEN      X'06080000'       P6 P7 P13                         *D-ROOT
         GEN      2                 ORG = KEYED
         GEN      2                 ACC = DIRECT
         GEN      3                 KEYM
SO%ADJ%NAME       ;
         DATA     X'01010008'
         RES      8
SO%KEY   RES      1                 FLAG/KEY FOR 'SO' TO FILE
X5%TKEY  RES      1                 TEMP FOR X5 KEY BUILD
         FIN
*
         BOUND    8
ACCOUNTS DATA,8   ':SYS    '
         RES      2
         DO1      SYS~=RBM
         RES,8    8
         BOUND    8
LSTBF    RES      34
TITLEBUF RES      0
         TEXT     '1* AP * '
         DO1      22
         DATA     '    '
         TEXT     '  PAGE  '
PGNUM    TEXT     '    '
PGLINES  RES      1
PAGENUM  DATA     0                 PAGE NUMBER IN BINARY
RD%STD   RES      1                 0=DON'T READ F:STD FILE
NUM%PAGE%LINES  RES  1              NUMBER OF LINES PER PRINT PAGE - 3
SDFCON   RES      21                SYSTEM NAME CONTROL INFO
SDFSYS   EQU      SDFCON+1          SYSTEM NAME TABLE
IM@NAME  RES      1                 COUNT & BYTE ADDR OF SYSTEM NAME
NIVO     RES      1                 DEPTH OF SYSTEM NESTING
SYSLEVEL EQU      NIVO
ADRDCB   RES      1                 ADDRESS OF SI DCB
ASSEMBLE%FLAG  RES  1               NON-ZERO WHEN DEFGEN IS REQUIRED
LINE%TYPE   RES   1                 1=SI, 2=CI, 3=BOTH
#ACCTS   RES      1
X1BUF    RES      WDX1SIZE          ENCODED TEXT BUFFER
X3BUF    RES      WDX3SIZE          COMPRESSED SOURCE BUFFER
CI%DCB   DATA     M:CI
1ERLECTURE%LI  RES  1
BO%IDWDS RES      4                 3 WDS FOR BOBUF ID, 1 FOR BO SEQNO.
BOSEQNO  EQU      BO%IDWDS+3        SEQ. NO. FOR COLS 73-80
BO%SIZE  RES      1                 BYTE SIZE OF BO RECORD
CO%IDWDS RES      4                 3 WDS OF COBUF ID, 1 FOR CO SEQNO.
CO%SIZE  RES      1                 BYTE SIZE OF CO RECORD
SAVAREA  RES      15                REGISTER SAVE AREA
FINMAJ   RES      1                 0=UPDATES NOT DONE ;1=DONE
UPDT%ERROR  RES   1                 NO. OF '+' CARD ERRORS
         DO       SYS=BPMUTS
DO%ONLINE  RES    1                 NON-ZERO WHEN DO IS ON-LINE
LO%ONLINE  RES    1                 NON-ZERO WHEN LO IS ON-LINE
         FIN
*
* UTS JIT OPTION BITS. MASKS FOR BITS WITHIN JOPT WORD
LOBIT    EQU      1
GOBIT    EQU      X'80'
DOBIT    EQU      X'100'
*
XT       EQU      4
XT1      EQU      XT+1
XT2      EQU      XT+2
RL       EQU      7
IOADD    EQU      8
IOSIZE   EQU      9
IORL     EQU      10
R10      EQU      10
R15      EQU      15
X1       EQU      1
X2       EQU      2
X3       EQU      3
X4       EQU      4
X5       EQU      5
X6       EQU      6
X7       EQU      7
R8       EQU      8
SR1      EQU      8
R9       EQU      9
         PAGE
         USECT    XAPCODE
START    RES      0
         M:SEGLD  XAPCCI
         BAL,R15  CTL%CARD%INTERPRETER
NEXT%PROGRAM  RES  0
         DO       SYS=BPMUTS
         LI,X1    0
         LI,X7    4
         STW,X1   PAGETBL-1,X7
         BDR,X7   %-1
         FIN
         M:SEGLD  XAPINIT
         BAL,R10  IM@INIT
         M:SEGLD  XAPNCDR
         BAL,R10  NCDR
         LW,X1    ASSEMBLE%FLAG     IS DEFGEN PASS REQUIRED
         BEZ      TRYCONC
*
         DO       SYS=RBM
         M:SEGLD  XAPDGCOM          COMMON ASSEMBLY-PHASE ROUTINES
         FIN
*
         M:SEGLD  XAPDG
         DO       SYS=RBM
         M:SEGLD  XAPDGINT
         BAL,R10  DGINIT            INITIALIZE FOR DEF PASS
         M:SEGLD  XAPPART
         BAL,R10  DEFGEN            EXECUTE DEF PASS
         M:SEGLD  XAPDGINT
         BAL,R10  ENDDEF            EXECUTE DEF-END PROCESSOR
         M:SEGLD  XAPPART
         BAL,R10  DEFGEN            EXECUTE GEN PASS
         M:SEGLD  XAPDGINT
         BAL,R10  ENDGEN            EXECUTE GEN-END PROCESSOR
         ELSE
         BAL,R10  DGINIT            INITIALIZE FOR DEF PASS
         BAL,R10  DEFGEN            EXECUTE DEF PASS
         BAL,R10  ENDDEF            EXECUTE DEF-END PROCESSOR
         BAL,R10  DEFGEN            EXECUTE GEN PASS
         BAL,R10  ENDGEN            EXECUTE GEN-END PROCESSOR
         FIN
         M:SEGLD  XAPENDP
         BAL,R10  DGEND             CALL GEN 'END' PROCESSOR
TRYCONC  RES      0
         LW,RL    DC%FLAG
         BEZ      TEST%BA%FLAG
         M:SEGLD  XAPCONC
         BAL,R10  CONCORD
TEST%BA%FLAG  RES  0
         DO       SYS=RBM
         LI,X3    M:CO              WRITE EOF ON CO IF OPEN
         BAL,RL   WEOF
         LI,X3    M:LO              WRITE EOF ON LO IF OPEN
         BAL,RL   WEOF
         LI,X3    M:DO              WRITE EOF ON DO IF OPEN
         BAL,RL   WEOF
         LI,X3    M:SO
         BAL,RL   WEOF              WRITE EOF ON SO IF OPEN
         FIN
         LW,RL    BA%FLAG
         BEZ      ROOTEXIT
*  RELEASE ALL PAGES USED AT THE END OF THE ASSEMBLY
         DO       SYS=BPMUTS
         LW,X1    LOWCORE
         LI,RL    0
FPG1     RES      0
         LW,X6    X1
         LW,X7    PAGETBL,RL
FPG2     RES      0
         BGZ      FPG3
         M:FVP    *X6
FPG3     RES      0
         AI,X6    512
         AW,X7    X7                SHIFT LEFT 1 AND SET COMPARITOR
         BNEZ     FPG2
         AI,RL    1
         AI,X1    512*32
         CW,X1    ENDCORE
         BL       FPG1
         FIN
         B        NEXT%PROGRAM
ROOTEXIT RES      0
         DO       SYS=RBM
         LI,X3    M:CO
         BAL,RL   IOTERM            WEOF, BACKSPACE 2, FORWARD 1
         LI,X3    M:GO
         BAL,RL   WEOF
         BAL,RL   IOTERM            WEOF, BACKSPACE 2, FORWARD 1
         LI,X3    M:LO
         BAL,RL   IOTERM            WEOF, BACKSPACE 2, FORWARD 1
         LI,X3    M:DO
         BAL,RL   IOTERM            WEOF, BACKSPACE 2, FORWARD 1
         LI,X3    M:SO
         BAL,RL   IOTERM            WEOF, BACKSPACE 2, FORWARD 1
         FIN
         LI,IORL  16                NORMAL CLOSE
         BAL,RL   CLOSE%FILES
         M:EXIT
ABORT    RES      0
         M:SEGLD  XAPCCI
         B        AP%ABORT
ERR%%BO  RES      0
ERR%%C   RES      0
ERR%%CI  RES      0
ERR%%CO  RES      0
ERR%%DO  RES      0
ERR%%GO  RES      0
ERR%%LO  RES      0
ABN%%SI  RES      0
ERR%%SI  RES      0
ERR%%SO  RES      0
ERR%%X1  RES      0
ABN%%X1  RES      0
ERR%%X2  RES      0
ABN%%X2  RES      0
ERR%%X3  RES      0
ABN%%X3  RES      0
ERR%%X2KF  RES    0
ABN%%X2KF  RES    0
ABN%%X4  RES      0
ERR%%X4  RES      0
ERR%%X5  RES      0
ABN%%X5  RES      0
ERR%%STD RES      0
ABN%%STD RES      0
         ABORT    ABORT5            ERROR OR ABN ON AN I/O FILE
         DO       SYS=RBM
XAPCCI   EQU      1
XAPINIT  EQU      2
XAPNCDR  EQU      3
XAPDGCOM EQU      4                 ASM COMMON
XAPDG    EQU      41                ASSEMBLER
XAPDGINT EQU      411               ASM INITIALIZATION
XAPPART  EQU      412               ASM PARTICULARIZATION
XAPENDP  EQU      42                ASM END/SUMMARY
XAPCONC  EQU      5                 CONCORDANCE
*
         ELSE
XAPCCI   TEXTC    'BO:APCCI'
XAPINIT  TEXTC    'BO:APINIT'
XAPNCDR  TEXTC    'BO:APNCD'
XAPDG    TEXTC    'BO:APDG'
XAPENDP  TEXTC    'BO:APEND'
XAPCONC  TEXTC    'BO:APCNC'
         FIN
         DO       SYS=RBM
*
*  W E O F
*  WRITE AN END-OF-FILE MARK IF THE (INPUT) FILE IS OPEN
*      INPUT:  THE LOCATION OF THE DCB IS IN REGISTER X3
*
WEOF     RES      0
         LW,X4    0,X3              FIRST WORD OF THE DCB
         CW,X4    =FCDBIT           IS THE DCB OPEN
         BAZ      *RL               EXIT IF IT'S CLOSED
         M:WEOF   *X3
         EXIT     RL
*
*  I O T E R M
*   TERMINATE A FILE ON A GIVEN DCB (INPUT)
*      INPUT:  THE LOCATION OF THE DCB IS IN REGISTER X3
*
IOTERM   RES      0
         LW,X4    0,X3              FIRST WORD OF THE DCB
         CW,X4    =FCDBIT           IS THE DCB OPEN
         BAZ      *RL               EXIT IF IT'S CLOSED
         M:WEOF   *X3
         M:PFIL   *X3,(SKIP),(REV)
         M:PFIL   *X3,(SKIP),(REV)
         M:PFIL   *X3,(SKIP),(FWD)
         EXIT     RL
         FIN
         PAGE
*
*  D E D I T
*        CONVERT A POSITIVE INTEGER TO EBCDIC DIGITS AND STORE IT
*          IN THE LISTING LINE IMAGE.
*
*          INPUT: NUMBER TO CONVERT IS IN REGISTER 5
*                 INDEX TO RIGHT-HAND DIGIT OF LSTBF IS IN
*                 REGISTER 6.
*
*         OUTPUT: REGISTER 5 CONTAINS ZERO.
*                 REGISTER 6 IS DECREASED BY THE NUMBER OF DIGITS STORED.
*
*        NO DIGITS ARE STORED IF THE INPUT NUMBER IS ZERO.
*
DEDIT    RES      0
         AI,X5    0                 EXIT IF ENTIRE NUMBER
         EXIT,EQ  RL                  IS CONVERTED
         LI,X4    0
         DW,X4    =10               REMAINDER IS NEXT DIGIT
         AI,X4    X'F0'
         STB,X4   LSTBF,X6
         BDR,X6   DEDIT             DECREASE LSTBF INDEX AND RETURN
         EXIT     RL
         PAGE
         DO       SYS=RBM
TRAPLOC  RES      0
         ABORT    ABORT6            ASSEMBLER ERROR
         FIN
         DO       SYS=BPMUTS
TRAPLOC  RES      0
         STW,X1   MPX1              SAVE POINTER TO PSD-REG BLOCK
         STCF     X1                SAVE CC TO TELL WHAT KIND OF TRAP
         MTW,2   MPX1               POINT TO SAVED R0
         LW,X7    0,X1              GET TRAPPED PSW1
         STW,X7   USERPSW1          SAVE IT
         LW,X7    18,X1
         CI,X7    X'40'             COULD IT BE MEMORY VIOLATION
         BNE      BADTRAP             BRANCH IF NO
         LC       X1                WAS TRAP FOR MEMORY PROTECTION
         BCS,14   BADTRAP             BRANCH IF NO
*
*  THIS ROUTINE GETS PAGES FROM UTS ON DEMAND AFTER AN INSTRUCTION
*    HAS TRAPPED BECAUSE OF A MEMORY PROTECTION VIOLATION.  IT IS NOT
*    A GENERAL ROUTINE, AND CAN BE FOOLED BY SPECIAL CASES SUCH AS
*    PSM, TBS, MBS, AND MULTI-LEVEL EXU, BUT XAP DOESN'T HAVE ANY
*    INSTRUCTIONS LIKE THAT.
*
         LB,X7    *USERPSW1         IS TRAPPED INSTR AN
         CI,X7    X'67'             EXECUTE-REMOTE
         BNE      NOTEXU            BRANCH IF NO
         LCI      0                 RESTORE USER'S REGS SO WE CAN
         LM,0     2,X1              GET ADDRESS OF REMOTE INSTRUCTION
         ANLZ,X7  *USERPSW1         & STORE IT AS ADDRESS OF
         STW,X7   USERPSW1          INSTRUCTION TO BE ANALYZED NEXT
NOTEXU   RES      0
         LCI      0                 RESTORE REGISTERS
         LM,0     *MPX1             OF TRAPPED PROGRAM
         ANLZ,X7  *USERPSW1         ANALYZE TRAPPED INSTRUCTION
         STCF     X6                IF NECESSARY
         SLS,X6   -30               CONVERT EA OF TRAPPED
         SLS,X7   -2,X6             INSTRUCTION TO WORD RESOLUTION
         AND,X7   =X'1FE00'         BOUND BACK TO PAGE
         M:GVP    *X7               ASK SYSTEM FOR PAGE
         BCS,8    CANTHAVE          BRANCH IF REFUSED
         SW,X7    LOWCORE           X7 NOW HAS AN OFFSET ADDRESS
         SLS,X7   -9                SHIFT TO AN OFFSET PAGE NUMBER
         LW,X1    X7                                                  *D-ROOT
         AND,X1   L(X'1F')          GET PAGE COUNT MOD 32             *D-ROOT
         LCW,X1   X1                SAVE AS RIGHT SHIFT COUNT         *D-ROOT
         SLS,X7   -5                SHIFT TO GENERATE A WORD OFFSET
         LW,X6    =X'80000000'      SHIFT INDICATOR BIT
         SLS,X6   0,X1                TO APPROPRIATE POSITION
         AWM,X6   PAGETBL,X7          AND SET THAT PAGE BIT ON
         M:TRTN                     RETURN TO TRAPPED PROGRAM FOR RETRY
CANTHAVE RES      0
         ABORT    ABORT7            MAX MEMORY PAGES
BADTRAP  RES      0
         ABORT    ABORT8            BAD INSTRUCTION TRAP
         FIN
         PAGE
*
*  C L O S E % F I L E S
*        INPUT FILES ARE NOT SAVED.  OUTPUT FILES ARE SAVED(*)./27453/*D-ROOT
*        TEMP FILES ARE ALSO CLOSED WITH SAVE TO AID PATCHING, /27453/*D-ROOT
*        BUT WILL GO AWAY BECAUSE OPENED TO NAMED FILE.        /27453/*D-ROOT
*                                                              /27453/*D-ROOT
*        (*)IN AN ABORT, DO NOT SAVE CERTAIN OUTPUT IF ASSIGNED/27453/*D-ROOT
*        TO A FILE, AS THE OLD COPY MIGHT STILL BE USEABLE.    /27453/*D-ROOT
*        HOWEVER, IF FILE IS COMPLETE, IT MAY BE SAVED.        /27453/*D-ROOT
*
*        INPUT:   REGISTER IORL CONTAINS 1 IF ABNORMAL TERMINATION
*
FCDBIT   EQU      X'200000'         OPEN/CLOSED BIT
PREFLD   EQU      X'7F000000'       'PRESERVE AFTER' SEG #     /27453/*D-ROOT
*                                                              /27453/*D-ROOT
         LOCAL    %10,%20,%30
         LOCAL    %15                                          /27453/*D-ROOT
*                                                              /27453/*D-ROOT
CLOSE%FILES  RES  0
         LI,X2    DCBCORG-DCBCEND   - NUMBER OF DCB'S TO CLOSE
%10      RES      0
         LW,X3    DCBCEND,X2        SAVE FLAG AND DCB ADDRESS
         LW,X4    0,X3              WORD 0 OF DCB
         CW,X4    =FCDBIT           IS DCB OPEN
         BAZ      %30               BRANCH IF CLOSED
         DO       SYS~=RBM
         CI,X3    0                 SHOULD IT BE SAVED
         BGZ      %20               BRANCH IF NO
         AND,X4   =15               SAVE ASN FIELD
         CW,X4    IORL              DON'T SAVE OUTPUT DCB'S
         BNE      %15                 IF FILE, IN AN ABORT,    /27453/*D-ROOT
*                                     AND PROTECT FLAG IS SET. /27453/*D-ROOT
         LV,X4    PREFLD                                       /27453/*D-ROOT
         AND,X4   X3                GET 'PRESERVE AFTER' SEG # /27453/*D-ROOT
         IF,NZ                                                 /27953/*D-ROOT
         LB,X4    X4                RIGHT-JUSTIFY              /27453/*D-ROOT
         CW,X4    SEGMENT#          CAN WE SAVE IT YET?        /27453/*D-ROOT
         BGE      %20               NOT YET                    /27453/*D-ROOT
*                                                              /27453/*D-ROOT
         FI                                                    /27953/*D-ROOT
%15      RES      0                                            /27453/*D-ROOT
         M:CLOSE  *X3,(SAVE)
         B        %30
         FIN
%20      RES      0
         M:CLOSE  *X3               CLOSE WITHOUT SAVE
%30      RES      0
         BIR,X2   %10
         B        *RL               EXIT
         PAGE
         BOUND    8
BLANKS   DATA,8   '        '        DOUBLE WORD OF BLANKS
BLANC    EQU      BLANKS
*                                                              /27453/*D-ROOT
DCBCON   COM,1,7,7,17 SCOR(AF(2),SAVE),AF(3),0,AF(1)           /27453/*D-ROOT
*                                                              /27453/*D-ROOT
DCBCORG  RES      0
         DO       SYS=BPMUTS
         DCBCON   M:SI
         DCBCON   M:CI
         FIN
         DCBCON   M:BO,SAVE,4       SAVE FILE AFTER END SEGMENT/27453/*D-ROOT
         DCBCON   M:CO,SAVE,1       SAVE FILE AFTER ENCODER SEG/27453/*D-ROOT
         DCBCON   M:DO,SAVE
         DCBCON   M:GO,SAVE
         DCBCON   M:LL,SAVE         SAVE LISTING LOG IF OPEN   /27953/*D-ROOT
         DCBCON   M:LO,SAVE
         DCBCON   M:SO,SAVE,1       SAVE FILE AFTER ENCODER SEG/27453/*D-ROOT
         DO       SYS=BPMUTS
         DCBCON   F:X1,SAVE
         DCBCON   F:X2,SAVE
         DCBCON   F:X2KF,SAVE
         DCBCON   F:X3,SAVE
         FIN
         DCBCON   F:STD,SAVE
DCBCEND  RES      0
         USECT    CCI4
SYSNAME  RES,1    9+23*(SYS=BPMUTS)    ROOM FOR SYSTEM NAME (LVL=1)
         BOUND    4
ROOTRTN  RES      1                 ROOT RETURN ADDRESS
         PAGE
         USECT    XAPCODE
*
*   C L R L S T B F
*        THIS ROUTINE STORES BLANKS IN THE LISTING BUFFER.
*
*        CALL:    BAL,RL  CLRLSTBF
*
*        USES REGISTERS
*                 XT
*                 XT1
*                 XT2
*
CLRLSTBF RES 0
         LD,XT    BLANKS
         LI,XT2   -17
         STD,XT   LSTBF+34,XT2      BLANKS TO LISTING BUFFER
         BIR,XT2  %-1
         B        0,RL              RETURN
         PAGE
*
*   R E P O R T % S T A T U S
*        IF ON-LINE, AND THE BREAK KEY WAS HIT AT THE USER CONSOLE,
*           REPORT THE CHARGEABLE CPU TIME SINCE START OF THIS
*           ASSEMBLY - THE ASSEMBLY PHASE IN PROGRESS - THE LINE
*           NUMBER (WITH POSSIBLE UPDATE FRACTION) - AND, IF IN A
*           SYSTEM, THE NAME OF THE LEVEL ONE SYSTEM.
*
         LOCAL    %10
*
REPORT%STATUS RES 0
*
         DO       SYS=BPMUTS
*
*   CALCULATE AND EDIT THE ELAPSED CPU TIME SINCE THE ASSEMBLER
*        WAS FIRST CALLED.
*
         LW,XT    L('.000')
         STW,XT   STATUS%MESSAGE+2
         LW,R9    J:JIT+TPEXT       PROCESSOR EXECUTION TIME
         AW,R9    J:JIT+TPOVT       PROCESSOR OVERHEAD TIME
         AW,R9    J:JIT+TUEXT       USER EXECUTION TIME
         AW,R9    J:JIT+TUOVT       USER OVERHEAD TIME
         SW,R9    INIT%TUNITS       MINUS JOB START COUNT
         LI,R8    0
         DW,R8    L(30)             CONVERT TO 1/1000 MIN.
         LI,XT2   BA(STATUS%MESSAGE)-BA(LSTBF)+11
         LW,XT1   R9                TO VALUE REGISTER
         CALL     DEDIT
         LI,XT    '.'
         STB,XT   STATUS%MESSAGE+2
         LI,R8    0
         DW,R8    L(1000)           CONVERT TO WHOLE MIN.
         LI,XT2   BA(STATUS%MESSAGE)-BA(LSTBF)+7
         LW,XT1   R9                TO VALUE REGISTER
         CALL     DEDIT
*
*   EDIT THE NUMBER OF THE ASSEMBLER PHASE CURRENTLY IN EXECUTION
*
         LW,XT1   SEGMENT#
         LB,XT    PHASE%MAP,XT1     MAP OVERLAY TO PHASE
         AI,XT    ' 0'
         STH,XT   STATUS%MESSAGE+5
         LI,XT    STATUS%MESSAGE
,TYPEFPT M:TYPE   (MESS,*XT)
*
*   IF NOT IN CONCORDANCE PHASE, EDIT CURRENT LINE NUMBER.
*
         CI,XT1   5
         IF,NE                 -01-
         LW,XT    BLANKS
         STW,XT   LINE%NUMBER+2
         STW,XT   LINE%NUMBER+4
         LW,XT    L(' 0  ')
         STW,XT   LINE%NUMBER+3
         LW,XT1   SUBLINE
         IF,NE                 -02-
*
*        EDIT MINOR LINE NUMBER
*
         LW,XT    L('  .0')
         STW,XT   LINE%NUMBER+3
         LI,XT2   -4                FIND SIZE OF MINOR LINE NUMBER
%10      RES      0
         CH,XT1   NINES,XT2
         IF,G                  -03-
         BIR,XT2  %10
*
         FI                    -03-
         AI,XT2   BA(LINE%NUMBER)-BA(LSTBF)+19
         CALL     DEDIT
         FI                    -02-
*
*        EDIT MAJOR LINE NUMBER
*
         LI,XT2   BA(LINE%NUMBER)-BA(LSTBF)+13
         LW,XT1   MAJLINE
         CALL     DEDIT
         LI,XT    LINE%NUMBER
         M:TYPE,E TYPEFPT
*
*   IF IN SYSTEM, PRINT NAME OF LEVEL-ONE SYSTEM.
*
         MTW,0    SYSLEVEL
         IF,G                  -04-
         LI,XT    SYSTEM%MESSAGE
         M:TYPE,E TYPEFPT
         LI,XT    SYSNAME
         M:TYPE,E TYPEFPT
         FI                    -04-
         FI                    -01-
*
*   PRINT NEW-LINE CHARACTER, RESET BREAK COUNT, AND RETURN
*
         LI,XT    L(X'01150000')
         M:TYPE,E TYPEFPT
         CAL1,8   L(X'06100000')    RESET BREAK COUNT
         M:TRTN
*
         DATA,2   9,99,999,9999
NINES    EQU      %
PHASE%MAP  DATA,1 ;
                  0,;               CCI - SHOULDN'T HAPPEN
                  1,;               ENCODER
                  2,;               DEF
                  3,;               GENERATION
                  3,;               END
                  4                 CONCORDANCE
SYSTEM%MESSAGE    ;
         TEXTC    ' - PROCESSING SYSTEM '
*
         USECT    CCI4
*
LINE%NUMBER       ;
         TEXTC    ' : LINE NNNNN.MMMMM'
STATUS%MESSAGE    ;
         TEXTC    'CPU =  .FFF : PHASE N'
*
         FIN
         PAGE
*
*        XAP DCB'S
*
         DO       SYS=RBM
F:STD    CSECT    0
F:SYS    CSECT    0
         FIN
         DO       SYS=BPMUTS
F:X1     DSECT    1
F:X2    DSECT    1
F:X2KF   DSECT    1
F:X3     DSECT    1
F:X5     DSECT    1
F:STD    DSECT    1
F:SYS    DSECT    1
F:X1     M:DCB    (FILE,'%%M:X1'),;
                  (OUTIN),;
                  (RECL,2048),;
                  (TRIES,10),;
                  (ERR,ERR%%X1),;
                  (ABN,ABN%%X1)
F:X2     M:DCB    (FILE,'%%M:X2'),;
                  (OUTIN),;
                  (RECL,2048),;
                  (TRIES,10),;
                  (ERR,ERR%%X2),;
                  (ABN,ABN%%X2)
F:X3     M:DCB    (FILE,'%%M:X3'),;
                  (OUTIN),;
                  (RECL,2048),;
                  (TRIES,10),;
                  (ERR,ERR%%X3),;
                  (ABN,ABN%%X3)
F:X2KF   M:DCB    (FILE,'FX2  ');
                  ,(OUTIN);
                  ,(RECL,2048);
                  ,(TRIES,10);
                  ,(ERR,ERR%%X2KF);
                  ,(ABN,ABN%%X2KF)
F:X5     M:DCB    (FILE,'%%M:X5'),(OUTIN),(RANDOM),;
                  (RECL,2048),(TRIES,10),;
                  (ERR,ERR%%X5),(ABN,ABN%%X5)
F:STD    M:DCB    (FILE,'%:STDDEF'),;
                  (IN),(SAVE),;
                  (RECL,2048),;
                  (TRIES,10),;
                  (ERR,STDERROR),;
                  (ABN,STDERROR)
         FIN
*
         DO       SYS=RBM
F:STD    M:DCB    (FILE,'%:STDDEF',D1),;
                  (ERR,STDERROR),;
                  (ABN,STDERROR),;
                  (RECL,2048),;
                  (TRIES,10),;
                  (IN),;
                  (SAVE)
F:SYS    M:DCB    (FILE,'        '),(ABN,SYSABN),(ERR,SYSOPNER)
         FIN
         DO1      SYS=BPMUTS
F:SYS    M:DCB    (FILE),(ABN,SYSABN),(ERR,SYSOPNER)
*
         USECT    XAPCODE
         PAGE
*
*  R E A D X 1
*        READ THE X1 (ENCODED TEXT) FILE
*
*          INPUT: NONE
*
READX1   RES      0
*
         M:READ   F:X1,(BUF,X1BUF),(SIZE,BYX1SIZE),(WAIT),;
                  (ABN,ABN%%X1),(ERR,ERR%%X1)
         EXIT     IORL
*
*  W R I T E X 1
*        WRITE THE X1 (ENCODED TEXT) FILE
*
*          INPUT: NONE
*
WRITEX1  RES      0
*
         M:WRITE  F:X1,(BUF,X1BUF),(SIZE,BYX1SIZE),(WAIT),;
                  (ABN,ABN%%X1),(ERR,ERR%%X1)
         EXIT     IORL
*
*  R E W X 1
*        REWIND THE X1 (ENCODED TEXT) FILE
*
*          INPUT: NONE
*
REWX1    RES      0
*
         M:REW    F:X1
         EXIT     IORL
*
*  P O S I T I O N X 1
*        POSITION THE X1 (ENCODED TEXT) FILE N RECORDS BACKWARD OR
*          FORWARD.
*
*          INPUT: IOSIZE CONTAINS THE NUMBER OF RECORDS AND THE
*                 DIRECTION (POSITIVE = FORWARD; NEGATIVE = BACKWARD)
*
POSITIONX1  RES   0
*
         LI,IOADD F:X1
POSIT%1  RES      0
         AI,IOSIZE  0
         EXIT,EQ  IORL
         BLZ      POSBKWD
         M:PRECORD *IOADD,(N,*IOSIZE),(FWD)
         EXIT     IORL
POSBKWD  RES      0
         LCW,IOSIZE  IOSIZE         COMPLEMENT NEGATIVE COUNT
         M:PRECORD *IOADD,(N,*IOSIZE),(REV)
         EXIT     IORL
*
* P O S I T I O N X 3
*        POSITION THE X3 TEMPORARY FILE
*
*          INPUT: IOSIZE CONTAINS THE NUMBER OF RECORDS AND THE
*                 DIRECTION (POSITIVE = FORWARD; NEGATIVE = BACKWARD)
*
POSITIONX3  RES   0
*
         LI,IOADD F:X3
         B        POSIT%1
*  R E A D X 3
*        READ THE X3 (COMPRESSED SOURCE) FILE
*
*          INPUT: IOADD CONTAINS BUFFER (WORD) ADDRESS
*
READX3   RES      0
*
         M:READ   F:X3,;
                  (ERR,ERR%%X3),;
                  (ABN,ABN%%X3),;
                  (BUF,*IOADD),;
                  (SIZE,BYX3SIZE),;
                  (WAIT)
         EXIT     IORL
*
*  W R I T E X 3
*        WRITE THE X3 (COMPRESSED SOURCE) FILE
*
*          INPUT: IOADD CONTAINS BUFFER (WORD) ADDRESS
*
WRITEX3  RES      0
*
         M:WRITE  F:X3,;
                  (ERR,ERR%%X3),;
                  (ABN,ABN%%X3),;
                  (BUF,*IOADD),;
                  (SIZE,BYX3SIZE),;
                  (WAIT)
         EXIT     IORL
*
*  R E W X 3
*        REWIND THE X3 (COMPRESSED SOURCE) FILE
*
*          INPUT: NONE
*
REWX3    RES      0
*
         M:REW    F:X3
         EXIT     IORL
*
*  R E A D X 5
*        READ THE X5 (CONCORDANCE OVERFLOW) FILE
*
*          INPUT: IOSIZE CONTAINS THE BLOCK (OR KEY) NUMBER REQUIRED
*                 IOADD CONTAINS THE BUFFER ADDRESS
*
READX5   RES      0
         DO       SYS=BPMUTS
         OR,IOSIZE   L(3**24)       MERGE KEY LENGTH
         STW,IOSIZE   X5%TKEY
         M:READ   F:X5,;
                  (ERR,ERR%%X5),;
                  (ABN,ABN%%X5),;
                  (BUF,*IOADD),;
                  (KEY,X5%TKEY),;
                  (WAIT)
         FIN
         DO       SYS=RBM
         STW,IOSIZE  X5RDFPT+5
,X5RDFPT M:READ   F:X5,;
                  (ERR,ERR%%X5),;
                  (ABN,ABN%%X5),;
                  (BUF,*IOADD),;
                  (BLOCK,0),;
                  (WAIT)
         FIN
         EXIT     IORL
*
*  W R I T E X 5
*        WRITE THE X5 (CONCORDANCE OVERFLOW) FILE
*
*          INPUT: IOSIZE CONTAINS THE BLOCK (OR KEY) NUMBER REQUIRED
*                 IOADD CONTAINS THE BUFFER ADDRESS
*
WRITEX5  RES      0
         DO       SYS=BPMUTS
         OR,IOSIZE   L(3**24)       MERGE KEY LENGTH
         STW,IOSIZE   X5%TKEY
         M:WRITE  F:X5,;
                  (ERR,ERR%%X5),;
                  (ABN,ABN%%X5),;
                  (BUF,*IOADD),;
                  (KEY,X5%TKEY),;
                  (ONEWKEY),;
                  (WAIT)
         FIN
         DO       SYS=RBM
         STW,IOSIZE  X5WTFPT+5
,X5WTFPT M:WRITE  F:X5,;
                  (ERR,ERR%%X5),;
                  (ABN,ABN%%X5),;
                  (BUF,*IOADD),;
                  (BLOCK,0),;
                  (WAIT)
         FIN
         EXIT     IORL
*
*  O P E N X 5
*        OPEN THE X5 (CONCORDANCE OVERFLOW) FILE
*
OPENX5   RES      0
         LW,IOADD F:X5
         IF,FZ    X'200000',IOADD
*
         DO       SYS=BPMUTS
         LW,IOADD *X'4F'
         STH,IOADD   X5OPNFPT+9
,X5OPNFPT         ;
         M:OPEN   F:X5,;
                  (RECL,2048),;
                  (KEYED),;
                  (DIRECT),;
                  (OUTIN),;
                  (KEYM,3),;
                  (FILE,'FX5  ')
         FIN
         DO       SYS=RBM
         M:OPEN   F:X5,;
                  (ERR,ERR%%X5),;
                  (ABN,ABN%%X5)
         M:DEVICE F:X5,;
                  (GSZ,2048),;
                  (SIZE,2048)
         FIN
*
         FI
         EXIT     IORL
*
*  C L O S E X 5
*        CLOSE THE X5 (CONCORDANCE OVERFLOW) FILE
*
CLOSEX5  RES      0
*
         M:CLOSE  F:X5
         EXIT IORL
*  W R I T E L O
*        WRITE THE LISTING FILE
*
*          INPUT: IOADD CONTAINS THE BUFFER ADDRESS
*                 IOSIZE CONTAINS THE NUMBER OF BYTES IN THE BUFFER
*
*          BYTE 0 OF THE BUFFER IS THE VFC
*
DGWRITELO   RES   0
         DO       SYS=BPMUTS
         MTW,0    LO%ONLINE         TRUNCATE THE LINE IF LO
         BEZ      WRITELO             IS A TYPEWRITER OR TTY
         LI,IOSIZE 109              TRUNCATE AFTER COL. 72
         FIN
WRITELO  RES      0
         DO       SYS=BPMUTS
         MTW,0    *X'4F'
         BGEZ     WRLO3             BRANCH IF NOT ON-LINE
         LW,X5    J:JIT+JOPT        DON'T PRINT IF
         CI,X5    LOBIT             LIST BIT (IN JIT) IS ZERO
         BAZ      *IORL
WRLO3    RES      0
         FIN
         MTW,-1   PGLINES           LINES REMAINING ON THIS PAGE
         BGZ      WRLO1
         MTW,+1   PAGENUM           BUMP LAST PAGE NUMBER
         LW,X5    PAGENUM           INSERT PAGE NUMBER IN TITLE
         DO       SYS=BPMUTS
         MTW,0    LO%ONLINE         IF 'LO' IS TYPEWRITER OR TTY
         BEZ      WRLO5             PRINT ONLY ONE SHORT TITLE
         CI,X5    1
         BNE      WRLO6             BRANCH IF NOT 1ST PAGE
         M:WRITE  M:LO,(BUF,TITLEBUF),(SIZE,96),(WAIT)
         B        WRLO6
WRLO5    RES      0
         FIN
         LI,X6    BA(PGNUM)-BA(LSTBF)+2
         BAL,RL   DEDIT
         M:WRITE  M:LO,(BUF,TITLEBUF),(SIZE,108),(WAIT)
WRLO6    RES      0
         LI,X4    X'C1'             CAUSE A BLANK LINE TO BE OUTPUT
         STB,X4   *IOADD            AFTER THE TITLE LINE
         LW,X4    NUM%PAGE%LINES
         DO       SYS=BPMUTS
*  FIND NUMBER OF LINES PER PAGE IF IT HASN'T ALREADY BEEN FOUND
         BGZ      WRLO2
         LW,X4    IOADD
         M:DEVICE M:LO,(NLINES)
         AI,SR1   -2
         BGZ      %+2               USE A VERY LARGE NUMBER IF MONITOR
         LI,SR1   X'7FFFF'            REFUSES TO PROVIDE NO. OF LINES
         STW,SR1  NUM%PAGE%LINES
         XW,X4    IOADD
WRLO2    RES      0
         FIN
         STW,X4   PGLINES
WRLO1    RES      0
         M:WRITE  M:LO,(BUF,*IOADD),(SIZE,*IOSIZE),(WAIT)
         EXIT     IORL
*
*  W R I T E B O
*        WRITE THE OBJECT MODULE FILE
*
*          INPUT: NONE
*
WRITEBO  RES      0
         MTH,0    BO%FLAG           IS 'SB' OPTION REQUESTED
         BEZ      WRITEBO1          NO, JUST WRITE BOBUF
         LCI      3
         STM,X5   SAVAREA           SAVE REGISTERS
         LM,X5    BO%IDWDS          MOVE IDENT AND ZEROES
         STM,X5   BOBUF+27            TO BOBUF AREA
         LW,IOSIZE BOSEQNO          NEXT CARD SEQUENCE NUMBER
         LI,XT    HA(BOBUF)+59      ADDRESS OF COLUMN 80
         LB,XT1   BO%FLAG           NUMBER OF SEQUENCE DIGITS
         BEZ      %+2
         BAL,RL   CARDSEQ           CONVERT AND STORE SEQUENCE NUMBER
         LCI      3
         LM,X5    SAVAREA           RESTORE REGISTERS
         MTW,+1   BOSEQNO           BUMP SEQUENCE NUMBER
WRITEBO1 RES      0
         M:WRITE  M:BO,;
                  (ERR,ERR%%BO),;
                  (ABN,ERR%%BO),;
                  (BUF,BOBUF),;
                  (SIZE,*BO%SIZE),;
                  (WAIT)
         EXIT     IORL
         PAGE
*
* C A R D S E Q
*        STORE SEQUENCE NUMBER IN COLS 73-80 FOR SB OR SC OPTION
*
*        INPUT:   XT CONTAINS HA OF COLUMN 80
*                 XT1 CONTAINS NUMBER OF DIGITS TO STORE (NOT ZERO)
*                 IOSIZE CONTAINS SEQUENCE NUMBER TO CONVERT
*
*        USES REGISTERS: XT,XT1,XT2,RL,IOADD,IOSIZE
*
CARDSEQ  RES      0
         LI,XT2   0                 INDEX TO SHIFT TABLE
         STW,RL   MPX1              SAVE RETURN
NEXTCOL  RES      0
         LB,RL    SFTBL,XT2         SHIFT FOR THIS COLUMN
         LI,IOADD 0                 CONVERT
         DW,IOADD =10                 RIGHTMOST DIGIT
         SW,RL    IOADD             ADD SHIFT AMOUNT FOR THIS COLUMN
         LI,IOADD 1                 SHIFT A BIT TO
         SLS,IOADD 9,RL               THE APPROPRIATE PLACE
         AH,IOADD  0,XT             INSERT RIGHT-MOST BITS
         STH,IOADD 0,XT               IN LOW ORDER HALFWORD
         CI,XT2   3                 IS THIS COLUMN 80 OR 76
         BAZ      ADVANCE             YES, DON'T BUMP COLUMN ADDRESS
         AI,XT    -1                BUMP COLUMN ADDRESS
         LH,IOADD  IOADD            ADD LEFT-MOST BITS
         AH,IOADD  0,XT               TO NEXT HALFWORD
         STH,IOADD 0,XT
ADVANCE  RES      0
         AI,XT2   1                 BUMP INDEX TO SFTBL
         BDR,XT1  NEXTCOL           DECREASE COLUMN COUNT AND RETURN
         B        *MPX1             EXIT
SFTBL    DATA,1   0,12,8,4,0,12,8,4
         BOUND    4
*
*  W R I T E D O
*        WRITE THE DIAGNOSTIC OUTPUT FILE
*
*         INPUT:  IOADD CONTAINS THE BUFFER ADDRESS
*                 IOSIZE CONTAINS THE NUMBER OF BYTES IN THE BUFFER
*
*          BYTE 0 OF THE BUFFER IS THE VFC.
*
WRITEDO  RES      0
         DO       SYS=BPMUTS
         MTW,0    *X'4F'
         BGEZ     WRDO1             BRANCH IF NOT ON-LINE
         LW,X5    J:JIT+JOPT        DON'T OUTPUT IF
         CI,X5    DOBIT             COMMENT BIT (IN JIT) IS ZERO
         BAZ      *IORL
         CI,X5    LOBIT
         BAZ      WRDO2
         FIN
WRDO1    RES      0
         MTB,0    CORRESWD          DON'T OUTPUT IF 'DO' AND 'LO'
         EXIT,NE  IORL                ARE THE SAME DEVICE
WRDO2    RES      0
         AI,IOSIZE  -1              SUBT 1 FOR VFC
         M:WRITE  M:DO,(BUF,*IOADD),(SIZE,*IOSIZE),(BTD,1),(WAIT)
         EXIT     IORL
*
*  W R I T E G O
*        WRITE THE GO FILE
*
*          INPUT: NONE
*
WRITEGO  RES      0
         DO       SYS=BPMUTS
         MTW,0    *X'4F'            BRANCH IF NOT ON-LINE
         BGEZ     WRGO1
         LW,IOSIZE  J:JIT+JOPT      DON'T OUTPUT IF
         CI,IOSIZE  GOBIT           OUTPUT BIT (IN JIT) IS ZERO
         BAZ      *IORL
WRGO1    RES      0
         FIN
*
         M:WRITE  M:GO,;
                  (ERR,ERR%%GO),;
                  (ABN,ERR%%GO),;
                  (BUF,BOBUF),;
                  (SIZE,*BO%SIZE),;
                  (WAIT)
         EXIT     IORL
*
*  R E A D S T D
*        READ THE STANDARD DEFINITION FILE
*
READSTD  RES      0
         M:READ   F:STD,(BUF,*IOADD),(SIZE,BYX1SIZE),(WAIT),;
                  (ERR,ERR%%STD),(ABN,ABN%%STD)
         EXIT     IORL
*
*  W R I T E S T D
*        WRITE THE STANDARD DEF FILE
*
WRITESTD RES      0
         M:WRITE  F:STD,(BUF,*IOADD),(SIZE,BYX1SIZE),(WAIT),;
                  (ERR,ERR%%STD),(ABN,ABN%%STD)
         EXIT     IORL
*
*  P O S I T I O N S T D
*        POSITION THE STD FILE N RECORDS FORWARD OR BACKWARD
*
POSITIONSTD  RES  0
         LI,IOADD F:STD
         B        POSIT%1
*  R E W S T D
*
*        REWIND THE STANDARD DEF FILE
*
REWSTD   RES      0
         M:REW    F:STD
         EXIT IORL
         END      START

