         PCC      0
*
********************
*  0.    PREAMBLE  *
********************
*
*
*  PROGRAM NAME:  UTS SYSTEM CONTROL SUBROUTINE MODULE 'CONSUB'
*
*  PURPOSE:         TO SERVE AS A SET OF CALLABLE SUBROUTINES FOR
*                 'CONTROL', UTS SYSTEM CONTROL MONITOR. BY INCULDING
*                 THE SUBROUTINES IN A SEPARATE MODULE, THE PHYSICAL
*                 SIZE OF 'CONTROL' WAS KEPT IN BOUNDS AS WELL AS
*                 THE ASSEMBLY TIME FOR EACH MODULE. SUBROUTINES INCLUD-
*                 ED IN 'CONSUB' WITH THEIR CORRESPONDING FUNCTION ARE
*                 LISTED BELOW IN THE MODULE DICTIONARY.
*
*
*  FUNCTION:        A DESCRIPTION OF THE INTERACTION BETWEEN 'CONSUB'
*                 SUBROUTINES AND 'CONTROL' OR 'PART', UTS MULTI-BATCH
*                 PARTITION CONTROL MODULE, MAY BE FOUND IN THE UTS
*                 TECHNICAL MANUAL UNDER SECTION QA. EACH SUBROUTINE
*                 IS CODED WITH AN EXPLANATION OF REGISTER USE SO THAT
*                 IT CAN BE DETERMINED BY EXAMINATION WHICH REGISTERS
*                 ARE PRESERVED, WHICH ARE USED FOR SCRATCH, AND WHICH
*                 CARRY PARAMETERS. EACH SUBROUTINE CARRIES A BRIEF
*                 EXPLANATION OF ITS FUNCTION.
*
         PAGE
*
*
*  IN-CORE HEADER:    THE IN-CORE HEADER GENERATION FOR THIS MODULE
*                     IS FOUND IN 'CONTROL' AND HAS THE FOLLOWING
*                     FORMAT:
*
*        TEXT     '########'
*        TEXT     'UTS CONTROL B00 '
*        TEXT     '################'
*        TEXT     '10-1-71 '
*ICTRACE TEXT     '  :TRACE'
*        TEXT     '########'
*
*                         SOME 'CONSUB' SUBROUTINES HAVE TRACE SUB-CODES
*                       WHICH ARE SHOWN BELOW. THESE ARE STORED IN
*                       BYTE 0 OF ICTRACE. PROVIDING THE MAJOR TRACE
*                       CODE IN BYTE 1 IS THE RESPONSIBILITY OF THE
*                       CALLING ROUTINE.
*
*                       SUB-CODES ARE USED TO INDICATE SUBROUTINE EXECU-
*                 TION AND ARE STORED IN BYTE 0 OF ICTRACE OVERLAYING A
*                 BLANK IF NO SUBROUTINE HAD PREVIOUSLY BEEN EXECUTED
*                 BY THAT MODULE OR ANOTHER SUB-CODE. ALL SUB-CODES
*                 ARE GENERATED ONLY FOR THE INITIAL TESTING LEVELS
*                 2 AND 1 EXCEPT THOSE NOTED BY AN ASTERISK (*) WHICH
*                 WILL CONTINUE TO FUNCTION IN THE PRODUCTION ENVIRON-
*                 MENT. ALL CURRENT SUB-CODES ARE SHOWN BELOW:
*
         PAGE
*
*
*                 TRACE SUB-CODE    SUBROUTINE     MODULE
*                 --------------    ----------     ------
*                     BLANK         NO SUBROUTINE ENTERED
*                       0                -            -
*                       1           MAP (34) *     CONTROL
*                       2           READSI (14) *  CONSUB
*                       3           ABNXX (20) *   CONSUB
*                       4           APEND (10)     CONSUB
*                                   BOUT (10)      CONSUB
*                                   BOUTX (10)     CONSUB
*                       5           DECIN (12)     CONSUB
*                                   DECINX (12)    CONSUB
*                       6           SAD (15)       CONSUB
*                       7           ITEMFIND (16)  CONSUB
*                       8           SEND (23) *    CONSUB
*                       9           BINOUT (24)    CONSUB
*                       A           MAIN (11) *    PART
*                       C           ADD (11)       PART
*                       D           ATRA (11)      PART
*                       E           BUILD (11)     PART
*                       F           CLEAR (11)     PART
*                       G           DISPLAY (11)   PART
*                       H           DROP (11)      PART
*                       I           ATRN (11)      PART
*                       J           SET (11)       PART
*                       K           STORE (11)     PART
*                       L           DISPA (14)     PART
*                       M           DISPX (14)     PART
*
         PAGE
