***************************************************************
*M*      TPG      TRANSACTION PROCESSING GHOST
***************************************************************
*P*
*P*      NAME:    TPG, TRANSACTION PROCESSING GHOST
*P*
*P*      PURPOSE: THE TPG IS THE OWNER OF THE QUEUE FILE
*P*               (TPQUEUE.:SYS) AND THE COMMON JOURNALS.
*P*               DEFINITIONS (I.E. ASSIGNMENTS) FOR THESE
*P*               FILES ARE ENTERED BY THE TP SYSTEM OPERATOR
*P*               VIA TPG COMMANDS.  THESE DEFINITIONS ARE
*P*               RETAINED IN A FILE (TPFILES.:SYS) ACROSS
*P*               TP SESSIONS UNTIL RELEASED OR DELETED.
*P*
*P*               THE POSSIBLE TPG COMMANDS ARE DEFINED IN
*P*               THE TRANSACTION PROCESSING REFERENCE MANUAL
*P*               FOR CP-V (90 31 12).
*P*
*P*               ONCE THE TP SESSION IS STARTED (THE QUEUE
*P*               FILE AND ANY JOURNALS ARE OPENED), THE TPG
*P*               IS PUT TO SLEEP WITH AN 'END' COMMAND.
*P*
*P*               FROM THIS POINT, THE TPG IS AWAKENED BY
*P*               AN OPERATOR INTERRUPT, OR BY THE COMMON
*P*               JOURNAL INTERFACE MODULE.
*P*               THE OPERATOR MAY INTERRUPT THE TPG TO
*P*               TERMINATE THE TP SESSION AND CLOSE THE
*P*               QUEUE FILES AND COMMON JOURNALS, OR TO
*P*               SIMPLY OBTAIN INFORMATION ABOUT THE
*P*               FILE DEFINITIONS.
*P*               THE COMMON JOURNAL INTERFACE MODULE INTERRUPTS
*P*               THE TPG TO PERFORM VOLUME SWITCHES ON THE
*P*               JOURNAL, AND TO HANDLE NON-RECOVERABLE WRITE
*P*               ERRORS ENCOUNTERED ON THE JOURNAL.
*P*
*P*
*P*
         PCC      0
         TITLE    'TRANSACTION PROCESSING GHOST***JUNE 6,1975'
GOD      EQU      1                 ONE-ACTUAL TPG; ZERO-DEBUG VERSION
GC       EQU      1                 GET CFU RATHER THAN STEALING FROM DCB
*
         SYSTEM   TPPROCS
         SYSTEM   SIG7FDP
         DEF      QRECBUF           QUEUE BLOCK BUFFER
         DEF      DRX               ROUTINE TO OUTPUT ERROR
*,*                                 MESSAGE AND RETURN
         DEF      ABTCMD            ROUTINE TO ABORT CURRENT CMND.
         DEF      TEMPID            HIGHEST TRANSACTION ID
         DEF      MASTER            MASTER MODE ROUTINE
         DEF      SLAVE             SLAVE MODE ROUTINE
         DEF      BUF               ADDRESS OF WORK SPACE
         DEF      ERR               I/O ERROR ROUTINE
         DEF      ABN               I/O ABNORMAL ROUTINE
         DEF      LOCKFPT           M:QUEUE LOCK FPT
         DEF      OPOUTFPT          ERROR MESSAGE FPT
         DEF      INIT              INITIALIZATION
         DEF      DRIVE             COMMAND DRIVER
         DEF      SET               SET COMMAND PROCESSOR
         DEF      OPOUTX            ERROR CAL MESSAGE BUILDER
         DEF      XA                PROCEDURE START (GENMD SYMBOL)
         DEF      GETUM             CHARACTER SCAN ROUTINE
         DEF      DATA              DATA START (GENMD SYMBOL)
         DO1      GOD
         REF      QCK               QUEUE CHECK SUBROUTINE
         DO       GC=0
         REF      F:CFU1            DEBUG VERSION REF
         REF      F:CFU2            DEBUG VERSION REF
         REF      F:CFU3            DEBUG VERSION REF
         REF      F:CFU4            DEBUG VERSION REF
         FIN
         REF      F:QDCB            QUEUE FILE DCB
         REF      M:EI              TPFILES DCB
         REF      M:SI              INPUT DCB
         REF      M:LL              OUTPUT DCB
         REF      M:EO              JOURNAL RECOVERY DCB
         DO       GC&GOD
         REF      CFUSIZE           CFU ENTRY LENGTH
         REF      ACNCFU            ACCOUNT DIRECTORY CFU
         REF      BGRCFU            CFU TABLE BEGIN
         REF      LASTCFU           CFU TABLE END
         FIN
         DO       GOD
         REF      S:CUN             CURRENT USER NUMBER
         REF      SL:PWP            MAX PHYSICAL WORK PAGES
         REF      SMUIS             MAX USERS IN SYSTEM
         REF      UH:FLG2           FLAG SET FOR TP USERS IN UH:FLG2
         SREF     TTP               TRANSACTION PROCESSING TABLE
M:TID    EQU      TTP+14            HIGHEST TID LOCATION
         ELSE
SL:PWP   DATA     10                SIMULATION VALUES
M:TID    DATA     0
SMUIS    EQU      3
UH:FLG2  DATA,2   0,0,TPF,0
S:CUN    DATA     1
         DEF      TTP               DEBUG VERSION DEF
TTP      EQU      M:TID-14
         FIN
TPF      EQU      X'100'
F:ANS1   DSECT    2
F:ANS1   M:DCB    (ANSLBL),(BLKL,2076),(SN,20),(TRIES,50)
F:ANS2   DSECT    2
F:ANS2   M:DCB    (ANSLBL),(BLKL,2076),(SN,20),(TRIES,50)
F:ANS3   DSECT    2
F:ANS3   M:DCB    (ANSLBL),(BLKL,2076),(SN,20),(TRIES,50)
F:ANS4   DSECT    2
F:ANS4   M:DCB    (ANSLBL),(BLKL,2076),(SN,20),(TRIES,50)
         CSECT    0
DATA     EQU      %
XA       DATA     10
YFFFE    DATA     X'FFFE0000'
Y0001    DATA     X'10000'
Y008     DATA     X'800000'
Y08      DATA     X'08000000'
Y1       DATA     X'10000000'
Y2       DATA     X'20000000'
Y4       DATA     X'40000000'
Y6       DATA     X'60000000'
Y8       DATA     X'80000000'
YC       DATA     X'C0000000'
XFF000001 DATA    X'FF000001'
M7       DATA     X'7F'
M8       DATA     X'FF'
M16      DATA     X'FFFF'
M17      DATA     X'1FFFF'
M20      DATA     X'FFFFF'
M24      DATA     X'FFFFFF'
M31      DATA     X'7FFFFFFF'
*    JRNL TABLES - MODIFY FOR NUMBER OF J ALLOWED IN SYSTEM
MAXJRNL  EQU      4
#JRNL    DATA     0                 # OF JRNL OPEN
JRNLNAM  EQU      %-1
         DATA     JN1,JN2,JN3,JN4
ANSDCB   EQU      %-1
         DATA     F:ANS1
         DATA     F:ANS2
         DATA     F:ANS3
         DATA     F:ANS4
         DO       GC=0
CFUDCB   EQU      %-1
         DATA     F:CFU1,F:CFU2,F:CFU3,F:CFU4
         FIN
JRNLCFU  EQU      %-1
         RES      MAXJRNL
#JRNLSN  EQU      %-1
         RES      MAXJRNL
JRNLIOQ  EQU      %-1
         DO       MAXJRNL
         DATA     0
         FIN
JN1      RES      8
JN2      RES      8
JN3      RES      8
JN4      RES      8
TMAXSN   EQU      20
CDAM     EQU      7
SREC     EQU      6
TDA      EQU      5
         DO       GOD=0
DEBUGCFU EQU      %-1
         DATA     CFUC,1,CFUD,CFUD
ACNCFU   EQU      %-17
CFUSIZE  EQU      8
BGRCFU   EQU      %
CFUA     DATA     0,0,0,0,0,0,0,0
CFUB     DATA     0,0,0,0,0,0,0,0
CFUC     DATA     ':SYS','    ',0,0,0,0,0,0
CFUD     DATA     0,0,0,0,0,0,0,0
LASTCFU  EQU      %
         FIN
COS      EQU      11*4
FLP      EQU      6
SND      EQU      12
*        DRIVE DATA
CMDREQUEST TEXTC  'TPG COMMAND  '
*
CMDOUT   DATA     '    '
CMD      EQU      %
         DO       73                CMD BUFFER
         DATA,1   0
         FIN
         BOUND    8
CMDTTBS  DATA     BA(TRANTAB)
         DATA     BA(CMD)+1
*  LEGAL FIRST CHARS OF CMDS
CMDTBL   DATA,1   0
         DATA,8   'CARVXELB'
CMDTBLSZ1 EQU     BA(%)-BA(CMDTBL)  LEGAL FOR ACTIVE`TP
         DATA,5   'DGOQS'
CMDTBLSZ EQU      BA(%)-BA(CMDTBL)  LEGAL ONLY FOR INACTIVE TP
         BOUND    4
CMDSUBR  DATA     0
         B        CLOSE
         B        ALLOW
         B        RELEASE
         B        CVOL
         B        ZAP
         B        END
         B        LIST
         B        BYPASS
         B        DELETE
GOINDEX  EQU      %-CMDSUBR
         B        GO
         B        OPEN
         B        QUEUE
         B        SET
         BOUND    8
CMDINDEX DATA     0
ACTIVE   DATA     0
INTF     DATA     0
SLEEPF   DATA     0
0ASHELL  DATA     10                INITIAL CONTENTS OF 0A REC
         DATA     0
         DO       8
         DATA     0
         FIN
ECB      DATA     0
*
*        SET DATA
*
SETESTER DATA     BDDEF
         DATA     BDTYPE
         DATA     BDSIZE
         DATA     BDNAME
         BOUND    8
         DO       GOD
SLPSD    RES      2
         GEN,10,22 1,SL1            MASTER MAPPED
         DATA     0
         FIN
ZERO     DATA     0,0
BYTESTRING DATA   0,0
TPGSTK   DATA     %+1
         DATA,2   40,0
         RES      40
DEVTYPE  EQU      %
         DATA,2   0
         DATA,2   'DC','DP','AT'
         BOUND    4
DEVCODE  DATA     X'700',X'B00'
TAPETYPE DATA,2   0,'BT','9T'
TAPETYPES EQU     2
         BOUND    4
DEVTYPES EQU      3
DEVTYPEQ EQU      2
MAXSN    EQU      100               100 SERIAL NUMBERS MAX
GET2PG   DATA     X'08000002'
BUF      DATA     0
*
*        QUEUE DATA
*        QSHELL MUST START ON AN ODD WORD BOUNDARY SO THAT
*        TXTPQUEUE IS IN A DOUBLEWORD.
*
         BOUND    8
         DATA     0
*
QSHELL   GEN,2,30 1,11              Q DEF, SIZE
         DATA     0,0
TXTPQUEUE TEXTC   'TPQUEUE'
         DATA     0
UNSHELL  GEN,8,24 X'6',F:QDCB
         GEN,4,20,4,4  7,0,4,0      UNLOCK FPT - NEW,NOBACKUP
         DATA     6
         DATA     2
         DATA     0
QDELIMS  DATA,1   0                 0 NULL
         DATA,1   0                 1 SPACE  DONE
         DATA,1   4+1               2 ,      ;SP
         DATA,1   0,4+2+1           4 ;      ;,SP
         BOUND    4
QTEMP    DATA     0,0,0,0,0
QPARAM   DATA,1   0,'B','P','K','T','N' NULL,BACKUP,PG,KEY,THRESH,NO BACK
         BOUND    4
QVECT    DATA     0                 QUEUE CMD SUBR
         B        QU4
         B        PQ
         B        KQ
         B        TQ
THRESHMAX EQU     100
QRECSZ   EQU      11*4
JRECSZ   EQU      (2+8+32)*4
OQFLG    DATA     0
QJINDEX  DATA     0
0ABUFMAX EQU      2+8+32
TEMPID   DATA     0
SAVR2    DATA     0
ANSBLKS  DATA     0                 NO. BLKS ON JOURNAL
ERRCOUNT EQU      12                NO. BLKS TO BACK UP ON ERR
Y000C    DATA     X'000C0000'       EOP SWITCH
SAVR15   DATA     0
WD1JWRT  GEN,16,16 X'1A',(512+5)*4
TIME     RES      4
JENDREC  EQU      %
         GEN,16,16 X'13',28
         DATA     0,0,0,0,0,0
         BOUND    8
NAM:SYS  TEXT     ':SYS '
         PAGE
*
*        GETUM    DATA
*
         BOUND    8
FLDT     EQU      %
DELIMITER DATA    0                 LAST DELIM FOUND
BSCC     DATA     0                 CC RESULTS CC4=1 IS FIELD FOUND
FWORDCNT DATA     0                 FIELD WD CNT
FBYTECNT DATA     0                 FIELD BYTE CNT
FIELD    RES      8                 FIELD LEFT JUST,WD SP FILLED
*  DELIMITER MASKS
MSK1     EQU      1                 SPACE
MSK2     EQU      2                 ,
MSK4     EQU      4                 ;
MSK8     EQU      8                 /
MSK10    EQU      X'10'             #
MSK0F    EQU      X'0F'             ACTIVE DELIMS (EXCEPT #)
MSKI     EQU      X'20'             ILLEGAL CHARACTERSS
*
DECTBL   TEXT     '00123456789ABCDEF' FOR TOHEX & CHARTO
         BOUND    4
UNIT     DATA     1,10,100,1000,10000,100000,1000000
HEXTBL   TEXT     '0123456789ABCDEF'
         BOUND    8
SPACES   TEXT     '        '
MLOC     DATA     0
         PAGE
CLSRELQ  GEN,8,24 X'15',F:QDCB
         DATA     X'80000000'
         DATA     1                 RELEASE
RDTPF    GEN,8,24 X'10',M:EI
         DATA     X'F8000010'       WAIT
         DATA     ERR
         DATA     ABN
         GEN,1,31 1,12              BUFF
         GEN,1,31 1,13              SZ
         GEN,1,31 1,14              KEY
*
RD0A     GEN,8,24 X'10',M:EI
         DATA     X'F8000010'
         DATA     ERR
         DATA     ABN
         DATA     0ABUF
         DATA     (0ABUFMAX)*4
         DATA     0AKEY
WRT0A    GEN,8,24 X'11',M:EI
         DATA     X'F8000070'
         DATA     ERR,ABN
         DATA     0ABUF
         DATA     (0ABUFMAX)*4
         DATA     0AKEY
0AKEY    DATA,1   3,0,0,'A'
*
WRTTPF   GEN,8,24 X'11',M:EI
         DATA     X'F8000070'       ONEWKEY,NEWKEY,WAIT
         DATA     ERR
         DATA     ABN
         GEN,1,31 1,12
         GEN,1,31 1,13
         GEN,1,31 1,14
0ABUF    RES      0ABUFMAX
*
RDTPFLST GEN,8,24 X'10',M:EI
         DATA     X'F0000010'
         DATA     ERR
         DATA     ABN
         GEN,1,31 1,12
         GEN,1,31 1,13
         DATA     LKEY
LKEY     RES      8
*
OCTYPE   DATA     X'2000000'
         GEN,1,31 1,0
         DATA     0                 WILL BE BUF ADR IN REG2
         DO       GOD
LLPRINT  GEN,8,24 1,0
         ELSE
LLPRINT  GEN,8,24 2,0
         FIN
         GEN,1,31 1,0
         DATA     0                 BUF IN REG2
*
FPTIOERR GEN,8,24 2,0               TYPE
         GEN,1,31 1,0
         DATA     IOERR
ERMSG    GEN,8,24 X'10',M:SI        RD ER MSG FILE
         DATA     X'F8000000'
         DATA     ERR,ABN
         DATA     ERMSGBUF
         DATA     132
         DATA     ERMSGKEY
ERMSGKEY DATA     X'03000000'
         TEXT     '    '
ERMSGBUF RES      34
*
OPOUTFPT GEN,8,24 2,0
         GEN,1,31 1,0
         GEN,1,31 1,10
*        FPT TO OPEN QUEUE
OQFPT    GEN,8,24 X'14',F:QDCB
         DATA     X'C5441001'
         DATA     ERR,ABN
         DATA     3                 ORG=RANDOM
         DATA     4                 FCN=4INOUT OR 2OUT
         DATA     2                 SAVE
         DATA     X'18000'          BITS20-23 WILL BE DEV CODE
         DATA     0                 GRAN SZ
         DATA     X'01010202'
         TEXTC    'TPQUEUE'
QRECBUF  EQU      %
         RES      11
CANSFPT  GEN,1,7,24 1,X'15',12
         DATA     X'80000020'       REMOVE
         DATA     2                 SAVE
         DO       GC=0
CCFUFPT  GEN,1,7,24 1,X'15',12
         DATA     X'80000000'
         DATA     1                 RELEASE
CFUFPT   GEN,8,24 X'14',0
         DATA     X'C5440001'
         DATA     ERR,ABN
         DATA     1                 ORG= CONSEC
         DATA     2                 MODE= OUT
         DATA     2                 SAVE
         DATA     X'18700'          DC MAY BE SET TO DC OR DP
         DATA     X'01010008'
         RES      8
         FIN
CVOLFPT  GEN,1,7,24 1,3,12          12 CONTAINS DCB ADR
         DATA     0
RDQFPT   GEN,8,24 X'10',F:QDCB
         DATA     X'F1000010'
         DATA     ERR,ABN
         GEN,1,31 1,12              BUF
         DATA     512*4
         DATA     0                 BLOCK #
WRTQFPT  GEN,8,24 X'11',F:QDCB
         DATA     X'F1000010'
         DATA     ERR,ABN
         GEN,1,31 1,BUF
         DATA     512*4
         DATA     0
LOCKFPT  GEN,8,24 X'C',F:QDCB
         DATA     X'00000010'       NO ECB, WAIT
PAUSEFPT GEN,8,24 X'C',F:QDCB
         DATA     X'00000110'       PAUSE,NO ECB,WAIT
WRTQJRNL GEN,8,24 X'11',0
         DATA     X'F0000010'       WAIT
         DATA     ERR,ABN
         GEN,1,31 1,12              BUF IN 12
         DATA     (512+4+1)*4
ANSFPT   GEN,8,24 X'14',0
         DATA     X'C5450045'
         DATA     ERR,ABN
         DATA     4                 ANS FORMAT - UNDEFINED
         DATA     8                 OUTIN
         DATA     2                 SAVE
         DATA     X'18800'          8=9T
         DATA     1                 VOL # TO START WITH
         DATA     X'01000008'
         RES      8
         DATA     X'07010014'
         RES      20
ANSOPNAGN GEN,1,7,24 1,X'14',12
         DATA     X'C0000000'
         DATA     ERR,ABN
         DATA     X'00010000'       NO VLP LIST
*
*        SET UP FOR BYPASS AND ALLOW REQUESTS
*
BYLIST   GEN,8,24 X'C0',QMSG        BYPASS 'PUT' LIST
ALLIST   GEN,8,24 X'50',QMSG        ALLOW 'PUT' LIST
QMSG     DATA     0                 QUEUE MESSAGE
         DATA     0
         DATA     0
         DATA     0
         DATA     0
         DATA     0
TRAN     TEXT     '                                '
         TEXT     'BYPASS TRANSACTION '
         PAGE
CALLOC   EQU      14
FPTCODE  EQU      29
FNAME    EQU      9                 MUST BE ODD
KNAME    EQU      13
BAKNAME  EQU      KNAME*4
         BOUND    8
IOERR    EQU      %
         TEXTC    'ERROR,CAL AT       FPT CODE    '
         TEXT     'FILE'
         TEXT     '            '
IOERKEY  TEXTC    'KEY                                       '
*
*        FOR LIST
*
         BOUND    8
1LINE    DATA,1   1,13,0,0          CR
TSNBC    EQU      33
TNOSN    DATA,1   18,'N','O',' '
TNO      DATA,1   59,'N','O',' '
TSP      DATA,1   59,' ',' ',' '
*
HD0A     TEXTC    '0000A RECORD'
TX0A     TEXTC    '    JOURNALS                   '
         TEXT     'QUEUE JOURNAL IS                                 '
HDQ      TEXTC    'TPQUEUE RECORD:'
TXQEX    TEXTC    '       GRANULE FILE EXISTS ON     '
TXQNO    TEXTC    '       GRANULE FILE DOES NOT EXIST ON      '
TXQQ     TEXTC    '   BACKUP,    CORE PAGES,    IS KEY SIZE,    % '
         TEXT     'SATURATION'  HAS TO GO IN PREV LINE
QSTATM   TEXTC    'CURRENT QUEUE STATUS:'
QTIDM    TEXTC    'HIGHEST TID QUEUED =          '
QENTM    TEXTC    'ENTRIES:  QUEUED=     IN-PROGRESS=     FAILED=     '
QMAXM    TEXTC    'MAXIMUM ENTRIES QUEUED=     AT   :   '
QSATM    TEXTC    'CURRENT QUEUE SATURATION:    %'
HDJ      TEXTC    'JOURNALS'
JEXIST   TEXTC    '                                EXISTS'
JNOTEXIST TEXTC   '                                DOES NOT EXIST'
TSN      TEXTC    '   SERIAL NUMBERS    LAST USED     '
TXNONE   TEXTC    'RECORD DOES NOT EXIST'
         BOUND    8
TXTQ     TEXT     'TPQUEUE'
TXT0A    TEXT     '0A  '
*
         PAGE
*        ERROR MESSAGES
PG       TEXTC    'UNABLE TO GET ENOUGH PGS'
BADCMD   TEXTC    'COMMAND NOT UNDERSTOOD'
ILLEG    TEXTC    'COMMAND NOT LEGAL DURING PROCESSING'
BADTYPE  TEXTC    'BAD DEVICE TYPE'
QNOSN    TEXTC    'THE QUEUE DOES NOT HAVE SERIAL NUMBERS'
DELBAD   TEXTC    'DELIMITER TABLE IS BAD'
OVERSN   TEXTC    'TOO MANY SERIAL NUMBERS'
BDDEF    TEXTC    'Q OR JRNL, NOT CONSISTANT WITH OLD'
BDTYPE   TEXTC    'DEVICE TYPE DIFFERENT FROM OLD'
BDSIZE   TEXTC    'SIZE DIFFERENT FROM OLD'
BDNAME   TEXTC    'NAME OR Q INFO DIFERENT FROM OLD'
DBLQASS  TEXTC    'Q ALREADY ASSOCIATED WITH ANOTHER JOURNAL'
BADDEC   TEXTC    'FOUND INVALID DECIMAL CHAR'
*
EHMESS   TEXTC    'EH '
         DO       18
         TEXT     '    '
         FIN
0FIELD   TEXTC    'PROG ERR, BYTE STRING COUNT ERROR'
NOREC    TEXTC    'RECORD DOESNT EXIST'
NOTIN0A  TEXTC    'JOURNAL NAME WAS NOT FOUND IN DEFINITION RECORD'
NODEF    TEXTC    'THE FILE DEFINITION DOESNT EXIST'
ILLEGDEF TEXTC    'PROG ERR, INCONSISTANCY IN DEFINITION RECORD'
NOSN     TEXTC    'NO SERIAL NUMBERS'
JNOTOPN  TEXTC    'JOURNAL ISNT OPEN'
SNDONE   TEXTC    '         IS OUT OF SN IN DCB, CLS & REOPN JRNL'
BADTAPE  TEXTC    '               VOLUME BAD, GOING TO NEXT ONE'
BADQRD   TEXTC    '               VOLUME DOES NOT HAVE QUEUE ON BEG'
TOOMANYJ TEXTC    'TOO MANY JOURNALS'
NOQOPN   TEXTC    'QUEUE DEF DOESNT EXIST, SO CANT OPEN'
IDVALUE  TEXTC    '         IS ID VALUE'
IDOK     TEXTC    'IS THAT VALUE OK (Y OR N)'
IDREPLY  TEXTC    '    '
IDN      TEXTC    'N'
IDY      TEXTC    'Y'
INPUTID  TEXTC    'INPUT ID VALUE'
IDINPUT  DATA     0,0,0
IDABORT  TEXTC    'ABORTED ID INITIALIZATION DUE TO ABOVE ERROR'
OPNFILE  TEXTC    'CANT RELEASE SINCE FILE IS OPN'
NOFILE   TEXTC    'ACCORDING TO DEFINITION, FILE DOESNT EXIST'
OVWKPG   TEXTC    'P VALUE NOT WITHIN LIMITS'
FILNOPN  TEXTC    'FILE ISNT OPEN'
NOTNOW   TEXTC    'WAIT, IM BUSY'
TPUSR    TEXTC    'TERMINATE ACTIVE TP USERS AND TRY AGAIN'
XCWHAT   TEXTC 'PROB EXISTS-EXIT,CONTINUE OR REQUEST OP CMD (X,C,R)'
VOLER    TEXTC    'CVOL ERROR- GOING TO CLOSE JRNL'
CONTENT  TEXT     '                '
BMSGH    TEXTC    ' TRANSACTIONS IN BYPASS MODE:'
BYMSG    TEXTC    '                      '
NUM      RES      3
BADHEX   TEXTC    'INVALID HEX DIGITS'
LOCIS    TEXTC    'XCON ENTRY FROM        '
ANSER    TEXTC    'ANS WRITE ERROR,          BLOCKS WRITTEN'
ABTCMD   TEXTC    'ABORTED COMMAND DUE TO ABOVE ERROR'
QSIZEBAD TEXTC    'Q FILE AND ITS DEF DIFFER ON GRAN SIZE'
TERMES   TEXTC    'TPG TERMINATED'
CYCLSN   TEXTC    'OUT OF SERIAL NUMBERS-WILL START AT BEG OF LIST'
JRNLBUSY TEXTC    'CANT CLOSE JRNL-USER CONNECTED TO CFU'
ACTERR   TEXTC    'COMMAND NOT LEGAL UNTIL QUEUE IS OPEN'
BYPERR   TEXTC    'SPECIFIED TRANSACTION ALREADY IN BYPASS MODE'
ALLERR   TEXTC    'NO RECORD OF THIS TRANSACTION IN BYPASS MODE'
         PAGE
TT       CNAME
         PROC
         DATA,1   AF(1)
         LIST     0
         DO       (AF(2)>0)*(AF(2)-1)
         DATA,1   AF(1)
         FIN
         LIST     1
         PEND
*
*        TRANSLATION TABLE
*
TRANTAB  EQU      %
         TT       MSKI,13
         TT       MSK1              CR
         TT       MSKI,21-14
         TT       MSK1              LF OR NL
         TT       MSKI,64-22
         TT       MSK1              SPACE
         TT       MSKI,75-65
         TT       0                 . (PERIOD)
         TT       MSKI,91-76
         TT       0                 %
         TT       0                 *
         TT       MSKI
         TT       MSK4              ;
         TT       MSKI
         TT       MSK10             - (MINUS)
         TT       MSK8
         TT       MSKI,107-98
         TT       MSK2              ,
         TT       0                 %
         TT       MSKI,111-109
         TT       0                 ? (QUESTION MARK)
         TT       MSKI,122-112
         TT       0                 :
         TT       MSK10             #
         TT       0                 @
         TT       MSKI,193-125
         TT       0,202-193         A-I
         TT       MSKI,209-202
         TT       0,218-209         J-R
         TT       MSKI,226-218
         TT       0,234-226         S-Z
         TT       MSKI,240-234
         TT       0,250-240         0-9
         TT       MSKI,256-250
         BOUND    4
P        EQU      %
         DO       30
         DATA     0
         FIN
         PAGE
*
*        INITIALIZE THE GHOST
*
INIT     EQU      %
INI      EQU      %
*  TAKE EXIT TRAP AND OP INT CONTROL
         M:XCON   XCON
         M:TRAP   (IGNORE,FX)
         M:INT    INT
         LI,1     2                 DONT PERMIT INFINITE LOOPS
IN1      EQU      %
         LI,9     03                FILE DOESNT EXIST
*  OPEN TPFILES
         M:OPEN   M:EI,(FILE,'TPFILES'),(KEYED),(DIRECT),(INOUT),;
                  (SAVE),(RECL,512),(KEYM,31),(BUF,*BUF),;
                  (ERR,ERR),(ABN,ABN)
         BGZ      IN4               READ FILE
         BEZ      %+3
         BAL,9    OPOUTX
         B        XIT
*  FILE DOESNT EXIST, CREATE IT
         LI,9     0
         M:OPEN   M:EI,(FILE,'TPFILES'),(KEYED),(DIRECT),(OUT),;
                  (SAVE),(RECL,2048),(KEYM,31),;
                  (ERR,ERR),(ABN,ABN)
         BEZ      IN3               OK
IN2      EQU      %
         BDR,1    IN1
         B        XIT
IN3      EQU      %
*  WRITE SHELL 0A REC, CLOSE, AND RETRY OPEN
         LI,12    0ASHELL
         LI,13    11*4
         LI,14    0AKEY
         LI,9     0
         CAL1,1   WRTTPF
         LI,9     0
         M:CLOSE  M:EI,(SAVE)
         B        IN2
IN4      EQU      %
*  READ 0A REC INTO 0ABUF
         LI,9     0
         CAL1,1   RD0A
         BLZ      XIT
*  GET 2 PGS, PUT ADR OF BEG OF FIRST IN BUF
         CAL1,8   GET2PG
         BCS,8    NOPG
         CI,8     2
         BNE      NOPG
         STW,9    BUF
         B        XIT
NOPG     EQU      %
*  CANT GET PG
         LI,10    PG
         BAL,9    OPOUTX
         B        END
*
XIT      EQU      %
         PAGE
*
*        COMMAND DRIVER
*        DRIVEN BY OPERATOR CMDS
*
DRIVE    EQU      %
*  GET OP CMD
         M:KEYIN  (MESS,CMDREQUEST),(REPLY,CMD),(SIZE,72),(ECB,ECB)
*  FIND INDEX OF CMD IN TABLE
         LB,7     CMD               GET LENGTH
         LI,8     X'08'             EOM IS CANCEL
         CB,8     CMD,7
         BE       DRIVE             START OVER
         LD,2     CMDTTBS
         STB,7    3
         LB,11    0,3               GET 1ST CHAR
         LI,7     CMDTBLSZ
         CB,11    CMDTBL,7
         BE       DR1
         BDR,7    %-2
         LI,10    BADCMD            ERR  CMD NOT UNDERSTOOD
         BAL,9    OPOUTX
         B        DRIVE
DR1      EQU      %
*  SAVE INDEX AND CHECK THAT IT IS WITHIN LEGAL LIMITS
         STW,7    CMDINDEX
         CI,7     CMDTBLSZ1         LIMITED LEGAL SET FOR ACTIVE TP
         BL       DR2
         MTW,0    ACTIVE
         BEZ      DR2
         LI,10    ILLEG             ERR  CMD NOT ALLOWED
         B        DR1-2
DR2      EQU      %
*  GET CMD POINTERS PAST CHAR IN CMD FIELD
         LI,8     X'40'
         CB,8     0,3
         BE       DR3
         AW,3     XFF000001
         BCS,8    %-3               CARRY FROM BIT 0, CONTINUE
         LCI      0
         B        DR5               ONLY ONE FIELD
DR3      EQU      %
*  GET PAST BLANKS TO FIRST FIELD
         CB,8     0,3
         BNE      DR4               FOUND NXT FIELD
         AW,3     XFF000001
         BCS,8    %-3
         B        DR5               NO MORE FIELDS
DR4      EQU      %
*  GET 1ST FIELD
         LI,0     MSK0F             ALL ACTIVE DELIMITERS
         CI,7     CMDTBLSZ1
         BL       %+2               WE ARE ACTIVE
         AI,0     MSK10             OTHERWISE ADD IN # DELIM
         BAL,11   GETUM
DR5      EQU      %
         B        CMDSUBR,7         GO TO CMD PROCESSING SUBR
DRX      BAL,9    OPOUTX            OUTPUT MESSAGE AND RETURN
DRRTN    EQU      %
         MTW,0    ACTIVE
         BEZ      DRIVE
         MTW,0    OQFLG
         BNEZ     E2                ACTIVE, SO GO TO SLEEP
         LI,1     MAXJRNL
         MTW,0    JRNLIOQ,1
         BNEZ     E2                ACTIVE, SO GO TO SLEEP
         BDR,1    %-2
         STW,1    ACTIVE
         B        DRIVE
         PAGE
*
*        SET DEFINITIONS INTO TPFILES
*
SET      EQU      %
         BCR,1    EH                NO FIELDS, OUTPUT ERR INDIC
*  CLEAR BUF
         LI,6     256
         LD,12    ZERO
         STD,12   *BUF,6
         BDR,6    %-1
         STD,12   *BUF
*  GET 1ST FIELD AND CHECK LEGALITY OF DEV TYPE
         LH,12    FIELD
         LI,6     DEVTYPES
         CH,12    DEVTYPE,6
         BE       SET2              FOUND
         BDR,6    %-2
*  BAD DEV TYPE
         LI,10    BADTYPE
         B        SETER
SET2     EQU      %
*  SET DEV TYPE
         AND,12   M16
         LI,5     1
         STW,12   *BUF,5
*  SET Q OOR JRNL DEF BIT
         LW,12    Y2                JRNL DEF BIT
         CI,6     DEVTYPEQ          IS IT Q
         BG       %+2               NO, J
         LW,12    Y4                Q DEF BIT
         STW,12   *BUF
*  DO WE HAVE SERIAL NUMBERS
         CI,1     MSK8              / DELIM IE FILE NAME NEXT
         BE       SET4              GO TO FILE
         CI,1     MSK10             #DELIM IS SN
         BNE      EH                NO SN SO BAD
*  GET AND SET UP SERIAL NUMBERS
         LI,10    QNOSN             Q DOESNT HAVE SNS
         LCF      *BUF
         BCS,4    SETER
         LI,10    DELBAD            DELIM TABLE BAD
         LI,7     12                START OF SN IN BUF
SET3     EQU      %
         BAL,11   GETUM
         BCR,1    EH
*  CONVERT ANS SN 6 BYTE TO 4
         LW,4     FBYTECNT
         CI,4     6
         BNE      EH
         LI,5     0
         LI,6     BA(FIELD)
SETPK1   EQU      %
         LB,9     0,6
         AI,6     1
         SLS,9    26
         SLD,8    2
         SLS,9    -28
         MI,5     10
         AW,5     9
         BDR,4    SETPK1
         SLS,8    20
         OR,8     5
         STW,8    *BUF,7
         AI,7     1
         LI,10    OVERSN
         CI,7     MAXSN+13
         BE       SETER             TOO MANY SNS
         CI,1     MSK2
         BE       SET3              ,DEL, SO CONT
*  SET NUMBER OF SNS INTO BUF
         AI,7     -12
         LI,6     22
         STH,7    *BUF,6
*
*        CHECK IF A DEVICE TYPE WAS GIVEN
*
         LI,12    '9T'              DEFAULT IS 9T
         CI,1     MSK10             MINUS DELIMETER
         BNE      SET3A             NO, CONTINUE
         LI,10    DELBAD
         BAL,11   GETUM
         BCR,1    EH                NO FIELDS IS ERROR
         LH,12    FIELD             GET DEVICE TYPE
         LI,6     TAPETYPES
         CH,12    TAPETYPE,6        CHECK VALIDITY
         BE       SET3A             OK
         BDR,6    %-2               CONTINUE
         B        SETER             ERROR
SET3A    AND,12   M16               MASK HALFWORD
         LI,5     1
         STW,12   *BUF,5            STORE AWAY CJ DEVICE TYPE
         CI,1     MSK8              /DEL
         BNE      EH                NO, ERROR
SET4     EQU      %
*  GET FILE NAME AND SET IN BUF
         LI,10    DELBAD            IN CASE DELIM TBE BAD
         BAL,11   GETUM
         BCR,1    EH                NO FIELDS
         LW,6     FBYTECNT
         LI,8     BA(FIELD)-1       SOURCE
         LW,9     BUF
         SLS,9    2
         AI,9     12                DESTINATION
         AI,6     1                 INCL BYTE CNT
         STB,6    9                 SET BYTE STRING CNT
         MBS,8    0
*  IF TPQUEUE, CK DEF BIT
         LI,10    BADTYPE           BAD DEVICE TYPE
         LI,7     3
         LCI      2
         LM,8     *BUF,7
         CD,8     TXTPQUEUE
         BNE      SET5
         LCF      *BUF
         BCR,4    SETER
         B        SET5B             CONTINUE
SET5     EQU      %
         LCF      *BUF              NOT JOURNAL, BAD SET
         BCR,2    SETER
         CI,1     MSK1              END OF FIELDS
         BE       SET5A             OK FOR JOURNALS
SET5B    EQU      %
         CI,1     MSK4              IS THIS SEMICOLON
         BNE      EH                NO, ERROR
         BAL,11   GETUM
         LW,6     FBYTECNT
         LCF      *BUF              CHECK DEFINITION BIT
         BCS,4    SET6              QUEUE-GET # GRANULES
*  Q SPEC- THIS JRNL ASSOC WITH Q
         LB,8     FIELD
         CI,8     'Q'
         BNE      EH
         LCF      *BUF
         BCS,4    EH                Q NOT ALLOWED ON Q
         BCR,2    EH                HOW COME NOT JRNL
         LW,9     Y1
         STS,9    *BUF
         B        SET7
SET5A    EQU      %
         LCF      *BUF              JOURNAL - OK
         BCR,4    SET7
         LI,10    ILLEGDEF          QUEUE MUST HAVE GRANULES
         B        SETER
SET6     EQU      %
*  SET UP SIZE
         CI,6     1                 GET COUNT OF GRANULE FIELD
         BLE      SET5A             ILLEGAL IF LESS THAN 10 GRANULES
         LI,5     BA(FIELD)
         BAL,15   TOHEX
         LI,6     2
         STW,8    *BUF,6            SET UP GRAN SIZE
SET7     EQU      %
*  DONE SETTING UP RECORD BUF - IF ALREADY EXISTS, UPDATE
         LW,12    BUF
         AI,12    512
         LI,13    512*4
         LW,14    BUF
         AI,14    3                 POINT TO FILE NAME IE KEY
         LI,9     X'43'             NO KEY
         CAL1,1   RDTPF
         BGZ      SET8              READ OK
         BE       SET13             REC DOESNT EXIST
         B        DRX
SET8     EQU      %
*  GOT REC,  COMPARE THEM
         LI,7     6                 # WORDS TO TEST
         LW,8     *BUF,7
         CW,8     *12,7
         BE       SET10             OK
         CI,8     0                 NEW VALUE DOESNT EXIST, SO
         BE       SET10             OK
         XW,8     *12,7             DOES OLD VALUE EXIST
         BEZ      SET10             NO, OK
         LC       *12               DOES QUEUE FILE EXIST
         BCR,8    SET10             NO, REDEFINITION OK
SET9     EQU      %
         CI,7     3
         BL       %+2
         LI,7     3
         LW,10    SETESTER,7        GET ERR MSG
         B        SETER
SET10    EQU      %
         BDR,7    SET8+1
*  AND COMPARE 1ST WD
         LW,8     *BUF
         LW,9     Y6
         CS,8     *12
         BNE      SET9              Q OF J DEF CONFLICT
*  INSURE J ASSOC WITH Q IS LOGICAL
         LW,9     Y1
         CS,8     *12
         BE       SET11             SAME SO OK
         LCF      *BUF
         BCR,1    SET11             NEW CMD DIDNT INDIC, SO OK
*  NEW SPEC OF J ASSOC WITH Q SO SET IN 0A REC
         LI,10    DBLQASS           ASSOC PREVIOUSLY
         LB,7     0ABUF+2
         BNEZ     SETER             ALREADY AN ASSOC
         STS,9    *12               SET ASSOC BIT
*  MOVE J NAME INTO 0A REC
         AI,12    3
         LB,7     *12
         STB,7    0ABUF+2
         LB,8     *12,7
         STB,8    0ABUF+2,7
         BDR,7    %-2
         AI,12    -3
SET11    EQU      %
*  FOR J, MOVE NEW SN BEHIND OLD LIST
         LCF      *BUF              IS IT A J
         BCR,2    SET12             NO
         LW,13    BUF
         AI,13    11
         AI,12    11
         LH,6     *13               # OF NEW SN
         BEZ      SET12             ALL OK, NO NEW ONES
         LH,5     *12               # OF OLD ONES
         LI,10    OVERSN            ERR, IF TOO MANY SN
         LW,8     6
         AW,8     5
         CI,8     MAXSN
         BG       SETER
         STH,8    *12               SET UP #
*  ADD NEW LIST TO END OF OLD
         AW,12    5
         LW,9     *13,6
         STW,9    *12,6
         BDR,6    %-2
         LW,12    BUF
         AI,12    512
         LI,9     X'FFFF'
         AI,8     12
         STS,8    *12
*
*    FINALLY MERGE OF OLD AND NEW RECORDS COMPLETED
SET12    EQU      %
*  SET UP FOR WRITE
         LW,12    BUF
         AI,12    512
         LI,13    X'FFFF'
         AND,13   *12               REC SZ
         SLS,13   2
         LW,14    12
         AI,14    3                 FILE NAME IS KEY ADR
         B        SET15
SET13    EQU      %
*  SINCE NEW REC, ENTER J NAME IN 0A REC
         LW,12    BUF
         LI,13    11
         LW,14    BUF
         AI,14    3                 FILE NAME LOC AND KEY
         LCF      *BUF
*  SET UP QUEUE UNLOCK INFO
         BCS,2    SET135            JRNL, NOT NECESSARY
         LI,7     5
         LW,9     BUF
         AI,9     5
         LW,8     UNSHELL-1,7
         STW,8    *9,7
         BDR,7    %-2
         B        SET14
SET135   EQU      %
         LW,8     0ABUF
         LI,10    TOOMANYJ
         CI,8     0ABUFMAX-7        WILL NEW J DEF OVERFLOW BUF
         BGE      DRX
         AI,8     0ABUF             PTS TO NEXT EMPTY ENTRY IN BUF
         LB,7     *14               NAME SZ
         STB,7    *8                SET IN REC
         LB,9     *14,7
         STB,9    *8,7
         BDR,7    %-2
*  SET JRNL ASSOC WITH Q IN 0A REC IF APPLICABLE
         LCF      *BUF
         BCR,1    SET137            NO Q SPEC
         LI,10    DBLQASS
         LB,7     0ABUF+2
         BNEZ     SETER             ALREADY ANOTHER ASSOC
         LB,7     *14
         STB,7    0ABUF+2
         LB,8     *14,7
         STB,8    0ABUF+2,7
         BDR,7    %-2
SET137   EQU      %
         LI,9     8
         AWM,9    0ABUF             INCR SZ OF REC
*  WRITE 0A REC
         LI,9     0
         CAL1,1   WRT0A
         BLZ      DRRTN
         LI,7     22
         LH,13    *BUF,7            # OF SN
         AI,13    12
SET14    EQU      %
*  PUT REC SZ IN
         LW,8     13
         LI,9     X'FFFF'
         STS,8    *12               SET REC SZ
         SLS,13   2
SET15    EQU      %
         LI,9     0
         CAL1,1   WRTTPF
         BEZ      DRRTN             NO ERR, SO DONE
*  IF WRITE ERR, TAKE J NAME OUT OF 0A IF JUST PUT IN
         CW,12    BUF
         BNE      DRRTN              NO NEED, OLD REC
         LCF      BUF
         BCR,1    DRRTN                       NOT JRNL
         LI,8     0
         LCF      *BUF
         BCR,1    %+2
         STW,8    0ABUF+2            IF ASSOC WITH Q UNDO IT
         MTW,-8   0ABUF
         LI,9     0
         CAL1,1   WRT0A
         B        DRRTN
*
SETER    EQU      %
*  TYPE ERR MSG AND ABORT CMD
         B        DRX
         PAGE
*
*        QUEUE COMMAND
*
QUEUE    EQU      %
*  CLEAR TEMP BUF - USSER TO HOLD NEW SPEC
         LI,7     4
         LI,8     0
         STW,8    QTEMP,7
         BDR,7    %-1
*  READ TPQUEUE REC FOR OLD SPEC
         LW,12    BUF
         LI,13    11*4
         LI,14    TXTPQUEUE         KEY
         LI,9     X'43'
         CAL1,1   RDTPF
         BGZ      QU1               OK, REC EXISTS
         BEZ      QU05              DOESNT
         B        DRX
*  RECORD DOESNT EXIST, SET UP SKELETON
QU05     EQU      %
         LCI      11
         LM,5     QSHELL
         STM,5    *BUF
QU1      EQU      %
*  GET SPEC AND DETERMINE WHETHER FIELD REQUIRES VALUE
         LI,4     5
         LB,6     FIELD
         CB,6     QPARAM,4
         BE       %+3
         BDR,4    %-2
         B        EH                ERR, PARAMETER INVALID
         LI,8     X'20'             FOR BACKUP
         CI,6     'B'
         BE       QU3               'B' DOESNT REQUIRE VALUE
         LW,8     Y8
         CI,6     'N'               IS IT NO BACKUP
         BNE      %+3               NO
         LI,4     1                 YES, NO BACKUP USE BACKUP INDEX
         B        QU3
*  FIELD HAS A VALUE, GET IT
         CI,1     4                 VALID DELIM MASK
         BG       EH                NO
         LB,0     QDELIMS,1         MASK FOR POSSIBLE DELIMITERS
         BEZ      EH                DONE IS ERR
         BAL,11   GETUM             GET FIELD IE VALUE
         BCR,1    EH
*  CONVERT TEXT DECIMAL VALUE TO HEX
         LW,6     FBYTECNT
         LI,5     BA(FIELD)
         LW,10    4                 SAVE PARA INDEX
         BAL,15   TOHEX             RESULT IN 8
         LW,4     10
QU3      EQU      %
         STW,8    QTEMP,4           SAVE VALUE OF PARAM IN TEMP BUF
         B        QVECT,4
*    SUBR FOR CKING VALIDITY OF VALUES ETC
PQ       EQU      %
*  DO PG
         LI,10    OVWKPG
         BAL,15   MASTER
         CW,8     SL:PWP            MAX # OF WORK PG
         BAL,15   SLAVE
         BGE      DRX
         CI,8     4                 4 IS MIN ALLOWED
         BL       DRX
         LI,7     2
         CW,8     *BUF,7            GRAN SIZE OF Q
         BL       QU4
         MTW,0    *BUF,7            OK IF NOT SET YET
         BNE      EH
         B        QU4
KQ       EQU      %
*  DO KEY
         LCF      *BUF              KEY NOT VALID IF Q EXISTS
         BCS,8    EH
         CI,8     16                MAX KEY SIZE
         BGE      EH
         AI,8     1+3               ROUND UP TO WORDS
         SLS,8    -2
         STW,8    QTEMP,4           USE WD CNT, NOT BYTE CNT
         B        QU4
TQ       EQU      %
*  DO THRESHOLD
         CI,8     THRESHMAX
         BG       EH
*    BACK TO ROUTINE Q
QU4      EQU      %
*  GET NEXT FIELD
         CI,1     4                 MAX VALID DELIM MASK
         BG       EH
         LB,0     QDELIMS,1
         BEZ      QU5               DONE
         BAL,11   GETUM
         BCR,1    EH
         B        QU1
QU5      EQU      %
*  GOT ALL FIELDS, SO MERGE IN VALUES
         LI,4     3
         LI,5     10
         LW,8     QTEMP+1,4
         BEZ      %+2
         STW,8    *BUF,5
         AI,5     -1
         BDR,4    %-4
         LI,9     X'20'
         LW,8     QTEMP+1           DO BACKUP PARAM SPECIAL
         STS,8    *BUF,5
*  WRITE RECORD
         LW,12    BUF
         LI,13    QRECSZ
         LI,14    TXTPQUEUE
         LI,9     0
         CAL1,1   WRTTPF            WRITE Q RECORD
         B        DRRTN
         PAGE
*
*        LIST COMMAND
*
LIST     EQU      %
         BCR,1    LI1               NO FIELD, SO DO ALL
*  LIST ONLY WHAT WAS SPEC ONTO OC
         LW,9     Y08
         STS,9    RDTPFLST+1        SET KEY BIT
         LCI      3
         LM,0     OCTYPE
         LW,7     FBYTECNT
         LD,8     FIELD
         CW,8     TXT0A
         BE       LI2               DO 0A REC
         CI,7     7                 IS CNT RIGHT FOR Q
         BNE      %+3
         CD,8     TXTQ              IS IT Q
         BE       LI25
*  NOT 0A OR TPQUEUE, ASSUME JRNL
         STB,7    LKEY
         LW,6     7
         AI,6     -1
         LB,8     FIELD,6
         STB,8    LKEY,7
         BDR,7    %-3
         B        LI5
LI1      EQU      %
*  LIST EVERYTHING ON LL
         LCI      3
         LM,0     LLPRINT
         LW,9     Y08
         LI,8     0
         STS,8    RDTPFLST+1        RESET KEY BIT
LI2      EQU      %
*  OUTPUT 0A RECORD
         BAL,15   LINE
         LI,2     HD0A
         BAL,15   LINE
         LI,4     3                 # OF DEC CHAR
         LI,5     BA(TX0A)+1
         LW,7     0ABUF             # OF WDS IN REC
         AI,7     -10               NUMBER OF JRNL NAME WDS
         SLS,7    -3                NUMBER OF JRNLS
         LW,14    7                 SAVE IT
         BAL,15   HEXTO             HEX TO DEC TO EBCDIC INTO BUF
*  IF Q JRNL THEN INDICATE NAME
         LI,6     12                NUMBER OF CHAR IF NO Q JRNL
         LB,7     0ABUF+2
         BEZ      LI22
         LW,6     7
         LB,8     0ABUF+2,7
         STB,8    TX0A+12,7
         BDR,7    %-2
         AI,6     48                # OF CHAR WITH Q ASSOC J
LI22     EQU      %
         STB,6    TX0A              SET UP RIGHT MESS COUNT
         LI,2     TX0A
         CAL1,2   0                 PRINT
         BAL,15   LINE
         LI,2     0ABUF+10          1ST JRNL NAME
         CI,14    0                 ANY JRNLS
         BEZ      LI25
*  OUTPUT JRNL NAMES FROM 0A REC
         CAL1,2   0
         BAL,15   LINE
         AI,2     8
         BDR,14   %-3
         BAL,15   LINE
         BAL,15   LINE
         LW,9     Y08
         CW,9     RDTPFLST+1
         BANZ     DRRTN             SINGLE REQUEST, SO DONE
*    DO TPQUEUE
LI25     EQU      %
*  READ REC
         LW,12    BUF
         LI,13    44
         LI,14    TXTPQUEUE
         LI,9     X'43'
         CAL1,1   RDTPF
         BGZ      LI3               REC EXISTS
         BEZ      %+2               REC DOESNT EXIST
         BAL,9    OPOUTX
         LW,9     Y08
         CW,9     RDTPFLST+1
         BANZ     LI10
         B        LI4
LI3      EQU      %
         BAL,15   LINE
         LI,2     HDQ
         CAL1,2   0                 HEADING OUT
         BAL,15   LINE
         LI,4     6                 # OF CHAR
         LI,5     BA(TXQEX)+1       MESS FILE EXISTS
         LCF      *BUF
         BCS,8    %+2
         LI,5     BA(TXQNO)+1       MESS FILE DOESNT EXIST
         LI,6     2
         LW,7     *BUF,6            GET GRAN SIZE
         BAL,15   HEXTO             CONVERT AND PUT IN MESS
*  IF GRAN SZ IS 0, THEN PUT ONE ZERO IN GRAN SZ OUTPUT
         LI,8     X'40'
         AI,5     -1
         CB,8     0,5
         BNE      %+3               NUMBER IS NON ZERO
         LI,8     X'F0'
         STB,8    0,5               SET IN 0
*  PUT IN DEVICE TYPE
         LI,6     1
         LW,8     *BUF,6            DEV TYPE
         LI,5     TXQEX+8
         LI,2     TXQEX
         LCF      *BUF
         BCS,8    %+3               DO CORRECT MESS
         LI,5     TXQNO+10
         LI,2     TXQNO
         STH,8    *5                PUT IT IN
         CAL1,2   0                 # GRAN FILE EX/NOT EX ON DC
         BAL,15   LINE
*  BACKUP OR NO BACKUP
         LW,9     TSP               MESS CNT & SP FOR YES BACKUP
         LI,6     7
         LI,8     X'20'             BACKUP BIT
         CW,8     *BUF,6
         BANZ     %+2               YES
         LW,9     TNO               MESS CNT & NO FOR NO BACKU
         STW,9    TXQQ
*  CORE PG
         LI,6     8
         LW,7     *BUF,6            # OF PG
         LI,5     BA(TXQQ+3)
         LI,4     2                 3 OF DIGITS
         BAL,15   HEXTO
*  KEY SIZE
         LI,6     9
         LW,7     *BUF,6            KEY SZ
         SLS,7    2                 TO BYTES
         AI,7     -1                LESS ONE (COUNT BYTE)
         LI,5     BA(TXQQ+6)+3
         LI,4     2
         BAL,15   HEXTO
*  SATURATION
         LI,6     10
         LW,7     *BUF,6            % SATURATION
         BNEZ     %+2               IF DEFAULT SET TO
         LI,7     100               100% SATURATION
         LI,5     BA(TXQQ+10)+3
         LI,4     3
         BAL,15   HEXTO
*  PRINT Q SPECIFICATIONS
         LI,2     TXQQ
         CAL1,2   0
         BAL,15   LINE
         MTW,0    OQFLG             IS QUEUE OPEN
         BEZ      LI31              NO, END OF LIST
         M:QUEUE  0,STATS,(BUF,*BUF),(BSIZE,30)
         LI,2     QSTATM
         CAL1,2   0                 WRITE QUEUE STATUS HDR
         BAL,15   LINE
*
         LI,5     BA(QTIDM)+22
         LI,8     8
         LI,7     1
         LW,7     *BUF,7            GET HIGHEST TID QUEUED
         BAL,15   TOCHAR
         LI,2     QTIDM
         CAL1,2   0                 WRITE HIGHEST TID MSG
         BAL,15   LINE
*
         LI,4     4                 FOUR DIGITS
         LI,7     2
         LW,7     *BUF,7            GET # ENTRIES QUEUED
         LI,5     BA(QENTM)+18
         BAL,15   HEXTO
         LI,4     4
         LI,7     3
         LW,7     *BUF,7            GET # ENTRIES IN-PROGRESS
         LI,5     BA(QENTM)+35
         BAL,15   HEXTO
         LI,4     4
         LW,7     *BUF,4            GET # ENTRIES FAILED
         LI,5     BA(QENTM)+47
         BAL,15   HEXTO
         LI,2     QENTM
         CAL1,2   0                 WRITE ENTRY STATUS MSG
         BAL,15   LINE
*
         LI,4     4
         LI,7     5
         LW,7     *BUF,7            GET MAX ENTRIES QUEUED
         LI,5     BA(QMAXM)+24
         BAL,15   HEXTO
         LI,2     7
         LW,7     *BUF,2            GET TIME OF MAX ENTRIES QUEUED
         LB,7     7
         LI,4     2                 # DIGITS
         LI,5     BA(QMAXM)+32
         BAL,15   HEXTO
         LW,7     *BUF,2
         SLS,7    8
         LB,7     7
         LI,4     2                 # DIGITS
         LI,5     BA(QMAXM)+35
         BAL,15   HEXTO
         LI,7     X'F0'             MAKE :MM TWO DIGITS IF NEEDED
         LI,2     X'40'
         LI,5     BA(QMAXM)+35
         CB,2     0,5
         BNE      %+2
         STB,7    0,5
         LI,2     QMAXM
         CAL1,2   0                 WRITE MAX ENTRIES MSG
         BAL,15   LINE
*
         LI,4     3                 # DIGITS
         LI,7     13
         LW,7     *BUF,7            GET SATURATION
         SLS,7    -16               AND POSITION PER CENT
         LI,5     BA(QSATM)+27
         BAL,15   HEXTO
         LI,2     QSATM
         CAL1,2   0                 WRITE QUEUE SATURATION
         BAL,15   LINE
*
LI31     EQU      %
         LW,9     Y08
         CW,9     RDTPFLST+1
         BANZ     DRRTN
LI4      EQU      %
*  DO JRNL RECORDS
         LW,8     0ABUF
         AI,8     -10               ARE THERE JRNLS
         BEZ      LI10              NONE EXIST
*  JRNL HEAD
         BAL,15   LINE
         LI,2     HDJ
         CAL1,2   0
         BAL,15   LINE
         M:PFIL   M:EI,(BOF)
         LI,8     0
         LW,9     Y08
         STS,8    RDTPFLST+1        TURN OFF KEY
LI5      EQU      %
         LI,13    512
         BAL,15   LINE
         LW,12    BUF
         LI,9     06
         CAL1,1   RDTPFLST
         BEZ      LI10              FINISHED
         BGZ      LI52              NO ERR
         LW,9     Y08
         CW,9     RDTPFLST+1
         BANZ     LI10              SINGLE REQUEST
         B        DRX
LI52     EQU      %
         LI,2     JEXIST
         AI,12    3                 TO NAME
         LCF      *BUF
         BCR,2    LI5               NOT JRNL
         BCS,8    %+2               IT EXISTS
*  MOVE NAME TO EITHER EXIST OR NOT EXIST BUFFER
         LI,2     JNOTEXIST
         LI,7     31
         LI,8     X'40'
         CB,7     *12               ARE WE TO NAME YET
         BE       %+3               YES
         STB,8    *2,7              FILL WITH SPACES
         BDR,7    %-3
         LB,8     *12,7
         STB,8    *2,7
         BDR,7    %-2
         CAL1,2   0                 OUTPUT NAME AND WHETHER IT EXISTS
         BAL,15   LINE
         AI,12    11-3              TO # OF SNS
         LW,8     TNOSN              IN CASE NONE
         STW,8    TSN               PUT NO IN
         LH,7     *12
         BEZ      LI57              NO SN
         LI,4     17
         LI,8     'S'
         CI,7     1
         BG       %+2               MAKE MESS PLURAL
         LI,8     X'40'             MAKE SN SINGULAR
         STB,8    TSN,4
         LI,4     2                 # OF CHAR
         LI,5     BA(TSN)+1
         BAL,15   HEXTO
*  INDICATE LAST USED
         LI,7     X'FFFF'
         AND,7    *12               CURRENT POS
         LI,4     2
         LI,5     BA(TSN+8)
         BAL,15   HEXTO
         LI,8     TSNBC
         STB,8    TSN
LI57     EQU      %
         LI,2     TSN
         CAL1,2   0
         BAL,15   LINE
         LH,7     *12               # OF SN
         BEZ      LI9
         LW,10    BUF
         AI,10    512               2ND BUF, USE FOR SNS
         LI,15    LI75
DEPACK   EQU      %
LI6      EQU      %
         LW,2     *12,7             GET SN
*  DEPACK SNS
         LW,8     SPACES
         SLD,2    -20
         SLS,3    -12
         LW,5     3
         LI,6     6
LI7      EQU      %
         SLD,2    -2
         SLS,3    -26
         LI,4     0
         DW,4     XA
         OR,3     4
         BEZ      %+2
         AI,3     X'80'
         AI,3     X'40'
         SLD,8    -8
         STB,3    8
         BDR,6    LI7
         STD,8    *10,7
         BDR,7    LI6
         B        *15
LI75     EQU      %
         LH,7     *12               # OF SN
         LW,2     10                BUF ADR
         AI,2     1
LI8      EQU      %
*  OUTPUT SN IN GROUPS OF 8
         LW,8     SPACES
         STW,8    *2
         LI,8     (8*8)+3           8 CHAR * 8 SNS
         CI,7     8                 IS THERE 8
         BGE      %+4               YES
         LW,8     7
         SLS,8    3
         AI,8     3                 MESS SZ FOR LESS THAN 8
         STB,8    *2
         CAL1,2   0                 OUTPUT A LINE OF SN
         BAL,15   LINE
         AI,2     (2*8)
         AI,7     -8
         BGZ      LI8               STILL MORE
LI9      EQU      %
         LW,9     Y08
         CW,9     RDTPFLST+1
         BAZ      LI5               NO, AVERYTHING SO CONT
         B        DRRTN
LI10     EQU      %
*  IF REC DOESNT EXIST FOR SINGLE REQUEST, OUTPUT DOESNT EXIST
         LW,9     Y08
         CW,9     RDTPFLST+1
         BANZ     %+3               SINGLE REQUEST
         CAL1,9   6                 DO ALL, SO SUPER CLOSE
         B        DRRTN
         LI,2     TXNONE
         CAL1,2   0
         B        DRRTN
*
LINE     EQU      %
         DO       GOD
         B        *15               NO 'LF' NEEDED ON OC
         ELSE
         STW,2    SAVR2
         LI,2     1LINE
         CAL1,2   0                 PRINT NL/CR
         LW,2     SAVR2
         B        *15
         FIN
         PAGE
*
*        DELETE A RECORD FROM TPFILES  COMMAND
*
DELETE   EQU      %
         BCR,1    EH
*  SET UP KEY & DELETE RECORD
         LW,7     FBYTECNT
         CI,7     31
         BG       EH                NAME TOO LONG
         LW,6     7
         STB,7    LKEY              PUT IN BYTE CNT
         AI,6     -1
         LB,8     FIELD,6
         STB,8    LKEY,7
         BDR,7    %-3
DE2      EQU      %
*  TAKE OUT OF 0A REC, IF IN IT
         LB,7     LKEY
         LW,6     0ABUF             SZ OF 0A REC
         AI,6     0ABUF
DE3      EQU      %
         LB,7     LKEY
         AI,6     -8
         CI,6     0ABUF+2
         BLE      DE7               NO JRNL
         CB,7     *6                IS CNT SAME
         BNE      DE3               THIS NAME ISNT SAME
         LB,8     LKEY,7
         CB,8     *6,7
         BNE      DE3               NOT SAME
         BDR,7    %-3
*  FOUND ENTRY, TAKE IT OUT BY MOVING REST OF ENTRIES DOWN
         LW,5     0ABUF
         AI,5     0ABUF
DE4      EQU      %
         LW,7     6                 TO LOC
         AI,6     8                 FROM LOC
         CW,6     5                 IS THIS ALL DONE
         BE       DE5               YES
         LCI      8
         LM,8     0,6
         STM,8    0,7
         B        DE4
DE5      EQU      %
*  UPDATE 0A REC CNTS
         MTW,-8   0ABUF             DECR REC SZ
*  IS THIS J ASSOC WITH Q
         LB,7     LKEY
         CB,7     0ABUF+2           DOES CNT MATCH
         BNE      DE6
         LB,8     LKEY,7
         CB,8     0ABUF+2,7
         BNE      DE6
         BDR,7    %-3
         STB,7    0ABUF+2           0 BYTE CNT, IE DESTROY ASSOC
DE6      EQU      %
*  WRITE 0A REC SINCE ITS UPDATED
         LI,9     0
         CAL1,1   WRT0A
DE8      EQU      %                 DELETE RECORD FROM TPFILES
         LI,9     X'13'
         M:DELREC M:EI,(KEY,LKEY)
         BG       DRRTN             NO ERRORS
         BLZ      %+2               UNEXPECTED ERROR
         LI,10    NOREC             RECORD DOESN'T EXIST
         B        DRX
*
DE7      EQU      %
*  NO JRNL, SO IT HAD BETTER BE Q
         LCI      2
         LM,8     LKEY
         CD,8     TXTPQUEUE
         BE       DE8               IT IS OK
         LI,10    NOTIN0A           RECOR DELETED WASNT IN 0A
         B        DRX
         PAGE
BYPASS   EQU      %                 BYPASS TRANSACTION COMMAND
         BCR,1    BYLISTX           NO NAME GIVEN, MUST BE LIST
         MTW,0    OQFLG             IS THE QUEUE OPEN
         BNEZ     BYPASS1           YES, CONTINUE
BYERR1   LI,10    ACTERR            TP NOT ACTIVE
         B        DRX               ELSE, ERROR
*
BYPASS1  LW,1     FBYTECNT          GET LAST BYTE OF NAME
         AI,1     -1
         LB,6     FIELD,1
         CI,6     '.'               AND CHECK FOR PERIOD
         BNE      EH                ERROR IF MISSING
*
BYPASS2  LI,1     0
         LI,7     16
BYPASS3  LB,6     FIELD,1           MOVE NAME TO PUT MSG
         CI,6     '.'               END
         BE       BYPASS4
         STB,6    TRAN,1            STORE IN MSG
         AI,1     1
         CI,1     7
         BG       EH                NAME TOO LONG
         B        BYPASS3
*
BYPASS4  STB,6    TRAN,1            STORE PERIOD(.)
         STW,1    SAVR2             SAVE R1
         AI,1     1                 ADJUST FOR ZERO
         CW,1     FBYTECNT          DID WE GET IT ALL
         BNE      EH
         AI,1     8                 ADD IN TID LENGTH
         LI,5     BA(TRAN)-1
         STB,1    0,5               STORE LENGTH IN MESSAGE
*
         M:GETID
         BCS,8    BYERR1            TP NOT ACTIVE
         STW,8    QMSG+4
         LI,5     BA(TRAN)+1        COMPUTE POSITION FOR TID
         AW,5     SAVR2
         LW,7     8
         LI,8     8
         BAL,15   TOCHAR            CONVERT TID TO EBCDIC
         LW,1     SAVR2
         AI,1     8+24+1            COMPUTE PUT MESSAGE LENGTH
         STW,1    QMSG
*
BYPASS5  LW,1     FBYTECNT          BUILD KEY FOR TPFILES RECORD
         AI,1     1
         LI,8     BA(FIELD)-1       TRANNAME + COUNT IS KEY
         LW,9     BUF
         SLS,9    2                 BYTE ADDRESS
         STB,1    9
         MBS,8    0
*
         LW,12    BUF               MAKE SURE TRANSATION IS NOT
         AI,12    32                ALREADY IN BYPASS MODE
         LI,13    19*4
         LW,14    BUF               KEY ADDRESS
         LI,9     X'43'             NO SUCH KEY IS GOOD RETURN
         CAL1,1   RDTPF
         BNE      BYERR2            TRAN ALREADY IN BYPASS MODE
*
         LI,10    0                 SET TRANSACTION BYPASS
         DO1      GOD
         M:QUEUE  BYLIST,PUT,(LSIZE,1),(HIGH),(WAIT)
         CI,10    0
         BNE      DRX
*
*                                   NOW WRITE BYPASS TRAN TO TPFILES
*
         LI,12    QMSG              BUFFER ADDR
         LW,13    QMSG              SIZE
         LW,14    BUF               KEY ADDRESS
         LI,9     0
         CAL1,1   WRTTPF            WRITE TPFILES
         B        DRRTN
*
BYERR2   LI,10    BYPERR            TRANSACTION ALREADY BYPASSED
         B        DRX
*
         PAGE
ALLOW    EQU      %                 ALLOW TRANSACTION COMMAND
         BCR,1    EH                NO NAME GIVEN
         MTW,0    OQFLG             IS THE QUEUE OPEN
         BNEZ     ALLOW1            YES
         LI,10    ACTERR
         B        DRX
ALLOW1   LW,6     FBYTECNT          GET COUNT OF NAME
         LI,8     BA(FIELD)-1
         LW,9     BUF
         SLS,9    2
         AI,6     1                 INCLUDE COUNT IN SIZE
         STB,6    9
         MBS,8    0                 MOVE NAME TO KEY BUFFER
         LI,12    QMSG              Q MESSAGE BUFFER
         LI,13    19*4              SIZE
         LW,14    BUF               KEY ADDRESS
         LI,9     X'43'             KEY NOT FOUND ERROR
         CAL1,1   RDTPF             READ PUT MSG FROM TPFILES
         BLZ      DRX
         BEZ      NORECX            RECORD DOESN'T EXIST
*
         LI,10    0                 SET ABNORMAL FLAG
         DO1      GOD
         M:QUEUE  ALLIST,PUT,(LSIZE,1),(HIGH),(WAIT)
         CI,10    0
         BNE      DRX
         LI,9     X'13'             DELETE FROM TPFILES
         M:DELREC M:EI,(KEY,*BUF)
         BLZ      DRX
         BGZ      DRRTN             RETURN
*
NORECX   LI,10    ALLERR            NO RECORD OF THIS TRAN
         B        DRX
         PAGE
BYLISTX  EQU      %                 LIST BYPASSED TRANSACTIONS
         LCI      3
         LM,0     OCTYPE            GET M:TYPE FPT
         LI,2     BMSGH             OUTPUT HEADER
         CAL1,2   0
         BAL,15   LINE
*
         M:PFIL   M:EI,(BOF)
         LI,8     0                 SET TO READ SEQUENTIAL
         LW,9     Y08
         STS,8    RDTPFLST+1
         LI,9     6                 EOF CODE
         LW,12    BUF               BUFR
         LI,13    10                SIZE (DOESN'T MATTER)
RDBYPASS CAL1,1   RDTPFLST
         BE       DRRTN             EOF
         LW,6     M:EI+10           GET KBUF
         LB,3     *6
         LB,7     *6,3              GET LAST BYTE OF KEY
         CI,7     '.'               IS IT A BYPASS RECORD
         BNE      RDBYPASS          NO
*
         SLS,6    2                 BYTE ADDRESS
         AI,6     1                 IGNORE COUNT BYTE
         LI,7     BA(BYMSG)+5
         STB,3    7
         MBS,6    0                 MOVE TO MESSAGE
         LI,2     BYMSG
         CAL1,2   0
         BAL,15   LINE
*
         LCI      4
         LM,4     CONTENT           BLANK BUFFER
         STM,4    BYMSG+1
*
         B        RDBYPASS          CONTINUE
*
         PAGE
*
*        OPEN COMMAND  OPN Q OR JRNL
*
OPEN     EQU      %
         BCR,1    EH                NO FIELD, THEN ERR INDIC
         LI,0     OP1
*  SET UP KEY
OP0      EQU      %
         LW,7     FBYTECNT
         STB,7    LKEY
         LW,6     FBYTECNT
         AI,6     -1
         LB,8     FIELD,6
         STB,8    LKEY,7
         BDR,7    %-3
*  SET UP TO READ J INTO BUF OR Q INTO QRECBUF
         LW,12    BUF               BUF FOR J
         LI,13    JRECSZ
         LD,8     FIELD
         CD,8     TXTQ              IS IT Q
         BNE      %+3
         LI,12    QRECBUF
         LI,13    QRECSZ
*  GET RECORD FROM TPFILES
         LI,14    LKEY
         LI,9     X'43'
         CAL1,1   RDTPF
         BG       *0
         BLZ      DRX               ANOTHER ERROR
         LI,10    NODEF             FILE DEF DOESNT EXIST
         B        DRX
OP1      EQU      %
         CI,12    QRECBUF
         BNE      OPNJRNL
OQ0      EQU      %
         LI,0     OQ3               RETURN ADR
OQ1      EQU      %
*  SET UP FILE OPEN INFO
         LI,7     3
         LH,8     QRECBUF,7         GET DEV TYPE
         LI,6     2
         CH,8     DEVTYPE,6
         BE       OQ2
         BDR,6    %-2
         LI,10    BADTYPE
         B        DRX               DEV TYPE BAD
OQ2      EQU      %
         LW,8     DEVCODE-1,6
         LI,9     X'F00'
         STS,8    OQFPT+7           SET DEV CODE IN FPT
         LI,7     2
         LW,8     QRECBUF,7
         STW,8    OQFPT+8           SET GRAN SZ
         B        *0
OQ3      EQU      %
*  SEE IF FILE EXSTS
         LI,10    ILLEGDEF
         LCF      QRECBUF
         BCR,4    DRX               SAYS ITS NOT A QUEUE DEF
         BCS,8    OQ4               FILE EXISTS
         LI,8     2                 FCN=OUT
         STW,8    OQFPT+5
*  CREATE Q FILE BY OPEN OUT AND CLOSE SAVE & SET EXIST BIT
         LI,9     0
         CAL1,1   OQFPT
         BNEZ     DRRTN
*  CLEAR BUFFER TO WRITE ZEROS TO Q FILE
         LI,7     511
         LI,8     0
         STW,8    *BUF,7
         BDR,7    %-1
         STW,8    *BUF
*  SET UP FPT & INITIALIZE LOOP
         STW,8    WRTQFPT+6         SET BLOCK CNT
         LW,6     QRECBUF+2         GRAN SIZE
OQ35     EQU      %
         LI,9     0
         CAL1,1   WRTQFPT
         BNEZ     %+3
         MTW,1    WRTQFPT+6
         BDR,6    OQ35
         LI,9     0
         M:CLOSE  F:QDCB,(SAVE)
         BLZ      DRRTN
         LI,9     X'40'
         STS,9    QRECBUF+7         SET NEW Q FLG IN UNLOCK
OQ4      EQU      %
*  SET INOUT BIT AND DO OPEN
         LI,8     4                 FCN=INOUT
         STW,8    OQFPT+5
         LI,9     0
         CAL1,1   OQFPT
         BLZ      DRRTN             ERR
         LW,15    F:QDCB+20
         AND,15   M16
         LI,10    QSIZEBAD
         CW,15    QRECBUF+2         ARE GRAN SIZES THE SAME
         BNE      OQ45              NO, DEF DIFFERENT FROM FILE
         BAL,15   QCK
*  UNLOCK Q USING INFO IN Q REC
         LI,10    0
         DO       GOD
         CAL1,7   QRECBUF+6         UNLOCK
         STW,8    TEMPID            SAVE THE ID
         FIN
         CI,10    0
         BEZ      OQ5               UNLOCK OK
*  COULDNT UNLOCK SO ABORT CMD
OQ45     EQU      %
         LI,8     0
         BAL,9    OPOUTX            OUTPUT UNLOCK ERROR
         M:CLOSE  F:QDCB,(SAVE)
         LI,10    ABTCMD
         B        DRX
OQ5      EQU      %
*  SET OLD Q BIT AND EXIST BIT
         MTW,1    OQFLG             INDICATE THAT QUEUE IS OPEN
         LI,8     0
         LI,9     X'40'             OLD Q
         STS,8    QRECBUF+7
         LW,9     Y8
         STS,9    QRECBUF           SET EXIST BIT
         LI,12    QRECBUF
         LI,13    QRECSZ
         LI,14    TXTPQUEUE
         LI,9     0
         CAL1,1   WRTTPF            UPDATA TPQUEUE RECORD
         LW,7     TEMPID
         B        ID2
OQ6      EQU      %
         LW,7     CMDINDEX
         CI,7     GOINDEX           WAS IT GO CMD
         BE       G2                YES, RTN TO GO, DONT COLLECT %200
         B        DRRTN
*
*        OPEN JRNL
*
OPNJRNL  EQU      %
*  WASNT Q, SO TEST FOR JRNL
         LI,10    ILLEGDEF
         LCF      *BUF
         BCR,2    DRX               ILLEGAL DEFINITION, NOT A JRNL
*  CHECK DEVICE TYPE
         LI,7     3
         LH,8     *BUF,7
         LI,6     TAPETYPES         TEST FOR TAPE TYPE
         LI,10    BADTYPE
         CH,8     TAPETYPE,6
         BE       OPENJ1            FOUND JOURNAL DEVICE TYPE
         BDR,6    %-2
         B        DRX               BAD DEVICE TYPE FOR JOURNAL
OPENJ1   EQU      %
*  PREPARE OPEN ANS TAPE FP
         LI,10    TOOMANYJ
         LI,1     MAXJRNL
         MTW,0    JRNLIOQ,1
         BEZ      %+3               FOUND AN EMPTY SLOT
         BDR,1    %-2
         B        DRX               NO SLOTS - TOO MANY JRNLS
         LCF      *BUF              IS THIS A Q JRNL
         BCR,1    %+2               NO
         STW,1    QJINDEX           YES SAVE INDEX
         LH,8     TAPETYPE,6        STORE DEVICE TYPE IN FPT
         AND,8    M16
         STW,8    ANSFPT+7
         LI,4     2
         LW,8     ANSDCB,1
         LI,9     X'1FFFF'
         STS,8    ANSFPT            SET UP DCB
         DO       GC=0
         LW,8     CFUDCB,1
         STS,8    CFUFPT            SET UP DCB
         FIN
*  SET UP JRNL NAME IN JRNL, ANSFPT AND CFUFPT
         LW,9     BUF
         AI,9     3
         LW,8     JRNLNAM,1         GET JRNL NAME ADR
         LB,7     *9                BYTE CNT OF NAME
         STB,7    ANSFPT+10
         DO1      GC=0
         STB,7    CFUFPT+9
         STB,7    *8
OJ1      EQU      %
         LB,10    *9,7              GET NAME
         STB,10   ANSFPT+10,7
         DO1      GC=0
         STB,10   CFUFPT+9,7
         STB,10   *8,7              SAVE NAME IN JRNL TABLE
         BDR,7    OJ1
*  SET # OF WDS OF NAME IN THE FPTS
         LI,7     2
         LB,8     *9
         AI,8     4                 FOR CNT OF NAME
         SLS,8    -2
         STB,8    ANSFPT+9,7
         DO1      GC=0
         STB,8    CFUFPT+8,7
*  MOVE SNS INTO FPT
OJ2      EQU      %
         LI,10    NOSN
         LI,5     22
         LH,6     *BUF,5            # OF SNS
         BEZ      OJ3               ERR, NO SN
         AI,5     1
         LH,5     *BUF,5            RELATIVE POSITION
         LW,9     BUF
         AI,9     10
         AW,9     5                 NXT SN REL TO BEG OF BUF
         SW,6     5
         BGZ      OJ25
         LI,10    CYCLSN            OUT OF SN
         BAL,9    OPOUTX
         LI,5     23
         LI,6     0
         STH,6    *BUF,5            START AT BEG OF LIST
         B        OJ2
OJ25     EQU      %
         AI,9     1
         CI,6     TMAXSN
         BLE      %+2
         LI,6     TMAXSN            MAX AT ONE TIME TO FIT IN DCB
         LI,4     2
         STB,6    ANSFPT+18,4       SET UP # OF SN IN FPT
         STW,6    #JRNLSN,1
         SLS,1    1
         STH,6    #JRNLSN,1
         SLS,1    -1
         LW,8     *9,6
         STW,8    ANSFPT+18,6       SN TO DCB
         BDR,6    %-2
*  OPEN ANS TAPE
         LI,9     0
         CAL1,1   ANSFPT            OPN JRNL
         BLZ      OJ3               OPN ERR
         DO       GC
*  GET A CFU
         BAL,15   MASTER
         LI,7     2
         LI,8     BGRCFU
         LI,9     X'10'
CFU1     EQU      %
         LC       *8                IS CFU BUSY
         BCR,4    CFU3              NO
         CB,9     *8,7              JRNL CFU
         BE       CFU1B             YES, TEST FURTHER
CFU1A    EQU      %
         AI,8     CFUSIZE
         CW,8     ACNCFU+13
         BL       CFU1
         M:WAIT   12
         B        CFU1-2
CFU1B    EQU      %
*  FOUND AN OLD JOURNAL CFU--USE IT AGAIN
         LW,10    *8,7              CHECK FOR SAME FILENAME
         LW,11    JRNLNAM,1
         LB,6     *11               BYTE COUNT
         AI,6     1
         SLD,10   2                 BYTE ADDRESSES
         STB,6    11
         CBS,10   0                 ARE THEY THE SAME
         BNE      CFU1A             NO, DON'T USE IT
CFU3     EQU      %
*  FOUND A CFU  HOLD IT
         LW,6     Y4
         STW,6    *8                SET BUSY
         STB,9    *8,7              JRNL MODE
         LI,6     0
         STW,6    *8,7              ACCT AND NAME
         LI,6     1
         STB,7    *8,6              SET # OF USERS TO 1
CFU4     EQU      %
*  TRY TO FIND NAME IN CFU NAME TABLE
         LW,10    JRNLNAM,1         ADR OF TEXTC JRNL NAME
         LW,5     ACNCFU+15         PTS TO 1ST WD IN NAME TAB
CFU5     EQU      %
         LB,6     *5                GET CNT OF NAME
         CB,6     *10               IS CNT SAME
         BNE      CFU7
CFU6     EQU      %
         LB,11    *5,6              GET BYTE FROM CFU NAME
         CB,11    *10,6             IS IT SAME AS JRNL NAME
         BNE      CFU7
         BDR,6    CFU6
         B        CFU9              FOUND NAME-SO SET ADR IN CFU
CFU7     EQU      %
         LB,6     *5
         SLS,6    -2
         AI,6     1
         AW,5     6
         CW,5     ACNCFU+16         AT END OF ACTIVE NAMES
         BL       CFU5              NO
*  NAME NOT IN TABLE
         LB,6     *10
         SLS,6    -2
         AI,6     1
         LW,11    5                 WHERE JRNL NAME GOES
         AW,11    6                 SIZE OF JRNL NAME
         CI,11    LASTCFU           WILL IT FIT
         BLE      CFU8              YES
         M:WAIT   12
         B        CFU4              TRY AGAIN
CFU8     EQU      %
*  PUT JRNL NAME INTO CFU NAME TABLE
*  5=FREE ENTRY IN CFU NAME TABLE
*  10=ADR OF JRNL NAME
*  11=ADR OF WD JUST BEYOND LAST ACTIVE NAME
         LB,6     *10
         STB,6    *5
         LB,9     *10,6
         STB,9    *5,6
         BDR,6    %-2
         STW,11   ACNCFU+16
CFU9     EQU      %
         AW,5     Y0001             1 IS INDEX OF :SYS ACCT
         STW,5    *8,7              ACCT INDEX & NAME ADR INTO CFU
         BAL,15   SLAVE
         B        OJ4
         ELSE
*  OPEN PUBLIC CONSEC FILE TO STEAL ITS CFU
         CAL1,1   CFUFPT
         BEZ      OJ4
*  IF ERROR, CLOSE ANS DCB AND ERR EXIT
         LW,12    ANSDCB,1
         LI,9     0
         CAL1,1   CANSFPT
         FIN
OJ3      EQU      %
         MTW,-1   #JRNL
         B        DRRTN
OJ4      EQU      %
         DO       GC=0
*  GET CFU ADR AND SAVE IN JRNL TABLE
         LI,8     X'1FFFF'
         LW,4     CFUDCB,1
         BAL,15   MASTER
         AND,8    1,4               GET CFU ADR
         BAL,15   SLAVE
         FIN
         STW,8    JRNLCFU,1         SAVE IT
         MTW,1    JRNLIOQ,1
         MTW,1    #JRNL
         B        CV9
         PAGE
*
*        CVOL EITHER OP CMD OR SYS DRIVEN
*
CVOL     EQU      %
*
*  ENTRY FOR OPERATOR REQUESTED VOL CHANGE
*
         LI,0     CV6
CV0      EQU      %
         LI,1     MAXJRNL
CV1      EQU      %
         MTW,0    JRNLIOQ,1         IS IT A GOOD ENTRY
         BEZ      CV2               NO, NOT IN USE
         LW,7     FBYTECNT
         LW,6     FBYTECNT
         LW,5     JRNLNAM,1         GET MANE ADR
         CB,7     *5
         BNE      CV2               CNT ISNT RIGHT
         AI,6     -1
         LB,8     FIELD,6
         CB,8     *5,7              DOES NAME COMPARE
         BNE      CV2               NO
         BDR,7    %-4
*  FOUND NAME
         LI,9     X'1C'             SET JOURNAL
         SLS,9    16                VOLUME SWITCH
         B        *0
CV2      EQU      %
         BDR,1    CV1
         LI,10    JNOTOPN
         B        DRX
*
*  ENTRY FOR SYSTEM REQUESTED VOLUME CHANGE
*
CV4      EQU      %
         LI,1     MAXJRNL           # OF JRNLS
         BAL,15   MASTER
CV5      EQU      %
*  FIND CFU WHERE SYSTEM SET CDAM INTO SREC TO INDIC CVOL NEEDED
         MTW,0    JRNLIOQ,1
         BEZ      CV55              ENTRY NOT ACTIVE
         LW,7     JRNLCFU,1
         LW,9     TDA,7             GET IOQ INFO
         MTB,0    9                 IS BYTE ZERO SET
         BEZ      CV57              NEED VOL CHANGE
CV55     EQU      %
         BDR,1    CV5
         BAL,15   SLAVE
         B        DRRTN             NO MORE VOL CHANGES TO PERFORM
*
*        COMMON CODE TO BOTH OPER & SYS INITIATED CVOL
*
CV57     EQU      %
         BAL,15   SLAVE
CV6      EQU      %
         LI,10    SNDONE
         LW,2     1
         SLS,2    1
         MTH,-1   #JRNLSN,2
         BGZ      CV7               MORE SN
*  SET UP JRNL NAME IN ERR MESS FOR NO MORE SN
         LI,7     8
         LW,12    JRNLNAM,1
         LI,8     X'40'
         STB,8    *10,7
         BDR,7    %-1
         LB,7     *12
         CI,7     8
         BLE      %+2
         LI,7     8
         LB,8     *12,7
         STB,8    *10,7
         BDR,7    %-2
         B        DRX
CV7      EQU      %
         LW,12    ANSDCB,1          DCB ADR IN 12
         LW,7     JRNLCFU,1
         BAL,15   MASTER
         STW,9    TDA,7             SET IOQ INFO
         LI,8     0
         XW,8     SREC,7            GET # OF BLOCKS WRITTEN
         LI,6     17
         DO1      GOD
         STW,8    *12,6             BLK COUNT TO DCB
         BAL,15   SLAVE
         LH,9     9
         CI,9     X'45'             IS IT PERM WRT ERR
         BNE      CV8               NO
         LW,7     *12,6             # OF BLOCKS
         AND,7    M24
         STW,7    ANSBLKS           SAVE NO. OF TAPE BLOCKS
         LI,4     6
         LI,5     BA(ANSER+4)+2
         BAL,15   HEXTO
         LI,10    ANSER
         CAL1,2   OPOUTFPT
         B        ERRECOV           BACK UP AND CVOL JOURNAL
CV8      EQU      %
         CI,9     X'1C'             IS IT VOL CHANGE
         BNE      CV8B              NO - SOME PROBLEM
         LI,9     0
         CAL1,1   CVOLFPT           CHANGE VOLUME
         BEZ      CV9
CV8B     EQU      %
         LI,10    VOLER
         BAL,9    OPOUTX
         B        CJ0               VOL ER, CLOSE OUT JRNL
CV9      EQU      %
*  IF JRNL ASSOC WITH Q, COPY Q TO JRNL
         CW,1     QJINDEX
         BNE      CV14              NOT THE J ASSOC WITH Q
         MTW,0    OQFLG             IS Q OPEN
         BEZ      CV14              NO, DONT COPY IT
         LI,10    0
         DO1      GOD
         CAL1,7   PAUSEFPT          LOCK, PAUSE TO Q
CV9A     EQU      %
         LW,12    ANSDCB,1
         LI,13    X'1FFFF'
         STS,12   WRTQJRNL
*  INITIALIZE HEADER OF BUF FOR Q WRT TO JRNL TAPE
         M:TIME   TIME,TMS
         LI,5     512-5
         LW,6     WD1JWRT
         LI,7     0
         LCI      4                 TIME IN REG 8 & 9
         STM,6    *BUF,5
         STW,7    RDQFPT+6
         LW,6     QRECBUF+2         GRAN SIZE
CV10     EQU      %
         LW,12    BUF
         AI,12    511               BUF ADR IS 2ND PG -1
         LI,13    BADQRD+2
         LI,9     0
         CAL1,1   RDQFPT
         BEZ      CV12
*  READ ERR - ABORT COPY, OUTPUT MESS & REWIND TAPE
CV11     EQU      %
         LW,10    13                ERR MSG
*  GET SN AND PUT IN MSG
         LW,5     ANSDCB,1
         LI,6     COS
         LB,7     *5,6              REL SN
         LW,12    FLP,5             BEG OF VLP
         LI,15    5                 NO. ANS VLPS
         LI,5     3                 BYTE CONTAINING LENGTH OF VLP
NXTVLP   LB,6     *12               GET VLP CODE
         CI,6     X'07'             SN ADDRESS
         BE       FOUND             YES
         LB,6     *12,5             LENGTH OF VLP
         AW,12    6                 STEP TO NEXT VLP
         AI,12    1
         BDR,15   NXTVLP            AND CONTINUE
FOUND    EQU      %                 R12=A(SN TABLE)
         AND,12   M17
         AW,12    7                 ADR OF BAD VOL - PRESENT ONE
         LI,7     0
         BAL,15   DEPACK
         AI,10    -2                BEG OF MSG
         BAL,9    OPOUTX
         LW,12    ANSDCB,1          DCB ADDRESS
         CI,13    BADTAPE+2         TAPE ERROR
         BNE      CV11A             NO, QUEUE ERROR
         M:CLOSE  *12,(REM)         SWITCH TO A NEW TAPE
         LI,9     0
         CAL1,1   ANSOPNAGN         REOPEN THIS VOLUME
         B        CV9A              AND CONTINUE
*
CV11A    EQU      %
         M:CLOSE  *12,(PTV)         ANS REWIND
         LI,9     0
         CAL1,1   ANSOPNAGN         REOPEN
         B        CV13              AND CONTINUE
*
CV12     EQU      %
*  SET UP CHECKSUM
         AI,12    -4                INCL HEADER IN BUF
         LI,7     1
         LW,8     *12
CV122    EQU      %
         AW,8     *12,7
         BNC      %+2
         AI,8     1
         AI,7     1
         CI,7     512+4             FINISHED
         BL       CV122             NO
         STW,8    *12,7
         LI,8     2068              PUT RECORD SIZE
         STW,8    WRTQJRNL+5        IN FPT
         LI,13    BADTAPE+2
         LI,9     0
         CAL1,1   WRTQJRNL
         BEZ      %+2
         B        CV11              WRT ERR
         MTW,1    RDQFPT+6          NEXT BLOCK #
         LI,2     1
         MTW,1    *12,2             SET BK CNT IN Q REC
         CW,6     RDQFPT+6          DONE WITH ALL BLOCKS
         BG       CV10
CV13     EQU      %
         DO1      GOD
         CAL1,7   QRECBUF+6         UNLOCK
         BAL,15   MASTER
         STW,8    M:TID
         BAL,15   SLAVE
CV14     EQU      %
*  UPDATE JRNL RECORD FOR LAST SN USED
         LI,5     23
         LH,7     *BUF,5            GET SN POS
         LW,12    BUF
         LI,13    JRECSZ
         LW,14    JRNLNAM,1         KEY ADR
         LI,9     0
         CAL1,1   RDTPF
         BNEZ     CV15
         MTW,0    ACTIVE            IS IT OPEN OR GO CMD
         BNEZ     %+2               NO
         STH,7    *BUF,5            YES,SET VALUE COMPUTED IN OPEN
         MTH,1    *BUF,5
         LW,7     Y8
         STS,7    *BUF              SET EXIST BIT
         CAL1,1   WRTTPF
CV15     EQU      %
*  SET UP INFO IN CFU
         LW,7     JRNLCFU,1
         LW,6     ANSDCB,1
         BAL,15   MASTER
         LW,8     17,6
         STW,8    SREC,7            BECOMES # OF REC WRITTEN
         LW,8     1,6               GET IOQ INFO
         SLS,8    16
         STW,8    JRNLIOQ,1
         STW,8    TDA,7             IOQ INFO
         BAL,15   SLAVE
         LW,7     CMDINDEX
         CI,7     GOINDEX           WAS THIS GO CMD
         BE       G4                YES, RTN TO GO
         B        DRRTN
ID2      EQU      %
*  ID IS 0 IN MEM & Q OR ASSOC J IS OPN, SO GET ID FROM 0ABUF
         CI,7     0
         BNEZ     %+2
         AI,7     1
         STW,7    TEMPID            SAVE IT
         LI,8     8                 # OF DIGITS
         LI,5     BA(IDVALUE)+1
         BAL,15   TOCHAR            ID IN 7 TO CONVERT
         LI,10    IDVALUE
         BAL,9    OPOUTX            OUTPUT ID VALUE
ID3      EQU      %
         M:KEYIN  (MESS,IDOK),(REPLY,IDREPLY),(SIZE,1),(ECB,ECB)
         LW,8     IDREPLY
         CW,8     IDY
         BE       ID6
         CW,8     IDN
         BNE      ID3
*  OPERATOR WANTS TO SUPPLY NEW VALUE
         M:KEYIN  (MESS,INPUTID),(REPLY,IDINPUT),(SIZE,8),(ECB,ECB)
         LI,5     BA(IDINPUT)+1
         LB,6     IDINPUT           # OF CHAR
         CI,6     8
         BNE      ID4
         LB,8     IDINPUT,6
         LI,7     16
         CB,8     DECTBL,7          IS LAST CHAR  HEX OR DELIM
         BE       ID4+1             DEC, SO ALL CHAR ARE GOOD
         BDR,7    %-2
ID4      EQU      %
         AI,6     -1                DELIM SO REDUCE # OF CHAR
         BAL,15   CHARTO            HEX VALUE RETURNED IN 8
         LW,7     8
         CW,8     TEMPID            IS NEW ID LESS THAN OLD
         BL       ID2               YES, REDO WITH NEW AS OLD
         STW,8    TEMPID
ID6      EQU      %
*  PUT ID IN 0A REC & WRITE REC
         LW,7     TEMPID
         STW,7    0ABUF+1
         LI,9     0
         CAL1,1   WRT0A             WRITE 0A BUF
         BEZ      ID7
         LI,10    IDABORT           ABORTED ID INIT
         B        DRX
ID7      EQU      %
*  INIT ID
         BAL,15   MASTER
         STW,7    M:TID
         BAL,15   SLAVE
         B        OQ6
         PAGE
*
*        GO COMMAND
*        OPN Q, OPN Q JRNL, AND INIT ID
*
GO       EQU      %
*  READ Q REC & GO OPEN IT
         MTW,0    OQFLG
         BNEZ     G2                Q ALREADY OPEN
         LI,12    QRECBUF
         LI,13    QRECSZ
         LI,14    TXTPQUEUE
         LI,9     X'43'
         CAL1,1   RDTPF             READ Q DEF
         BG       OQ0               READ OK, GO OPEN THE Q
         BLZ      DRX               READ ERR - ABORT
         LI,10    NOQOPN
         BAL,9    OPOUTX
G2       EQU      %
*  IS THERE A Q JRNL
         MTW,0    QJINDEX
         BNEZ     G4                J ALREADY OPN
         LB,8     0ABUF+2           IS THERE A Q J
         BEZ      G4                NO
*  READ Q JRNL DEF REC
         LW,12    BUF
         LI,13    JRECSZ
         LI,14    0ABUF+2           KEY ADR
         LI,9     0
         CAL1,1   RDTPF
         BEZ      OPNJRNL           GO OPN Q JRNL
         BAL,9    OPOUTX            OUTPUT IO ERR
G4       EQU      %
*  GO INITIALIZE ID (IT'LL CHECK WHETHER Q OR Q JRNL OPN)
         B        DRRTN
         PAGE
*
*        RELEASE COMMAND - RELEASE FILE BUT NOT TPFILES REC
*
RELEASE  EQU      %
         BCR,1    EH
         BAL,0    OP0               READ DEF REC
*  RETURN INDICAS DEF EXISTS
         LI,10    NOFILE
         LCF      *12               DOES FILE EXIST
         BCR,8    DRX               NO
         LD,8     TXTQ
         CD,8     FIELD             IS IT Q TO BE RELEASED
         BNE      RE8               NO
*  RELEASE Q
         LI,10    OPNFILE
         MTW,0    OQFLG             IS IT OPN
         BNEZ     DRX               YES
         BAL,0    OQ1               SET UP OPN
         LI,8     1                 FCN IS IN
         STW,8    OQFPT+5
         LI,9     0
         CAL1,1   OQFPT
         BLZ      DRRTN
         LI,9     0
         CAL1,1   CLSRELQ           RELEASE FILE
         BLZ      DRRTN
RE4      EQU      %
         LI,8     0
         LW,9     Y8
         STS,8    *12               RESET EXISTANCE BIT
         LI,9     0
         CAL1,1   WRTTPF            UPDATE FILE DEF REC
         B        DRRTN
RE8      EQU      %
*  FOR JRNL, SIMPLY RESET CURRENT SN POSITION
         LI,8     0
         LI,7     23
         STH,8    *12,7
         B        RE4
         PAGE
*        CLOSE COMMAND
*
CLOSE    EQU      %
         BCR,1    EH
         LD,8     FIELD
         CD,8     TXTQ
         BNE      CLSJRNL
*  CLOSE QUEUE
CLSQUEUE EQU      %
         LI,10    FILNOPN
         MTW,0    OQFLG             IS IT OPEN
         BEZ      DRX               NO
         MTW,-1   OQFLG
         BAL,15   MASTER
         LW,7     M:TID
         STW,7    TEMPID
         BAL,15   SLAVE
         DO1      GOD
         CAL1,7   LOCKFPT           LOCK Q
*  PRINT ID
         LI,8     8
         LI,5     BA(IDVALUE)+1
         BAL,15   TOCHAR
         LI,10    IDVALUE
         BAL,9    OPOUTX
         LI,9     0
         M:CLOSE  F:QDCB,(SAVE)
         B        DRRTN
*  CLOSE JOURNAL
CLSJRNL  EQU      %
         BAL,0    CV0               FIND JRNL ENTRY
CJ0      EQU      %
         LI,0     CJ2
*  DONT RTN ON ERR, IF RTN THEN REG 1 IS JRNL INDEX
CJ1      EQU      %
         LW,7     JRNLCFU,1
         BAL,15   MASTER
         LI,10    JRNLBUSY
         LH,8     *7
         SLS,8    -1
         AND,8    M7
         CI,8     1                 ANY USERS ATTACHED TO CFU
         BE       %+3               NO
         BAL,15   SLAVE
         B        DRX
         LI,8     0
         STW,8    TDA,7             STOP JRNL IO THRU CFU
         LI,6     2
         STB,6    *7,6              MAKE CFU A FILE AGAIN
         LW,12    ANSDCB,1
         XW,8     SREC,7            GET BLOCK CNT
         LI,6     17
         DO1      GOD
         STW,8    *12,6             SET IN ANS DCB
         DO       GC
         LI,8     0
         STW,8    *7
         LI,6     2
         STW,8    *7,6
         BAL,15   SLAVE
         ELSE
         BAL,15   SLAVE
         LW,12    CFUDCB,1
         LI,9     0
         CAL1,1   CCFUFPT           DCB IN 12
         FIN
         B        *0
CJ2      EQU      %
*  READ JRNL RECORD INTO BUF
         BAL,0    Z55
         BG       CJ3-1
         BAL,9    OPOUTX
         LI,0     DRRTN
CJ3      EQU      %
*  CREATE JOURNAL END RECORD
         M:TIME   TIME,TMS
         STW,8    JENDREC+2
         STW,9    JENDREC+3
         BAL,15   MASTER
         LW,8     M:TID
         BAL,15   SLAVE
         BNEZ     %+2
         LW,8     TEMPID
         STW,8    JENDREC+1
         LI,12    JENDREC
*  DO CHECKSUM
         LI,7     1
         LW,8     *12
CJ33     EQU      %
         AW,8     *12,7
         BNC      %+2
         AI,8     1
         AI,7     1
         CI,7     6
         BL       CJ33
         STW,8    *12,7             PUT IN CHECKSUM
         LW,8     ANSDCB,1
         LI,9     X'1FFFF'
         STS,8    WRTQJRNL
         LI,8     X'1C'             PUT RECORD SIZE
         STW,8    WRTQJRNL+5        IN FPT
         CAL1,1   WRTQJRNL          12 IS BUF ADR
*  INDICATE TO OPERATOR IF ALL VOLUMES COMPLETE
         LI,5     23
         LH,8     *BUF,5
         LI,5     22
         CH,8     *BUF,5
         BL       CJ36
         LI,10    CYCLSN
         BAL,9    OPOUTX
CJ36     EQU      %
         LW,12    ANSDCB,1
         LI,9     0
         CAL1,1   CANSFPT           CLS ANS TAPE
         BEZ      CJ4               NO ERROR
*  ERROR CLOSING PRINT OUT BK CNT
         LI,6     17
         LW,7     *12,6             BLOCK CNT FROM DCB
         AND,7    M24
         LI,4     6
         LI,5     BA(ANSER+4)+2
         BAL,15   HEXTO
         LI,10    ANSER
         CAL1,2   OPOUTFPT
CJ4      EQU      %
         LI,8     0
         STW,8    JRNLIOQ,1         INDICATES ENTRY AVAILABLE
         CW,1     QJINDEX
         BNE      %+2
         STW,8    QJINDEX
         LW,12    BUF
         LI,13    JRECSZ
         LI,14    LKEY
         LI,9     0
         CAL1,1   WRTTPF            UPDATE JJRNL REC
         B        *0
         PAGE
*
END      EQU      %
*  IS Q OPEN
         MTW,0    OQFLG
         BNEZ     E2                Q ACTIVE
*  IS THERE A JRNL OPEN
         LI,1     MAXJRNL
         MTW,0    JRNLIOQ,1
         BNEZ     E2                JRNL ACTIVE
         BDR,1    %-2
*  TERMINATE TPG
         LI,8     0
         STW,8    ACTIVE
         LI,9     0
         CAL1,1   WRT0A
         M:CLOSE  M:EI,(SAVE)
         LI,10    TERMES
         CAL1,2   OPOUTFPT
         M:XCON   0
         M:EXIT
*
E2       EQU      %
*  TP ACTIVE
         MTW,1    ACTIVE
         MTW,1    SLEEPF
         M:WAIT   3000              60 MINUTE SLEEP
         LI,8     0
         STW,8    SLEEPF
         B        CV4               SEE IF CVOL NEEDED
         PAGE
*
ZAP      EQU      %
*  CHECK WHETHER ANY TP USERS ACTIVE
         LI,7     SMUIS
         LI,8     TPF
         BAL,15   MASTER
Z1       EQU      %
         CH,8     UH:FLG2,7
         BAZ      Z2
         LW,10    S:CUN             WE ARE CURRENT USER
         CW,7     10                SO DON'T COUNT
         BE       Z2
         LI,10    TPUSR
         BAL,15   SLAVE
         B        DRX
Z2       EQU      %
         BDR,7    Z1
         LW,7     M:TID
         STW,7    TEMPID
         BAL,15   SLAVE
*  LOCK & CLOSE Q
         MTW,0    OQFLG
         BEZ      Z4                Q NOT OPEN
         DO       GOD
         CAL1,7   LOCKFPT
         FIN
*  PRINT ID
         LI,8     8
         LI,5     BA(IDVALUE)+1
         BAL,15   TOCHAR
         LI,10    IDVALUE
         BAL,9    OPOUTX
         LI,9     0
         M:CLOSE  F:QDCB,(SAVE)
         STW,9    OQFLG
Z4       EQU      %
*  CLOSE JRNL
         LI,1     MAXJRNL
Z5       EQU      %
         MTW,0    JRNLIOQ,1
         BEZ      Z7                ENTRY NOT ACTIVE
         LI,0     Z6
Z55      EQU      %
*  READ JRNL REC
         LW,8     JRNLNAM,1
         LB,7     *8
         STB,7    LKEY
         LB,9     *8,7              MOVE NAME
         STB,9    LKEY,7
         BDR,7    %-2
         LW,12    BUF
         LI,13    JRECSZ
         LI,14    LKEY
         LI,9     X'43'
         CAL1,1   RDTPF
         B        *0
Z6       EQU      %
         BG       %+3               READ OK
         BAL,9    OPOUTX
         B        Z7                DONT TRY TO CLOSE
         BAL,0    CJ1               DISABLE JRNL & CLOSE CFU DCB
         BAL,0    CJ3               SAVE SN POS, CLOSE ANS & WRT
*                                   JRNL REC
Z7       EQU      %
         BDR,1    Z5
*  JRNLS CLOSED, WRITE 0A REC
         LI,9     0
         CAL1,1   WRT0A
         LI,8     0
         STW,8    ACTIVE
         B        DRRTN
         PAGE
*
*        RECOVERY ROUTINE FOR PERMANENT WRITE ERROR
*        ON JOURNAL TAPE...BACK UP AND DO CVOL.
*        THEN WRITE OLD RECORDS ON NEXT TAPE.
*
ERRECOV  EQU      %
         BAL,15   MASTER
         LW,5     Y000C             SET LAST OPERATION
         EOR,5    *12               TO READ IN THE DCB
         STW,5    *12
         BAL,15   SLAVE
*
         M:OPEN   M:EO,(FILE,'X1'),(SAVE),(OUTIN)
         LI,5     ERRCOUNT          NO. BLOCKS TO READ
         LW,6     12                ANS DCB
         LW,13    BUF
         AI,13    507               BUFFER ADDRESS
COPY     EQU      %
         M:READ   *6,(BUF,*13),(SIZE,2068),(REV)
         LW,7     13,6              RWS
         SLS,7    -2                 IN WORDS
         LW,14    13
         AI,14    517               END ADDRESS (507+517=1024)
         SW,14    7                 BEGINNING ADDRESS OF BLK
         SLS,7    2                 BYTE COUNT
*
         M:WRITE  M:EO,(BUF,*14),(SIZE,*7)
         BDR,5    COPY
*
         BAL,15   MASTER
         LW,5     Y000C
         EOR,5    *12               SET LAST OPERATION TO WRITE
         STW,5    *12
         LI,5     17                SET BLKCOUNT
         LW,7     ANSBLKS
         AI,7     -ERRCOUNT
         STW,7    *12,5             IN DCB
         BAL,15   SLAVE
*
         LI,9     0
         CAL1,1   CVOLFPT           SWITCH VOLUMES
*
         LI,5     ERRCOUNT          COPY TO NEXT VOL.
COPY2    EQU      %
         M:READ   M:EO,(BUF,*13),(SIZE,2068),(REV)
         LW,7     M:EO+13           RWS
         M:WRITE  *6,(BUF,*13),(SIZE,*7)
         BDR,5    COPY2
         M:CLOSE  M:EO,(REL)
         B        CV9               CONTINUE
         PAGE
*        HANDLE IO ERRORS
*        PRIOR TO EACH CAL REG 9 IS SET UP
*  IF REG 9 IS SET TO 0, THEN AFTER CAL
*                 BEZ  INDICATES NO ERROR
*                 BLEZ INDICATES ERROR & MESS HAS BEEN PRINTED
*  IF REG 9 SET TO ERR/ABN CODE, THEN AFTER CAL
*                 BGZ  INDICATES NO ERROR
*                 BEZ  INDICATES SAME ERROR
*                 BLEZ INDICATES ANOTHER ERROR
*                 (ERROR MESSAGES ARE NOT AUTOMATICALLY OUTPUT)
*
ERR      EQU      %
ABN      EQU      %
         CI,9     0                 NO ERROR INDIC, SO TYPE MESS
         BE       OPOUTX
         CB,9     10
         BE       *8                EXPECTED ERR, SO SET CC=0, RTN
         LCI      1                 INDIC DIFF ERR, SO NEG & RTN
         B        *8
*
*        COMMON ERROR HANDLING MESSAGE ROUTINE
*        IF REG 10 HAS HIGH ORDER CODE THEN OUTPUT
*        ERROR MESSAGE FILE MESSAGE
*        IF REG 10 ONLY HAS ADR THEN OUTPUT
*        ERROR MESSAGE POINTED TO
*        IF REG 9 HAS 0 OR ERR/ABN CODE,
*        RETURN *8, OTHERWISE RETURN *9
*
OPOUTX   EQU      %
*  SAVE ALL REGISTERS
         LCI      0
         PSM,0    TPGSTK
         CW,10    YFFFE
         BANZ     OPO1              NORMAL IO ERROR
*  NOT ERR, JUST OUTPUT MESS AND EXIT
         CAL1,2   OPOUTFPT
         BAL,15   OCLINE
         B        OPO7
OPO1     EQU      %
         LW,1     8
         BEZ      OPO65
         AI,1     -1                GET TO CAL
*  CONVERT CAL LOC AND PUT IN BUF
         LW,7     1
         SLS,7    12                LEFT JUSTIFY
         LI,8     5                 # OF DIGITS
         LI,5     BA(IOERR)+CALLOC
         BAL,15   TOCHAR
         LW,4     M17
         AND,4    *1                ADR OF FPT IN 4
*  FIND KEY ADR IF THERE IS ONE
         LI,0     0                 IN CASE NO KEY
         LW,12    1,4               GET P LIST INDICATORS
         LI,3     0
         LI,2     4                 # OF PARAMS BEFORE KEY
OPO15    EQU      %
         SLS,12   1                 IS THERE A PARAMETER
         BCR,4    %+2               NO
         AI,3     1                 YES, SKIP IT
         BDR,2    OPO15
         SLS,12   1                 IS THERE KEY
         BCR,4    %+3               NO
         AI,3     2                 GET TO KEY
         LW,0     *4,3              GET KEY ADR
         BGE      OPO16+1           NOT INDIRECT
         AND,0    M17
         CI,0     16                IS IT A REGISTER
         BGE      OPO16             NO
         AW,0     TPGSTK
         AI,0     -15               POINTS TO REG IN STK
OPO16    EQU      %
         LW,0     *0
         LW,4     0,4               1ST WD OF FPT
*  CONVERT FPT OP CODE & PUT IN BUFFER
         LB,7     4                 GET OP CODE
         SLS,7    24
         LI,8     2
         LI,5     BA(IOERR)+FPTCODE
         BAL,15   TOCHAR
         LB,3     4
         AND,4    M17               POINTS TO DCB
*  IF OP CODE READ OR WRITE, THERES A KEY
         CI,3     10
         BE       OPO17             KEY IS VALID
         CI,3     11
         BE       OPO17
         LI,0     0
OPO17    EQU      %
*  GO THRU VAR LENGTH PARA TO FILE NAME
         LI,12    01
         AI,4     22
         LI,1     16                MAX # OF ENTRIES, STOPS INF LUP
OPO2     EQU      %
         CB,12    *4
         BE       OPO4              FOUND FILE ENTRY
         CH,12    *4
         BANZ     OPO3              THIS WAS LAST ENTRY
         LW,13    M8
         AND,13   0,4
         AW,4     13
         AI,4     1
         BDR,1    OPO2
OPO3     EQU      %
*  NO FILE ENTRY
         LI,2     FPTCODE+2         SIZE OF BUF IF NO FILE NAME
         B        OPO6
OPO4     EQU      %
*  PUT NAME INTO BUFFER
         AI,4     1
         LB,1     *4                GET BC OF NAME
*  LIMIT NAME LENGTH TO 10 CHAR
         CI,1     10
         BLE      %+2
         LI,1     10
         LD,12    SPACES
         STD,12   IOERR+FNAME+1
         STW,12   IOERR+FNAME
         LB,12    *4,1
         STB,12   IOERR+FNAME,1
         BDR,1    %-2
*  PUT KEY INTO BUFFER
         LI,2     38
         LI,12    X'40'
         STB,12   IOERKEY+1,2       CLEAR BUF
         BDR,2    %-1
         LI,2     BAKNAME-5         BUF SIZE IF NO KEY
OPO6     EQU      %
         STB,2    IOERR
         CAL1,2   FPTIOERR
         CI,0     0
         BE       OPO65             NO KEY
         LB,1     *0                GET SIZE OF KEY
         CI,1     31
         BG       OPO65             NOT A GOOD KEY
         CI,1     11
         BL       %+2               LIMIT KEY TO 11 CHAR
         LI,1     11
         LW,2     1
         LB,12    *0,1
         STB,12   IOERKEY+1         PUT KEY INTO BUF
         BDR,1    %-2
         LI,5     BA(IOERKEY+4)+1
         LI,3     0
OPO62    EQU      %
*  CONVERT KEY TO HEX DIGITS
         LI,8     8
         LW,7     *0,3
         BAL,15   TOCHAR
         AI,3     1
         CI,3     3
         BL       OPO62
         CAL1,2   FPTIOERR          OUTPUT TO OP CONSOLE
OPO65    EQU      %
*  GET ERROR MESSAGE FROM FILE
         LW,12    YFFFE
         AND,12   10                GET ERR CODE & SUBCODE
         LI,13    0
         SLD,12   -24
         SLS,12   1
         SLD,12   7
         LI,1     1
         STH,12   ERMSGKEY,1
         M:OPEN   M:SI,(FILE,'ERRMSG',':SYS'),(KEYED),(DIRECT),;
                  (IN),(ERR,ERR),(ABN,ABN)
         CAL1,1   ERMSG
         M:CLOSE  M:SI,(SAVE)
*  OUTPUT MESSAGE FROM ERRMSG FILE
         LW,2     M24
         AND,2    ERMSG
         LW,12    4,2
         SLS,12   -17               GET ACTUAL SIZE
         AI,12    3                 INITIAL BLANKS
         STB,12   ERMSGBUF-1
         BAL,15   OCLINE
         LI,10    ERMSGBUF-1        MESS ADR
         CAL1,2   OPOUTFPT
OPO7     EQU      %
         LCI      0
         PLM,0    TPGSTK
         CI,9     X'100'            RETURN ADR OR ERR CODE
         BL       %+3               CODE OR 0
         LCI      1                 SET NEG FLAG & RETURN ON 9
         B        *9
         LCI      1                 SET NEGITIVE FLAG
         B        *8
         PAGE
*        OUTPUTS OP COMMAND AND BELOW IT
*        OUTPUTS EHXX    %
*        WHERE XX INDICATES WHICH CHAR IN ERROR
*        AS DOES % ALSO INDICATE ERROR POSITION
*
EH       EQU      %
*  PUT 4 BLANKS IN FRONT OF CMD & OUTPUT
         STW,15   SAVR15
         LB,8     CMD
         AI,8     4
         STB,8    CMDOUT
         LI,10    X'40'
         STB,10   CMD
         M:TYPE   (MESS,CMDOUT)
*  SST % IN BLANK MESS AT RIGHT POINT
         LW,7     M20
         AND,7    3
         AI,7     -BA(CMD)-1
         LI,8     '%'
         STB,8    EHMESS+1,7
         STB,7    EHMESS
         MTB,4    EHMESS
*  PUT CHAR# AFTER EH
         SLS,7    24                CNT LEFT JUSTIFIED
         LI,8     2                 # OF DIGITS
         LI,5     BA(EHMESS)+3
         BAL,15   TOCHAR
         M:TYPE   (MESS,EHMESS)     OUTPUT EHXX  ...%
         LB,7     EHMESS
         STB,10   EHMESS,7          BLANK OUT % FOR NEXT TIME
         B        DRRTN
         TITLE
*        CARRAGE RETURN ON OC
OCLINE   EQU      %
         DO       GOD
         B        *15               NO 'LF' NEEDED ON OC
         ELSE
         STW,10   SAVR2
         LI,10    1LINE
         CAL1,2   OPOUTFPT
         LW,10    SAVR2
         B        *15
         FIN
         TITLE    'TPG   SUBROUTINES'
*        GETS NEXT FIELD & SETS UP INFO ABOUT IT
*
*  I  0  MASK IE DELIMITER
*  I  2,3 BYTE STRING POINTER TO 1ST CHAR OF FIELD
*  I  11 LINK REG
*     1,8,12,13 ARE WORK REGS
*  O  2,3 POINTER TO NEXT FIELD IE DELIMITER + 1
*  O  BCS,1 INDICATES FIELD WAS FOUND
*
GETUM    EQU      %
*  FOR DEBUGGING SAVE PTR
         STD,2    BYTESTRING
*  SET UP FOR BYTE STRING INST
         LD,12    2
         OR,0     =MSKI             ADD IN ILLEGAL CHAR. FLAG
         STB,0    12
         TTBS,12  0
         STCF     BSCC
         BCS,1    GET1              FIELD FOUND
*  NO FIELD FOUND
         XW,2     12
         XW,3     13
         LC       BSCC
         B        *11
GET1     EQU      %
         CW,3     13                CHECK THERE IS A FIELD
         BNE      %+3
         LI,10    0FIELD            CNT FUNNY IN BYTE STRING
         B        DRX
         LI,1     0
GET2     EQU      %
*  SAVE FIELD IN LOC FIELD AND ITS SZ IN FBYTECNT
         LB,8     0,3
         STB,8    FIELD,1
         AI,1     1
         CI,1     32
         BNE      %+4               FIELD TOO LONG, WILL OVERRUN BUF
         LI,8     0
         STB,8    BSCC
         B        GET4
         AW,3     XFF000001         +1 TO ADR AND -1 TO CNT
         BCR,8    %+4               NO CARRY, END OF CMD
         CW,3     13                IF EQUAL THEN FIELD DONE
         BNE      GET2
         AW,3     XFF000001         OFF DELIM ONTO NEXT CHAR
         STW,1    FBYTECNT
         LI,8     X'40'
GET4     EQU      %
*  BLANK REST OF WD IN FIELD
         CI,1     3
         BAZ      GET5              IF MULTIPLE OF 4, THEN DONE
         STB,8    FIELD,1
         AI,1     1
         B        GET4
GET5     EQU      %
*  SAVE WD COUNT OF FIELD
         SLS,1    -2
         STW,1    FWORDCNT
         LB,1     12                GET DELIMITER FOUND
         STW,1    DELIMITER
         CI,1     MSKI              DID WE FIND ILLEG CHAR
         BE       EH                YES, OUTPUT MESS IN ABORT CMD
         LC       BSCC
         B        *11
         PAGE
*
*        CONVERTS HEX TO DEC TO EBCDIC AND PUTS IN BUFFER
*
*  I  4  # OF DEC CHAR TO CREATE
*  I  5  BA(BUF)
*     6  WORK REG
*  I  7  NUMBER TO CONVERT
*     8  WORK REG
*     15 LINK
*
HEXTO    EQU      %
         LI,6     0
         DW,6     UNIT-1,4          6=REMAINDER,  7=QUOTIENT
         LI,8     '>'               IF NUM TO LARGE PUT OUT >
         CI,7     10
         BGE      HE4               TOO LARGE
         CI,7     0                 IF 0 PUT OUT LEADING SPACES
         BNE      HE2
         LCF      5
         BCS,4    HE2               ALREADY STARTED NUMBER
         LI,8     X'40'
         B        HE4
HE2      EQU      %
         OR,5     Y4                SET BIT FOR CHAR FOUND
         LB,8     HEXTBL,7
HE4      EQU      %
         STB,8    0,5
         LW,7     6
         AI,5     1
         BDR,4    HEXTO
         LCF      5
         BCS,4    *15               VALUE WAS NOT 0
         AI,5     -1
         LI,8     X'F0'
         STB,8    0,5               PUT A 0 IN
         B        *15
         PAGE
*
*        CONVERT HEX TO EBCDIC AND PUT IN BUF
*
*  I  5  BA(BUF)
*     6  WORK REG
*  I  7  DIGITS LEFT JUSTIFIED
*  I  8  # OF DIGITS
*     9  WORK REG
*     15 LINK
*
TOCHAR   EQU      %
         LI,6     0
         SLD,6    4                 MOVE CHAR INTO 6
         LB,9     HEXTBL,6          GET EBCDIC
         STB,9    0,5               PUT IN BUFFER
         AI,5     1
         BDR,8    TOCHAR
         B        *15
         PAGE
*        CONVERT EBCDIC DECIMAL # FROM BUFFER TO HEX
*
*  I  5  BA(BUF)
*  I  6  # OF DIGITS
*     7  WORK REG
*  O  8  CONVERTED NUMBER
*     9  WORK REG
*     15 LINK
*
TOHEX    EQU      %
         LI,8     0
         LI,4     0
         AW,5     6
TOH2     EQU      %
         AI,5     -1
         LB,9     0,5
         LI,7     10
         CB,9     DECTBL,7
         BE       TOH4
         BDR,7    %-2
         LI,10    BADDEC
         B        DRX               BAD DECIMAL DIGIT
TOH4     EQU      %
         AI,7     -1
         MW,7     UNIT,4
         AW,8     7
         AI,4     1
         BDR,6    TOH2
         B        *15
         PAGE
*        CONVERT ECBDIC HEX TO HEX
*
*  I  5  BA(BUF)
*  I  6  # OF DIGITS
*     7  WORK REG
*  O  8  CONVERTED NUMBER
*     9  WORK REG
*     15 LINK
*
CHARTO   EQU      %
         LI,8     0
         CI,6     8
         BG       CH1               NUM TOO LARGE
CH0      EQU      %
         LI,7     16
         LB,9     0,5
         CB,9     DECTBL,7
         BE       CH2
         BDR,7    %-2
CH1      EQU      %
         LI,10    BADHEX
         B        DRX
CH2      EQU      %
         SLS,8    4
         AI,7     -1
         AW,8     7
         AI,5     1
         BDR,6    CH0
         B        *15
         PAGE
MASTER   EQU      %
         DO       GOD
         STCF     15
         LCI      3
         PSM,8    TPGSTK
         M:SYS
         LCI      3
         PLM,8    TPGSTK
         LCF      15
         FIN
         B        *15
SLAVE    EQU      %
         STW,15   SAVR15
         DO       GOD
         XPSD,2   SLPSD             GOES TO NXT INST
SL1      EQU      %
         LW,15    Y008
         STS,15   SLPSD             SLAVE
         MTW,4    SLPSD             INCR TO SL2
         LPSD,0   SLPSD
SL2      EQU      %
         FIN
         B        *SAVR15
*
         PAGE
*        OPERATOR INTERRUPT ROUTINE
*
INT      EQU      %
         MTW,0    SLEEPF
         BEZ      INT2              NO
         LI,4     DRIVE
         LI,5     X'1FFFF'
         STS,4    *1                RTN ADR
         LI,4     0
         STW,4    SLEEPF
         B        INT4
INT2     EQU      %
         M:TYPE   (MESS,NOTNOW)
INT4     EQU      %
         M:TRTN
*
*        EXIT CONTROL ROUTINE
*
XCON     EQU      %
         CI,8     0
         BNE      XC2
XC1      EQU      %
*  NORMAL EXIT
         LI,10    TERMES
         CAL1,2   OPOUTFPT
         M:XCON   0
         M:EXIT
XC2      EQU      %
         DO       GOD=0
         CI,8     X'40'
         BANZ     XC1               CTL-Y IS QUIT IN DEBUG
         FIN
         SLS,11   25
         SLD,10   24
         LI,8     0
         BAL,9    OPOUTX
         LI,7     X'1FFFF'
         AND,7    *1                TRAP LOC
         SLS,7    12
         LI,8     5
         LI,5     BA(LOCIS)+17
         BAL,15   TOCHAR
         LI,10    LOCIS
         BAL,9    OPOUTX
XC3      EQU      %
         M:KEYIN  (MESS,XCWHAT),(REPLY,IDREPLY),(SIZE,1),(ECB,ECB)
         BAL,15   OCLINE
         LI,5     X'1FFFF'
         LI,7     1
         LB,8     IDREPLY,7         GET CHAR
         CI,8     'X'
         BE       ZAP               EXIT
         LW,4     *1                GET TRAP ADR
         AI,4     1                 TO GO TO NEXT INST
         CI,8     'C'
         BE       XC4
         LI,4     DRIVE
         CI,8     'R'               REQUEST OP CMD
         BE       XC4
         B        XC3               NONE TRY AGAIN
XC4      EQU      %
         STS,4    *1                CHANGE PSD TO ZAP OR DRIVE
         M:TRTN   XCON              GO TO THEM
         DO       GOD=0
QCK      B        *15               DUMMY SUBROUTINE
         DEF      PATCH
PATCH    RES      50
         FIN
         END      INIT