*
**********************
*  0.1   DICTIONARY  *
**********************
*
*        0.       PREAMBLE
*        1.       ASSEMBLY ENVIRONMENT
*        2.       PROCEDURES
*        3.       CONDITIONAL ASSEMBLY PARAMETERS
*        4.       EXTERNAL REFERENCES & DEFINITIONS
*        5.       STATIC ASSEBMLY PARAMETERS
*        6.       DATA CONSTANTS
*        7.       DATA POINTERS
*        8.       DATA TABLES
*        9.       MESSAGES AND OTHER TEXT
*       10.       'APEND','BOUT','BOUTX' (APPEND STRING TO BUF & OUTPT)
*       11.       'CLOCK' (RETURN CURRENT TIME OF DAY)
*       12.       'DECIN','DECINX' (CONVERT EBCDIC DECIMAL TO BINARY)
*       13.       'RDNAME' (READ M:SI FOR ITEM NAME OR ATTRIBUTE)
*       14.       'READSI' (READ M:SI FOR INPUT STRING)
*       15.       'SAD' (SEARCH & DELETE # FROM FI/FO STACK)
*       16.       'ITEMFIND' (FIND INDEX OF ITEM/ATTRIBUTE IN TABLE)
*       17.       'OPENDCB' (OPEN SPECIFIED DCB TO OP-LABEL W/ABN)
*       18.       'SETDCB' (SET ABN RETURN ADR FOR SPECIFIED DCB)
*       19.       'CLOSE' (CLOSE SPECIFIED DCB, IF OPEN)
*       20.       'ABNXX' (HANDLE ABNORMAL RETURNS FROM I/O CALLS)
*       21.       'HEXOUT','DECOUT' (BIN-->EBCDIC CONVERSION)
*       22.       'SPACE' (APPEND BLANKS TO BUFFER)
*       23.       'SEND' (OUTPUT MESSAGE IN BUFFER)
*       25.       'NEWLN' (SKIP 'N' LINES)
*       30.       DYNAMICALLY MODIFIED DATA CELLS
*       31.       DYNAMICALLY MODIFIED DATA POINTERS
*       32.       DATA BUFFERS
*       33.       DCB'S AND FPT'S
*       34.       LITERALS
         PAGE
*
********************************
*  1.    ASSEMBLY ENVIRONMENT  *
********************************
*
*
CS:CONSUB:PROCEDURE CSECT 1
CS:CONSUB:DATA CSECT 0
CS:CONSUB:TEXT CSECT 1
*
         SYSTEM   SIG7
         SYSTEM   BPM
*
         TITLE    '''CONSUB'' - SYSTEM CONTROL SUBROUTINES'
*
**********************
*  2.    PROCEDURES  *
**********************
*
*
*********PROC NAME:     TYPE
*
*        TYPE:          COMMAND
*
*        CALL FORMAT:   TYPE  'CHARACTER STRING'
*
*        PURPOSE:       TO PROVIDE A PROCEDURE FOR TYPING MESSAGES
*                       ON THE 'DO' DEVICE.
*
*        REGISTER USE:  R1, R2
*
TYPE     CNAME
         PROC
         LOCAL    TY@TA
         DISP     %
         LIST     0
         USECT    CS:CONSUB:TEXT
         DO       TCOR(AF(1),S:C)=1  DO ONLY IF CHAR STRING
TY@TA      SET      %               SET SYMBOL TO 1ST BYTE OF STRING
LF(2)      TEXTC    AF(1)           SET LABEL TO TEXTC STRING, IF ANY
         ELSE                       IF SYMBOL, SET LOCAL TO 1ST BYTE
TY@TA      SET      AF(1)           OF PREVIOUSLY CREATED STRING
           FIN
CSEND:CONSUB:TEXT SET %             BUMP END OF TEXT POINTER FOR DUMP
*
         PAGE
*
*
         USECT    CS:CONSUB:PROCEDURE ANALYSIS.
LF(1)    EQU      %                 SET LABEL FIELD, IF ANY
*********CK%CODE  SAVE REGISTERS
         DO       CK%CODE>=1        FOR LEVELS 1 & 2 ONLY
           LCI      2               LOAD CONDITION CODES FOR PSM
           PSM,R1   *SPDADR         SAVE REGS R1,R2
         FIN
*********CK%CODE  END
         LI,R2    TY@TA
         BAL,R1   TYPEDO          >>M:WRITE THROUGH M:DO DCB
*********CK%CODE  RESTORE REGISTERS R1,R2 AFTER 'TYPE' EXECUTION
         DO       CK%CODE>=1
           LCI      2               PREPARE FOR PLM
           PLM,R1   *SPDADR         RESTORE R1,R2
         FIN
*********CK%CODE  END
         LIST     1
         PEND
*
         PAGE
*
*
*********PROC NAMES:    GENERATE TRACE CODE (TRACE%, CK%TRACE)
*
*        TYPE:          COMMAND
*
*        CALL FORMAT:   TRACE%   'STRING'
*
*                       WHERE STRING=1 CHARACTER (SUB-CODE) OR 2 CHAR-
*                       ACTERS (MAIN CODE IN EBCDIC FORMAT WHICH IDEN-
*                       TIFY THE CALLING ROUTINE.
*
*        DATE:          NOVEMBER 18, 1971
*
*        PURPOSE:       TO PROVIDE A SIMPLE MEANS TO GENERATE A TRACE-
*                       CODE OR SUB-CODE AT THE START OF A ROUTINE.
*                       THE SPECIFIED TRACE-CODE IS STORED IN THE
*                       IN-CORE HEADER AT THE BEGINNING OF THE LOAD
*                       MODULE DATA SECTION.
*
*
TRACE%   CNAME    0                 UNCONDITIONAL ASS'Y OF TRACE-CODE
CK%TRACE CNAME    1                 CONDITIONAL ASS'Y OF TRACE-CODE
         PROC
         LOCAL    TR@NC,TR@AF,TR@OP
TR@AF    SET      AF                GET AF LIST; NOT JUST LIST NAME
TR@NC    SET      S:NUMC(TR@AF)     GET # CHARS IN TRACE-CODE
         ERROR,X'2',(TR@NC>2)|(TR@NC=0)|(TCOR(AF,S:C))=0 ;
         'PROC.TRACE%.# TRACE BYTES>2 OR =0, OR NOT CHAR SSTRING'
TR@OP    SET      X'75',X'55'       SET UP OP-CODE TBL WITH STB & STH
         DO       (NAME=0)|(CK%CODE>=1) UNCOND OR CK%CODE=1,2
           LI,R0    TR@AF           GET CHECK-CODE
           GEN,8,7,17  TR@OP(TR@NC),0,ICTRACE  STB OR STH
         FIN
         PEND
*
         PAGE
*
*
*********PROC NAMES:    LOAD STD REGS AND BAL TO SUBR (LBAL%)
*                       LOAD STD REGS AND BRANCH TO ROUTINE (LBR%)
*
*        TYPE:          COMMAND PROCEDURES
*
*        CALL FORMAT:   LBAL%,R  SUBR,AF1,AF2,AF3,AF4
*                       LBR%     SUBR,AF1,AF2,AF3,AF4
*
*                       WHERE: LBAL%,LBR%=PROC NAMES
*                              R=BAL REGISTER (FOR LBAL%)
*                              AF1=DATA TO BE LOADED INTO REG SR1
*                              AF2=DATA TO BE LOADED INTO REG SR2
*                              AF3=DATA TO BE LOADED INTO REG SR3
*                              AF4=DATA TO BE LOADED INTO REG SR4
*                              SUBR=TARGET SUBROUTINE OR ROUTINE
*
*                       AND, ANY AF(N) MAY HAVE THE FOLLOWING SYNTAX:
*                              ADR
*                              (W,<*>ADR <,REG>)
*                              (H,<*>ADR <,REG>)
*                              (B,<*>ADR <,REG>)
*                              (WAM,<*>ADR <,REG>)
*                              (HAM,<*>ADR <,REG>)
*                              (BAM,<*>ADR <,REG>)
*
*                       WHERE: ADR=SYMBOLIC OR ABSOLUTE ADDRESS (IF
*                                  IT IS THE ONLY SPECIFICATION IN AF,
*                                  A LOAD IMMEDIATE IS GENERATED).
*                              <*>=OPTIONAL INDIRECT ADDRESS
*                              <REG>=OPTIONAL INDEX REGISTER
*                              W=WORD LOCATION (LOAD WORD GENERATED)
*                              H=HALFWORD LOCATION (LOAD HALFWORD
*                                GENERATED).
*                              B=BYTE LOCATION (LOAD BYTE GENERATED)
*                              WAM=LOAD WORD AND MASK WA
*                              HAM=LOAD WORD AND MASK HA
*                              BAM=LOAD WORD AND MASK BA
*
*
*  DESCRIPTION:   THE PURPOSE OF BOTH PROCS IS TO SET UP STANDARD
*                 REGISTERS SR1-SR4 FOR A CALL TO THE SPECIFIED SUB-
*        ROUTINE. LBAL% PRODUCES A BRANCH AND LINK INSTRUCTION ON
*        THE REGISTER SPECIFIED IN COMMAND FIELD 2 AND LBR% PRODUCES
*        A DIRECT BRANCH TO THE ROUTINE SPECIFIED. ANY OF THE REG-
*        ISTER SPECIFICATIONS MAY BE LEFT BLANK IF A COMMA IS PLACED
*        TO INDICATE PRESENCE OF THE PARAMETER. (THIS IS NECESSARY ONLY
*        IF ANOTHER REGISTER SPECIFICATION FOLLOWS).
*
*                 DATA TO BE LOADED INTO THE REGISTERS MAY BE A SINGLE
*        SYMBOL (INWHICH CASE A LOAD IMMEDIATE INSTRUCTION WILL BE
*        GENERATED) OR A KEYWORD (W,H, OR B) AND A SYMBOL (IN WHICH
*        CASE A LOAD WORD, HALFWORD, OR BYTE INSTRUCTION WILL BE GEN-
*        ERATED). AN INDIRECT ADDRESS MAY BE SPECIFIED BY PLACING AN
*        ASTERISK IN FRONT OF THE ADDRESS SYMBOL IN ALL CASES EXCEPT
*        FOR THE IMMEDIATE ADDRESS FORMAT. AN INDEX REGISTER MAY BE
*        SPECIFIED FOLLOWING THE SYMBOLIC ADDRESS IN ALL CASES EXCEPT
*        FOR THE IMMEDIATE ADDRESS FORMAT. IF THE DATA WHICH IS LOADED
*        IS TO BE MASKED TO PRODUCE A WORD, HALFWORD OR BYTE ADDRESS,
*        'WAM', 'HAM', OR 'BAM' MAY BE USED AS KEYWORDS IN WHICH CASE
*        A 'LW' INSTRUCTION WILL BE GENERATED FOLLOWED BY AN 'AND' WITH
*        A 17-BIT, 18-BIT, OR 19-BIT MASK.
*
*        NOTE1:   REGISTER USE IS AS FOLLOWS:
*
*        ENTRY             INTERNAL            EXIT
*        -----             --------            ----
*        'R'=USER SUPPLIED SR1-SR4=LOAD REGS   ALL REGS PRESERVED
*        BAL REGISTER      'R'=BAL REG
*
         PAGE
*
*
LBR%     CNAME    0             <<  LOAD STD REG & BRANCH TO SUBR
LBAL%    CNAME    1             <<  LOAD STD REG & BAL TO SUBR
         PROC
         LOCAL    I,LB@BR,LB@SR,LB@E1,LB@E2,LB@3,LB@F,LB@OP,;
                  LB@M
LB@E1    SET      (NAME=1)&(NUM(CF(2))=0) SET ERR FLG IF LBAL% & NO REG
LB@E2    SET      NUM(AF(1))=0            SET ERR FLG IF NO SUBR ADR
         GOTO,LB@E1|LB@E2  LB@3     SKIP CODE GEN IF ERROR CONDITION
*
LB@BR    SET      CF(2)             GET SYMBOLIC REGISTER SPECIFICATION
LB@SR    SET      ,SR1,SR2,SR3,SR4  CREATE STD REG LIST // TO AF
LB@OP    SET      X'32',X'52',X'72' CREATE LW,LH,LB OP-CODE LIST
LB@M     SET      ,,,X'1FFFF',X'3FFFF',X'7FFFF'  CREATE WA,HA,BA MSK LST
*
LF       SET      %                 SET LABEL FIELD  %, IF ANY
I        SET      1                 INITIALIZE AF INDEX
         DO       NUM(AF)-1         DO FOR ALL STD REGS SPECIFIED
I         SET      I+1              INCREMENT AF INDEX TO NEXT REG
LB@F      SET      SCOR(AF(I,1),W,H,B,WAM,HAM,BAM)   GET KEYWORD INDEX
          DO       LB@F=0         ->IS SPEC AN IMMEDTE VAL/NULL?
           DO1      NUM(AF(I))>0      YES-IS IT IMMEDIATE VAL?
             LI,LB@SR(I) AF(I)        YES-LOAD IMMEDIATE ADDRESS
          ELSE                    ->GO TO 'DO' END;TRY NXT FIELD
*                                   E.P. TO GEN LW,LH, OR LB
           DO       LB@F<4      <-  DO ONLY IF NO MASK DESIRED
             GEN,1,7,4,3,17 AFA(I,2),LB@OP(LB@F),; GEN INDRCT BIT,OP,
                      LB@SR(I),AF(I,3),AF(I,2)    REG,INDEX REG,ADR
           ELSE                     DO IF MASK DESIRED
             GEN,1,7,4,3,17 AFA(I,2),X'32',LB@SR(I),; GEN INDIRECT
                      AF(I,3),AF(I,2)     BIT,OP-CODE,REG,
*                                   INDEX REG, REF ADDRESS
             AND,LB@SR(I) L(LB@M(LB@F)) MASK WA,HA, OR BA
           FIN
          FIN                   <-
         FIN
*
*
         DO       NAME=0            DO IF DIRECT BRANCH DESIRED
           B        AF(1)         >>BRANCH TO ROUTINE
         ELSE                       DO IF BAL DESIRED
           BAL,LB@BR AF(1)        >>BAL TO SUBROUTINE
         FIN
*
LB@3     ERROR,X'5',LB@E1  'PROC.LBAL%.NO BAL REG SPECIFIED'
         ERROR,X'5',LB@E2  'PROC.LBR%/LBAL%.NO BRANCH TARGET SPECIFIED'
*
         PEND
*
         PAGE
*
*******************************************
*  3.    CONDITIONAL ASSEMBLY PARAMETERS  *
*******************************************
*
*
CK%CODE  EQU      0     THREE LEVELS OF MODULE CHECK-OUT ARE PROVIDED
*                       BY THE INCLUSION OF CHECK-CODES WITH CERTAIN
*                       OF THE TEST TABLE ENTRIES AND CONDITIONAL
*                       ASSEMBLY OF THE 'CONTROL' AREAS WHICH CHECK
*                       THE TABLE CODES FOR CORRECT ACCESS. ON THE
*                       FIRST GO-AROUND, THESE CHECK-CODES WILL BE
*                       INCLUDED WITH EACH APPLICABLE TABLE ENTRY AND
*                       WILL BE COMPARED TO SIMILAR CODES IN THE FIRST
*                       CHECK-OUT LEVEL OF THE 'CONTROL' MODULE.
*                       WHEN THE 'CONTROL' UPDATES HAVE BEEN FIRMED UP
*                       THROUGH INITIAL TESTING (LEVEL 2), THE
*                       TABLES WILL BE REASSEMBLED WITHOUT THE CHECK-
*                       CODES AND RUN WITH THE CORRESPONDING VERSION
*                       OF 'CONTROL' WHICH WILL EMPLOY LIMITED CHECKS.
*                       ULTIMATELY, 'CONTROL' WILL BE TESTED WITH NO
*                       GUARD-CODE IN CONJUNCTION WITH PRODUCTION
*                       SYSGEN TABLES.
*
*                 0 ===> PRODUCTION VERSION - NO GUARD-CODE
*                 1 ===> INTERMEDIATE TESTING - PRODUCTION TABLES.
*                 2 ===> INITIAL TESTING - GUARD-CODE IN TABLE ENTRIES
*
         PAGE
*
*********************************************
*  4.    EXTERNAL REFERENCES & DEFINITIONS  *
*********************************************
*
*  4.1   EXTERNAL REFS
*
*
*        'CONTROL' REFERENCES
*
         REF      FOMAP             MON PGS VIR MEM MAPPING CONSTANT
         REF      DFLTSI,DFLTDO,DFLTLO  XX DEVICE DEFAULT OP-LABEL
         REF      COMMAND           ITEM/ATTRIBUTE NAME INPUT BUF
         REF      CBUFWSZ           ITEM/ATRT/BTE NAME BUF WORD SIZE
         REF      IMCNT             INPUT MESSAGE BYTE COUNT CELL
         REF      BREAK,BREAK3,BREAK5 E.P. FOR BREAK CONTROL HANDLERS
         REF      JOBX              JOB TYPE INDEX(1=GHOST,2=O/L,3=BCH)
         REF      TYPEDO            SUBR FOR TYPING MESSAGE ON M:DO
         REF      ICTRACE           TRACE CODE CELL: IN-CORE HEADER
         REF      10IN11            'CONTROL' INITIALIZATION; TYPE CNTRL HERE
         REF      SPDADR            ADR OF USER'S TCB TEMP STACK SPD
         REF      INDICATR          GERM SYNTAX,I.E. TCMD
         REF      INDJOB            JOB INDICATION,I.E. GOB
         REF      GERMWORD          GERM ITEM CODE WORD
         REF      GERMBANG          CONTROL BANG INDICATION
         REF      RCONSTR           DBLWD FOR NAME RECONSTRTN
         REF      GCONSTK           GERM TBL FOR 'ADD' 'DROP'
         REF      GCONVAL           GERM TBL FOR CON BANG VALUS
         REF      GDECTBL           GERM DECISION TBL
         REF      GREFTBL           GERM REFERNCE TBL
         REF      GMINTBL           GERM MIN VALU TBL
         REF      GMAXTBL           GERM MAX VALU TBL
         REF      GTEXTBL           GERM TEXT HDNG TBL
* EQUS
         REF      #DECTBL           # OF ENTRIES IN GDECTBL
         REF      RPNM#             RSRCE/SYMBNT NAME CHTR # (2)
         REF      SNM#              SRVCE NAME CHTR # (4)
         REF      NAMEPOS           POSTN. IN NAME TBLS  (0)
         REF      GERMCLS           RSRCE,SRVCE OR SYMBNT  (1)
         REF      JOBCLS            JOB TYPE--SYS,G,O,B  (2)
         REF      TYPECLS           VALU TYPE--TOTAL,SUM,MAX,DFT (3)
*
*        REFERENCES TO SYSTEM PARAMETERS
*
         REF      M:SI
         REF      M:LO
         REF      M:DO
         REF      M:XX              DCB FOR ERRMSGE FILE READ
         REF      ERRMSGE           ENTRY POINT FOR ERRMSGE FILE READER
         REF      J:JIT             USER TYPE FLAGS
         REF      SH:RNM,SV:RSIZ    RSRCE NAME TBL;SIZE
         REF      SL:NAME,SV:LIM    SRVCE NAME TBL;SIZE
         REF      SH:SYMT,SV:FTYM   SYMBN NAME TBL;SIZE
         REF      FMAP              MAPPING CONSTANT
*
F        EQU      FMAP
*
*
*        REFERENCES TO 'PART' - PARTITION CONTROL MODULE
*
         REF      PEXEC             PARTITION CONTROL EXECUTION FLAG
         REF      SPD               'PART' STACK POINTER DW
         REF      ZEROUT            PART DEF STACK FREE PGS SUBR
*
*
*  4.2   EXTERNAL DEFINITIONS
*
         DEF      CS:CONSUB:TEXT    CONTROL SECTION
         DEF      CS:CONSUB:PROCEDURE CONTROL SECTION
         DEF      CS:CONSUB:DATA    CONTROL SECTION
         DEF      CSEND:CONSUB:TEXT CONTROL SECTION END
         DEF      CSEND:CONSUB:PROCEDURE CONTROL SECTION END
         DEF      CSEND:CONSUB:DATA CONTROL SECTION END
         DEF      CS:REENTRANT:DATA REENTRANT DATA BLOCK
         DEF      CS:RED:SIZE       WORD SIZE - REENTRANT DATA BLOCK
         DEF      OPENDCB           SUBROUTINE
         DEF      SETDCB            SUBROUTINE
         DEF      CLOSE             CLOSE SPECIFIED, IF OPEN
         DEF      APEND,BOUT,BOUTX  SUBROUTINE
         DEF      CLOCK             SUBROUTINE
         DEF      DECIN,DECINX      SUBROUTINE
         DEF      HEXIN,HEXINX      SUBROUTINE
         DEF      PRESCAN           SUBROUTINE IN READSI
         DEF      OCTOLP,LPTOOC     LO SWITCHERS FOR GHOST JOBS
         DEF      OBUFSZ            SIZE OF OUTPUT BUFFER FOR ONLINE JOBS
         DEF      SETPROMPT         PROMPT CAL FOR GHOSTS
         DEF      RDNAME            SUBROUTINE
         DEF      READSI            SUBROUTINE
         DEF      SAD               SUBROUTINE
         DEF      ITEMFIND          SUBROUTINE
         DEF      SPACE             SUBROUTINE
         DEF      NEWLN             SUBROUTINE
         DEF      DECOUT,HEXOUT,OCTOUT SUBROUTINE
         DEF      SEND              SUBROUTINE
         DEF      ABNLO,ABNSI,ABNDO I/O ABN RTN ENTRY POINTS
         DEF      OBUFX             INDEX TO NEXT AVAILABLE BUF CHAR
         DEF      OUTFPT            M:WRITE FPT
*
*DEF FOR GERM RELATED SUBROUTINES
         DEF      GERMFIND
         DEF      GERMFILL
         DEF      MKNME
         DEF      GOUTRTN
         DEF      GTSTVAL
*
         PAGE
*
**************************************
*  5.    STATIC ASSEMBLY PARAMETERS  *
**************************************
*
*
*  5.1   REGISTER USAGE
*
R0       EQU      0                 SCRATCH REG
R1       EQU      1                 SCRATCH REG;PROC REG
R2       EQU      2                 SCRATCH REG;PROC REG
R3       EQU      3                 SCRATCH REG
R4       EQU      4                 SCRATCH REG
R5       EQU      5                 INDEX REG
R6       EQU      6                 DATA REG
R7       EQU      7                 RETURN LINK REG
SR1      EQU      8                 OUTPUT PARAMETER;CAL RETURN ADR
SR2      EQU      9                 OUTPUT PARAMETER
SR3      EQU      10                INPUT  PARAMETER;CAL ERR/ABN CODE
SR4      EQU      11                INPUT  PARAMETER; RETURN LINK REG
D1       EQU      12                CALLING PARAM IN ABNXX
D2       EQU      13                WORK REG IN ABNXX
*D3      EQU      14                NOT USED
*D4      EQU      15                NOT USED
*
*                 REGISTERS D3 AND D4 ARE ALWAYS PRESERVED
*
*
         PAGE
*
**************************
*  6.    DATA CONSTANTS  *
**************************
*
*
         BOUND    8
BCDD#L   DATA     C'0',C'9'         DEC CONVERSION DIGIT LIMITS
BCDH#L   DATA     C'A',C'F'         HEX CONVERSION DIGIT LIMITS
XXADR    DATA     0,M:DO,M:SI,M:LO  DCB ADR TBL;INDEXED BY DCBX
OPLB     DATA     0                 OP-LABEL TEXT NAME TABLE;INDEX=DCBX
         TEXTC    'DO'
         TEXTC    'SI'
         TEXTC    'LO'
OPLBTX   DATA,1   0                 OPLBT2 & OPLBT5 INDICES
         DATA,1   5                 POINTING TO LABELS DO,SI, & LO
         DATA,1   9
         DATA,1   3
*
         BOUND    8
DWBLANKS TEXT     '        '        DOUBLEWORD OF BLANKS
*
         PAGE
*
*************************
*  7.    DATA POINTERS  *
*************************
*
*
DFLTXX   DATA     0                 DCB DEFAULT OP-LABEL POINTER TBL
         DATA     DFLTDO
         DATA     DFLTSI
         DATA     DFLTLO
*
         PAGE
*
**********************************
**  9.   MESSAGES AND OTHER TEXT  *
**********************************
*
*
DELIMS   DATA     0                 DELIM LIST FOR RDNAME CALL TO
*                                   PRESCAN.
IOERM1   TEXTC    ' I/O ERROR AT  '
IOERM2   TEXTC    '  THROUGH M:'
IOERM3   TEXTC    ' DCB'
IOERM4   TEXTC    ' I/O SUBROUTINE CALL AT  '
*
CSEND:CONSUB:TEXT SET %             INITIAL SETTING FOR END-OF-TEXT-
*                                   DATA AREA:MAY BE INCREMENTED BY
*                                   'TYPE' PROC IN LEVELS 1 & 2.
         PAGE
*
******************************************************************
*  10.   'BOUT', 'BOUTX', & 'APEND' - APPEND STRING TO BUFFER    *
*                                       WITH OPTIONAL OUTPUT     *
******************************************************************
*
*
*  DESCRIPTION:   'APEND' RECEIVES AS ARGUMENTS THE ADDRESS OF A CHAR-
*                 ACTER STRING CREATED BY A TEXTC DIRECTIVE AND APPENDS
*        THE DESIGNATED STRING TO THE CHARACTER STRING CURRENTLY RE-
*        SIDING IN 'BUFFER'. 'BOUT' PERFORMS THE SAME TASK, EXCEPT THAT
*        THE RESULTANT MERGED STRING IS OUTPUT ON THE LO DEVICE. A CALL
*        TO 'BOUTX' WILL BEHAVE AS EITHER 'BOUT' OR 'APEND' DEPENDING ON
*        THE SETTING OF A FLAG IN SR2, THE ONLY DIFFERENCE BEING THAT
*        THE CALLING PROGRAM MUST SUPPLY THE BYTE ADDRESS OF THE FIRST
*        CHARACTER TO BE APPENDED AS WELL AS THE STRING LENGTH
*        AND AN OUTPUT FLAG.
*
*        NOTE1:   REGISTER USAGE AND PRESERVATION FOR 'BOUT', 'BOUTX',
*                 AND 'APEND' IS AS FOLLOWS:
*
*        ENTRY               INTERNAL            EXIT
*        -----               --------            ----
*BOUT &  SR3=STRNG WD ADR    R0,R2=WORK          R0-R2,SR1,SR3,SR4 VOL
*APEND   R7=RETURN LINK      R1=STR BYT XFER CNT R3-R7,SR2,D1-D4 PRSRVD
*------------------------    SR2=OUTPUT FLAG     IF 'SEND' NOT CALLED,
*BOUTX   SR2=OUTPUT FLAG     SR4=BYT ADR LAST    SR3 PRESERVED
*        SR3=STR BYTE ADR    CHAR INPUT STR
*        SR4=STRING LENGTH   SR1=OUTPUT DCB ADR
*        R7=RETURN LINK      SR3=I/O ABN RTN ADR (IN 'SEND')
*
*
         USECT    CS:CONSUB:PROCEDURE  USE PRECEDURE SECTION
*
BOUT,10BOUT EQU   %                 ENTRY POINT; APPEND STR TO BUF
*                                   AND OUTPUT.
         LI,SR2   1             <<  GET OUTPUT FLAG
         B        10BOUT2+1       ->
BOUTX,10BOUT1 EQU %                 ENTRY POINT; NON-TEXTC FMT
         AND,SR3  =X'7FFFF'     <<  MASK OFF BA
         AI,SR3   -1                POINTS TO BYTE BEFORE STR
         B        10BOUT3         ->START TRANSFER
APEND,10BOUT2 EQU %                 ENTRY POINT; APPEND STR TO BUF
         LI,SR2   0             <<  GET NO-OUTPUT CODE
         LB,SR4   *SR3          <-  STR CREATED BY 'TEXTC'; GET LENGTH
         SLS,SR3  2                 WORD ADR OF STR-->BYTE ADR OF CNT
10BOUT3  EQU      %             <-  START CORE OF ROUTINE
         CK%TRACE '4'               '4' IS TRACE CODE FOR APEND, ETC.
         AW,SR4   SR3           <<  SR4=BYTE ADR OF LAST CHAR
         LW,R2    SR3               GET BA(BYTE PRECEDING 1ST STR BYT)
         LW,R1    OBUFX             R1=INDEX TO NXT CHAR OF BUF
10BOUT4  CW,R1    OBUFSZ            IS OUTPUT BUFFER FULL
         BGE      10BOUT5         ->  YES-TRUNCATE INPUT
         AI,R2    1                   NO-INCREMENT STR PTR
         CW,R2    SR4               HAS LAST CHAR BEEN OUTPUT?
         BG       10BOUT6         ->  YES-TEST FOR OUTPUT
         LB,R0    0,R2                NO-STORE ANOTHER STR CHAR IN BUF
         STB,R0   BUFFER,R1
         AI,R1    1                 INCREMENT NXT BUF CHAR PTR
         B        10BOUT4         ->
10BOUT5  EQU      %             <-  OVERFLOW ON BUFFER BYTE COUNT
*********CK%CODE  OVERFLOW FLAG FOR 'SEND'
         DO       CK%CODE>=1
           USECT    CS:CONSUB:DATA  DATA WORD FOR TESTING ONLY
OVFLG      DATA     0               OVERFLOW FLAG FOR TEST IN 'SEND'
           USECT    CS:CONSUB:PROCEDURE
           LI,R2    1               GET OVERFLOW FLAG
           STW,R2   OVFLG           STORE
           FIN
*********CK%CODE  END
10BOUT6  EQU      %             <-  INPUT STR XFERED TO BUF
         STW,R1   OBUFX             SAVE INDEX TO NXT CHAR OF BUF
         CI,SR2   1                 SHALL WE OUTPUT THE BUFFER?
         BE       23SEND          >>  YES-OUTPUT BUF
         B        *R7             >>  NO-RETURN
*
         PAGE
*
*************************************
*  11.   'CLOCK' - GET TIME OF DAY  *
*************************************
*
*
CLOCK,11CL1 EQU   %                 E.P. FOR TIME OF DAY
         B        *SR4            >>RETURN
*
         PAGE
*
*
*********************************************************************
*  12.   'DECIN','DECINX','HEXIN','HEXINX' - DECIMAL & HEXADECIMAL  *
*                                            TO BINARY CONVERSION   *
*********************************************************************
*
*
*  DESCRIPTION:   THERE ARE FOUR ENTRY POINTS TO THIS SUBROUTINE.
*                 'DECIN' AND 'HEXIN' ACCEPT A 2-WORD BUFFER ADDRESS
*        CONTAINING A RIGHT-JUSTIFIED, BLANK-FILLED EBCDIC DECIMAL
*        OR HEXADECIMAL NUMBER. 'DECINX' ACCEPTS THE BYTE ADDRESS
*        OF THE MOST SIGNIFICANT DIGIT OF AN EBCDIC DECIMAL NUMBER AND
*        THE NUMBER OF DIGITS AS ARGUMENTS AND RIGHT-JUSTIFIES THE
*        NUMBER IN A BLANK 2-WORD BUFFER. 'HEXINX' ACCEPTS THE SAME
*        ARGUMENTS AS 'DECINX' FOR A HEXADECIMAL NUMBER. ALL ENTRIES
*        BRANCH TO A COMMON CONVERSION ROUTINE WHICH OUTPUTS THE CON-
*        VERTED BINARY NUMBER IN THE USER'S BUFFER.
*
*                 'DECIN' AND 'HEXIN' REQUIRE THE (WA) OF THE MOST SIG-
*        NIFICANT WORD OF THE 2-WORD BUFFER. 'DECINX'  AND 'HEXINX'
*        REQUIRE THE BYTE ADDRESS OF THE MOST SIGNIFICANT DECIMAL OR
*        HEXADECIMAL DIGIT IN BITS 13-31 OF SR1 AND THE DIGIT COUNT
*        IN BITS 0-7, RIGHT-JUSTIFIED. ANY NUMBER HAVING MORE THAN
*        8 DIGITS WILL PRODUCE AN ERROR RETURN. AN ERROR RETURN AD-
*        DRESS MUSTT BE SPECIFIED IN SR3 AS WELL AS AN OUTPUT BUFFER
*        ADDRESS IN SR2.
*
*
*  FUNCTION:      THE DECIMAL ONE'S POSITION IS PICKED UP, CONVERTED
*                 TO BINARY, MULTIPLIED BY1 AND ACCUMULATED IN THE
*        USER-SPECIFIED OUTPUT BUFFER. THEN THE TEN'S POSITION IS
*        PICKED UP, MULTIPLIED BY 10 AND ACCUMULATED IN THE BUFFER,
*        ETC. SUBROUTINE IS REENTRANT.
*
*                 THE OPERATION FOR THE HEXADECIMAL ROUTINE IS SIMILAR
*        EXCEPT THAT THE DIGIT POSITIONS ARE 1,16,256,ETC., AND THE
*        MULTIPLIER IS 16.
*
*
*        NOTE1:   REGISTER USE IS AS FOLLOWS:
*
*        ENTRY            INTERNAL            EXIT
*        -----            --------            ----
*DECIN & SR1=2 WD DEC ADR R0,R1=WORK          R0-R1=VOLATILE
*HEXIN                    R2-R3=MBX,MULTIPLR  R2-R7,SR1-SR4,D1-D4
*------------------------ R4-R5=DEC BUF       PRESERVED
*DECINX  SR1=BA(HIGHORDR  R6=SCALE FACTOR
*HEXINX      DIGIT);DIGIT
*            CNT(BYT 0)
*        SR2=BIN OUT BUF ADR
*        SR3=ERROR RTN
*        SR4=RTN LINK
*
*
HEXIN    EQU      %                 E.P. FOR 8 CHAR EBCDIC HEX
*                                   INTEGER TO BINARY CONVERSION.
         LI,R1    -2            <<  GET 'HEXIN' ENTRY FLAG
         B        %+2             ->
HEXINX   EQU      %                 E.P. FOR UNBUFFERED EBCDIC HEX
*                                   INTEGER STR TO BIN CONVERSION.
         LI,R1    -1            <<  GET 'HEXINX' ENTRY FLAG
         CK%TRACE '5'           <-  SET TRACE-CODE
         LCI      10
         PSM,R2   *SPDADR           SAVE R2-SR4
         LI,R7    16                GET HEXADECIMAL BASE
         B        12DEC2          ->MERGE WITH DEC ROUTINE
DECIN    EQU      %                 E.P. FOR 8 CHAR EBCDIC DECIMAL
*                                   INTEGER TO BINARY CONVERSION
         LI,R1    -2            <<  GET DECIN ENTRY FLAG
         B        %+2             ->SET TRACE-CODE
DECINX   EQU      %                 E.P. FOR UNBUFFERED EBCDIC DEC
*                                   INTEGER STR TO BIN CONVERSION.
         LI,R1    -1            <<  GET DECINX ENTRY FLAG
         CK%TRACE '5'           <-  '5' IS TRACE SUB-CODE FOR DECIN
         LCI      10                SAVE R2-SR4
         PSM,R2   *SPDADR           PUSH
         LI,R7    10                GET DECIMAL BASE
12DEC2   PSW,R1   *SPDADR       <-  PUSH A DUMMY WD IN STK FOR
*                                   TEMP OUT BUF
         LW,SR2   *SPDADR           GET TOP OF STK ADR
         BIR,R1   12DEC4          ->DECIN SKIP BUF SET-UP
12DEC3   EQU      %                 TRANSFER DEC INT TO BUF,RT-JUST
         LB,R2    SR1               GET DEC BYTE COUNT
         CI,R2    8                 IS DECIMAL>BUF SIZE?
         BG       12DEC7          ->  YES-ERROR RETURN
         LI,R3    16+8                NO-GET BA(R4)+8
         SW,R3    R2                SHIFT 1ST BYT LFT IN BUF TO RT-
*                                   JUSTIFY DECIMAL IN R2-R3.
         STB,R2   R3                STORE BYTE COUNT
         LW,R2    SR1               GET BEGINNING BYTE ADR
         AND,R2   =X'7FFFF'         MASK 19-BIT BYTE ADR
         LD,R4    DWBLANKS          BLANK DECIMAL BUFFER
         MBS,R2   0                 MOVE DEC TO BUF & RT-JUST
         LI,SR1   R4                GET WA(DEC BUF)
*                                   DECIMAL INTEGER<=8 DIGITS NOW
*                                   STORED IN BLANKED 2-WORD BUF
12DEC4   EQU      %                 CONVERT DEC TO BIN
         LI,R6    1             <-  START WITH 1ST DEC DIGIT
*                                   (R6)=SCALE FACTOR FOR EACH DEC DIG
         LI,R2    0                 INITIALIZE BINARY LOCATION
         STW,R2   *SR2              IN TEMP BUF.
         LI,R1    7                 GET POINTER TO FIRST DIGIT
12DEC5   EQU      %                 CONVERT EBCDIC BYTE LOOP
         LB,R3    *SR1,R1       <-  GET DECIMAL DIGIT
         CI,R3    C' '              IS CHARACTER A BLANK?
         BE       12DEC6          ->  YES-CONVERSION COMPLETED
         CI,R7    10                  NO-IS IT DEC CONVERSION?
         BE       12DEC5A         ->  YES-SKIP HEX TESTS
         CLM,R3   BCDD#L              NO-IS DIGIT>=C'0' AND<=C'9'?
         BCR,9    12DEC5B         ->  YES-GOOD ONE; PROCESS IT AS DEC
         CLM,R3   BCDH#L              NO-IS DIGIT<C'A' OR>C'F'
         BCS,9    12DEC7          ->  YES-ERROR;RETURN;NON-HEX INT
         AI,R3    9                   NO-CONV LOW ORDER HEX DIG
*                                   TO GIN EQUIVALENT.
         B        12DEC5B         ->PROCESS IT
*
12DEC5A  EQU      %                 DECIMAL CONVERSION
         CLM,R3   BCDD#L        <-  IS DIGIT<C'0' OF>C'9'?
         BCS,9    12DEC7          ->  YES-ERROR;RETURN;NON-INTEGER
12DEC5B  EQU      %                 GENUINE HEX OR DEC DIGIT
         AND,R3   =X'F'         <-  STRIP OFF MOST SIGNIFICANT
*                                     HEX DIGIT
         MW,R2    R6                SCALE THE INTEGER DEPENDING UPON
*                                   DIGIT (POSITION).
         AWM,R3   *SR2              ADD PRODUCT TO BINARY SUM
         AI,R1    -1                DECREMENT DECIMAL INT PTR
         BLZ      12DEC6          ->8 DIGITS CONVERTED; CONV COMPLTE
         LW,R3    R7                GET BASE
         MW,R2    R6                RAISE BASE ANOTHER POWER
         STW,R3   R6                STORE NEW DIGIT SCALE
         B        12DEC5          ->CONVERT NEXT DIGIT
12DEC6   EQU      %             <-  CONVERSION COMPLETE
         PLW,R1   *SPDADR           GET TEMP BIN BUF
         LCI      10                RESTORE R2-D4
         PLM,R2   *SPDADR           PULL
         STW,R1   *SR2              STORE BIN# IN USER'S BUF
         B        *SR4            >>RETURN
*
12DEC7   EQU      %                 ERROR RETURN
         PLW,R1   *SPDADR           ELIMINATE TEMP OUT BUF FROM STK
         LCI      10            <-  RESTORE R2-SR4
         PLM,R2   *SPDADR           PULL
         B        *SR3            >>RETURN
*
         PAGE
*
*****************************************
*  13.   'RDNAME' - READ INPUT MESSAGE  *
*****************************************
*
*
*  DESCRIPTION:   'RDNAME' BLANKS THE ITEM NAME INPUT BUFFER AND
*                 CALLS 'READSI' TO ISSUE A PROMPT AND READ THE USER
*        INPUT ITEM NAME. THE NUMBER OF CHARACTERS IN THE INPUT MESSAGE
*        IS COUNTED BY 'READSI' AND RETURNED. IF THE NUMBER OF SIGNIFI-
*        CANT CHARACTERS IS ZERO (USER CARRIAGE RETURN OR OTHER DELIMI-
*        TER), 'RDNAME' TAKES AN ERROR RETURN. OTHERWISE, THE MESSAGE
*        LENGTH IS STORED AND ANORMAL RETURN IS TAKEN. IF 'READSI'
*        DETECTS ANY INPUT ERROR (EXCEPT FOR ABN X'07'=INPUT TRUNCATION
*        DUE TO INSUFFICIENT BUFFER SIZE), IT OPENS M:SI TO THE DEFAULT
*        DEVICE FOR THE TYPE OF JOB EXECUTING (I.E. GHOST, BATCH, OR
*        ON-LINE) AND RETURNS TO INITIALIZATION IN 'CONTROL'. AN I/O
*        ERROR MESSAGE IS TYPED ON THE DO DEVICE INFORMING THE USER
*        THAT 'CONTROL' HAS RECOVERED FROM THE ERROR (IF THE ERROR/
*        ABN CODE WAS NOT GREATER THAN X'3F').
*
*
*        NOTE1:   PRESERVATION OF REGISTER INTEGRITY AND REGISTER USE
*                 IS AS FOLLOWS:
*
*        ENTRY              INTERNAL             EXIT
*        -----              --------             ----
*        (R7)=ERR RTN ADR   R0,R1=WORK           R0-R1,SR1-SR4 VOLATILE
*                           SR1-SR4=PARAMETER REGS
*        (R7)+1=RTN ADR     ST1-SR4=PARAM REGS   R2-R7,D1-D4 PRESERVED
*
*
RDNAME,13NAME EQU %                 ENTRY POINT FOR 'RDNAME' SUBROUTINE
         LW,R0    L(C'    ')    <<  GET A WORD OF BLANKS
         LI,R1    CBUFWSZ           LOAD INDEX
         STW,R0   COMMAND,R1    <-  BLANK OUT  BUFFER
         BDR,R1   %-1             ->
         STW,0    COMMAND           FIRST WORD TOO
         LBAL%,SR4 SETPROMPT,,,'.'  SET 3RD LEVEL PROMPT
*
         LI,SR1   32                READ BUFFER SIZE=32 BYTES
         LI,SR2   COMMAND           GET M:READ BUFFER ADR
         LI,SR3   DELIMS            GET DELIM LIST ADR FOR PRESCAN
         BAL,SR4  READSI          >>M:READ INTO BUF;TRUNCATE DELIMITERS
*                                   SR1=INDEX TO RTMOST BYTE OF MSGE
         LBAL%,SR4 SETPROMPT,,,'>'  RESTORE PROMPT
         AI,SR1   1                 ANY INPUT BESIDES RETURN
         BLEZ     *R7             >>ABN RETURN IF COMMAND 0 LENGTH
         STW,SR1  IMCNT             STORE MESSAGE LENGTH
         B        1,R7            >>NORMAL RETURN
*
         PAGE
*
************************************************************
*  13.1  SETPROMPT - SET PROMPT CHAR FOR ONLINE AND GHOST  *
************************************************************
*
*
*        REGISTERS:
*        SR3 CONTAINS PROMPT CHARACTER
*        OR ZERO, IF REQUEST IS TO RESET PREVIOUS PROMPT
*        CHARACTER - AS IS PROCEED FROM BREAK CONTROL
*        SR4 IS LINK REG
*
*        ALL REGISTERS PRESERVED
*
*
SETPROMPT EQU %
         CI,SR3   0                 IF ZERO SET OLD PROMPT
         BNE      %+3
         LH,SR3   PROMPT
         AI,SR3   -X'100'
         STW,SR3  PROMPT
         LI,SR3   X'2C'             MAKE A PROMPT CAL
         STB,SR3  PROMPT
         CAL1,1   PROMPT
         LW,SR3   PROMPT
         STH,SR3  PROMPT
         LH,SR3   PROMPT
         MTB,1    PROMPT
         B        *SR4
         PAGE
*
*************************************************
*  14.   'READSI' - READ DCB FOR COMMAND INPUT  *
*************************************************
*
*
*  DESCRIPTION:   'READSI' READS A STRING OF INPUT CHARACTERS INTO
*                 AN INPUT BUFFER THROUGH THE M:SI DCB, STRIPS
*        DELIMITERS FROM THE RIGHT SIDE, FINDS THE LAST SIGNIFICANT
*        CHARACTER IN THE MESSAGE, AND RETURNS TO THE CALLING ROUTINE
*        WITH A POINTER TO THE RIGHTMOST SIGNIFICANT CHARACTER. IF
*        ANY READ ERRORS ARE DETECTED, THE MONITOR HANDLES THOSE
*        WITH A SEVERITY >= X'40' (WHICH RESULTS IN AN ERROR MESSAGE
*        AND JOB STEP ABORT). 'READSI' HANDLES ABN CODE X'07' (BUFFER
*        SPECIFIED SMALLER THAN STRING READ) AND CALLS 'ABNXX' TO
*        HANDLE AND RECOVER FROM OTHER ABNORMAL CONDITIONS. RETURN
*        FROM 'ABNXX' IS NOT THROUGH 'READSI'.
*
*        NOTE1:   REGISTER USE IS AS FOLLOWS:
*
*        ENTRY             INTERNAL            EXIT
*        -----             --------            ----
*        SR1=BUF SIZE      R1=WORK             SR1=PTR TO LAST BYTE
*            IN BYTES      R0,R2-R7,D1-D4      R1,SR2-SR4 VOLATILE
*        SR2=ADR OF BUF    PRESERVED           R0,R2-R7,D1-D4 PRESERVED
*        SR4=LINK REG                          I/O ERR DESTROYS R7
*
*
*  14.1  READ AN INPUT LINE
*
READSI,14READ EQU %                 ENTRY POINT FOR READSI
         TRACE%   '2'               '2'= TRACE SUB-CODE FOR 'READSI'
         LCI      4                 PREPARE TO STORE STD REGS
         STM,SR1  READREGS          STORE THEM UNTIL I/O RETURN
         LW,R1    JOBX              IF GHOST DO KEYIN FOR READ
         BDR,R1   14READ1
         CAL1,2   KEYIN             DO THE KEYIN CAL
         LC       KEYIN+5           IS IT DONE
         BCS,8    %-1
         LB,R1    *SR2              GET BYTE COUNT
         LI,SR4   ' '               BLANK FOR LAST+1 CHAR
         LW,SR3   SR4               SAVE PREV (NEXT) CHAR
         LB,SR4   *SR2,R1           GET NOW
         STB,SR3  *SR2,R1           STORE NEXT ON ITS OLD PLACE
         BDR,R1   %-3               LOOP
         LB,R1    *SR2
         STB,SR4  *SR2              PUT AWAY THE LAST (FIRST) ONE
         B        14READ3
14READ1,RDSIFPT M:READ M:SI,(BUF,*SR2),(SIZE,*SR1),(ABN,14READ6)  ****
14READ2  LI,R1    3             <<  COMPARE ASN CODE 3(DEV) TO DCB TYPE
         CS,R1    M:SI              FILE, TAPE OR DEVICE?
         BE       %+3             ->FILE/TAPE==>USE RWS FIELD. BYTE
*                                   COUNT MAY BE > ARS FLD LENGTH.
         LW,R1    M:SI+13           RSW
         B        14READ3         ->
         LH,R1    M:SI+4            DEVICE DCB. BYTE CNT OK FROM ARS
         SLS,R1   -1                RIGHT-JUSTIFY ARS
14READ3  AI,R1    -1            <-  DECREMENT BYTE COUNT INDEX
         BLZ      14READ4         ->IF NO SIGNIFICANT CHARS LEFT, RETURN
         LB,SR1   *SR2,R1           GET NEXT CHAR
         CI,SR1   X'40'             ANYTHING > X'40' = DELIMITER
         BL       14READ5         ->STRIP DELIMITER
         BE       14READ3         ->IGNORE BLANK; GET NEXT
*                                   BUFFER,R1 POINTS TO RIGHTMOST
*                                   NON-BLANK, NON-DELIMITER CHAR
14READ4  LW,SR1   R1            <-  BYTE INDEX--->STD REG
         LW,SR3   READREGS+2        GET INPUT SR3;PRESCAN DESIRED?
         BEZ      %+3             ->  NO-RETURN
         AI,SR1   1                 CRANK TO BYTE COUNT
         BAL,SR4  PRESCAN         >>  YES-COMPRESS INPUT CMD
         B        *READREGS+3   <<>>RETURN
*
14READ5  LI,SR1   C' '          <-  GET BLANK
         STB,SR1  *SR2,R1           STORE OVER OLD CHAR
         B        14READ3         ->LOOK AT ANOTHER BYTE
*
14READ6  EQU      %             <-  ERROR RETURN FROM M:READ
         LB,R1    SR3               GET ABN CODE FROM STD REG (DCB ADR
*                                   IN BYTES 2-3; SUB-CODE IN BITS 8-14)
         CI,R1    X'06'
         BE       14ERR
*
         CI,R1    X'07'             X'07'==>DATA HAS BEEN LOST BECAUSE
*                                   BUFFER WAS SMALLER THAN RECORD READ.
         BE       14READ2         ->IT'S OK; READ THE MESSAGE; BUF
*                                   WAS ADEQUATE FOR VALID MESSAGE.
         CI,R1    X'1C'             WAS IT END-OF-VOLUME?
         BNE      ABNSI           >>  NO-LET ABN I/O HANDLER
*                                   CLEAN UP; CLOSE DCB'S AND RE-OPEN
*                                   TO DEFAULT OP-LABELS; SAVE R11
*                                   FOR ERROR PRINT-OUT.
         M:CVOL   M:SI            **  YES-CLOSE THIS REEL AND GET NXT
         LCI      4             **  PREPARE TO RESTORE STD REGS
         LM,SR1   READREGS          RESTORE THEM
         B        14READ1         ->ATTEMPT READ AGAIN
*
14ERR    EQU      %
         TYPE     'JCL CMND RECVD OR EOF ENCOUNTERED'
         M:ERR
*
         PAGE
*
*  14.2  'PRESCAN' - SCANS THE INPUT STRING POINTED TO BY THE STANDARD
*                    CALLING REGISTERS SR1-SR2 AND PERFORMS 3 FUNC-
*                 TIONS:
*
*        1.       LEFT-JUSTIFIES THE INPUT STRING IN THE INDICATED
*                 BUFFER.
*        2.       COMPRESSES MULTI-BLANK FIELD DELIMITERS TO 1 BLANK.
*        3.       ACCEPTS AS AN ARGUMENT A TEXTC STRING OF DELIMITERS
*                 AND ELIMINATES BLANKS BETWEEN THESE DELIMITERS (IF
*                 ANY EXIST IN THE INPUT STRING) AND THE PREVIOUS AND
*                 FOLLOWING NON-BLANK FIELDS.
*
*
*        NOTE2: REGISTER USE IS AS FOLLOWS:
*
*        ENTRY              INTERNAL             EXIT
*        -----              --------             ----
*        SR1=BUF BYTE SZ    R0=WORK              SR1=INDEX TO LAST BYTE
*        SR2=BUF WA         R1=DESTNAT'N INDX    R0-R7,SR1-SR4,D1-D4
*        SR3=WA(TEXTC TBL)  R2=SOURCE CHAR       PRESERVED
*        SR4=RTN LINK       R3=SOURCE INDX
*                           R4=DELIM;BLANK
*                           R5=DELIM CNT
*                           R6=PREVIOUS DELIM FLAG
*                           SR1=BYTE INDX TO LAST CHAR IN BUF
*                           SR2=WA(BUF)
*                           SR3=WA(TEXTC DELIM TBL)
*
*
PRESCAN,14RD10 EQU %                E.P. TO SCAN AND COMPRESS REDUNDANT
*                                   BLANKS IN AN INPUT LINE.
         LCI      7             <<
         PSM,R0   *SPDADR           PUSH R0-R6
         LI,R1    0                 INITIALIZE DESTINATION BYT INDX
         LI,R3    -1                INITIALIZE SOURCE BYTE INDEX
*                                   LEFT-JUSTIFY INPUT LINE
14RD12   AI,R3    1             <-  INCREMENT SOURCE BYTE INDX
         CW,R3    SR1               HAVE ALL BYTES BEEN EXAMINED?
         BGE      14RD24          ->  YES-PREPARE FOR RETURN
         LB,R2    *SR2,R3           GET NEXT SOURCE BYTE
         CI,R2    X'40'             IS IT A BLANK?
         BE       14RD12          ->  YES-GET NEXT
14RD14   EQU      %                   NO-FIRST NON-BLANK BUF CHAR FOUND;
*                                   PACK FIELDS.
         LI,R6    0             <-  RESET PREVIOUS DELIMITER FLAG
14RD16   STB,R2   *SR2,R1       <-  STORE SOURCE BYTE AT DESTINATION
         AI,R1    1                 INCREMENT DEST BYTE INDX
         AI,R3    1                 INCREMENT SOURCE BYTE INDX
         CW,R3    SR1               HAVE ALL BYTES BEEN EXAMINED?
         BGE      14RD24          ->  YES-PREPARE FOR RETURN
         LB,R2    *SR2,R3             NO-GET NEXT SOURCE BYTE
         CI,R2    X'40'             IS IT A BLANK?
         BNE      14RD16          ->  NO-TRANSFER IT TO DESTINATION
*                                     YES-FIND NEXT NON-BLANK
14RD18   AI,R3    1             <-  INCREMENT SOURCE BYTE INDEX
         CW,R3    SR1               HAVE ALL BYTES BEEN EXAMINED?
         BGE      14RD24          ->  YES-PREPARE FOR RETURN
         LB,R2    *SR2,R3           GET NEXT SOURCE BYTE
         CI,R2    X'40'             IS IT A BLANK?
         BE       14RD18              YES-GET NEXT
         LB,R5    *SR3                NO-GET DELIM CNT; IS IT ZERO?
         BEZ      14RD21              YES-DON'T LOOK FOR DELIMS
14RD20   LB,R4    *SR3,R5       <-    NO-GET NEXT DELIM
         CW,R2    R4                DOES SOURCE BYTE=DELIM?
         BE       14RD22          ->  YES
         BDR,R5   14RD20          ->  NO-COMPARE ON NEXT DELIM
14RD21   EQU      %             <-  NONE LEFT;BYTE NOT DELIM
         CI,R6    1                 IS PREVIOUS DELIM FLAG SET?
         BE       14RD14          ->  YES-TRANSFER BYTE TO DEST
         LI,R4    X'40'               NO-INSERT FIELD DELIMITER
         STB,R4   *SR2,R1           STORE BLANK
         AI,R1    1                 INCREMENT DEST INDEX
         B        14RD14          >>TRANSFER SOURCE BYTE TO DEST BYTE
14RD22   EQU      %                 BYTE=DELIM
         LI,R6    1             <-  SET PREVIOUS DELIM FLAG
         B        14RD16          ->TRANSFER SOURCE BYTE TO DEST
14RD24   EQU      %                 ALL DONE
         LW,R4    SR1               LENGTH OF INPUT STRING
         SW,R4    R1                COMPUTE NO. BLANKS COMPRESSED
         BEZ      14RD25            NONE
         LW,R2    SR1
         LI,R3    X'40'
         AI,R2    -1                DECREMENT INDEX
         STB,R3   *SR2,R2           BLANK EXTRANEOUS CHARS
         BDR,R4   %-2
14RD25   EQU      %
         AI,R1    -1            <-  DECREMENT DEST INDEX;POINTS
*                                   TO LAST BYTE IN INPUT LINE.
         LW,SR1   R1                GET PTR TO LAST BYTE IN SR1
         LCI      7
         PLM,R0   *SPDADR           PULL R0-R6
         B        *SR4              >>RETURN
*
         PAGE
*
******************************************************************
*  15.   'SAD' - SEARCH AND DELETE NUMBER FROM FI/FO BYTE STACK  *
******************************************************************
*
*
*  DESCRIPTION:   'SAD' IS A SUBROUTINE WHICH RECEIVES AS ARGUMENTS
*                 THE WORD ADDRESS OF A BYTE TABLE AND ANUMBER < 255
*        (USUALLY AN INDEX INTO ANOTHER TABLE) AND SEARCHES THE TABLE
*        FOR THAT NUMBER. IF THE NUMBER IS NOT FOUND, NO ACTION IS
*        TAKEN AND RETURN IS TO THE CALLING LOCATION PLUS ONE. IF THE
*        NUMBER IS FOUND, IT IS DELETED FROM THE TABLE AND ENTRIES WITH
*        HIGHER ADDRESSES ARE MOVED DOWN ONE BYTE EACH. A VALUE OF 0
*        IN A BYTE SIGNALS THE END OF THE TABLE.
*
*                 REGARDLESS OF WHETHER THE NUMBER IS FOUND OR NOT,
*        THE BYTE INDEX OF THE ZERO MARKING THE END-OF-TABLE IS RETURNED
*        TO THE CALLING ROUTINE.
*
*
*                 FOR GERM ITEMS,THE ABOVE WORDING IS APPLICABLE WHEN
*        'BYTE' IS REPLACED BY 'WORD' AND THE NUMBER CAN BE AS
*        LARGE AS 330.
*
*
*        NOTE1:   REGISTER USE IS AS FOLLOWS:
*
*        ENTRY             INTERNAL           EXIT
*        -----             --------           ----
*        SR2=TBL ADR       R0=TRACE CODE      SR2=BYT INDX TO 0 INTBL
*        SR3=NUMBER        R1-R2=INDEX REGS   R0,SR4 VOLATILE
*        (SR4)=ERR RTN     R3=TBL # BUF       R1-R7,SR1,SR3,D1-D4 PRE-
*        (SR4+1)=RTN LINK  R4=INDEX REG    SERVED
*
*
SAD,15SAD1 EQU    %                 E.P. TO SEARCH A FIRST IN/FIRST OUT
*                                   BYTE STACK AND DELETE A NUMBER,
*                                   IF FOUND.
         LCI      4                 PREPARE TO PUSH
         PSM,R1   *SPDADR           SAVE REGS R1-R3
         LW,R4    GERMWORD
         BEZ      %+2               FOR NON-GERM OR RSRCE FROM PART
         LI,R4    1                 INDICATE GERM ITEM
         LI,R1    -1                GET STARTING BYTE INDEX
15SAD2   AI,R1    1             <-  INCREMENT TBL BYTE INDX
         EXU      15SEEG1,R4        GET BYTE/WD FROM TBL;END OF TBL
         BEZ      15SAD5          ->  YES-EXIT;NUMBER NOT FOUND
         CW,R3    SR3                 NO-IS BYTE=#?
         BNE      15SAD2          ->  NO-GET NEXT BYTE
*                                     YES-MOVE HIGHER BYTES DOWN
         LW,R2    R1                INITIALIZE HIGHER BYTE INDX
15SAD3   AI,R2    1                 INCREMENT HIGH BYTE INDX
         EXU      15SEEG2,R4        GET NXT HIGH BYTE/WD;IS IT 0
         BEZ      15SAD4            ->  YES-DONE
         EXU      15SEEG3,R4        N0--STORE IN LOW BYTE /WORD
         AI,R1    1                 INCREMENT LOW BYTE INDX
         B        15SAD3          ->DO NEXT BYTE PAIR
15SAD4   EQU      %                 NUMBER FOUND AND TRANSFER DONE
         EXU      15SEEG3,R4        STORE 0 IN LST TBL BYTE/WD
         AI,SR4   1                 INCREMENT RTN ADR
15SAD5   EQU      %                 PULL REGS AND RETURN
         LW,SR2   R1                GET BYTE INDX TO LAST BYT IN TBL
         LCI      4
         PLM,R1   *SPDADR
         B        *SR4            >>RETURN
*
15SEEG1  LB,R3    *SR2,R1
         LW,R3    *SR2,R1
*
15SEEG2  LB,R3    *SR2,R2
         LW,R3    *SR2,R2
*
15SEEG3  STB,R3   *SR2,R1
         STW,R3   *SR2,R1
*
         PAGE
*
**************************************************************
*  16.   'ITEMFIND' - FIND ENTRY NUMBER OF ITEM IN DW TABLE  *
**************************************************************
*
*
*  DESCRIPTION:   'ITEMFIND' RECEIVES AS ARGUMENTS: THE ADDRESS OF A
*                 DOUBLEWORD TABLE CONTAINING EBCDIC ITEM NAME ENTRIES,
*        THE NUMBER OF ITEMS IN THE TABLE, THE BYTE ADDRESS OF AN EBCDIC
*        STRING WHICH IS TO BE COMPARED TO THE TABLE ENTRIES, AND A
*        COUNT OF THE NUMBER OF CHARACTERS IN THE STRING. 'ITEMFIND'
*        RETURNS THE ENTRY NUMBER OF THE COMPARABLE ITEM IN THE TABLE
*        (IF FOUND). IF THE ITEM IS NOT FOUND, AN ERROR RETURN IS MADE.
*
*
*  FUNCTION:      ALL WORKING REGISTERS ARE SAVED AND RESTORED IN THIS
*                 ROUTINE SO CALLING PROGRAM DOES NOT HAVE TO WORRY
*        ABOUT CLOBBERED DATA. ON ENTRY, AN MBS IS SET UP TO TRANSFER
*        THE USER INPUT STRING TO A BLANK-FILLED BUFFER. A COMPARE
*        DOUBLE WAS CHOSEN OVER A FLOATING CBS BECAUSE THE COMPARE
*        MUST BE DONE ON THE NUMBER OF CHARACTERS IN THE TABLE ENTRY,
*        NOT ON THE NUMBER OF CHARACTERS INPUT BY THE USER. IT IS
*        EASIER TO COMPARE ON A BLANK-FILLED BUFFER THAN TO CHANGE
*        'X' TABLES TO TEXTC FORMAT AND THE CODE TO ACCOMODATE THEM.
*        SUCCESSIVE COMPARE DOUBLES ARE EXECUTED UNTIL THE ITEM IS
*        FOUND IN THE TABLE OR THE TABLE IS EXHAUSTED. IF NO COMPARE
*        WAS EFFECTED, RETURN IS MADE TO THE INSTRUCTION FOLLOWING THE
*        MAIN ROUTINE'S CALL. IF A COMPARE WAS MADE, SR3 IS LOADED
*        WITH THE ENTRY NUMBER AND RETURN IS MADE TO THE SECOND IN-
*        STRUCTION FOLLOWING THE MAIN ROUTINE'S CALL.
*
         PAGE
*
*
*        NOTE1:   REGISTER USE IS AS FOLLOWS:
*
*        ENTRY             INTERNAL              EXIT
*        -----             --------              ----
*        SR1=# ENTRIES IN  R1=TABLE INDEX        SR3=ENTRY # IN TBL
*            TBL (BYT 0);  R4-R5=MBS REGS        (SR4)=FAIL RTN ADR
*            TBL ADR       R6-R7=DW ITEM BUF     (SR4)+1=ITEM FOUND RTN
*        SR2=BYT CNT(BYT0);                      R0-R7,SR1-SR2,D1-D4
*            STR ADR                             PRESERVED
*        SR4=RETURN LINK
*
*
ITEMFIND,16IF1 EQU %                E.P. TO FIND ITEM IN DW TABLE
         CK%TRACE '7'           <<  '7' IS TRACE SUB-CODE FOR 'ITEMFIND'
         LCI      10                PREPARE TO SAVE R0-SR2
         PSM,R0   *SPDADR           PUSH THEM
*                                   SET UP REGS FOR MBS
         LD,R6    DWBLANKS          BLANK ITEMFIND NAME COMPARE DW BUF
         LB,R4    SR2               GET ITEM STRING BYTE COUNT
         CI,R4    8                 CAN NOT AFFORD TO
         BLE      %+2                CLOBBER SR1
         LI,R4    8
         LI,R5    4*R6              GET BA(MBS DESTINATION)
         STB,R4   R5                STORE THE MOVE BYTE COUNT
         LW,R4    SR2               GET THE BA(SOURCE STRING)
         AND,R4   =X'7FFFF'         MASK THE BA
         MBS,R4   0                 MOVE SIGNIFICANT BYTES OF ITEM
*                                   NAME TO BLANKED COMPARE BUFFER..
*                                   COMPARE LOOP
         LB,R1    SR1               GET NUMBER OF TABLE ENTRIES
16IF2    CD,R6    *SR1,R1       <-  IS ITEM NAME=TBL ENTRY?
         BE       16IF3           ->  YES-RETURN WITH SR3=INDEX
         BDR,R1   16IF2           ->  NO-TBL SEARCH DONE?
         B        16IF4           ->  YES-RETURN;NO COMPARE
16IF3    EQU      %                 ITEM FOUND INTABLE
         LW,SR3   R1            <-  GET TABLE ENTRY #
         AI,SR4   1                 INCREMENT RETURN LINK
16IF4    LCI      10            <-  PREPARE TO RESTORE R0-SR2
         PLM,R0   *SPDADR           RESTORE REGISTERS
         B        *SR4            >>RETURN
*
         PAGE
*
******************************************
*  17.   'OPENDCB' - OPEN SPECIFIED DCB  *
******************************************
*
*
*        NOTE1:   REGISTER CONVENTIONS ARE AS FOLLOWS:
*
*                 SR1=DCB ADDRESS
*                 SR2=EBCDIC OP-LABEL RIGHT-JUSTIFIED IN DATA WORD
*                 SR3=ABNORMAL RETURN ADDRESS
*                 SR4=LINK REGISTER
*
*
OPENDCB,17OPEN EQU %            <<
         M:OPEN   *SR1,(DEVICE,*SR2),(ABN,*SR3) **OPEN  SPECIFIED
*                                                  DCB TO DEVICE W/ABN
         B        *SR4          **>>RETURN TO CALLING PROGRAM
*
         PAGE
*
***************************************************************
*  18.   'SETDCB' - SET ABN RETURN ADDRESS FOR SPECIFIED DCB  *
***************************************************************
*
*
*        NOTE1:   REGISTER CONVENTIONS ARE AS FOLLOWS:
*
*        SR1=DCB ADDRESS
*        SR3=ABNORMAL RETURN ADDRESS
*        SR4=LINK REGISTER
*
*
SETDCB,18SET EQU  %             <<  SET ABNORMAL RETURN ADDRESS
         M:SETDCB *SR1,(ABN,*SR3)  ** >>
         B        *SR4          **>>
         PAGE
*
*********************************************************
*  18.1  'OCTOLP,LPTOOC' - SWITCH LO OUTPUT FOR GHOSTS  *
*********************************************************
*
*
*        NOTE:    REGISTERS
*        R7=LINK
*
*        R1,SR1,SR2,SR3,SR4 VOLATILE
*
*
OCTOLP   LI,SR2   'LP'
         B        %+2
LPTOOC   LI,SR2   'OC'
         LW,SR1   JOBX              ONLY DO IT FOR GHOSTS
         BDR,SR1  0,R7
         LI,SR1   M:LO
         LW,SR3   M:LO+4
         BAL,SR4  CLOSE
         BAL,SR4  OPENDCB
         CI,SR2   'OC'              IF GOING TO OC, SUPCLS
         BNE      0,7
         CAL1,9   6
         B        0,7
         PAGE
*
***************************************
*  19.   'CLOSE' - CLOSE DCB IF OPEN  *
***************************************
*
*
*  DESCRIPTION:   'CLOSE' TESTS THE FCD BIT IN WORD 0 OF THE DCB (1==>
*                 OPENED, 0==>CLOSED). IF THE DCB IS CLOSED, NO ACTION
*        IS TAKEN, BUT IF IT IS OPEN, M:CLOSE IS CALLED.
*
*
*        NOTE1:   REGISTER USE IS AS FOLLOWS:
*
*        ENTRY              INTERNAL             EXIT
*        -----              --------             ----
*        SR1=DCB ADDRESS    R1=WORK              R0,R2-D4 PRESERVED
*        SR4=RETURN LINK                         R1 VOLATILE
*
*
CLOSE,19CLOSE EQU %                 UNIQUE ENTRY POINT FOR CLOSE
         LW,R1    L(X'00200000') << GET MASK FOR FCD BIT IN DCB WD 0
         CS,R1    *SR1              IS DCB OPEN?
         BNE      %+2             ->  NO-SKIP CLOSE
         M:CLOSE  *SR1,(SAVE)     **  YES-CLOSE DCB AND SAVE I/O
         B        *SR4          **>>RETURN
*
         PAGE
*
*************************************************
*  20.   'ABNXX' - I/O ABNORMAL RETURN HANDLER  *
*************************************************
*
*
*  DESCRIPTION:   ERROR RETURNS FROM I/O CALLS ARE DIFFICULT TO HANDLE
*                 AND, THEREFORE, ONLY ABNORMAL RETURNS (ERROR CODE
*        <=X'2E') ARE HANDLED. IT IS THE RESPONSIBILITY OF THE CALLING
*        PROGRAM TO HANDLE ANY SPECIAL ERROR CODE BEFORE CONTROL IS
*        PASSED TO THIS ROUTINE BECAUSE ALL THE DCB'S WHICH ARE OPEN
*        ARE GOING TO BE CLOSED HERE AND FILE POSITIONING, ETC WILL BE
*        LOST. 'ABNXX' ACCEPTS A DCB ADDRESS, ERROR CODE, AND SUB-CODE
*        AS ARGUMENTS AND IN ALL CASES AN APPROPRIATE ERROR MESSAGE
*        CORRESPONDING TO THE ERROR CODE IS SENT TO THE M:DO DCB DEFAULT
*        DEVICE, ALL DCB'S ARE CLOSED AND RE-OPENED TO THEIR DEFAULT
*        DEVICES, AND RETURN IS EFFECTED TO THE CALLING ROUTINE.
*
*             IF ANY ABNORMAL OR ERROR CONDITION RESULTS FROM I/O CALLS
*        PERFORMED IN THIS ROUTINE, AN ERROR EXIT IS TAKEN WHICH DUMPS
*        ALL REGISTERS AND PERTINENT DATA AND TERMINATES EXECUTION.
*
*
*  FUNCTION:      MULTIPLE ENTRY POINTS INTO THE ROUTINE ARE PROVIDED
*                 CORRESPONDING TO EACH DCB SO THAT THE DCB THROUGH
*        WHICH THE ABN RETURN OCCURRED MAY BE IDENTIFIED. BREAK CONTROL
*        SHOULD HAVE BEEN RELINQUISHED IN THE READ/WRITE/OPEN ROUTINE
*        CAUSING THE ABNORMAL CONDITION, BUT IF NOT, UNPON ENTRY,
*        BREAK CONTROL IS GIVEN UP. ALL REGISTERS ARE PUSHED AND THE
*        ERROR MEESAGE FROM THE ERRMSGE FILE CORRESPONDING THE ABN
*        CODE/SUB-CODE IS READ INTO A BUFFER. THE ABN RETURN ON ALL
*        DCB'S IS SET TO THE CATASTROPHIC ABORT ROUTINE, 'ABNX', TO
*        GUARANTEE NON-REETRANCE OF THIS ROUTINE IN CASE OF I/O FAILURE
*        ON ERROR MESSAGE WRITES.
*
         PAGE
*
*                 A TEST IS MADE TO DETERMINE IF THE ERRORED DCB WAS
*        OPENED TO ITS DEFAULT OP-LABEL BY COMPARING THE DCT INDEX IN
*        THE OP-LABEL TABLES TO THE DCT INDEX IN THE DCB. IF THE TEST IS
*        FALSE, ALL DCB'S ARE CLOSED AND REOPENED TO THEIR OP-LABELS
*        AS DETERMINED BY THE 'CONTROL' INITIALIZATION ENTRY IN
*        DFLTXX AND AN ERROR MESSAGE IS PRINTED ON THE M:DO DEVICE.
*
*                 IF THE TEST IS TRUE, THEN ALL DCB'S ARE TESTED TO
*        FERRET OUT THE OFFENDING ONE. IF M:DO ERRORED, THEN CONTROL
*        IS CLOSED AND REOPENED TO DEFAULT, AND WILL OUTPUT THE ERROR
*        MESSAGE CONTROL WILL THEN BE TRANSFERRED TO 'ABNX'. THERE IS
*        NO USE CONTINUING SINCE THE USER CANNOT INPUT COMMANDS TO
*        CONTROL. IF THE DCB WAS M:LO, M:DO, IF OPENED TO OTHER THAN
*        THE DEFAULT OP-LABEL, IS CLOSED AND REOPENED TO THE DEFAULT
*        AND THE ERROR MESSAGE IS WRITTEN ON THE DO DEVICE AFTER
*        WHICH M:SI IS CLOSED AND REOPENED TO THE DEFAULT (IF NOT
*        ALREADY OPEN TO THE DEFAULT).
*
*                 IN ANY CASE, IF AN ERROR MESSAGE IS PRINTED (THAT IS,
*        IF CONTROL WAS NOT TRANSFERRED TO 'ABNX'), THE ABN RETURN IN
*        ALL DCB'S IS RESET TO THE ERROR HANDLER 'ABNXX', AND BREAK
*        CONTROL IS RELINQUISHED TO THE USER AFTER ALL REGISTERS ARE
*        PULLED.
*
*  ERROR MESSAGE FORMAT:
*
*        'I/O ERROR AT XXXXX THROUGH M:XX DCB'
*        'MESSAGE FROM ERRMSGE FILE CORRESPONDING TO ABN CODE'
*        'I/O SUBROUTINE CALL AT XXXXX'
*
         PAGE
*
*        NOTE1:   REGISTER PRESERVATION IS NOT PERTINENT AS ALL
*                 REGISTERS ARE PUSHED ON ENTRY. REGISTER USE IS AS
*                 FOLLOWS:
*
*        ENTRY               INTERNAL                EXIT
*        -----               --------                ----
*                          R0,R1=WORK              R0-R1 VOLATILE IF
*                          SR1-SR3=SUBR CALL REGS  STK NOT EMPTY ON
*                          SR4=BAL REG             ON PULL ALL.
*                            R3=MASK,R2=WORK,DCB ADR
*                            R4,D1=PARAM REGS
*                            R7=LINK TO SUBRS
*
*
ABNLO,20ABN EQU   %                 ENTRY POINT FOR M:LO ABNORMAL RTN
         MTW,1    DCBX          <<  SET DCBX TO 3 FOR LO
ABNSI    EQU      %                 ENTRY POINT FOR M:SI ABN RTN
         MTW,1    DCBX          <<  SET DCBX TO 2 FOR SI
ABNDO    EQU      %                 ENTRY POINT FOR M:DO ABN RTN
         MTW,1    DCBX          <<  SET DCBX TO 1 FOR DO
         GEN,8,4,12,8  X'02',3,0,X'F3'  ==>LCFI  X'F3'  (TRACE CODE)
         STCF     ICTRACE           STORE ABNXX TRACE WITHOUT REG
         M:INT    BREAK3          **SET BREAK DELAY IN CASE
*                                   I/O CALL ROUTINE DID NOT. STACK
*                                   COULD BE IN MESS IF USER GETS
*                                   CONTROL HERE.
         LCI      0             **  SET UP THE PUSH
         PSM,R0   *SPDADR           PUSH 16 INTO THE USER'S STACK
         STD,SR3  ECODE             SAVE ORIG I/O SUBR CALL ADR (SR4)
*                                   AND ERROR CODE (SR3)
         STW,R7   OUTPTR            SAVE I/O CAL ERR ADR (SR1) AND
         STW,SR1  CALPTR            ORIG OUTPUT SUBR CAL ADR (R7)
         LI,R2    M:XX              GET DCB ADR IN R2
         LI,R3    MBUF              GET ERR MESSAGE BUF ADR
         LI,R4    MBSZ              GET SIZE OF MBUF IN BYTES
         LH,D1    SR3               GET ERR CODE (BITS 0-7) & SUB-CODE
*                                   (BITS 8-14) FROM SR3.
         SLD,D1   -8                SHIFT 7-BIT SUB-CODE INTO D2
         SLS,D2   -1                SHIFT SUBCODE TO BYTE BOUNDARY
         SLD,D1   8                 SHIFT BACK SUB-CODE, RT- JUSTIFIED
         MTB,3    D1                SET KEY LENGTH
         BAL,SR4  ERRMSGE         >>READ ERROR MESSAGE INTO BUF
         STW,R4   MSZ           <<  R4=SIZE OF MESSAGE IN BYTES
*                 SET ABN TO CATASTROPHIC ABORT ADR (ABNX) FOR ALL DCB'S
         LBAL%,SR4  SETDCB,M:SI,,20ABNX  >>SET M:SI ABN RTN ADR
         LBAL%,SR4  SETDCB,M:DO,,20ABNX  <<>>SET M:DO ABN RTN ADR
         LBAL%,SR4  SETDCB,M:LO,,20ABNX  <<>>SET M:LO ABN RTN ADR
*
*        NOTE:    DETERMINE IF AN DCB WAS OPENED TO DEFAULT OP-LABEL/
*                 DEVICE (OPLBT2=TEMP ASSIGNMENT). IF NOT, CLOSE DCB
*                 AND OTHERS NOT OPENED TO DEFAULT LABELS AND RE-OPEN
*                 TO DEFAULTS. IF ERRORED DCB OPENED TO DEFAULT,
*                 DETERMINE WHICH DCB IT WAS.
*
*
         LW,SR1   DCBX              GET DCB INDEX
         LW,SR2   JOBX              GET JOB TYPE INDEX (1=GST,2=O/L,3=B)
         BAL,SR4  20ABN4          ->WAS OFFENDING DCB OPENED TO
*                                   DEFAULT LABEL?
         B        20ABN2        <-->  NO - DCB CLOSED & RE-OPENED
*                                     TO DEFAULT; NO I/O ERRORS.
*
*
*        THE ABOVE BRANCH WILL NOT BE EXECUTED(IT CANNOT BE TRUE),
*        BECAUSE, NOW IN 20ABN4,ALWAYS TRY TO RE-OPEN TO DEFAULT
*        OP-LABEL WITHOUT CHECKING IF ALREADY OPENED TO DEFAULT
*
***RISK OF LOOPING*****
*
         CI,SR1   1             <-    YES - NO ACTION TAKEN (SR1=DCBX)
*                                   WE'RE IN TROUBLE; RE-OPENING WON'T
*                                   DO MUCH GOOD.
*                                   WAS IT THE M:DO DCB?
         BE       20ABNX          ->  YES - NO HOPE; CAN'T EVEN WRITE
*                                   AN ERR MESSAGE TO DEFAULT DEVICE.
         LI,SR1   1                 CLOSE M:DO, IF OPEN, AND RE-OPEN
*                                   TO DEFAULT LABEL.
         BAL,SR4  20ABN4          ->WAS AN OPEN PERFORMED?
         NOP                    <-    YES - DCB CLOSED AND
*                                     RE-OPENED TO DEFAULT.
         LW,SR1   DCBX          <-    NO - NO ACTION TAKEN; M:DO IS SET
*                                   UP FOR ERR MSGE WRITE; GET DCBX
         CI,SR1   2                 WAS IT THE M:SI DCB?
         BNE      %+3             ->  NO - THEN IT WAS M:LO
         LI,R7    20ABNX              YES- @#%& NO HOPE; USER CAN'T
*                                   INPUT COMMANDS; SET ABORT EXIT
         B        20ABN1            OUTPUT ERR MSGE AND QUIT
*                                   FOR M:LO ABN RTN, OUTPUT ERR MSGE
*                                   & TRY TO RE-OPEN M:SI.
         BAL,R7   20ABN1          ->OUTPUT ERROR MESSAGE
*                                   GET M:SI DCB INDX & JOB TYPE INDX
         LBAL%,SR4  20ABN4,2,(W,JOBX)  <->>WAS DCB OPN TO TMP OPBLB?
         NOP                    <-    NO-DCB CLOSED & RE-OPENED
         B        20ABN8        <-    YES-NO ACTION; GO WIND UP SHOW
*
*                 OUTPUT ERROR MESSAGE - 1ST LINE (IT'S A BEAR)
*
20ABN1   EQU      %                 WRITE THE I/O ERR MSGE ON M:DO
         STW,R7   R7LINK        <-  SAVE CALLING RTN ADR
         LI,SR1   1                 # BLANKS TO BE APPENDED
         BAL,SR4  SPACE             PUT A BLANK IN THE BUFFER
         LBAL%,R7  23SEND1,M:DO,,20ABNX  >>OUTPUT A SPACE DOWN
         LI,SR3   IOERM1            GET ADR OF 1ST PART OF ERR MSGE
         BAL,R7   APEND           >>APPEND 'I/O ERROR AT  ' TO BUF
         LW,SR1   CALPTR        <<  GET ADR+1 OF OFFENDING CAL
         AI,SR1   -1                CORRECT THE ADDRESS
         BAL,SR4  HEXOUT          >>CONVERT ADR TO EBCDIC HEX INTEGER
         BAL,R7   APEND         <<>>SR3=ADR OF STRING IN TEXTC FORMAT
         LI,SR3   IOERM2        <<  GET ADR OF 3RD PART OF ERR MSGE
         BAL,R7   APEND           >>APPEND ' THROUGH M:' TO BUF
         LI,SR3   OPLB          <<  GET BASE OF DCB OP-LABEL TEXT TBL
         AW,SR3   DCBX              INDEX IT BY DCB TYPE
         BAL,R7   APEND           >>APPEND 'XX' TO MSGE INDICATING
*                                   ERRORED DCB TYPE.
         LI,SR3   IOERM3        <<  GET ADR OF NEXT PART OF ERR MSGE
         BAL,R7   APEND           >>APPEND ' DCB'
         LBAL%,R7  23SEND1,M:DO,,20ABNX  <<>>OUTPUT 'I/O ERROR AT XXXXX
*                                   THROUGH M:XX DCB'
*                 OUTPUT 2ND LINE OF ERROR MESSAGE
*
         LW,SR4   MSZ           <<  GET MESSAGE LENGTH IN BYTES
         LBAL%,R7  BOUTX,,0,BA(MBUF)  >>STORE MON I/O ERR MSGE IN BUF
         LBAL%,R7  23SEND1,M:DO,,20ABNX  <<>>OUTPUT ERRMSG FILE MSGE
*
*                 OUTPUT 3RD LINE OF ERROR MESSAGE - ADR OF SUBROUTINE
*                 WHICH CALLED THE I/O ROUTINE WHICH PRODUCED ERROR
*
         LI,SR3   IOERM4        <<  GET ADR OF NEXT MSGE
         BAL,R7   APEND           >>APPEND 'I/O SUBROUTINE CALL AT  '
         LW,R1    DCBX          <<  GET OFFENDING DCB INDEX
         CI,R1    2                 IS IT M:SI (INPUT) DCB?
         BE       %+3             ->  YES - GET INPUT SUBR LINK ADR - SR4
         LW,SR1   OUTPTR              NO - GET BAL REG CONTENTS TO
*                                   OUTPUT CAL ROUTINE-1 (R7)
         B        %+2             ->SKIP INPUT ADR FETCH
         LW,SR1   INPTR         <-  GET (INPUT SUBR CALL ADR)-1
         AI,SR1   -1            <-  CORRECT THE ADR ; POINTS TO
*                                   BAL ADR OF CALLING I/O ROUTINE.
         BAL,SR4  HEXOUT          >>CONVERT ADR TO EBCDIC HEX INTEGER
         BAL,R7   APEND         <<>>SR3=ADR OF TEXTC STR; APPEND TO BUF
         LBAL%,R7  23SEND1,M:DO,,20ABNX  <<>>OUTPUT
*                                   'I/O SUBROUTINE CALL AT XXXXX'
*                 OUTPUT A LINE OF BLANKS FOR SPACING
         LI,SR1   1             <<  # BLANKS TO PLACE IN BUF
         BAL,SR4  SPACE             INSERT BLANK IN BUFFER
         LBAL%,R7  23SEND1,M:DO,,20ABNX  <<>>OUTPUT A SPACE DOWN
*                 DONE WITH MESSAGE
         B        *R7LINK       <<>>RETURN
20ABN2   EQU      %             <-  OFFENDING DCB WAS OPEN TO AN
*                                   OP-LABEL OTHER THAN ITS DEFAULT; DCB
*                                   HAS BEEN CLOSED AND RE-OPENED TO
*                                   DEFAULT; FIND OTHER DCB'S WHICH MAY
*                                   NOT BE OPENED TO THE TEMPORARY
*                                   (STDLBL) ASSIGNMENT DEVICE AND RE-
*                                   OPEN THEM TO IT.
*                                   SR1=DCB INDEX; SR2=JOB TYPE INDEX
         LI,SR1   3                 REOPEN ALL OTHER DCBS
20ABN3   EQU      %                 TO THEIR DEFAULTS
         BAL,SR4  20ABN4        <-->TEST. IS DCB OPEN TO DEFAULT?
         NOP                    <-    NO-DCB CLOSED & RE-OPENED
         BDR,SR1  20ABN3        <-->  YES-NO ACTION;ALLDONE
*                                     NO-TEST REMAINING DCB
         BAL,R7   20ABN1          ->  YES-GO PRINT ERR MSGE
         B        20ABN8        <-->HOME SAFE; GO WIND UP SHOW
*
20ABN4   EQU      %   <-SUBROUTINE CHECKS IF DCB IS ASSIGNED TO
*                       THE SAME DEVICE TYPE AS ITS OPLBL
*                       DEFAULT (IN OPLBT2 OR -5). IF NOT, DCB IS CLOSED
*                       (IF OPEN) AND RE-OPENED TO A DEFAULT OP-LABEL
*                       SPECIFIED IN TABLE DFLTXX WHERE XX=SI,DO,OR LO,
*                       AND CONTROL IS TRANSFERRED TO (SR4). IF ASSIGN-
*                       MENT IS TO TEMPORARY DEVICE, NO ACTION IS TAKEN
*                       AND CONTROL IS TRANSFERRED TO (SR4)+1.
*                       PRESERVED=SR1,SR2; VOLATILE=R1-R4
*                       SR1=DCB INDEX; SR2=JOB TYPE INDEX
*
*
*
*FOR NOW,ALWAYS RE-OPEN TO DEFAULT OP-LABEL WITHOUT CHECKING
*IF ALREADY OPENED TO DEFAULT OP-LABEL
*
***MIGHT HAVE ADVERSE EFFECTS***
*
*
20ABN7   EQU      %                   NO-GET SET FOR A PUSH
         LCI      4             <-  ENTRY FOR CLOSE AND RE-OPEN OF DCB
         PSM,SR1  *SPDADR           PUSH ALL SRX REGS UNTIL OPN &CLS DN
         LW,R3    SR1               GET DCBX IN AN INDEX REG
         LW,SR1   XXADR,R3          GET DCB ADR FOR NEXT 2 CALLS
         BAL,SR4  CLOSE           >>CLOSE IT IF YOU CAN
         LW,SR2   DFLTXX,R3     <<  GET DFLTXX TABLE ADR
*                                   IN INITIALIZATION, WD 0 OF M:XX
*                                   DEFAULT TABLE SET WITH DEFAULT OP-
*                                   LABEL FOR THIS JOB TYPE.
         LW,SR2   *SR2              GET DEFAULT OP-LABEL FOR THIS DCB
         LBAL%,SR4  OPENDCB,,,20ABNX  >>RE-OPEN DCB TO DEFAULT OPLBL
         LCI      4             <<  SUCCESSFUL RTN; GET REGS
         PLM,SR1  *SPDADR           PULL THEM OUT
         B        *SR4            >>RETURN
*
*                 SUCCESSFUL EXIT FROM ERROR RECOVERY ROUTINE
*
20ABN8   EQU      %                 IT'S ALL OVER BUT THE SHOUTING;
*                                   WE'VE DECIDED TO STAY
         LBAL%,SR4  SETDCB,M:DO,,ABNDO  <->>SET ABN RTN TO HANDLER
         LBAL%,SR4  SETDCB,M:SI,,ABNSI  <<>>RESET ABN RTN IN DCB
         LBAL%,SR4  SETDCB,M:LO,,ABNLO  <<>>RESET ABN RTN TO HANDLER
         BAL,SR4  SPACE             PUT A BLANK IN THE BUFFER
*                       ERY ROUTINE; ALL DCB'S NOW OPEN TO STANDARD
*                       SET OF DEFAULT OP-LABELS; USER CAN COMMUNICATE
*                       WITH 'CONTROL'.
*
         LI,R0    0             <<
         STW,R0   DCBX              RESET DCB INDEX TO 0
         MTW,0    PEXEC             IS 'PART' EXECUTION FLG SET?
         BLEZ     20ABN9          ->  NO-DON'T RESET 'PART' STACK
         LI,R1    X'7FFF'             YES-GET MASK FOR STACK WD CNT
         LS,R1    SPD+1             GET WORD COUNT
         LCW,R1   R1                MAKE IT NEGATIVE
         MSP,R1   SPD               ZAP PUSHED REGS IN 'PART'
         BAL,SR4  ZEROUT          >>RELEASE PART DEF STACK VIRTUAL
*                                   PAGES IF ALLOCATED.
         LI,R0    0             <<  DISCONTINUE PARTITION CONTROL
         STW,R0   PEXEC             EXECUTION STATUS.
20ABN9   LCI      0             <-  PULL ALL REGISTERS
         PLM,R0   *SPDADR
         BSE      20ABN10         ->IF STACK EMPTY,SKIP MSP
         LI,R0    X'7FFF'           MASK FOR WD CNT IN STACK
         LI,R1    1                 2ND WORD OF SPDWD
         AND,R0   *SPDADR,R1        GET WORD COUNT
         LCW,R1   R0                COMPLEMENTIT
         MSP,R1   *SPDADR           ZAP PUSHED ENVIRONMENT IN TCB STACK
20ABN10  BAL,SR4  BREAK5          >>CHECK FOR DELAYED BREAK
         B        10IN11        <<>>GO TYPE 'CONTROL HERE'; RESTART
*
20ABNX   EQU      %             <-  CATASTROPHIC ABORT ON 2ND ABN RTN
         LW,R1    *SPDADR           GET USER'S TEMP STACK SPD ADR
         M:SNAP   'STACK',(*SPDADR,*R1)     **SNAP ALL USEFUL PARAMETERS
         M:SNAP   'M:SI',(M:SI,M:SI+20)  ****
         M:SNAP   'M:DO',(M:DO,M:DO+20)  ****
         M:SNAP   'M:LO',(M:LO,M:LO+20)  ****
         M:SNAP   'DATAREA',(CS:CONSUB:DATA,CSEND:CONSUB:DATA)  ****
         LCI      0             **  PULL ALL REGS
         PLM,R0   *SPDADR
         M:XXX                    **GO HOME WITH TAIL BETWEEN LEGS
*
         PAGE
*
************************************************************************
*  21.   'HEXOUT', 'OCTOUT', & 'DECOUT' - BINARY TO EBCDIC CONVERSION  *
************************************************************************
*
*
*  DESCRIPTION:   'HEXOUT' ACCEPTS AS AN ARGUMENT A BINARY NUMBER AND,
*                 AFTER CONVERTING IT TO A BASE 16 EBCDIC INTEGER,
*        STORES IT IN A BUFFER IN TEXTC FORMAT (BYTE0=BYTE COUNT OF
*        STRING) AND COMMUNICATES THE BUFFER ADDRESS TO THE CALLING
*        PROGRAM.
*
*                 'DECOUT' PERFORMS THE SAME FUNCTIONS AS 'HEXOUT'
*        EXCEPT THAT THE NUMBER IS CONVERTED TO A BASE 10 INTEGER.
*
*                 'OCTOUT' PERFORMS THE SAME FUNCTIONS AS 'HEXOUT'
*        EXCEPT THAT THE NUMBER IS CONVERTED TO A BASE 8 INTEGER.
*
*
*  FUNCTION:      THE DIVISOR IS SET TO 8,10, OR 16, DEPENDING WHICH
*                 ROUTINE WAS CALLED, AND THE BUFFER LENGTH IN BYTES
*        IS LOADED TO BE USED AS AN INDEX TO THE NEXT (INITIALLY
*        LAST) BYTE OF THE EBCDIC OUTPUT STRIING. THE NUMBER IS INITI-
*        ALLY DIVIDED BY THE BASE TO OBTAIN A QUOTIENT AND A REMAINDER.
*        THE REMAINDER IS THE NUMBER OF UUNITS OF 16**0 (1) PRESENT
*        IN THE NUMBER. THIS REMAINDER IS CONVERTED TO AN EBCDIC INTEGER
*        AND STORED IN THE '1'S POSITION OF THE EBCDIC OUTPUT BUFFER.
*        THE QUOTIENT IS TREATED AS THE DIVIDEND AND IS DIVIDED AGAIN
*        BY THE BASE TO OBTAIN THE NUMBER OF '16'S, AND SO ON. WHEN
*        THE QUOTIENT BECOMES 0, THE ENTIRE NUMBER HAS BEEN CONVERTED
*        AND THE NUMBER OB EBCDIC CHARACTERS IN THE NUMBER IS STORED
*        IN THE FIRST BYTE OF THE BUFFER. FINALLY, THE EBCDIC CHARACTER
*        STRING IS SHIFTED LEFT TO FOLLOW THE BYTE COUNT IN THE BUFFER.
*
*
*        NOTE1:   REGISTER USER IS AS FOLLOWS:
*
*        ENTRY               INTERNAL             EXIT
*        -----               --------             ----
*        SR1=BIN # TO BE     R0-R2,SR1-SR3=WORK   SR3=TEXTC BUF WD ADR
*        CONVERTED           (R1,R2=INDEX REGS)   R0-R2,SR1-SR2 VOL
*        SR4=RETURN LINK     (SR3=DIVISOR)        R3-R7,D1-D4 PRESRVD
*                            (SR1-SR2=DIVIDEND)
*
*
OCTOUT,21OCT EQU  %                 ENTRY PT FOR BINARY TO EBCDIC OCTAL
*                                   INTEGER CONVERSION ROUTINE.
         LI,SR3   8             <<  LOAD DIVISOR (BASE 8)
         B        21HEX+1         ->START CONVERSION
DECOUT,21DEC EQU  %                 ENTRY PT FOR BINARY TO EBCDIC DECI-
*                                   MAL INTEGER CONVERSION ROUTINE.
         LI,SR3   10            <<  LOAD DIVISOR (BASE 10)
         B        21HEX+1         ->START CONVERSION
HEXOUT,21HEX EQU  %                 ENTRY POINT FOR BINARY TO EBCDIC
*                                   HEX INTEGER CONVERSION ROUTINE
         LI,SR3   16            <<  LOAD DIVISOR (BASE 16)
         LI,R1    HBSZ              GET BYTE SIZE OF BUF IN NXT BYTE PTR
         SLD,SR1  -32               ZERO OUT THE REMAINDER CELL
21HEX1   EQU      %                 DECREMENT THE BUF BYTE STORE INDEX;
         AI,R1    -1            <-  POINTS TO NXT AVAILABLE BUF BYTE
         LI,SR1   0                 ZERO OUT THE REMAINDER CELL
         DW,SR1   SR3               DIVIDE # BY BASE TO GET REMAINDER
         CI,SR1   9                 IS REMAINDER > 9?
         BG       %+3             ->  YES-GET HEX BASE LETTER CONVERSION
         AI,SR1   X'F0'               NO-CONVERT REMNDR TO EBCDIC #0-9
         B        %+2             ->SKIP LETTER CONVERSION
         AI,SR1   X'B7'         <-  CONVERT REMAINDER TO EBCDIC LTR A-F
         STB,SR1  HEXB,R1       <-  STORE BYTE IN NXT AVAILABLE LOC
         CI,SR2   0                 IS QUOTIENT ZERO?
         BNE      21HEX1        <-    NO-CALCULATE NXT DIGIT
*                                     YES-ALL DONE CONVERTING
         LCW,R0   R1                GET NEGATIVE BYTE POINTER
         AI,R0    HBSZ              CALCULATE # BYTES PROCESSED
         STB,R0   HEXB              STORE BYTE CNT IN 1ST WD OF BUF
         LCW,R1   R0                GET NEGATIVE # OF BYTES PROCESSED
*                                   FOR BIR INDEXING ON TRANSFER
         LI,R2    1                 GET NEW BYTE INDEX FOR LEFT-JUSTI-
*                                   FICATION OF STRING IN BUFFER.
21HEX2   EQU      %             <-  BYTE TRANSFER LOOP; # BYTES OUTPUT
*                                   CANNOT BE > THAN 8 FOR 32-BIT WD
         LB,R0    HBEND,R1          GET BYTE FROM HIGH ORDER BYTE
         STB,R0   HEXB,R2           XFER TO LOW-ORDER BYTE (LFT-JUSTIFY)
         AI,R2    1                 INCREMENT BYTE INDEX
         BIR,R1   21HEX2          ->INCREMENT BYTE INDEX
         LI,SR3   HEXB              GET WD ADR OF BUF
         B        *SR4            >>RETURN
*
         PAGE
*
*****************************************************
*  22.   'SPACE' - APPEND  BLANKS TO OUTPUT BUFFER  *
*****************************************************
*
*
*  DESCRIPTION:   'SPACE' RECEIVES AS AN ARGUMENT THE NUMBER OF BLANKS
*                 TO BE APPENDED TO THE OUTPUT BUFFER. IT APPENDS BLANKS
*        TO THE BUFFER ONE AT A TIME UNTIL THE TOTAL NUMBER SPECIFIED
*        HAVE BEEN APPENDED OR THE OUTPUT BUFFER OVERFLOWS. IN TESTING
*        LEVELS 2 AND 1, BUFFER OVERFLOW WILL SET AN OVERFLOW FLAG
*        WHICH WILL PRODUCE AN ERROR MESSAGE WHEN 'SEND' IS CALLED.
*        IN LEVEL 0, ALL THE BUGS SHOULD HAVE BEEN WORKED OUT OF THE
*        PROGRAM AND OVERFLOW SHOULD NOT OCCUR. HOWEVER, IN THAT EVENT
*        THE SPECIFIED BLANKS WOULD BE TRUNCATED.
*
*
*        NOTE1:   REGISTER USE IS AS FOLLOWS:
*
*        ENTRY             INTERNAL              EXIT
*        -----             --------              ----
*        SR1=# BLANKS TO   R1=INDEX INTO BUF     R1-R2,SR1 VOLATILE
*            BE OUTPUT     R2='BLANK' CHAR       R0,R3-R7,SR2-SR4,
*        SR4=RETURN LINK   SR1=BLANK CNTR        D1-D4 PRESERVED
*
*
SPACE,22SP1 EQU   %                 E.P. TO APPEND BLANKS TO OUTPUT BUF
         LW,R1    OBUFX         <<  GET INDEX TO NXT CHAR OF BUF
         LI,R2    C' '              GET BLANK CHARACTER
22SP2    CW,R1    OBUFSZ            IS OUTPUT BUFFER FULL
         BGE      22SP3           ->  YES-TRUNCATE BLANKS
         AI,SR1   -1                  NO-DECREMENT BLANK COUNT;ALL DONE?
         BLZ      22SP4           ->  YES-EXIT
         STB,R2   BUFFER,R1           NO-STORE A BLANK IN OUTPUT BUF
         AI,R1    1                 INCREMENT NXT CHAR PTR
         B        22SP2           ->TEST TO STORE ANOTHER BLANK
*
22SP3    EQU      %             <-  OVERFLOW ON BUFFER BYTE CNT
*********CK%CODE  SET OVERFLOW FLAG FOR 'SEND'
         DO       CK%CODE>=1
           LI,R2    1               GET OVERFLOW FLAG
           STW,R2   OVFLG           STORE IT
         FIN
*********CK%CODE  END
22SP4    EQU      %                 BLANKS APPENDED TO BUFFER
         STW,R1   OBUFX         <-  STORE NXT AVAILABLE CHAR PTR
         B        *SR4            >>RETURN
*
         PAGE
*
********************************************
*  23.   'SEND' - OUTPUT CHARACTER STRING  *
********************************************
*
*
*  DESCRIPTION:   'SEND' EXAMINES A CHARACTER STRING FOR TRAILING
*                 BLANKS, TRUNCATES THEM, AND OUTPUTS THE RESULTANT
*        STRING THROUGH THE M:LO DCB. TO PRESERVE THE INTEGRITY OF THE
*        ABNORMAL I/O SUBROUTINE (ABNXX), BREAK CONTROL IS RELINQUISHED
*        BEFORE THE WRITE IS PERFORMED IN CASE OF AN ABNORMAL RETURN.
*
*
*        NOTE1:   REGISTER USE IS AS FOLLOWS:
*
*        ENTRY               INTERNAL             EXIT
*        -----               --------             ----
*SEND    R7=RETURN LINK      R0-R1=WORK           NONE VOLATILE
*--------------------------  SR2=BUF ADR          R0-R7,SR1-SR4,
*23SEND1 SR1=OUTPUT DCB ADR                       D1-D4 PRESERVED
*        SR3=ABN RTN ADR
*        R7=RETURN LINK
*
*
SEND,23SEND EQU   %                 ENTRY POINT FOR MOST ROUTINES
         LI,SR1   M:LO          <<  GET M:LO DCB ADDRESS
         LI,SR3   ABNLO             GET ABN RETURN ADR
23SEND1  EQU      %                 TRUNCATE BLANKS FROM BUF & OUTPUT
         TRACE%   '8'           <<  '8'=TRACE CODE FOR 'SEND' SUBR
         LCI      12
         PSM,R0   *SPDADR           PUSH R0-R7,SR1-SR4
         LW,R1    OBUFX             GET INDEX TO NEXT BUFFER CHAR
         LI,R0    C' '              GET BLANK
         STB,R0   BUFFER,R1         STORE IT IN 1ST CHAR AFTER STRING
*                                   IN BUFFER (JUST TO GET STARTED)
         CB,R0    BUFFER,R1     <-  IS THIS CHAR A BLANK?
         BNE      %+2             ->  NO-NO MORE TRAILING BLANKS
         BDR,R1   %-2             ->  YES-DECREMENT BYTE INDEX
*                                     (TRUNCATE BLANK)
         AI,R1    1             <-  INCREMENT INDEX TO GET BYTE CNT
         LI,SR2   BUFFER            GET BUFFER ADDRESS
,OUTFPT  M:WRITE  *SR1,(BUF,*SR2),(SIZE,*R1),(ABN,*SR3)  ***
*                                   INDICATED.
         LI,R0    0             <<  SET OBUFX TO 0 SO THAT A NEW
         STW,R0   OBUFX             STRING CAN BE CONSTRUCTED.
         LCI      12
         PLM,R0   *SPDADR           PULL R0-SR4
         B        *R7             >>RETURN
*
         PAGE
*
***************************************************
*  25.   'NEWLN' - OUTPUT A SERIES OF LINE FEEDS  *
***************************************************
*
*
*  DESCRIPTION:   'NEWLN' IS A SUBROUTINE DESIGNED TO ACCEPT AS AN
*                 ARGUMENT THE NUMBER OF BLANK LINES DESIRED FOR
*        OUTPUT AND TO OUTPUT THESE BLANK LINES ON THE M:LO DEVICE.
*        THIS IS ACCOMPLISHED BY BUILDING  A BUFFER OF ONE BLANK
*        CHARACTER AND LOOPING ON AN M:WRITE UNTIL THE LINE COUNT IS
*        EXHAUSTED.
*
*
*        NOTE1:   REGISTER USE IS AS FOLLOWS:
*
*        ENTRY            INTERNAL           EXIT
*        -----            --------           ----
*        SR1=# BLANK LNS  R0-R2=WORK         R0-R2,R7,SR1-SR3 VOLATILE
*        SR4=RETURN LINK  R7=LINK TO 'SEND'  R2-R6,SR4,D1-D4 PRESRVED
*
*
NEWLN,25NL1 EQU   %                 E.P. TO OUTPUT 'N' BLANK LINES
         LI,R0    X'40'         <<  GET A BLANK CHAR
         STB,R0   BUFFER            STORE IN 1ST BUF BYTE
         LW,R2    SR1               GET NEW LINE COUNT
25NL2    AI,R2    -1            <-  IS COUNT EXHAUSTED?
         BLZ      *SR4            >>  YES-RETURN
         LI,R0    1
         STW,R0   OBUFX               NO-SET NXT AVIL BUF CHAR INDEX
         LBAL%,R7 23SEND          >>OUTPUT A BLANK LINE ON M:LO
         B        25NL2         <<->TEST FOR ANOTHER NEW LINE
*
CSEND:CONSUB:PROCEDURE EQU %        END OF PROCEDURE CONTROL SECTION
*
         PAGE
*
* 26.  'GERMFIND' - ESTBLISH COD WORD FOR SPECIFIED GERM ITEM
*
*GERM ITEM SPECFICATION :
*        XYZ  OR  UV
* WHERE
*        X=G, O, B (GHOST,ONLINE,BATCH)
*        Y=T,C,M,D (TOTAL/SUM,CURR,MAX,DFT)
*        Z=RSRCE (2 CHTR),SRVCE (2 OR 4 CHTR),SYMBNT (2 CHTR.) NAMES
*        U=T  (SYSTEM TOTAL)
*        V=RSRCE NAME(2 CHTR.)
*
*INPUT :          BYTE 0 OF SR2 CONTAINS THE BYTE COUNT OF PORTION
*                 OF COMMAND TO BE SEARCHED FOR ITEM NAME
*        SPECIFICATION IN 'COMMAND' (PRESCANNED,LEFT JUSTIFIED,BLANK
*        BTWN INDICATR & NON-BLNK CHTR. DELETED,BLANK FILLED)
*OUTPUT :         GERMWORD ESTBLISHD IF SPEC. VALID
*                 GERMWORD REMAIN 0 IF SPEC. NON-VALID
*EXIT :
*        VALID SPEC. RTN ON SR4
*        NON-VALID SPEC. RTN ON (SR4)+1
*        R0-R7 PRESERVED
*        SR2  PRESERVED
*
*COMMENT : STRICT IN-LINE CODING ADOPTED
*  1. TO EMPHASIZE SYNTAX CHECKING
*  2. USING SMALL SUBRTN DOESN'T AMOUNT TO TOO MUCH
*
GERMFIND EQU      %
         LCI      8
         PSM,R0   *SPDADR
         LI,R1    0                 INITIALIZE
         LB,R5    SR2               COMMAND BYTE COUNT
         LW,R6    DWBLANKS          USE TO SEACH TBL
         LB,R3    COMMAND,R1
         LB,R2    INDJOB
LOOKJOB  EQU      %                 LOOK FOR GOB
         CB,R3    INDJOB,R2
         BE       FDJOB
         BDR,R2   LOOKJOB
         B        FDJOB+1           CHTR. POST. STILL AT 0
FDJOB    AI,R1    1
         LI,R7    JOBCLS
         STB,R2   GERMWORD,R7       JOB CLASS OBTNED
         LB,R3    COMMAND,R1
         LB,R2    INDICATR
LOOKTPE  EQU      %                 LOOK FOR TCMD
         CB,R3    INDICATR,R2
         BE       FDTPE
         BDR,R2   LOOKTPE
         B        NOGERM            CANNOT BE A GERM ITEM
FDTPE    AI,R1    1
         LI,R7    TYPECLS
         STB,R2   GERMWORD,R7       TYPE CLASS OBTNED
LOOKGEM  EQU      %                 LOOK FOR NAME
         SW,R5    R1                (R1)=# OF CHTR. SCANNED
         CI,R5    SNM#
         BGE      SERNAME           IF >4,LOOK AT 4 CHTR. ONLY
         CI,R5    RPNM#
         BE       RPNAME
         B        NOGERM            EITHER 2 OR >=4 CHTR. FOR NAME
RPNAME   EQU      %                 FOR RSRCE OR SYMBNT NAME
         LI,R4    0
         LB,R2    COMMAND,R1
         STB,R2   R6,R4
         AI,R1    1
         AI,R4    1
         CI,R4    RPNM#
         BNE      RPNAME+1          MORE
         LI,R4    SV:RSIZ
         LH,R6    R6
         CH,R6    SH:RNM+F,R4
         BE       FDRES
         BDR,R4   %-2               NOT FND YET
         LI,R4    SV:FTYM
         CH,R6    SH:SYMT+F,R4
         BE       FDSYM
         BDR,R4   %-2               NOT FND YET
         AI,R1    -2                GET BK POST.,SRVCE NANE CAN BE 2 CHTR.
         LW,R6    DWBLANKS          CLEAN GARGABE
         LI,R5    2
         B        SERNAME+1
SERNAME  EQU      %                 FOR SRVCE NAME
         LI,R5    SNM#              4 CHTR.
         LI,R4    0
         LB,R2    COMMAND,R1
         STB,R2   R6,R4
         AI,R1    1
         AI,R4    1
         CW,R4    R5
         BNE      SERNAME+2         MORE
         LI,R4    SV:LIM
         CW,R6    SL:NAME+F,R4      SRVCE NAME BLNK FILLED IF 2
         BE       FDSERV
         BDR,R4   %-2
         B        NOGERM            NO SUCH GERM NAME
FDSYM    LI,R2    3
         B        FDRES+1
FDSERV   LI,R2    2
         B        FDRES+1
FDRES    LI,R2    1
         LI,R7    GERMCLS
         STB,R2   GERMWORD,R7       GERM CLASS OBTNED
         LI,R7    NAMEPOS
         STB,R4   GERMWORD,R7       NAME POST. OBTNED
         LW,R1    GERMWORD          *NOW SEE IF DEFINED IN GDECTBL
         LI,R2    0
         STB,R2   R1,R7             NAMEPOS SUBDUED
         LI,R2    #DECTBL
VALID    CW,R1    GDECTBL-1,R2
         BE       COMRTN            O.K.;RETURN
         BDR,R2   VALID
NOGERM   LI,R1    0
         STW,R1   GERMWORD          GERMWORD REMAINS 0
         AI,SR4   1
COMRTN   LCI      8
         PLM,R0   *SPDADR
         B        *SR4
         PAGE
*
* 27.  'GTSTVAL' - GETS OR STORES SOME DESIRED VALUE
*
*BASED ON INFO. IN CODEWORD(GERMWORD),AND INPUT INFO.IN SR1&SR2
*GET VALUE FROM OR STORE VALUE INTO SOME SYSTEM TABLE
*
*INPUT :
* IF SR2=0,GET A VALUE              * IF SR2=1,STORE A VALUE
*  THEN SR1=0-->ASSOCIATED VALU     *   SR1=VLU TO BE STORED
*       SR1=1-->MAX INDICATION      *
*       SR1=2-->MIN INDICATION      *
*OUTPUT :
*  IN SR1         *                 *
*INTERNAL REG : R1-R7
*EXIT : R1-R7 PRESERVED
*        RTN ON SR4
GTSTVAL  EQU      %
         LCI      7                 SAVE REG R1-R7
         PSM,R1   *SPDADR
         LB,R1    GERMWORD          NAMEPOS AS INDEX
         BEZ      GGERR1            CANNOT BE 0
         LW,R7    SR2               GET/STORE INDICATION
         LI,R2    0
         LW,R3    GERMWORD
         STB,R2   R3                CLEAR BYTE 0 FOR COMPARISON
GGVAL0   CW,R3    GDECTBL,R2
         BE       GGVAL1            FOUND
         AI,R2    1
         CI,R2    #DECTBL
         BNE      GGVAL0
         TYPE     'GERM: GERMWORD NOT VALID, EXIT'
         M:EXIT
GGERR1   TYPE     'GERM: NAMEPOS=0, EXIT'
         M:EXIT
GGVAL1   EQU      %
         LW,R4    GREFTBL,R2
         MTW,0    SR2
         BCS,3    GGGO              STORE CASE
         MTW,0    SR1
         BCS,3    GGJUMP            GET MAX/MIN CSE
GGGO     EQU      %                 DETERMINE TYPE PF INDX
         LI,R5    TYPECLS
         LB,R6    GERMWORD,R5       GET TYPE INDICATION
         CI,R6    2
         BLE      HLFINDX           HALFWORD
         LI,R5    GERMCLS
         LB,R6    GERMWORD,R5       GET GERM INDICATION
         CI,R6    1
         BE       BYEINDX           BYTE
         CI,R6    2
         BE       WDINDX            WORD
         LI,R6    31                BIT DISPLCNT;BIT 1-->1ST ENTRY
         MTW,0    SR2
         BCR,3    GTBIT             GET BIT CASE
         LCW,SR2  SR2               GET ALL 1'S
         SLS,SR2  *R1               SHAKE OFF LEFT 1'S
         SLS,SR2    -31             ***SHAKE OF RIGHT 1'S
         SW,R6    R1
         SLS,SR2  *R6               ONLY ONE 1 IN THE PARTICULAR
*                  BIT POSTN.; REST ALL 0
         LW,R1    SR1               HAS TO BE A 0 OR 1
         BCS,3    %+3               GO TURN THE BIT ON
         AND,SR2  *R4               WANT OFF;SEE IF BIT ALRDY OFF
         BCR,3    GGRET             YES;THAT IS IT
         EXU      ONOFF,R1          NO;HAVE TO DO IT
         STW,SR2  *R4               STORE;OTHER BITS PRESERVED
         B        GGRET             RETURN
GTBIT    SW,R6    R1
         LCW,R6   R6
         LW,SR1   *R4
         SLS,SR1  *R6
         LI,R5    1
         AND,SR1  R5                EITHER 1 OR 0
         B        GGRET             RETURN
HLFINDX  EXU      HLFTBL,R7
         B        GGRET             RETURN
BYEINDX  EXU      BYETBL,R7
         B        GGRET             RETURN
WDINDX   EXU      WDTBL,R7
GGRET    LCI      7
         PLM,R1   *SPDADR
         B        *SR4
*
GGJUMP   EQU      %                 EITHER MIN OR MAX
         LW,R6    SR1
         EXU      GGMXMN,R6
         CI,SR1   0
         BGE      GGRET             REAL VALU;RETURN
         CI,SR1   -2                -1-->CURR;-2-->SPECIAL
         BGE      GGRET
         LW,R4    SR1
         LI,R5    TYPECLS           :DUE TO MAX SETUP
         LB,R6    GERMWORD,R5       SB:RBMX--->SH:RBSUM
         CI,R6    3
         BE       HLFINDX
         B        GGGO              GET ASSOC.MAX OR MIN VALU
GGMXMN   EQU      %-1
         LW,SR1   GMAXTBL,R2
         LW,SR1   GMINTBL,R2
HLFTBL   LH,SR1   *R4,R1
         STH,SR1  *R4,R1
*
BYETBL   LB,SR1   *R4,R1
         STB,SR1  *R4,R1
*
WDTBL    LW,SR1   *R4,R1
         STW,SR1  *R4,R1
*
ONOFF    EOR,SR2  *R4               TURN OFF THE BIT IF ORIGNLY ON
         OR,SR2   *R4               TURN ON THE PARTICULAR BIT
*
         PAGE
*
* 28.  'GERMFILL' - ACCORDING TO A FIXED PATTERN
*        EITHER FILLS THE GCONSTK WILL ALL VALID CODES
*        OR  FILLS THE GCONVAL WITH ALL OBTNED VALUS(VIA GTSTVAL)
*
*ENTRY : SR4-RTN LINK
*        GERMBANG=0 ---> 'ADD' ALL (GCONSTK)
*        GERMBANG=1 ---> CONTROL BANG (GCONVAL)
*INTERNAL REG *
*        R0-R4,R7,SR1,SR2
*EXIT : ALL INTERNAL REG.S VOLATILE
*
GERMFILL EQU      %
         LI,R1    -1                INCREASING INDEX FOR STORING
         LI,R2    -1                INDX FOR GREFTBL
GFILL1   EQU      %
         LI,R3    0                 FOR NAMEPOS VARIATION
         AI,R2    1
         CI,R2    #DECTBL
         BNE      GMORE
         MTW,0    GERMBANG
         BCS,3    *SR4              ALL DONE;CONTROL BANG
         AI,R1    1
         STW,R3   GCONSTK,R1        INDICATE END
         B        *SR4
GMORE    LW,R0    GDECTBL,R2
         LH,R7    R0                BYTE 0=0,BYTE 1=GERMCLS
         EXU      GFILL11,R7
GFILL2   EQU      %
         AI,R3    1
         CW,R3    R4                RSRCE/SRVCE/SYMBNT EXHAUSTED
         BE       GFILL1
         AI,R1    1
         STB,R3   R0                NAMEPOS FURNISHED
         MTW,0    GERMBANG
         BCR,3    GFSTK             GO FILL STK
         STW,R0   GERMWORD
         LI,SR2   0                 GO GET
         LI,SR1   0                 GET ASSOCIATED VALU
         PSW,SR4  *SPDADR           SAVE RTN LNK
         BAL,SR4  GTSTVAL           GET VALU
         PLW,SR4  *SPDADR
         STW,SR1  GCONVAL,R1        FILL GCONVAL TBL
         B        GFILL2
GFSTK    STW,R0   GCONSTK,R1        FILL GCONSTK TBL
         B        GFILL2
*
GFILL11  EQU      %-1
         LI,R4    SV:RSIZ+1
         LI,R4    SV:LIM+1
         LI,R4    SV:FTYM+1
*
         PAGE
*
* 29.  'MKNME' - RECONSTRUCTS AN ITEM NAME ACCORDING TO THE
*                 4-BYTE CODE IN GERMWORD
*
*ENTRY :  SR3---RTN LNK
*        INPUT IN GERMWORD
*INTERNAL REG :R0-R2,R4,R7,SR1,SR2,SR4
*
*EXIT : ALL INTERNAL REG.S VOLATILE
*        RECONSTRUCTED NAME IN RCONSTR (DBLWD)--LEFT JUSTIFIED
*        ,RIGHT BLANK FILLED
*
*  INTERNAL REG.S    R1,R2,R4,R7,SR1,SR2,SR4
*
MKNME    EQU      %
         LD,SR1   DWBLANKS
         STD,SR1  RCONSTR           FILL WITH BLANKS
         LI,R7    -1                FOR INDX INTO RCONSTR
         LI,R2    JOBCLS
         LB,R4    GERMWORD,R2       GET JOBCLS CODE
         BEZ      MKNME1            0 MEANS T FOLLWOED BY NAME
         LI,SR1   INDJOB            JOB INDICATR--GOB
         BAL,SR4  MKNME2
MKNME1   LI,R2    TYPECLS
         LB,R4    GERMWORD,R2       GET TYPECLS CODE--TCMD
         LI,SR1   INDICATR
         BAL,SR4  MKNME2
         LI,R2    GERMCLS
         LB,R4    GERMWORD,R2       GET GERMCLS CODE
         EXU      MKNME3,R4
         EXU      MKNME4,R4
         LI,R2    NAMEPOS
         LB,R1    GERMWORD,R2
         CI,R4    2                 IF GERMCLS=2,4 CHTR. SRVCE NME
         BE       %+4
         LH,SR1   *SR1,R1           2 CHTR. RSRCE/SYMBNT NAME
         SLS,SR1  16                TO LEFT HALF
         B        %+2
         LW,SR1   *SR1,R1           SERVICE NAME
         LI,R4    -1
MKNME11  AI,R4    1
         CW,R4    SR2
         BE       *SR3              ALL DONE;RTN
         AI,R7    1
         LB,R2    SR1,R4
         STB,R2   RCONSTR,R7
         B        MKNME11
*
MKNME2   EQU      %                 FILL DATA WORD RCONSTR
         AI,R7    1
         LB,R2    *SR1,R4
         STB,R2   RCONSTR,R7
         B        *SR4
*
MKNME3   EQU      %-1
         LI,SR1   SH:RNM+F          RSRCE
         LI,SR1   SL:NAME+F         SRVCE
         LI,SR1   SH:SYMT+F         SYMBNT
*
MKNME4   EQU      %-1
         LI,SR2   2                 2 CHTR.
         LI,SR2   4                 4 CHTR.
         LI,SR2   2                 2 CHTR.
*
         PAGE
*
* 30.  'GOUTRTN' - USES GERMWORD TO GET TEXT HEADING(INDX INTO GTEXTBL
*        IN R2),
*        THEN ATTACH GERM ITEM NAME (VIA SUBROUTINE MKNME),
*        THEN ASSOCIATE VALUE FROM GCONVAL (INDX INTO GCONVAL IN R1),
*        AND OUTPUTS
*INPUT :  R1---INDX INTO GCONVAL
*        R2----INDX INTO GTEXTBL
*        R5----PRINT/NOT PRINT
*INTERNAL : R6,R7,SR3,SR4
*EXIT :   RTN ON SR4
*        ALL REG.S SAVED
*
*
GOUTRTN  EQU      %
         LCI      0
         PSM,R0   *SPDADR           SAVE ALL
         PSW,R1   *SPDADR
         PSW,R2   *SPDADR
         CI,R5    0                 PRINTING RIGHT HALF
         BE       GOUT1
         LBAL%,SR4  SPACE,3         YES;SPACE 3 BLNKS
GOUT1    PLW,R2   *SPDADR
         LBAL%,R7 APEND,,,(W,GTEXTBL,R2)   TEXT HEADING
         LBAL%,SR4  SPACE,1         ONE SPACE
         BAL,SR3  MKNME             GET NAME
         LD,SR3   RCONSTR           NAME CANNOT BE >6 CHTR.
         SLD,SR3  -8
         LI,R7    7
         STB,R7   RCONSTR           MAKE IT A MANDATORY 7 COUNT
         LI,R6    X'7E'             =SIGN
         STB,R6   RCONSTR,R7        MAKE LST BYE A = SIGN
         LBAL%,R7 APEND,,,RCONSTR   APPEND NAME
         PLW,R1   *SPDADR
         LW,SR2   GCONVAL,R1        GET VALU
         LBAL%,SR4  DECOUT,(W,SR2)
         LB,SR1   *SR3
         AI,SR1   -5                ASSUMING DEC. BYTE COUNT CANNOT <=5
         LCW,SR1  SR1
         LBAL%,SR4  SPACE
         LB,SR4   *SR3              FOR BOUTX,SR4=STRING LENGTH
         SLS,SR3  2                 SR3=STR BYTE ADDRESS
         AI,SR3   1
         LBAL%,R7 BOUTX,,(W,R5)     APPEND DEC. #,OUTPUT/DONT OUTPUT
         LCI      0
         PLM,R0   *SPDADR           RESTORE
         B        *SR4              RETURN FOR MORE
         PAGE
*
*******************************************
*  30.   DYNAMICALLY MODIFIED DATA CELLS  *
*******************************************
*
*
*        NOTE:    BECAUSE THESE SUBROUTINES ARE RE-ENTRANT, REGISTERS
*                 OR THE USER'S TCB STACK ARE USED FOR DATA STORAGE.
*        THE ONLY SUBROUTINE HAVING A DATA STORE OF ITS OWN
*        SHOULD BE 'ABNXX' WHICH IS NOT RE-ENTRANT.
*
         USECT    CS:CONSUB:DATA    USE DATA CONTROL SECTION
*
MBSZ     EQU      80                ERR MESSAGE BUFFER BYTE SIZE
MBUF     RES,1    MBSZ              MONITOR ERROR MESSAGE BUFFER
MSZ      RES      1                 ERR MSGE ARS IN BYTES
DCBX     DATA     0                 IF I/O ABN RTN,DCBX=1==>M:DO DCB
*                                                  DCBX=2==>M:SI DCB
*                                                  DCBX=3==>M:LO DCB
R7LINK   RES      1                 R7 SAVE LOC (FOR *RETURN)
         BOUND    8
ECODE    RES      1                 ERROR/ABN CODE (BITS 0-7),
*                                   SUB-CODE (BITS 8-14),
*                                   ADR OF ERRORED DCB (BITS 15-31)
INPTR    RES      1                 IF INPUT I/O ERROR, LINK REG
*                                   CONTENTS FROM CALLING ROUTINE
OUTPTR   RES      1                 IF OUTPUT ABN RETURN, LINK REG
*                                   CONTENTS FROM CALLING ROUTINE
CALPTR   RES      1                 ADR OF ERRORED CAL +1
*
OBUFSZ   DATA     105               OUTPUT BUFFER SIZE
*
KEYIN    DATA,1   4,0,0,0           KEYIN CAL FOR GHOSTS
         DATA     X'F0000000'
         PZE      PROMPT
         PZE      *SR2
         PZE      *SR1
         PZE      %
         PAGE
*
************************
*  32.   DATA BUFFERS  *
************************
*
CS:REENTRANT:DATA EQU %             BEGINNING OF REENTRANT DATA SECTION
*
OBUFX    DATA     0                 INDEX TO NXT FREE CHAR IN OUT BUF
HBSZ     EQU      12                BIN--->EBCDIC CONVERSION BUFFER SIZE
HEXB     RES,1    HBSZ              BIN-->EBCDIC CONVERSION BUFFER
HBEND    EQU      %                 WA(END OF HEXB) FOR BIR BYTE XFER
         BOUND    4
PROMPT   TEXTC    '-'               PROMPT CHAR FOR KEYIN CALS
BUFFER   RES,1    120               OUTPUT BUFFER
         BOUND    4
READREGS RES      4                 'READSI' STD REG BUFFER
*
CSEND:CONSUB:DATA EQU %             END OF DATA SECTION
CS:RED:SIZE EQU   CSEND:CONSUB:DATA-CS:REENTRANT:DATA
*
         END                        END OF MODULE

