         SPACE    10
SIMULATE EQU      1 FOR TPC SIMULATOR, 0 FOR REAL TPC.
*
DATE     EQU      '081574'          LATEST ASSEMBLY DATE OF THIS CODE.
*
* THIS MANY FAILED TRANSACTIONS CAUSE A TPM TO BE REGULATED OFF:
SYSTEM#THRESHOLD#FOR#FAILED#TRANSACTIONS  SET  3
*
*  TPM HAS TIMED OUT AFTER PROCESSING A TRANSACTION THIS MANY SECONDS:
TPM#TIMEOUT#SECONDS  SET  15
TPM#TIMEOUT#TUN      EQU  TPM#TIMEOUT#SECONDS*500  (TIMER UNITS)
*
         SPACE    6
*
TITTLE   CNAME                      THIS PROC CLEANS UP SEVERAL UGLIES
         PROC                       ASSOCIATED WITH TITLES.
         TITLE    S:PT('***  ',AF,'  *** ',DATE,' ***')
         PEND
         TITTLE   'TRANSACTION PROCESSING CONTROLLER'
*
@T       CSECT    0                 TEMP AREA (ALL ACCESS).
@P       CSECT    1                 CODE AREA (PROTECTED).
@S       CSECT    1                 STATIC DATA (PROTECTED).
*
         SYSTEM   SIG7              INSTRUCTIONS (INCL. BYTE STRING)
         SYSTEM   BPM               OPERATING SYSTEM PROCS.
,,@F     M:PT     1                   (FORCE FPT'S TO BE PROTECTED).
*
         DEF      INITATPC,GETATRAN,OUTALINE,OUTATRAN
         DEF      FAILURE,JOURNAL,TPC
*
         SREF     Q:TID,Q:CCBADR,Q:DBEXC  EDMS INTERFACE (DATA).
         SREF     Q:ENTCOD                EDMS INTERFACE (DATA).
         SREF     DMSLOCK,DMSRLSE         EDMS INTERFACE (CODE).
         SREF     9INITIAL               FORTRAN INTERFACE.
         SREF     C:TRP                  COBOL INTERFACE.
         REF      F:JRNL            JOURNALIZATION DCB.
         DO       SIMULATE
         REF      M:SI              SIMULATED TRANSACTION INPUT.
         REF      M:LO              SIMULATED QUEUE OUTPUT.
         FIN
*
         DEF      @T,@P,@S,@F       THESE DEF'S ARE FOR DEBUGGING.
         DEF      @DATE             SHOW ASSEMLBYDATE ON MAP.
@DATE    EQU      #DATE**-16
NEEDSMOREWORK   COM,0  0          SHOWS NICELY IN CONCORDANCE.
#ECBP    EQU      X'80000000'       THIS BIT SAYS AN ECB IS POSTED.
ARS      EQU      4                 FIELD IN DCB.
FCD      EQU      0                 FIELD IN DCB.
FCDBIT   EQU      X'00200000'         DITTO.
J:DCBLINK EQU     X'8C2B'           UGLY BUT WILL DO FOR NOW.
J:JIT    EQU      X'8C00'
         PAGE
************************************ * * * * * * * * * * * * * * * * * *
*                                                                      *
*  PROCEDURES FOR CHANGING THE CURRENT CONTROL SECTION.                *
*                                                                      *
************************************ * * * * * * * * * * * * * * * * * *
@P       CNAME    @P                GO TO CODE SECTION.
@S       CNAME    @S                GO TO STATIC DATA SECTION.
@T       CNAME    @T                GO TO TEMP SECTION.
         PROC
         USECT    NAME              GO THERE.
         BOUND    CF(2)+4*(NUM(CF)<2)  GET PROPER BOUND (DEFAULT = WORD)
LF       DO1      AF~=SCOR(AF,)     DEFINE LF.   IF AF IS NOT ZERO,
         DATA,0   0                  CAUSE WHERE-WE-ARE TO BE DISPLAYED.
         PEND
************************************ * * * * * * * * * * * * * * * * * *
*                                                                      *
*  HELPER PROCS FOR USE IN OTHER PROCEDURES.                           *
*                                                                      *
************************************ * * * * * * * * * * * * * * * * * *
S:S      FNAME                      THIS FUNCTION IS HANDY TO HAVE:
         PROC                       GIVEN N AND A LIST,
         PEND     AF(AF(1)+2)       SELECT THE (N+1)ST ITEM IN THE LIST.
*
EXPLAIN  CNAME,0                    PRINTS OUT EXPLANATIONS.
         PROC
         OPEN     X,I
X        SET      S:UFV(AF)         LIST OF MESSAGES.
I        DO       NUM(X)
         ERROR,*  ;                 SHOW THEM ALL.
         '                                           *** ',X(I)
         FIN
         CLOSE    X,I
         PEND
         PAGE
************************************ * * * * * * * * * * * * * * * * * *
*                                                                      *
*        REGISTERS                                                     *
*                                                                      *
************************************ * * * * * * * * * * * * * * * * * *
R0       EQU      0
R1       EQU      1
R2       EQU      2
R3       EQU      3
R4       EQU      4
R5       EQU      5
R6       EQU      6
R7       EQU      7
R8       EQU      8
SR1      EQU      8
R9       EQU      9
SR2      EQU      9                 (MONITOR'S NAME FOR IT)
*        REGISTER 10 USED ONLY IN PROCS.
SR3      EQU      10                (AND BY MONITOR RETURNS)
*        REGISTER 11 USED ONLY IN PROCS.
R12      EQU      12
R13      EQU      13
R14      EQU      14
R15      EQU      15
         PAGE
************************************ * * * * * * * * * * * * * * * * * *
*                                                                      *
*  TABLE OF TRANSACTION PROCESSING MODULE INITIALIZATION ENTRY POINTS. *
*                                                                      *
************************************ * * * * * * * * * * * * * * * * * *
         OPEN     X,I
         SREF     ;
 TPMS00,TPMS01,TPMS02,TPMS03,TPMS04,TPMS05,TPMS06,TPMS07,TPMS08,TPMS09,;
 TPMS10,TPMS11,TPMS12,TPMS13,TPMS14,TPMS15,TPMS16,TPMS17,TPMS18,TPMS19,;
 TPMS20,TPMS21,TPMS22,TPMS23,TPMS24,TPMS25,TPMS26,TPMS27,TPMS28,TPMS29,;
 TPMS30,TPMS31,TPMS32,TPMS33,TPMS34,TPMS35,TPMS36,TPMS37,TPMS38,TPMS39,;
 TPMS40,TPMS41,TPMS42,TPMS43,TPMS44,TPMS45,TPMS46,TPMS47,TPMS48,TPMS49,;
 TPMS50,TPMS51,TPMS52,TPMS53,TPMS54,TPMS55,TPMS56,TPMS57,TPMS58,TPMS59,;
 TPMS60,TPMS61,TPMS62,TPMS63,TPMS64,TPMS65,TPMS66,TPMS67,TPMS68,TPMS69,;
 TPMS70,TPMS71,TPMS72,TPMS73,TPMS74,TPMS75,TPMS76,TPMS77,TPMS78,TPMS79,;
 TPMS80,TPMS81,TPMS82,TPMS83,TPMS84,TPMS85,TPMS86,TPMS87,TPMS88,TPMS89,;
 TPMS90,TPMS91,TPMS92,TPMS93,TPMS94,TPMS95,TPMS96,TPMS97,TPMS98,TPMS99
X        SET      ;
 TPMS00,TPMS01,TPMS02,TPMS03,TPMS04,TPMS05,TPMS06,TPMS07,TPMS08,TPMS09,;
 TPMS10,TPMS11,TPMS12,TPMS13,TPMS14,TPMS15,TPMS16,TPMS17,TPMS18,TPMS19,;
 TPMS20,TPMS21,TPMS22,TPMS23,TPMS24,TPMS25,TPMS26,TPMS27,TPMS28,TPMS29,;
 TPMS30,TPMS31,TPMS32,TPMS33,TPMS34,TPMS35,TPMS36,TPMS37,TPMS38,TPMS39,;
 TPMS40,TPMS41,TPMS42,TPMS43,TPMS44,TPMS45,TPMS46,TPMS47,TPMS48,TPMS49,;
 TPMS50,TPMS51,TPMS52,TPMS53,TPMS54,TPMS55,TPMS56,TPMS57,TPMS58,TPMS59,;
 TPMS60,TPMS61,TPMS62,TPMS63,TPMS64,TPMS65,TPMS66,TPMS67,TPMS68,TPMS69,;
 TPMS70,TPMS71,TPMS72,TPMS73,TPMS74,TPMS75,TPMS76,TPMS77,TPMS78,TPMS79,;
 TPMS80,TPMS81,TPMS82,TPMS83,TPMS84,TPMS85,TPMS86,TPMS87,TPMS88,TPMS89,;
 TPMS90,TPMS91,TPMS92,TPMS93,TPMS94,TPMS95,TPMS96,TPMS97,TPMS98,TPMS99
*
TPMS%%   @P                         TABLE OF INITIALIZE ENTRY POINTS:
I        DO       100
         B        X(I)              BRANCH TO TPM.
         LIST     0
         FIN
         LIST     1
*                                   (PREV 3 LINES LIST 0,FIN,LIST 1).
         PAGE
************************************ * * * * * * * * * * * * * * * * * *
*                                                                      *
*  TABLE OF TRANSACTION PROCESSING MODULE (TPM) EXECUTION ENTRY POINTS.*
*                                                                      *
************************************ * * * * * * * * * * * * * * * * * *
         SREF     ;
 TPMX00,TPMX01,TPMX02,TPMX03,TPMX04,TPMX05,TPMX06,TPMX07,TPMX08,TPMX09,;
 TPMX10,TPMX11,TPMX12,TPMX13,TPMX14,TPMX15,TPMX16,TPMX17,TPMX18,TPMX19,;
 TPMX20,TPMX21,TPMX22,TPMX23,TPMX24,TPMX25,TPMX26,TPMX27,TPMX28,TPMX29,;
 TPMX30,TPMX31,TPMX32,TPMX33,TPMX34,TPMX35,TPMX36,TPMX37,TPMX38,TPMX39,;
 TPMX40,TPMX41,TPMX42,TPMX43,TPMX44,TPMX45,TPMX46,TPMX47,TPMX48,TPMX49,;
 TPMX50,TPMX51,TPMX52,TPMX53,TPMX54,TPMX55,TPMX56,TPMX57,TPMX58,TPMX59,;
 TPMX60,TPMX61,TPMX62,TPMX63,TPMX64,TPMX65,TPMX66,TPMX67,TPMX68,TPMX69,;
 TPMX70,TPMX71,TPMX72,TPMX73,TPMX74,TPMX75,TPMX76,TPMX77,TPMX78,TPMX79,;
 TPMX80,TPMX81,TPMX82,TPMX83,TPMX84,TPMX85,TPMX86,TPMX87,TPMX88,TPMX89,;
 TPMX90,TPMX91,TPMX92,TPMX93,TPMX94,TPMX95,TPMX96,TPMX97,TPMX98,TPMX99
X        SET      ;
 TPMX00,TPMX01,TPMX02,TPMX03,TPMX04,TPMX05,TPMX06,TPMX07,TPMX08,TPMX09,;
 TPMX10,TPMX11,TPMX12,TPMX13,TPMX14,TPMX15,TPMX16,TPMX17,TPMX18,TPMX19,;
 TPMX20,TPMX21,TPMX22,TPMX23,TPMX24,TPMX25,TPMX26,TPMX27,TPMX28,TPMX29,;
 TPMX30,TPMX31,TPMX32,TPMX33,TPMX34,TPMX35,TPMX36,TPMX37,TPMX38,TPMX39,;
 TPMX40,TPMX41,TPMX42,TPMX43,TPMX44,TPMX45,TPMX46,TPMX47,TPMX48,TPMX49,;
 TPMX50,TPMX51,TPMX52,TPMX53,TPMX54,TPMX55,TPMX56,TPMX57,TPMX58,TPMX59,;
 TPMX60,TPMX61,TPMX62,TPMX63,TPMX64,TPMX65,TPMX66,TPMX67,TPMX68,TPMX69,;
 TPMX70,TPMX71,TPMX72,TPMX73,TPMX74,TPMX75,TPMX76,TPMX77,TPMX78,TPMX79,;
 TPMX80,TPMX81,TPMX82,TPMX83,TPMX84,TPMX85,TPMX86,TPMX87,TPMX88,TPMX89,;
 TPMX90,TPMX91,TPMX92,TPMX93,TPMX94,TPMX95,TPMX96,TPMX97,TPMX98,TPMX99
*
TPMX%%   @P                         TABLE OF EXECUTION ENTRY POINTS:
I        DO       100
         B        X(I)              BRANCH TO TPM.
         LIST     0
         FIN
         LIST     1
*                                   (PREV 3 LINES LIST 0,FIN,LIST 1).
X        SET      0                 GIVE METASYM MORE ASSEMBLY ROOM.
         CLOSE    X,I
         PAGE
************************************ * * * * * * * * * * * * * * * * * *
*                                                                      *
*  FLAG MANIPULATION PROCEDURES.                                       *
*                                                                      *
************************************ * * * * * * * * * * * * * * * * * *
*  THIS COM IS BEZ OR BNEZ DEPENDING ON CF(2).
BEZ     COM,1,6,1,4,3,17  AFA(1),X'34',CF(2),3,AF(2),AF(1)
*
SETT     CNAME    1                 SET A FLAG.
CLEAR    CNAME    0                 CLEAR A FLAG.
         PROC
         ERROR,7,1-TCOR(AF,S:AAD)   'NOT A FLAG'
         DO       NUM(CF)<2         IF NO REGISTER SPECIFIED,
LF       LI,11    NAME                LOAD 11 WITH NONZERO OR ZERO
         STW,11   AF,R4               AND FIX UP THE FLAG.
         ELSE                       IF REGISTER SPECIFIED,
LF       STW,CF(2)  AF,R4             FIX FLAG WITH REGISTER CONTENTS.
         FIN
         PEND
*
BON      CNAME    1                 BRANCH IF FLAG SET.
BOFF     CNAME    0                 BRANCH IF FLAG CLEARED.
         PROC
         ERROR,7,1-TCOR(CF(2),S:AAD) 'NOT A FLAG'
LF       MTW,0    CF(2),R4          TEST THE FLAG AND BRANCH IF THE
         BEZ,NAME  AF              APPROPRIATE CONDITION IS MET.
         PEND
*
SETBON   CNAME    1,1               SET FLAG AND BRANCH IF IT WAS SET.
CLEARBON CNAME    0,1               CLEAR FLAG & BRANCH IF IT WAS SET.
SETBOFF  CNAME    1,0               SET FLAG AND BRANCH IF WAS CLEARED.
CLEARBOFF  CNAME  0,0               CLEAR FLAG & BRANCH IF WAS CLEARED.
         PROC
         ERROR,7,1-TCOR(CF(2),S:AAD)  'NOT A FLAG'
         DO       NUM(CF)<3         IF NO REGISTER SPECIFIED,
LF       LI,11    NAME(1)             LOAD 11 WITH NONZERO OR ZERO,
         XW,11    CF(2),R4            FIX FLAG, & GET PREVIOUS VALUE.
         ELSE                       IF REGISTER SPECIFIED,
LF       XW,CF(3)  CF(2),R4           FIX FLAG FROM REG & GET PREV VALUE
         FIN
         BEZ,NAME(2)  AF           BRANCH IF FLAG HAD APPROPRIATE VALUE
         PEND
         PAGE
************************************ * * * * * * * * * * * * * * * * * *
*                                                                      *
*  CALL, ENTRY, AND RETURN ARE FOR INTERNAL TPC LINKING.               *
*        THE LINK LABEL IS A 3-ITEM LIST:                              *
*        1.  (1) ADDRESS OF ROUTINE.                                   *
*            (2) LINK REGISTER (11 FOR ENTRY, CF(2) FOR ROUTINE).      *
*        2.  ADDRESS OF A TEMP FOR REMEMBERING CALLER'S ADDRESS.       *
*        3.  LIST OF TEXT STRINGS TO BE DISPLAYED AT CALL LINE.        *
*  ROUTINE IS LIKE ENTRY, FOR ROUTINES WHICH LINK ON A REGISTER        *
*        OTHER THAN 11.  IT DOES NOT USE A TEMP.                       *
*                                                                      *
************************************ * * * * * * * * * * * * * * * * * *
*
         OPEN     X
*
CALL     CNAME,4                    CALL CALLS A SUBROUTINE.
         PROC
X        SET      S:UFV(AF)
         ERROR,7,NUM(X)=3=0 'BAD CALL'  COMPLAIN IF IT ISN'T A SUBR.
         BAL,X(1,2)  X(1,1)         CALL IT.
         EXPLAIN  X(3)
         PEND
*
ROUTINE  CNAME                      ROUTINE FOR NON-R11-LINKED ROUTINES.
         PROC
         @P
LF       EQU      (%,CF(2)),0,(AF)
         ERROR,7,NUM(CF)<2  'NO REG GIVEN'
         PEND
*
ENTRY    CNAME                      ENTRY STARTS A SUBROUTINE.
         PROC
         LOCAL    X,Y
X        @T       0                 RESERVE A WORD IN TEMP SPACE
         DATA     0                 FOR HOLDING RETURN ADDRESS.
Y        @P       0
LF       EQU      (Y,11),X,(AF)
         STW,11   X                 REMEMBER CALLER'S ADDRESS.
         PEND
*
RETURN   CNAME                      RETURN EXITS A SUBROUTINE.
         PROC                       NOTE: RETURN MUST FOLLOW ENTRY OR
X        SET      S:UFV(AF)           ENTRYR IN TPC SOURCE.
         ERROR,7,NUM(X)<2   'BAD RETURN'  COMPLAIN IF IT WASNT ENTRY'ED.
LF       B        *X(2)               RETURN TO CALLER.
         PEND
         CLOSE    X
         PAGE
************************************ * * * * * * * * * * * * * * * * * *
*                                                                      *
*        DISPLACEMENTS IN VARIOUS TABLES.                              *
*                                                                      *
************************************ * * * * * * * * * * * * * * * * * *
*
*        DISPLACEMENTS IN CRITERION ENTRIES.
*
#C#NORMP EQU      0                 NORMAL PRIORITY.
#C#NEXTP EQU      1                 NEXT PRIORITY.
#C#LNTH  EQU      2                 CRITERION LENGTH.
#C#TPM   EQU      3                 ASSOCIATED TPM NUMBER.
#C#ABORT EQU      4                 ABORT ADDRESS
#C#NAME  EQU      7                 CRITERION TEXT.
#C#CRI   EQU      7                 PLACE WHERE CRITERION POINTER POINTS
#C#NONCRI#LEN EQU 7+1                 (7 UP FRONT, 1 FLAGBYTE FOLLOWING)
#C#MAX#LEN    EQU 8+32
*
*        DISPLACEMENTS IN REPORT AND TRANSACTION JOURNAL ENTRIES
*
*                 AS THEY LOOK DURING PROCESSING:
*
             EQU  0                 (0-7) JNL FLAG  (16-31) ENTRY LNTH.
#J#CHAINW    EQU  1                 LINKS ENTRIES TOGETHER.
#J#TEXTMBSW  EQU  2                 BA(TEXT END)+1 FOR REPORTS.
#J#NAMECBSW  EQU  3                 NAMELEN, BA(NAME).
#J#LENGTHSW  EQU  5                 (0-15) TEXT LNTH  (16-31) NAME LNTH.
*
*                 AS THEY LOOK UPON DELIVERY TO JOURNAL:
*
#J#FLAGSW    EQU  0        (0-7) FLAGS (8-15) RCD TYPE (16-31) RCD LNTH.
#J#ORIGIDW   EQU  1                 ID OF ORIGINATING TRANSACTION.
#J#DATEW     EQU  2                 DATE IN THIS WORD, TIME IN NEXT.
#J#IDW       EQU  4                 ID OF THIS ENTITY.
*
*                 AS THEY LOOK ALL THE TIME:
*
#J#NAMEW     EQU  6                 ENTRY NAME.
#J#NAMEB     EQU  #J#NAMEW*4
#J#TEXTW     EQU  14                ENTRY TEXT.
#J#TEXTB     EQU  #J#TEXTW*4
#J#HDR#LEN   EQU  6*4
#J#NAME#LEN  EQU  8*4
*
*        FLAG BITS IN BYTE 0 OF JOURNAL ENTRIES.
*
##JQUEUE EQU      X'80'             QUEUED
##JQUEUES   EQU   7                 .
##JFAIL  EQU      X'20'             FAILED
##JFAILS    EQU   5                 .
##JIP    EQU      X'10'             IN PROGRESS
##JIPS      EQU   4                 .
##JJRNLI EQU      X'08'             THE ENTITY WHICH CREATED THIS ONE
##JJRNLIS   EQU   3                   WAS JOURNALIZED.
##JJRNLO EQU      X'04'             THE CREATION OF THIS ENTITY WAS OR
##JJRNLOS   EQU   2                   WILL BE JOURNALIZED.
##JJRNLD EQU      X'02'             THE DELIVERY OF THIS ENTITY WAS OR
##JJRNLDS   EQU   1                   WILL BE JOURNALIZED.
*
*
*
#JOURNAL#BT  EQU  X'10'             BEGIN-TRANSACTION RECORD TYPE.
#JOURNAL#ET  EQU  X'11'             END-TRANSACTION RECORD TYPE.
#JOURNAL#OR  EQU  X'15'             OUTPUT-REPORT RECORD TYPE.
#JOURNAL#US  EQU  X'20'             USER JOURNALIZATION RECORD TYPE.
*
*
#QTOOFULL EQU     X'BC'**7+X'12'    Q-MANAGER ERR FOR CANT DO ECBWAIT.
#QINTOUT EQU      X'BC'**7+X'02'    Q-MANAGER ERR FOR INT OUT OF M:Q.
         PAGE
*
*  TABLE FOR CONVERTING (CVS) BINARY TO DECIMAL.
*
BIN#TO#DEC  @S
         DATA     0,0,0,0,8000,4000,2000,1000
         DATA     0,0,0,0,800,400,200,100
         DATA     0,0,0,0,80,40,20,10
         DATA     0,0,0,0,8,4,2,1
         PAGE
************************************ * * * * * * * * * * * * * * * * * *
*                                                                      *
*        PROCEDURES FOR PROTECTING AND UNPROTECTING TPC'S DATA         *
*                                                                      *
************************************ * * * * * * * * * * * * * * * * * *
*
*    PROTECT  SETS ACCESS OF 10 (READ ONLY) ON TPC'S PRECIOUS DATA.
*  UNPROTECT  SETS ACCESS OF 00 (WRITEABLE) ON TPC'S PRECIOUS DATA.
*
PROTECT  CNAME
         PROC
LF       STW,R4   PROTECTED,R4      SAY IT'S PROTECTED.
         M:SMPRT,E  FPT#PROTECT,R4  PROTECT IT.
         PEND
UNPROTECT         CNAME
                  PROC
LF       M:SMPRT,E  FPT#UNPROTECT,R4 UNPROTECT IT.
         AWM,R4   PROTECTED,R4      SAY IT'S NOT PROTECTED.
         PEND
         @S
,PROTECT M:SMPRT,L  2,0
,UNPROTECT  M:SMPRT,L  0,0
#FPT#PROTECT#LEN  EQU  %-PROTECT
         ERROR,7,#FPT#PROTECT#LEN||4   'XXX'
*  GRIPE IF THE MONITOR CHANGES, SO OUR CODE WILL CHANGE TOO.
*
*  FINDPROTECTED  RETURNS THE ADDRESS OF THE TPC'S PROTECTED AREA
*                 IN REGISTER 4.
*
FINDPROTECTED     CNAME
                  PROC
LF       @P       0
         BAL,R4   FINDPROTECTED
         PEND
*
FINDPROTECTED     @P
         STD,SR1  10                SAVE REGISTERS.
         M:GL                       GET COMMON LIMITS IN SR1, SR2.
         AND,SR2  L(X'1FE00')       SR2 IS NOW WA(LAST PAGE).
         XW,SR2   11                SR2 IS RESTORED; 11 IS ANSWER.
         LW,SR1   10                SR1 AND SR2 ARE NOW RESTORED.
         XW,R4    11                R4 IS ANSWER. 11 IS RETURN.
         CW,R4    PROTECTED,R4      RETURN EQUAL IF IT'S PROTECTED.
         B        *11               RETURN.
         PAGE
************************************ * * * * * * * * * * * * * * * * * *
*                                                                      *
*        DYNAMIC AREA LAYOUT                                           *
*                                                                      *
************************************ * * * * * * * * * * * * * * * * * *
*
REZ      CNAME
         PROC
         RES      -AF
LF       DO1      1
         DISP     LF
         PEND
*
         ASECT
         ORG      512
PROTECTED    REZ  1       = R4 WHEN THIS DATA IS WRITE-PROTECTED.
F#INIT   REZ      1       NONZERO DURING INITIALIZATION.
F#KEYIN  REZ      1       NONZERO WHILE KEYIN IN PROGRESS.
F#KEYIN#PROTECT   REZ  1  NONZERO IF WRITE-PROTECTED UNDER KEYIN.
F#SORT   REZ      1       NONZERO IF CRITERIA NEED SORTING.
F#SORTING  REZ    1       NONZERO WHILE SORTING CRITERIA.
F#USER   REZ      1       => RETURN POINT IN TPC, WHEN IN TPM.
F#USER#TPC REZ    1       => RETURN POINT IN TPM, WHEN IN TPC SUBR.
F#WAIT   REZ      1       NONZERO WHEN ABOUT TO WAIT ON ECB.
F#XKEYIN REZ      1       NONZERO WHEN OPERATOR X'ED US.
*
F#FAIL       REZ  1       SET WHEN TPM CALLS FAILURE WHILE PROCESSING.
F#KEEP       REZ  1       SET IF FAILURE SPECIFIES KEEP-XACTION-IN-QUEUE
F#ABORTME    REZ  1       SET IF FAILURE SPECIFIES REGULATE-ME-OFF.
F#TPMABORT   REZ  1       SET WHEN TPM DOES A NO-NO.
F#TPLMABORT  REZ  1       SET WHEN TPLM IS TO BE TERMINATED.
F#TIMEDOUT   REZ  1       SET WHEN TIMER RUNOUT OCCURS.
F#UARLSE     REZ  1       SET CALLING DMSRLSE FROM USER%ABORT.
*
*
*
*
TPM#NUMBER REZ    1                 NUMBER OF THE CURRENTLY-RUNNING TPM.
TPM#INDEX  REZ    1                 (ITS INDEX W/IN ALL EXISTENT TPMS)
TPM#TRAN#COUNT    REZ  1            => TPM XACTION COUNT WORD TABLE.
TPM#TIME          REZ  1            => TPM LAST-TIME-I-RAN WORD TABLE.
*
*
FPT#PROTECT  REZ  #FPT#PROTECT#LEN
FPT#UNPROTECT EQU  FPT#PROTECT+#FPT#PROTECT#LEN/2
*
*
CRI#POINTER REZ   1
CRI#COUNT#TOTAL   REZ   1
CRI#COUNT#GOOD    REZ   1
CRI#COUNT#PREVIOUS REZ   1
CRI#POINT#CURRENT REZ 1
CRI#POINT#PREVIOUS REZ 1
*
*
S#SPAWN  REZ      1                 => SPAWNED-XACTION CHAIN(SIMULATOR).
*
*
TRAN#POINTER REZ  1                 => CURRENT TRANSACTION.
TRAN#TIME    REZ  2                 DATE/TIME OF XACTION START OR STOP.
TRAN#EXTIME  REZ  1                 TIME SPENT EXECUTING CURRENT XACTION
SPACE#AVAIL  REZ  1                 = WA(LAST PAGE USED).
REPORT#CHAIN REZ  1                 => CHAIN OF CURRENT REPORTS.
TRANOUT#CHAIN REZ  1                => CHAIN OF SPAWNED TRANSACTIONS.
OUT#COUNT  REZ    1                 COUNT OF REPORTS + SPAWNEDS.
QGET#ID  REZ      1                 QUEUE MGR'S ID OF OUR GET LIST.
DMS#XCON REZ      1                 DBM'S EXIT-CONTROL ADDRESS.
*
*
*
*
TRAN#ABORT  REZ   1                 USER ABORT-LOC THIS TRANSACTION.
TRAN#ID     REZ   1                 ID OF CURRENT TRANSACTION (HEX).
TRAN#JOURNAL  REZ 1                 JOURNAL-FLAGS FOR CURRENT XACTION.
*
TPM#ACTIVE#TABLE  REZ  25           BYTE TABLE OF TPM STATUS.
TPM#INDEX#TABLE   REZ  25           INDEX OF EXISTENT TPMS IN TABLES.
*
DYN#AVAIL         REZ  0
*
*
QGET#ECB     @T,8
         RES      2                 ECB FOR M:QUEUE/GET.
QDEFPUT#ECB  @T,8
         RES      2                 ECB FOR M:QUEUE/DEFINELIST,PUT.
*
         @S
BA@R5    LB,0     *R5               FOR ANLZ ONLY.
BA@R5:R3 LB,0     *R5,R3            FOR ANLZ ONLY.
WA@TPM#ACTIVE#TABLE  LW,0  TPM#ACTIVE#TABLE,R4   (FOR ANLZ)
WA@TPM#INDEX#TABLE   LW,0  TPM#INDEX#TABLE,R4    (FOR ANLZ)
*
BLANK#   DATA     '    '            FOR CLEARING THINGS TO BLANKS.
         TITTLE   'NOT YET IMPLEMENTED'
*
M:GSP    CNAME
         PROC
LF       LW,R5    SPACE#AVAIL,R4
         AI,R5    -512
         STW,R5   SPACE#AVAIL,R4
         M:GVP    *R5
         PEND
*
M:FSP    CNAME
         PROC
LF       M:FVP    *AF(2)
         PEND
*
         TITTLE   'MESSAGE GENERATOR'
************************************ * * * * * * * * * * * * * * * * * *
*                                                                      *
*  MESSAGE PROC AND MESS%AGE ROUTINE BUILD MESSAGES.                   *
*  MESSAGES COME IN SEVERAL FLAVORS:                                   *
*  ,T    PROGRAM TRACE IN TPC SIMULATOR.                               *
*  ,E    ERROR MESSAGES.                                               *
*  ,K    RESPONSES TO OPERATOR KEYINS.                                 *
*                                                                      *
*  MESSAGE PROC IS INVOKED BY:                                         *
*        (M)ESSAG(E),T/E/K  AF1,AF2,...,AFN                            *
*    WHERE EACH AFI IS OF ONE OF THE FORMS:                            *
*        'TEXT' - - - - - - PUT THIS TEXT STRING INTO MESSAGE.         *
*        (S,L)  - - - - - - S IS BA OF A TEXT STRING                   *
*                             OR *WA OF BA OF TEXT STRING.             *
*                           L IS LENGTH OF STRING IN BYTES             *
*                             OR *WA OF LENGTH OF STRING.              *
*        (N,L,T)  - - - - - N IS WA OF A NUMBER                        *
*                             OR *WA OF WA OF NUMBER.                  *
*                           L IS NUMBER OF DIGITS TO PUT IN MSG.       *
*                           T IS TYPE OF NUMBER:                       *
*                                   0 - DECIMAL INTEGER.               *
*                                   1 - DECIMAL, SUPPRESS LEADING 0'S. *
*                                   2 - HEXADECIMAL.                   *
*                                                                      *
************************************ * * * * * * * * * * * * * * * * * *
         OPEN     I,J,#L
MESSAGE  CNAME    2+1               MESSAGE BUILDS & PRINTS A MESSAGE.
MESSAG   CNAME    2+0               MESSAG  STARTS A MESSAGE.
ESSAGE   CNAME    0+1                ESSAGE FINISHES & PRINTS A MESSAGE.
ESSAG    CNAME    0+0                ESSAG  ADDS TO A MESSAGE.
         PROC
*             CF(2)                   TPC    TPCSIM
*               T   PROGRAM TRACE     --     M:PRINT
*               E   ERROR MESSAGE    M:TYPE  M:PRINT
*               K   OPERATOR KEYIN   M:TYPE  M:TYPE
*
J        SET      SCOR(CF(2),T,E,K)
         ERROR,7,J=0  'SYNTAX'
*
         DO       J>1|SIMULATE      BUILD MSG EXCEPT TPC/TRACE.
*
LF       BAL,10   S:S(NAME/2,ESS%AGE,MESS%AGE)
*
I        DO       NUM(AF)
         GOTO,NUM(AF(I))  #L,#CT,#CVS
*
#CVS     CLOSE                      NUMBER: (SOURCE),LENGTH,TYPE.
*                             TYPE: 0=DECIMAL, 1=DECIMALZS, 2=HEX.
 GEN,1,3,4,4,3,17  AFA(I,1,1),3,AF(I,2),AF(I,3),AF(I,1,2),AF(I,1,1)
         GOTO     #FIN
*
#CT      CLOSE                      TEXTPOINTER: (SOURCE),(LENGTH).
         GEN,1,000000000003,4,4,3*AFA(I,1,1),20-3*AFA(I,1,1) ;
             0,2+AFA(I,1,1),0,3,AF(I,1,2),AF(I,1,1)
         LW,0     AF(I,2)
         GOTO     #FIN
*
#L       SET      S:UT(AF(I))       TEXT: ' TEXT '.
         GEN,16,8,8  NUM(#L),#L(1),#L(2)
#L(1),#L(2)  SET  ''
         TEXT     #L
         ERROR,7,1-TCOR(AF(I),S:C)  'ILLEGAL ARG'
#FIN     FIN
*
         BAL,10   S:S(NAME&1,%+1,;        GO TO CLEANUP.
                  S:S(J<3&SIMULATE,MESS%TYPE,MESS%PRINT))
         ELSE
LF       @P                         (JUST DEFINE LF IF NOT MESSAGING)
         FIN
         CLOSE    I,J,#L
         PEND
         PAGE
*
MESS#T   @T
MESS#RET     RES  1                 REMEMBER RETURN ADDRESS.
MESS#POINT   RES  1                 REMEMBER WHERE WE ARE IN LINE.
MESS#AREA    RES  133//4            BUILD MESSAGE LINE.
MESS#INTSAVE      @T                SAVE PARTIAL MSG HERE IF INTERRUPTED
#MESS#SAVE  EQU  BA(MESS#INTSAVE)-BA(MESS#T)  LENGTH OF SAVEAREA.
         RES,1    #MESS#SAVE        SAVEAREA.
         @S
MESS##SAVE  GEN,8,24  #MESS#SAVE,BA(MESS#INTSAVE)    REGISTER &DISPL
#MESS#SAVE#MBS  EQU  BA(MESS#T)-BA(MESS#INTSAVE)     FOR SAVE.
MESS##REST  GEN,8,24  #MESS#SAVE,BA(MESS#T)          REGISTER & DISPL
#MESS#REST#MBS  EQU  BA(MESS#INTSAVE)-BA(MESS#T)     FOR RESTORE.
*
         @P
MESS%AGE LI,11    BA(MESS#AREA)+1   ***  START NEW MESSAGE.
MESS%00  STW,11   MESS#POINT        REMEMBER CURRENT PLACE IN MSG.
*
ESS%AGE  STW,10   MESS#RET          REMEMBER CURRENT PLACE IN PLIST.
MESS%01  INT,10   *MESS#RET         GET A PARAMETER WORD.
         BCS,15   MESS%20
         STB,10   MESS#POINT  0000**IMMEDIATE TEXT: (8-15)=LENGTH.
         LW,11    MESS#POINT        MOVE TEXT TO MESSAGE AREA
         ANLZ,10  BA@MESSRET         FROM PARAMETER WORD ITSELF
         MBS,10   2                  STARTING AT BYTE 2.
         AI,10    5                 THEN ADVANCE TO NEXT
         SLS,10   -2                 PARAMETER WORD.
         B        MESS%00
BA@MESSRET LB,0   *MESS#RET
*
MESS%20  BCS,9    MESS%21
         BCS,4    *MESS#RET   01X0**PLIST END: GO WHERE IT SAYS TO.
*
MESS%21  LW,11    *MESS#RET         CONVERT PARAMETER WORD
         AND,11   L(X'F00FFFFF')     INTO
         OR,11    L(X'02B00000')     LOAD,11 INSTRUCTION
         EXU      11                 AND DO IT.
         MTW,+1   MESS#RET          INCREMENT PLIST POINTER.
         SCS,10   -8                10=TYPE(0-3),COUNT(28-31),XX(4-7).
         STB,10   MESS#POINT        COUNT => MESSAGE POINTER.
         LC       10                               10  11
         BCR,15   MESS%60           0:DECIMAL      LEN #
         BCR,14   MESS%70           1:DECIMALZS    LEN #
         BCR,13   MESS%80           2:HEXADECIMAL  LEN #
*                                   3:TEXT         --  BA(TEXT)
         ANLZ,10  *MESS#RET         10 = LENGTH OF TEXT.
         MTW,+1   MESS#RET
         STB,10   MESS#POINT        LENGTH => MESSAGE POINTER.
         LW,10    11                MOVE TEXT
         LW,11    MESS#POINT         TO
         MBS,10   0                  MESSAGE.
         STW,11   MESS#POINT        UPDATE MSG POINTER.
         B        MESS%01
*
MESS%60  CVS,11   BIN#TO#DEC        **DECIMAL: GET EBCDIC TO 11.
         B        MESS%76
MESS%70  CVS,11   BIN#TO#DEC        **DECIMAL ZERO-SUPPRESSED:
         AI,10    MESS#MASKS-1      POINT TO ZS-MASKS.
MESS%72  CW,11    *10               IS CURRENT CHARACTER ZERO?
         BANZ     MESS%74            NO.
         MTB,-1   MESS#POINT         YES.  REDUCE COUNT AND
         BDR,10   MESS%72             MOVE TO NEXT ZS-MASK.
MESS%74  AI,10    1-MESS#MASKS      GET NONZERO LENGTH.
MESS%76  XW,11    MESS#POINT        DEST TO 11, EBCDIC TO MESS#POINT.
         LCW,10   10                COMPUTE
         AI,10    BA(MESS#POINT)+4   START OF TEXT
         MBS,10   0                   AND MOVE THE TEXT.
         STW,11   MESS#POINT        REMEMBER NEW PLACE IN MSG.
         B        MESS%01
MESS#MASKS        @S
         DATA     X'FFFFFFFF'
         DATA     X'00000F00'
         DATA     X'000F0000'
         DATA     X'0F000000'
         @P
*
MESS%80  SLS,10   2                 **HEXADECIMAL:
         LCW,10   10                NUMBER OF BITS TO DISCARD
         AI,10    32                = 32 - 4*(NUMBER OF DIGITS).
         SLS,11   *10               DISCARD THE BITS.
         XW,3     MESS#POINT        GET CURRENT PLACE IN MSG.
MESS%82  LI,10    '0'**-4           CONVERT
         SLD,10   +4                 A
         CI,10    '9'                 DIGIT
         BLE      MESS%84              TO
         AI,10    'A'-'9'-1             EBCDIC.
MESS%84  STB,10   0,3               ADD IT TO MESSAGE.
         AI,3     +1                BUMP MSG POINTER.
         MTB,-1   3                 REPEAT
         BNEZ     MESS%82            UNTIL DONE.
         XW,3     MESS#POINT        UPDATE MSG POINTER.
         B        MESS%01
*
MESS%TYPE MTW,0   J:JIT             MESSAGE TYPER TO OPERATOR:
         BLZ      MESS%PRINT        TYPE & PRINT BATCH, PRINT ONLINE.
         LW,11    MESS#POINT
         AI,11    -1-BA(MESS#AREA)  GET MESSAGE LENGTH
         STB,11   MESS#AREA          TO BYTE 0 OF MESSAGE.
         M:TYPE   (MESS,MESS#AREA)  TYPE THE MESSAGE.
MESS%PRINT LW,11  MESS#POINT        MESSAGE PRINTER:
         AI,11    -1-BA(MESS#AREA)  GET MESSAGE LENGTH
         STB,11   MESS#AREA          TO BYTE 0 OF MESSAGE.
         M:PRINT  (MESS,MESS#AREA)  PRINT THE MESSAGE.
         B        *10
         TITTLE   'INTERFACE TO QUEUE/SIMULATED QUEUE'
************************************ * * * * * * * * * * * * * * * * * *
*                                                                      *
*  GET%ID GETS A NEW TRANSACTION ID IN HEX AND EBCDIC FORMS.           *
*                                                                      *
************************************ * * * * * * * * * * * * * * * * * *
         @T
#DATE    EQU      (DATE&DATE**-4&255**16)+(DATE**-8&DATE**-12&255**24)
ID#TEMP  DATA     #DATE             START ID FOR TPCSIM, IGNORE FOR TPC.
*
GET%ID   ENTRY    ;
        'R12<= NEW XACTION ID (HEX)  R13<= ''.''  R14/15<= ID (EBCDIC).'
         DO       SIMULATE
*  THE FOLLOWING IS THE CODE FOR GETTING A SIMULATED TRANSACTION ID.
         MTW,1    ID#TEMP           BUMP SIMULATED ID WORD.
         ELSE
*  THE FOLLOWING IS THE CODE FOR GETTING A REAL TRANSACTION ID.
         STW,SR1  ID#TEMP           PRESERVE SR1.
         M:GETID                    SR1 <= HEXADECIMAL TRANSACTION ID.
         XW,SR1   ID#TEMP           MOVE IT TO ID#TEMP.
         FIN
         LI,R14   0                 CLEAR THE REGISTERS WHICH WILL
         LI,R15   0                   CONTAIN THE EBCDIC ID.
         LW,R13   ID#TEMP           GET ID TO R13.
GETID%10 LI,R12   '0'**-4           CONVERT ONE DIGIT
         SLD,R12  +4                  TO EBCDIC.
         CI,R12   '9'               WAS IT CONVERTED INTO '0' - '9'?
         BLE      GETID%15          YES.
         AI,R12   'A'-'9'-1         NO.  ADJUST IT TO BE 'A' - 'F'.
GETID%15 SLD,R14  8                 MAKE ROOM FOR IT.
         OR,R15   R12               PUT IT IN.
         BNOV     GETID%10          OV SET BY SLD WHEN FINISHED.
         LI,R13   '.'               PERIOD BEFORE EBCDIC IS HANDY.
         LW,R12   ID#TEMP           PUT HEX ID INTO R12.
         RETURN   GET%ID            FINISHED.
*
*
         DO       SIMULATE
         @T
S#INBUF  RES      21
         FIN
         PAGE
************************************ * * * * * * * * * * * * * * * * * *
*                                                                      *
*  QUEUE%GET GETS A TRANSACTION FROM THE QUEUE OR SIMULATED QUEUE.     *
*                                                                      *
************************************ * * * * * * * * * * * * * * * * * *
QUEUE%GET  ENTRY  ;
         'GET A TRANSACTION INTO PAGE POINTED TO BY TRAN#POINTER.',;
         'WHEN GOTTEN, QGET#ECB WILL BE POSTED WITH CC OF 1.',;
         'RETURNS SR1=LIST INDEX.',;
         'ALL REGS BUT R4 ZAPPED.  NEEDS R4=>DYN.AREA(UNPROTECTED).'
         DO       SIMULATE
*  THE FOLLOWING IS THE CODE FOR THE SIMULATOR VERSION.
         LW,R5    S#SPAWN,R4        R5 =>SPAWNED-TRANSACTION ENTRY.
         BEZ      M%Q%G%GET              IF NONE, GO READ ONE IN.
M%Q%G%10 LW,R6    CRI#POINTER,R4    R6 =>CRITERIA LIST.
         LW,R8    CRI#COUNT#GOOD,R4 R4 = NUMBER OF CRITERIA.
         BEZ      M%Q%G%25               IF NONE, CAN'T BE A MATCH.
M%Q%G%20 ANLZ,R12 BA@R5             R12= BA(TRANSACTION ENTRY).
         LW,R13   0,R6              R13= BA(CRITERION).
         CBS,R12  #J#NAMEB               DOES NAME MATCH CRITERION?
         BE       M%Q%G%FOUND            YES.
         AI,R6    +1                     NO.
         BDR,R8   M%Q%G%20               TRY NEXT CRITERION.
*                                   **  THIS TRANSACTION LOSES.
M%Q%G%25 LW,R2    #J#CHAINW,R5      R2 =>NEXT SPAWNED TRANSACTION.
         M:FSP    512,R5                 FREE THE LOSER'S SPACE.
         LW,R5    R2                R5 =>NEXT SPAWNED TRANSACTION.
         BNEZ     M%Q%G%10               IF ONE EXISTS, GO DO IT.
         STW,R5   S#SPAWN,R4             IF NOT, RESET SPAWN-CHAIN HEAD.
         M:GL                            AND, WHILE WE'RE AT IT,
         STW,SR1  SPACE#AVAIL,R4         TELL OURSELVES NOSPACEINUSE.
M%Q%G%GET         @P                ** NO MATCHES; PREPARE TO READ.
         M:GSP    512               R5 =>NEW 512-WORD AREA.
         BCS,8    MASTER%ABORT           DIE IF NO SPACE.
*                                   ** NOW WE HAVE SPACE TO READ INTO.
M%Q%G%30 ANLZ,R1  BA@R5                  CLEAR:
         AW,R1    L(#J#HDR#LEN**24)        TRANSACTION HEADER
         MBS,R0   BA(L(0))                   TO ZEROS.
         AW,R1    L(#J#NAME#LEN**24)       TRANSACTION NAME AREA
         MBS,R0   BA(BLANK#)                 TO BLANKS.
         M:READ   M:SI,(BUF,S#INBUF),(SIZE,80),;  READ NAME RECORD OF
                  (ABN,M%Q%G%ABN),(ERR,M%Q%G%ERR)  NEXT TRANSACTION.
         LI,R2    BA(S#INBUF)       R2 =>START OF XACTION NAME RECORD.
         LB,R14   0,R2              R14= JOURNAL INDICATOR.
         AND,R14  L(3)                   SEE IF JRNL OR DELIJRNL SPEC.
         BEZ      M%Q%G%32               ---> NO. USE ZERO JRNL.
         LI,R14   ##JJRNLO+##JJRNLD      YES. SET JRNL FLAGS.
M%Q%G%32 AI,R14   ##JQUEUE+##JIP         ALSO QUEUED & INPROGRESS.
         SLS,R14  +24               R14= FLAGS(0-7), 0(8-31).
         LW,R6    M:SI+ARS
         SLS,R6   -17               R6 = RECORD SIZE FROM READ.
         STB,R14  S#INBUF,R6             PUT A STOPPER AFTER RECORD.
         AI,R6    -1
         LI,R15   ' '               R15= 0(0-23), BLANK(24-31).
         CB,R15   S#INBUF,R6             IF LAST CHAR OF RECORD IS
         BLE      M%Q%G%35               A FUNNY ONE (CR,LF,ETC),
         STB,R15  S#INBUF,R6             MAKE IT A BLANK.
*
M%Q%G%35 LI,R9    0                 R9 WILL BE TEXT LENGTH.
M%Q%G%40 AI,R2    +1                R2 =>CURRENT CHAR IN NAMERECORD.
         LB,R8    0,R2              R8 = CURRENT CHARACTER.
         AI,R8    -'0'                   IS IT A DIGIT?
         BGEZ     M%Q%G%43               YES.
         AI,R8    '0'-' '                IS IT A BLANK?
         BNEZ     M%Q%G%45               NO. MUST BE START OF NAME.
M%Q%G%43 MI,R9    10                   ADD THIS CHARACTER'S VALUE
         AW,R9    R8                   INTO NAME LENGTH.
         CI,R9    1980                 NAME IS NOT ALLOWED TO BE
         BLE      M%Q%G%40             LONGER THAN 1980 CHAR.
         B        M%Q%G%ERR            IF IT IS, COMPLAIN.
M%Q%G%45 AI,R8    ' '-'?'   **NOTE: THIS IS BLANK MINUS QUESTIONMARK.
         BNEZ     M%Q%G%ERR           ERROR UNLESS NAME STARTS W/ Q.M.
*
         AW,R14   R9                R14= (00-07) JOURNAL/QUEUE FLAGS.
         AI,R14   #J#TEXTB+3+4           (16-31) RECORD LENGTH(BYTES).
         AND,R14  L(X'FFFFFFFC')
         STW,R14  #J#FLAGSW,R5         SET UP FLAGWORD IN XACTION.
*
         ANLZ,R3  BA@R5
         AI,R3    #J#NAMEB          R3 =>NAMESPACE IN XACTION AREA.
         LI,R8    1-#J#NAME#LEN       COPY NAME
M%Q%G%50 LB,R12   0,R2                TO
         STB,R12  0,R3                TRANSACTION AREA.
         AI,R2    +1
         AI,R3    +1
         CB,R15   0,R2                WHEN FIRST BLANK IS REACHED,
         BE       M%Q%G%55            STOP COPYING.
         BIR,R8   M%Q%G%50            IF NO BLANKS,
         B        M%Q%G%ERR           BAD NEWS.
M%Q%G%55 CI,R12   '.'               IS LAST CHAR IN NAME A PERIOD?
         BNE      M%Q%G%57            NO.
         AI,R8    8                   YES. SAY NAME IS 8 LONGER.
         BGZ      M%Q%G%ERR         COMPLAIN IF THAT MAKES IT TOOBIG.
         CALL     GET%ID
         LI,R2    8                      ADD AN 8-CHARACTER TID
         STB,R2   R3                     TO THE END OF THE
         MBS,R2   (R14*4)-8              TRANSACTION NAME.
M%Q%G%57 AI,R8    #J#NAME#LEN       R8 = TRUE LENGTH OF NAME.
         STH,R9   R8                R8 = TEXT LENGTH, NAME LENGTH.
         STW,R8   #J#LENGTHSW,R5       SET UP LENGTHSWORD IN XACTION.
         LW,R13   R9                IF NO TEXT,
         BEZ      M%Q%G%10            GO MATCH TO CRITERIA.
         ANLZ,R15 BA@R5
         AI,R15   #J#TEXTB          R15=> TEXTSPACE IN TRANSACTION AREA.
*
M%Q%G%60 M:READ   M:SI,(ERR,M%Q%G%ERR),;   READ A RECORD OF
                  (ABN,M%Q%G%ERR)        TRANSACTION TEXT.
         LW,R2    M:SI+ARS
         SLS,R2   -17               R2= RECORD SIZE FROM READ.
         CI,R2    73                IF IT'S A BIG RECORD,
         BL       M%Q%G%62
         LI,R2    72                  USE 72 CHARACTERS.
         B        M%Q%G%64
M%Q%G%62 AI,R2    -1                IF IT'S A SMALL RECORD,
         LB,R9    S#INBUF,R2        LOOK AT LAST CHAR OF RECORD.
         CI,R9    X'15'             IF IT'S L/F
         BE       M%Q%G%64
         CI,R9    X'0D'             OR C/R,
         BE       M%Q%G%64
         AI,R2    +1                DON'T USE THAT CHARACTER.
M%Q%G%64 LI,R14   BA(S#INBUF)
         SW,R13   R2                MORE THAN ONE TEXTRECORD LEFT?
         BLEZ     M%Q%G%65          NO.
         STB,R2   R15               MOVE 72 CHARACTERS
         MBS,R14  0                 FROM RECORD TO ENTRY.
         B        M%Q%G%60          KEEP READING.
*
M%Q%G%65 AW,R13   R2                LAST RECORD.
         STB,R13  R15               MOVE HOWEVER MANY CHARACTERS
         MBS,R14  0                 FROM RECORD TO ENTRY.
         B        M%Q%G%10          GO MATCH TRANSACTION TO CRITERIA.
*
*  FOUND A MATCH.  R5=>ENTRY.  R6=>CRITERION POINTER.
*
M%Q%G%FOUND       @P
         SW,R6    CRI#POINTER,R4
         AI,R6    +1                R6 = INDEX OF MATCHING CRITERION.
         LW,R2    #J#CHAINW,R5          REMOVE THIS ENTRY
         STW,R2   S#SPAWN,R4             FROM SPAWN-CHAIN.
         LW,R7    TRAN#POINTER,R4   COPY THIS ENTRY TO
         LI,R2    255                 TRAN#POINTER'S PAGE.
M%Q%G%70 LD,R12   *R5,R2            MOVE
         STD,R12  *R7,R2            IT
         BDR,R2   M%Q%G%70          DOUBLEWORD
         LD,R12   *R5               BY
         STD,R12  *R7               DOUBLEWORD.
         M:FSP    512,R5            FREE THE ENTRY'S OLD SPACE.
         LW,R2    L(#ECBP)          --- POSTED
         LI,R3    1                 --- WITH CC OF 1
         STD,R2   QGET#ECB          ---  INTO TRANSACTION-GET ECB.
         LW,SR1   R6                SR1= CRITERION INDEX.
         RETURN   QUEUE%GET
*
M%Q%G%ERR         @P                ** BAD NEWS READING THE XACTION.
         MESSAGE,T '<<< EVIL INPUT. TRY AGAIN.'
         B        M%Q%G%30
*
M%Q%G%ABN         @P
         MESSAGE,T '* END OF TRANSACTION INPUT FILE'
         B        END%
         ELSE
*  THE FOLLOWING IS THE CODE FOR THE NON-SIMULATOR VERSION.
*
         LW,R5    TRAN#POINTER,R4   GET PLACE TO HOLD TRANSACTION.
         LW,R6    QGET#ID,R4        GET ID OF LIST.
         BEZ      M%Q%G%31          (IF ID=0 NO REQUESTS, SO WAIT)
         M:QUEUE  *R6,GET,(BUF,*R5),(BSIZE,512),WAIT,(ECB,QGET#ECB)
         BCR,12   M%Q%G%99          GO IF TRANSACTION HAS BEEN GOTTEN.
         BCS,4    M%Q%G%11          GO IF WE NEED TO WAIT ON QUEUE.
         SLS,SR3  -17               EITHER BAD NEWS OR WAIT NO-ECB.
         CI,SR3   #QINTOUT            (OR INTERRUPT BUMPOUT)
         BE       MASTER%             (IN WHICH CASE TRY AGAIN.)
         CI,SR3   #QTOOFULL         WHICH ONE?
         BNE      MASTER%ABORT      BAD NEWS. DIE HORRIBLY.
         M:WAIT   1                 WAIT NO-ECB. WAIT A WHILE,
         B        MASTER%            AND TRY AGAIN.
*
M%Q%G%11 SETT     F#WAIT            SIGNAL ABOUT-TO-WAIT.
         BON,F#SORT  M%Q%G%21       BACK TO TOP IF INT WHILE WAITING.
*
*                                   WAIT FOR SOMETHING TO HAPPEN.
         M:CHECKECB  (ECB,QGET#ECB)
         BCS,15   MASTER%ABORT      ANY CC FROM CHECKECB IS BAD NEWS.
         LC       QGET#ECB          DID ECB GET POSTED?
         BCS,8    M%Q%G%21          YES.  GO ON.
         SETT     F#SORT            NO.  MUST PURGE BEFORE RESUBMITTING.
M%Q%G%21 CLEAR    F#WAIT            NO LONGER ABOUT-TO-WAIT.
         B        MASTER%           GO SEE WHAT HAPPENED.
*
M%Q%G%31 SETT     F#WAIT            SIGNAL ABOUT-TO-WAIT.
         BON,F#SORT  M%Q%G%21       BACK TO TOP IF INT WHILE WAITING.
         M:WAIT 10000               (WAIT FOREVER IF NO REQUESTS)
         B        M%Q%G%21            TRY AGAIN IF INTERRUPTED OUT.
*
M%Q%G%99 RETURN   QUEUE%GET         GOT A TRANSACTION. RETURN.
         FIN
         PAGE
************************************ * * * * * * * * * * * * * * * * * *
*                                                                      *
*  QUEUE%PUT PUTS STUFF IN THE QUEUE OR SIMULATED QUEUE.               *
*                                                                      *
************************************ * * * * * * * * * * * * * * * * * *
QUEUE%PUT  ENTRY  ;
         'PUT THINGS INTO THE QUEUE OR SIMULATED QUEUE.',;
         'ALL BUT R4 ZAPPED. NEEDS R5=>PUTLIST,R6=LISTLEN,R4=>DYNAREA.'
         DO       SIMULATE
         LW,R3    R5
M%Q%PUT  @P
*
*  R3= ADDRESS OF PUTLIST.    R6= LENGTH OF PUTLIST.
*
         LW,R5    *R3               R5 => ENTRY.
         LB,R8    R5                GET FLAGS.
         CI,R8    ##JIP             SEE IF IT'S THE ORIG XACTION.
         BANZ     M%Q%P%END         DONT DISPLAY XACTION DELETION.
         INT,R8   #J#LENGTHSW,R5    R8= TEXT LENGTH.
         CVS,R8   BIN#TO#DEC        R9= TEXT LENGTH(DECIMAL)
         LB,R8    R5
         SLS,R8   -##JJRNLDS        ALIGN JOURNALIZE BIT(2)
         AND,R8   L(3)              AND DELIVERY JOURNAL BIT(1).
         AI,R8    '0'               R8(24-31)= JOURNAL FLAG.
         LI,R13   BA(S#INBUF)       BUILD MESSAGE IN S#INBUF.
         LI,R12   R8*4+3
         MTB,5    R13
         MBS,R12  0                 PUT FLAG & LENGTH IN MESSAGE.
         INT,R8   #J#LENGTHSW,R5    R9= NAME LENGTH.
         STB,R9   R13
         ANLZ,R12 BA@R5
         MBS,R12  #J#NAMEB          PUT NAME IN MESSAGE.
         AI,R13   -BA(S#INBUF)      WRITE NAME RECORD.
         M:WRITE  M:LO,(BUF,S#INBUF),(SIZE,*R13),WAIT
         LW,R12   R5
         AI,R12   #J#TEXTW          R12 => TEXT OF ENTITY.
*
M%Q%P%10 AI,R8    -72
         BLZ      M%Q%P%20
         M:WRITE  M:LO,(BUF,*R12),(SIZE,72),WAIT
         AI,R12   18
         B        M%Q%P%10
M%Q%P%20 AI,R8    72
         BEZ      M%Q%P%30
         M:WRITE  M:LO,(BUF,*R12),(SIZE,*R8),WAIT
M%Q%P%30 LW,R8    #J#NAMEW,R5
         SLS,R8   -24
         CI,R8    '?'               THIS IS A QUESTION MARK.
         BNE      M%Q%P%40          GO IF ENTITY IS REPORT.
         AND,R5   L(X'1FFFF')       R5 =>NEW SPAWNED XACTION.
         LI,R2    S#SPAWN-#J#CHAINW
         AW,R2    R4                R2 =>HEAD OF SPAWNED XACTIONS.
M%Q%P%34 CW,R5    #J#CHAINW,R2           LOOK DOWN THE CHAIN,
         BG       M%Q%P%36               KEEPING IT IN ORDER
         LW,R2    #J#CHAINW,R2           FROM BIG TO LITTLE
         B        M%Q%P%34               MEMORY ADDRESSES.
M%Q%P%36 LW,R12   #J#CHAINW,R2      R12= ADDRESS OF NEXT-ON-CHAIN.
         STW,R5   #J#CHAINW,R2           INSTALL THIS ONE ON CHAIN.
         STW,R12  #J#CHAINW,R5           KEEP THE REST OF THE CHAIN.
         STW,R5   S#SPAWN,R4        OF SPAWNED TRANSACTIONS.
         B        M%Q%P%END
M%Q%P%40 INT,R8   #J#FLAGSW,R5      REPORT --
         SLS,R9   -2
         M:FSP    *R9,R5              RELEASE ITS SPACE.
M%Q%P%END         @P
         AI,R3    1
         BDR,R6   M%Q%PUT           REPEAT UNTIL LIST FINISHED.
*
*
         M:GL                       SR1= WA(LOWEST COMMON PAGE).
         LW,R7    SR1               R7 = WA(LOWEST COMMON PAGE).
         LI,R5    S#SPAWN-#J#CHAINW
         AW,R5    R4                R5 =>NEXT SPAWNED XACTION.
M%Q%P%70 LW,R6    #J#CHAINW,R5      R6 = WA(NEXT SPAWNED XACTION).
         BEZ      M%Q%P%90               GO IF NO MORE OF THEM.
         AI,R7    -512              R7 = WHERE R6 SHOULD BE PUT.
         CW,R7    R6                     IS IT ALREADY THERE?
         BE       M%Q%P%78               YES.
         M:GVP    *R7                    NO. GET THE PAGE TO PUT IT IN.
         BCS,8    M%Q%P%ERR            ** (OOPS.) **
         STW,R7   #J#CHAINW,R5           POINT CHAIN TO RIGHT PLACE.
         LI,R2    255               COPY
M%Q%P%74 LD,R12   *R6,R2             FROM
         STD,R12  *R7,R2              WRONG
         BDR,R2   M%Q%P%74             TO
         LD,R12   *R6                   RIGHT
         STD,R12  *R7                    PLACE.
         M:FVP    *R6                    DISCARD THE WRONG PAGE NOW.
         BCS,8    M%Q%P%ERR            ** (OOPS.) **
M%Q%P%78 LW,R5    #J#CHAINW,R5           PROCEED DOWN
         B        M%Q%P%70               THE CHAIN.
*
M%Q%P%90 STW,R7   SPACE#AVAIL,R4    R7 = WA(LOWEST PAGE NOW IN USE).
*
         RETURN   QUEUE%PUT
         ELSE
         LI,R9    0
         STD,R9   QDEFPUT#ECB
M%Q%P%11 M:QUEUE  *R5,PUT,(LSIZE,*R6),WAIT,(ECB,QDEFPUT#ECB)
         BCR,12   M%Q%P%31          GO IF PUT WAS SUCCESSFUL.
         BCS,4    M%Q%P%21          GO IF NEED TO ECBWAIT ON QUEUE.
         SLS,SR3  -17               EITHER BAD NEWS OR WAIT NO-ECB.
         CI,SR3   #QINTOUT            (OR INTERRUPT BUMPOUT)
         BE       M%Q%P%11            (IN WHICH CASE TRY AGAIN.)
         CI,SR3   #QTOOFULL         WHICH ONE?
         BNE      M%Q%P%ERR         BAD NEWS. DIE HORRIBLY.
         M:WAIT   1                 WAIT NO-ECB. WAIT A WHILE,
         B        M%Q%P%11           AND TRY AGAIN.
M%Q%P%21 M:CHECKECB  (ECB,QDEFPUT#ECB)
         BCS,15   M%Q%P%ERR         ANY CC FROM CHECKECB IS BAD NEWS.
         LC       QDEFPUT#ECB       DID ECB GET POSTED?
         BCS,8    M%Q%P%11          YES. TRY AGAIN.
         B        M%Q%P%21          NO. GO BACK AND WAIT SOME MORE.
M%Q%P%31 LW,R7    R6
         AI,R6    -1                SKIP INITIAL XACTION.
M%Q%P%41 AI,R6    -1
         BLZ      M%Q%P%81
         LW,R9    *R5,R6
         M:FSP    512,R9
         B        M%Q%P%41
M%Q%P%81 M:GL
         STW,SR1  SPACE#AVAIL,R4
         RETURN   QUEUE%PUT
         FIN
M%Q%P%ERR  @P                       *****     QUEUE/PUT ERROR.
         MESSAGE,E  'M:QUEUE/PUT ERROR.'
         B        MASTER%ABORT%TIP
         PAGE
************************************ * * * * * * * * * * * * * * * * * *
*                                                                      *
*  QUEUE%PURGE PURGES THE OUTSTANDING GETLIST IF ANY (TPC)             *
*              DOES NOTHING       (TPC SIMULATOR)                      *
*                                                                      *
************************************ * * * * * * * * * * * * * * * * * *
QUEUE%PURGE ENTRY ;
         'PURGE ANY OUTSTANDING GETLIST.',;
         'ALL REGS BUT R4 ZAPPED.  NEEDS R4=>DYN.AREA(UNPROTECTED).'
         DO       SIMULATE
         LI,R6    0
         STW,R6   QGET#ID,R4        CLEAR OUT LIST ID ONLY.
         RETURN   QUEUE%PURGE
         ELSE
         LI,R6    0
         XW,R6    QGET#ID,R4        GET QUEUE LIST ID AND CLEAR IT.
         BEZ      M%Q%PG%9          GO IF NO OUTSTANDING GETLIST.
M%Q%PG%3 M:QUEUE  *R6,PURGE,WAIT    PURGE OUTSTANDING GETLIST.
         BCR,12   M%Q%PG%9          GO IF LIST SUCCESSFULLY PURGED.
         SLS,SR3  -17               EITHER BAD NEWS OR WAIT NO-ECB.
         CI,SR3   #QINTOUT            (OR INTERRUPT BUMPOUT)
         BE       M%Q%PG%3            (IN WHICH CASE TRY AGAIN.)
         CI,SR3   #QTOOFULL         WHICH ONE?
         BNE      MASTER%ABORT      BAD NEWS. DIE HORRIBLY.
         M:WAIT   1                 WAIT NO-ECB. WAIT A WHILE,
         B        M%Q%PG%3           AND TRY AGAIN.
*
M%Q%PG%9 RETURN   QUEUE%PURGE       LIST HAS BEEN PURGED. RETURN.
         FIN
         PAGE
************************************ * * * * * * * * * * * * * * * * * *
*                                                                      *
*  QUEUE%DEFINELIST  ESTABLISHES A QUEUE-GET LIST.                     *
*                                                                      *
************************************ * * * * * * * * * * * * * * * * * *
QUEUE%DEFINELIST ENTRY ;
         'ESTABLISH A QUEUE-GET LIST.',;
         'RETURNS SR1= LIST ID(TPC) DUMMY ID(SIMULATOR).',;
         'ALL REGS BUT R4 ZAPPED.  NEEDS R4=>DYN.AREA(UNPROTECTED).'
         DO       SIMULATE
         LI,SR1   X'ABCD'           JUST RETURN ID FOR SIMULATOR.
         MTW,0    CRI#COUNT#GOOD,R4  ANY CRITERIA?
         BNEZ     M%Q%D%50          YES. RETURN WITH ID.
         LI,SR1   0                 NO.  RETURN WITH ZERO.
M%Q%D%50 @P
         RETURN   QUEUE%DEFINELIST
         ELSE
M%Q%D%10 LI,R9    0
         STD,R9   QDEFPUT#ECB       CLEAR OUT ECB FIRST.
         LW,R6    CRI#POINTER,R4    R6=> GET LIST.
         LW,R7    CRI#COUNT#GOOD,R4 R7= NUMBER OF CRITERIA.
         BEZ      M%Q%D%90          (RETURN ZERO ID IF NO CRITERIA)
         M:QUEUE  *R6,DEFINELIST,(LSIZE,*R7),WAIT,(ECB,QDEFPUT#ECB)
         BCR,12   M%Q%D%99          GO IF LIST HAS BEEN ESTABLISHED.
         BCS,4    M%Q%D%20          GO IF NEED TO ECBWAIT.
         SLS,SR3  -17               EITHER BAD NEWS OR WAIT NO-ECB.
         CI,SR3   #QINTOUT            (OR INTERRUPT BUMPOUT)
         BE       M%Q%D%10            (IN WHICH CASE TRY AGAIN.)
         CI,SR3   #QTOOFULL         WHICH ONE?
         BNE      MASTER%ABORT      BAD NEWS. DIE HORRIBLY.
         M:WAIT   1                 WAIT NO-ECB. WAIT A WHILE,
         B        M%Q%D%10           AND TRY AGAIN.
M%Q%D%20 M:CHECKECB  (ECB,QDEFPUT#ECB)
         BCS,15   MASTER%ABORT      ANY CC FROM CHECKECB IS BAD NEWS.
         LC       QDEFPUT#ECB       DID ECB GET POSTED?
         BCS,8    M%Q%D%10          YES. TRY AGAIN.
         B        M%Q%D%20          NO. GO BACK AND WAIT SOME MORE.
*
M%Q%D%90 LI,SR1   0                 (RETURN ZERO ID IF NO CRITERIA)
M%Q%D%99 RETURN   QUEUE%DEFINELIST  LIST HAS BEEN ESTABLISHED. RETURN.
         FIN
         TITTLE   'INITIALIZATION'
************************************ * * * * * * * * * * * * * * * * * *
*                                                                      *
*  TPC%  IS WHERE IT ALL BEGINS.                                       *
*        HE DOES ALL THE INITIAL HOUSEKEEPING.                         *
*                                                                      *
************************************ * * * * * * * * * * * * * * * * * *
TPC%     @P
         M:GL                       SR2=>HIGH END OF COMMON STORAGE.
         LI,R4    X'1FE00'
         AND,R4   SR2               R4 = WA(LAST COMMON PAGE).
         LW,R2    R4                R2 = WA(LAST COMMON PAGE).
         CALL     GET%COMMON
*
         LCI      #FPT#PROTECT#LEN
         LM,R8    PROTECT
         STM,R8   FPT#PROTECT,R4
         AWM,R4   FPT#PROTECT,R4
         AWM,R4   FPT#PROTECT+1,R4
         AWM,R4   FPT#UNPROTECT,R4
         AWM,R4   FPT#UNPROTECT+1,R4
*
         M:TRAP   (IGNORE,FX)       MUST HAVE THIS IF NO COBOL/FORTRAN.
         LI,R7    C:TRP             IF COBOL IS AROUND,
         BEZ      TPC%14            GIVE HIM TRAP CONTROL LIKE HE WANTS.
         M:TRAP   C:TRP,(PERMIT,DEC),(IGNORE,FX),(TRAP,DEC,FP)
TPC%14   LI,R7    9INITIAL          IF FORTRAN IS AROUND,
         BEZ      TPC%18              LET HIM
         BAL,R6   9INITIAL            INITIALIZE HIMSELF, THEN
         FINDPROTECTED                GET BACK ADDRESS OF OUR DATA.
*
TPC%18   M:PC     '>'               MIGHT AS WELL DO THIS NOW.
         CALL     GET%ID            SEE IF TP IS OPERATIONAL.
         AI,R12   0                 DID WE GET A NON-ZERO ID?
         BEZ      INIT%ABORT%NOTP   NO.. TP IS NOT RUNNING.
*
         M:XCON   XCON%             ESTABLISH EXIT CONTROL.
         BCS,8    INIT%ABORT%NOXC   IF WE CAN'T, QUIT.
*
         LI,R7    Q:TID             IS EDMS AROUND?
         BEZ      TPC%20              NO.
         STW,R12  Q:TID             TELL EDMS HE'S WORKING WITH TP.
         LI,R14   1                 INVOKE DMSLOCK
         BAL,R15  DMSLOCK           AND TELL HIM TO REPORT ERRORS
         PZE      DMSABORT%         HERE.
         FINDPROTECTED              GET DYNAMIC-DATA ADDRESS AGAIN.
         M:XCON   XCONDMS%          RE-ESTABLISH OUR EXIT CONTROL,
         BCS,8    INIT%ABORT%NOXC   IF WE CAN'T, QUIT NOW.
         STW,SR1  DMS#XCON,R4       AND REMEMBER DBM'S XCON ADDRESS.
TPC%20   @P
*
*  NOW WE HAVE EXIT CONTROL AND THE DBM KNOWS ABOUT US.
*
         PAGE
*
*        CALL ALL TPM'S AT TPMSNN SO THEY CAN INITIALIZE THEMSELVES.
*
         SETT     F#INIT            WE ARE NOW INITIALIZING.
         M:INT    INTERRUPT%        DIDNT WANT TO DO THIS UNTIL F#INIT.
         LI,R7    DYN#AVAIL
         AW,R7    R4
         SLS,R7   +2
         STW,R7   CRI#POINT#CURRENT,R4
         STW,R7   CRI#POINT#PREVIOUS,R4
         LI,R3    0                 START WITH
         STW,R3   TPM#NUMBER,R4       TPM NUMBER 0.
*
INIT%LOOP         @P
         LW,R3    TPM#NUMBER,R4     GET NUMBER OF CURRENT TPM.
         LI,R7    X'1FFFF'
         CW,R7    TPMS%%,R3         IF NO INITIALIZATION ENTRY POINT,
         BAZ      INIT%ZAP%TPM        THIS TPM DOESN'T EXIST.
         CW,R7    TPMX%%,R3         IF NO PROCESSING ENTRY POINT,
         BAZ      INIT%ZAP%TPM        THIS TPM DOESN'T EXIST.
*
         MESSAGE,T '*ENTER TPMS',(R3,2,0),'.'
         LI,R15   INIT%END
         SETT,R15 F#USER            WE ARE NOW IN USER.
         PROTECT                    KEEP USER OUT OF OUR DATA.
         LI,R14   0                 CALL TPM:  # ARGUMENTS = 0.
         LI,R15   TPC                          RETURN = TPC.
         B        TPMS%%,R3         GO TO THE TPM.
*
INIT%END FINDPROTECTED              GET ADDRESS OF OUR PRECIOUS DATA.
         LI,R7    Q:TID
         BEZ      INITE%10          IF EDMS DBM IS PRESENT,
         MTW,0    Q:CCBADR
         BEZ      INITE%10          AND DATABASE HAS BEEN OPENED,
         LI,R14   0                 TELL THE DBM
         BAL,R15  DMSRLSE           TO DISCARD THE TRANSIENT JOURNAL.
         FINDPROTECTED
INITE%10 UNPROTECT
         CLEAR    F#USER            WE AREN'T IN THE TPM ANY MORE.
         LW,R7    CRI#COUNT#TOTAL,R4 IF CRITERIA COUNT
         CW,R7    CRI#COUNT#PREVIOUS,R4 IS UNCHANGED,
         BE       INIT%ZAP%TPM        THIS TPM DOESN'T EXIST.
         STW,R7   CRI#COUNT#PREVIOUS,R4 UPDATE CRITERIA COUNT.
         LW,R7    CRI#POINT#CURRENT,R4
         STW,R7   CRI#POINT#PREVIOUS,R4
         MTW,+1   TPM#INDEX,R4      BUMP GOOD-TPM COUNT.
         LW,R2    TPM#INDEX,R4
         B        INIT%20
INIT%ZAP%TPM      @P
         LI,R2    0
INIT%20  LW,R3    TPM#NUMBER,R4
         ANLZ,R5  WA@TPM#INDEX#TABLE
         STB,R2   *R5,R3
         AI,R3    +1
         STW,R3   TPM#NUMBER,R4
         CI,R3    100
         BL       INIT%LOOP
*
         LW,R3    TPM#INDEX,R4
         BEZ      INIT%ABORT%ZERO
         LW,R6    CRI#POINT#CURRENT,R4
         SLS,R6   -2
         LI,R3    X'1FE00'
         LW,R2    R6
         SW,R2    TPM#INDEX,R4
         SW,R2    TPM#INDEX,R4
         CS,R2    R6                WILL TPM TIMES AND TRANCOUNTS FIT?
         BE       INIT%30           YES.
         CALL     GET%COMMON        NO.  HAVE TO GET A PAGE.
INIT%30  SW,R6    TPM#INDEX,R4
         AI,R6    -1
         STW,R6   TPM#TIME,R4       ESTABLISH BASE OF TPM TIME TABLE.
         STW,R2   TPM#TRAN#COUNT,R4
         MTW,-1   TPM#TRAN#COUNT,R4 ESTABLISH BASE OF TRANCOUNT TABLE.
         LW,R6    R2
         SW,R6    CRI#COUNT#TOTAL,R4
         STW,R6   CRI#POINTER,R4    ESTABLISH BASE OF CRITERIA LIST.
INIT%32  CS,R2    R6                DO WE NEED PAGES?
         BE       INIT%35           NO.
         AI,R2    -512              YES.
         CALL     GET%COMMON        GET ONE.
         B        INIT%32
INIT%35  AI,R2    -512              GET ONE MORE PAGE, FOR XACTIONS.
         CALL     GET%COMMON
         STW,SR1  TRAN#POINTER,R4   THIS IS THE PAGE.
*
         LW,R2    CRI#POINTER,R4    R2 =>CRITERIA LIST.
         LW,R8    CRI#COUNT#TOTAL,R4 R8= NUMBER OF CRITERIA.
         LW,R6    CRI#POINT#CURRENT,R4
         AI,R6    #C#CRI            R6 =>TEXT OF FIRST CRITERION.
INIT%40  STW,R6   0,R2                   PUT CRIPOINTER IN LIST.
         AI,R6    #C#LNTH-#C#CRI       ADVANCE
         LB,R7    0,R6                  TO
         AW,R6    R7                     NEXT
         AI,R6    #C#NONCRI#LEN+#C#CRI-#C#LNTH  CRITERION.
         AI,R2    +1                     ADVANCE TO NEXT LIST ENTRY.
         BDR,R8   INIT%40              REPEAT FOR ALL CRITERIA.
*
         M:GL
         STW,SR1  SPACE#AVAIL,R4
         CLEAR    F#INIT
         B        MASTER%
         PAGE
*
INIT%ABORT @P
         LW,R6    CRI#POINT#PREVIOUS,R4  R6= PREV LOWADDR OF CRITERIA.
         XW,R6    CRI#POINT#CURRENT,R4  R6 = CURRENT LOW ADDR OF THEM.
         LI,R7    X'7F800'
INIT%52  CS,R6    CRI#POINT#PREVIOUS,R4
         BE       INIT%60
         AND,R6   R7
         SLD,R6   -2
         M:GL
         CW,R6    SR1
         BNE      INIT%ABORT%SPACEBAD
         M:FCP    1
         AI,R6    512
         STS,R6   FPT#PROTECT,R4
         STS,R6   FPT#UNPROTECT,R4
         SLD,R6   +2
         B        INIT%52
INIT%60  LW,R1    R6                R1 = MAX(CURR,START OF PREV PAGE).
         SW,R6    CRI#POINT#PREVIOUS,R4  R6= -(#BYTES TO CLEAR).
         BEZ      INIT%70                    GO IF NONE NEEDED.
         LCW,R6   R6                R6 = # BYTES TO CLEAR.
INIT%64  CI,R6    255               CLEAR
         BLE      INIT%66            DISCARDED
         MTB,-1   R1                  CRITERIA
         MBS,R0   BA(L(0))             SPACE
         AI,R6    -255                  TO
         B        INIT%64                ZEROS.
INIT%66  STB,R6   R1                      CLEAR ALL
         MBS,R0   BA(L(0))                 OF IT.
INIT%70  LW,R6    CRI#COUNT#PREVIOUS,R4  ADJUST CRITERIA COUNT
         STW,R6   CRI#COUNT#TOTAL,R4     DOWNWARD.
         MESSAGE,E  'UNABLE TO START UP TPM ',((TPM#NUMBER,R4),2,0),'.'
         B        INIT%ZAP%TPM
*
INIT%ABORT%NOTP   @P
         MESSAG,E 'TP NOT UP'
         B        INIT%ABORT%COMMON
INIT%ABORT%NOXC   @P
         MESSAG,E 'CAN''T GET XCON'
         B        INIT%ABORT%COMMON
INIT%ABORT%ZERO   @P
         MESSAG,E 'NO TPMS'
         B        INIT%ABORT%COMMON
INIT%ABORT%NOSPACE  @P
         MESSAG,E 'NEED MORE CORE'
         B        INIT%ABORT%COMMON
INIT%ABORT%SPACEBAD                 @P
         MESSAG,E 'MEMORY MIXUP'
INIT%ABORT%COMMON @P
         ESSAGE,E ' -- INITIALIZATION ABORTED.'
         B        DIE%
         TITTLE   'MASTER CONTROL'
************************************ * * * * * * * * * * * * * * * * * *
*                                                                      *
*  MASTER% IS THE START OF THE MASTER CONTROL LOOP.                    *
*        MASTER CONTROL DECIDES WHAT NEEDS TO BE DONE AND DOES IT.     *
*        IT MAY CALL KEYIN% TO PROCESS AN OPERATOR INTERRUPT, GO TO    *
*        TRAN% TO PROCESS A TRANSACTION, OR TERMINATE THE TPC.         *
*                                                                      *
************************************ * * * * * * * * * * * * * * * * * *
MASTER%  @P
         LI,R9    0                 CLEAR TRANSACTION-GET ECB
         STD,R9   QGET#ECB          TO ZERO.
         BON,F#XKEYIN  END%         IF OPERATOR X'ED US, GO QUIT.
         BON,F#SORT  CRI%PROC       GO IF CRITERIA NEED REARRANGING.
*
*                                   TRY TO GET A TRANSACTION.
         CALL     QUEUE%GET
         B        TRAN%               THEN GO PROCESS.
*
*  DEATH MESSAGES . . . . . . . . . . . . . . . . . . . . . . . . . . .
*
MASTER%ABORT MESSAGE,E 'TPLM PROBLEM. ABORTING. NO TRANSACTION LOST.'
         M:XXX
MASTER%ABORT%TIP  @P
         FINDPROTECTED
         LW,R5    TRAN#POINTER,R4
         ANLZ,R3  BA@R5
         AI,R3    #J#HDR#LEN
         INT,R1   #J#LENGTHSW,R5
         MESSAGE,E 'TPLM ABORTING. ',(*R3,*R1),' IN PROGRESS.'
         M:XXX
         PAGE
*
*  END% IS WHERE IT ALL GETS SHUT DOWN.
*
DIE%     @P
         LI,R2    1                 EVIL TERMINATION....
         B        END%00
END%     LI,R2    0                 NORMAL TERMINATION...
END%00   @P
         LW,R7    L(FCDBIT)         CLOSE ALL OPEN DCBS (SAVE).
         LW,R3    J:DCBLINK         R3= START OF DCB NAMELIST.
END%10   AI,R3    1                 R3=> DCBNAME.
         LB,R5    *R3               R5= NAMELENGTH.
         SLS,R5   -2                R5= NAMELENGTH(WORDS) - 1.
         AW,R3    R5
         AI,R3    1                 R3=> DCB ADDRESS.
         LW,R6    0,R3              R6=> DCB.
         CW,R7    FCD,R6            IS OIT OPEN?
         BAZ      END%20            NO.
         M:CLOSE  *R6,SAVE          YES.  SAVE IT.
END%20   MTW,0    1,R3              IS THAT ALL OF THEM?
         BNEZ     END%10            NO.
         CI,R2    0                 YES.
         BNE      END%90
         M:EXIT                     NORMAL TERMINATION.
END%90   M:XXX                      EVIL TERMINATION.
*
*        *****  *   *  *****      *****  *   *  ****
*          *    *   *  *          *      **  *  *   *
*          *    *****  ****       ****   * * *  *   *
*          *    *   *  *          *      *  **  *   *
*          *    *   *  *****      *****  *   *  ****
*
         PAGE
************************************ * * * * * * * * * * * * * * * * * *
*                                                                      *
*  CRI%PROC SORTS THE CRITERIA LIST IN DESCENDING PRIORITY ORDER.      *
*                                                                      *
************************************ * * * * * * * * * * * * * * * * * *
         @T
CRI##FIR RES      1                 TEMP FOR FIRST-CRITERION ADDR.
CRI##LAS RES      1                 TEMP FOR  LAST-CRITERION ADDR.
CRI%PROC @P
         SETT     F#SORTING         WE'RE SORTING CRITERIA NOW,
         CLEAR    F#SORT            SO DISCARD THE REQUEST-TO-SORT.
         CALL     QUEUE%PURGE
*********         ****************** * * * * * * * * * * * * * * *
*                 PHASE 1:  PREPARE FOR SORT.
*
         LW,R13   L(X'FF000000')    MASK FOR BYTE 0 (PRIORITY).
         LW,R8    CRI#POINTER,R4    R8 =>CRITERIA LIST.
         AI,R8    -1                     FIX IT FOR EASIER BDR.
         ANLZ,R9 WA@TPM#ACTIVE#TABLE R9=>TABLE OF TPM STATUS.
         LI,R3    0
         STW,R3   CRI#COUNT#GOOD,R4      NO GOOD CRITERIA YET.
         LW,R2    CRI#COUNT#TOTAL,R4 R2= TOTAL NUMBER OF CRITERIA.
CRI%10   LW,R5    *R8,R2            R5 =>CURRENT CRITERION.
         AI,R5    #C#TPM-#C#CRI     R5 =>TPM-NUMBER OF CURR CRITERION.
         LB,R6    0,R5              R6 = TPM-NUMBER.
         LC       *R9,R6                 IS THE TPM EXISTENT & ACTIVE?
         BCR,12   CRI%13                  >>> YES.
         LI,R12   0                 R12= 0 PRIORITY FOR INACTIVE TPM.
         B        CRI%18
CRI%13   AI,R5    #C#NORMP-#C#TPM   R5 =>NORM-PRIORITY FOR ACTIVE TPM.
         CW,R6    TPM#NUMBER,R4          IS THIS TPM THE CURRENT TPM?
         BNE      CRI%15                 >>> NO. USE NORM-PRIORITY.
         AI,R5    #C#NEXTP-#C#NORMP      YES. USE NEXT-PRIORITY.
CRI%15   LB,R12   0,R5              R12= PRIORITY OF THIS CRITERION.
         BEZ      CRI%18                 IF ZERO, IT DOESN'T COUNT.
         MTW,+1   CRI#COUNT#GOOD,R4      COUNT THIS CRITERION GOOD.
         SCS,R12  -8                R12= (0-7) NONZERO PRIORITY.
CRI%18   STS,R12  *R8,R2                 PUT PRIO INTO CRI-POINTER.
         BDR,R2   CRI%10               REPEAT FOR ALL CRITERIA.
*********         ****************** * * * * * * * * * * * * * * *
*                 PHASE 2:  SORT CRITERIA IN PRIORITY ORDER.
*
         LW,R6    CRI#COUNT#TOTAL,R4
         AI,R6    -1                R6= NUMBER OF CRITERIA MINUS ONE.
         BLEZ     CRI%80            IF ONLY ONE, DON'T SORT.
         AW,R6    CRI#POINTER,R4    R6=> LAST CRITERION.
         STW,R6   CRI##LAS          REMEMBER LAST-CRITERION ADDR.
         LW,R3    CRI#POINTER,R4
         LW,R7    CRI#POINTER,R4
*
*        SORT LOW-PRIORITY CRITERIA TO END OF LIST.
*        R3=> LAST SWAP.            R7=> CURRENT CRITERION.
*
CRI%40   STW,R7   CRI##FIR             REMEMBER FIRST-CRITERION ADDR.
CRI%50   LW,R12   0,R7                 GET CURRENT CRITERION.
         CS,R12   1,R7              IS IT IN ORDER WITH NEXT ONE?
         BGE      CRI%55              YES.
         XW,R12   1,R7              NO.
         STW,R12  0,R7              SWAP THE CRITERIA.
         LW,R3    R7                REMEMBER WHERE WE SWAPPED.
CRI%55   AI,R7    +1                   GO TO NEXT CRITERION.
         CW,R7    CRI##LAS             IS THAT ALL OF THEM?
         BL       CRI%50                 >>> NO. KEEP GOING.
         CW,R3    CRI##FIR             WERE THERE ANY SWAPS?
         BLE      CRI%80                 >>> NO. SORT IS FINISHED.
*
         STW,R3   CRI##LAS             NEED SORT ONLY TO LAST SWAP.
*
*        SORT HIGH-PRIORITY CRITERIA TO HEAD OF LIST.
*        R3=> CURRENT CRITERION.    R7=> LAST SWAP.
*
CRI%70   LW,R12   0,R3                 GET CURRENT CRITERION.
         CS,R12   -1,R3             IS IT IN ORDER WITH PREVIOUS ONE?
         BLE      CRI%75              YES.
         XW,R12   -1,R3             NO.
         STW,R12  0,R3              SWAP THE CRITERIA.
         LW,R7    R3                REMEMBER WHERE WE SWAPPED.
CRI%75   AI,R3    -1                   GO TO NEXT CRITERION.
         CW,R3    CRI##FIR             IS THAT ALL OF THEM?
         BG       CRI%70                 >>> NO. KEEP GOING.
         CW,R7    CRI##LAS             WERE THERE ANY SWAPS?
         BL       CRI%40                 >>> YES. KEEP SORTING.
*********         ****************** * * * * * * * * * * * * * * *
*                 PHASE 3:  HAVING SORTED, RESTORE POINTER LIST.
*
CRI%80   LW,R2    CRI#COUNT#TOTAL,R4  R2= TOTAL NUMBER OF CRITERIA.
CRI%85   LW,R3    *R8,R2            R3 =>CRITERION.
         AI,R3    #C#LNTH-#C#CRI       =>CRITERION LENGTH BYTE.
         LB,R12   0,R3              R12= CRITERION TEXT LENGTH.
         SCS,R12  -8                   = (0-7)CRITERION TEXT LENGTH.
         STS,R12  *R8,R2               PUT LENGTH INTO CRI-POINTER.
         BDR,R2   CRI%85               REPEAT FOR ALL CRITERIA.
*
         CALL     QUEUE%DEFINELIST
         STW,SR1  QGET#ID,R4        WE HAVE A GETLIST OUTSTANDING.
         CLEAR    F#SORTING         WE HAVE NOW SORTED THE CRITERIA.
         B        MASTER%           BACK TO MASTER CONTROL.
         PAGE
************************************ * * * * * * * * * * * * * * * * * *
*                                                                      *
*  INTERRUPT% IS WHERE OPERATOR INTERRUPT COMES.                       *
*        IT CALLS KEYIN% UNLESS IT'S NOT GOOD TO ALLOW KEYINS NOW.     *
*        IF THE TPC WAS ABOUT TO M:WAIT, THE WAIT IS SKIPPED.          *
*                                                                      *
************************************ * * * * * * * * * * * * * * * * * *
*
INTERRUPT%        @P                OPERATOR INTERRUPT.
         FINDPROTECTED              GET ADDRESS OF OUR PRECIOUS DATA.
         BNE      INT%20            GO IF WE CAN PLAY WITH IT ALREADY.
         UNPROTECT                  LET US MODIFY IT.
         SETT     F#KEYIN#PROTECT   FLAG THE NEED TO RE-PROTECT LATER.
INT%20   SETBON,F#KEYIN  INT%80     FLAG INT; IF ALREADY FLAGGED, EXIT.
         CLEARBOFF,F#WAIT  INT%50   IF WE WERE SETTING UP M:WAIT,
         LI,R2    MASTER%           GO BACK TO MASTER%
         LI,R3    X'1FFFF'          AFTER PROCESSING KEYIN.
         STS,R2   0,R1              (R1 POINTS TO PUSHED CONTEXT).
         LC       QGET#ECB          SEE IF ECB FOR WAIT IS POSTED.
         BCS,8    INT%50            IF SO, WE ARE OKAY.
         SETT     F#SORT            IF NOT, MUST PURGE AT MASTER%.
*
INT%50   LW,R7    MESS##SAVE
         MBS,R7   #MESS#SAVE#MBS
         CALL     KEYIN%            SEE WHAT THE OPERATOR WANTS.
         LW,R7    MESS##REST
         MBS,R7   #MESS#REST#MBS
         CLEAR    F#KEYIN
INT%80   CLEARBOFF,F#KEYIN#PROTECT  INT%90
         PROTECT                    RE-PROTECT OUR DATA IF NECESSARY.
INT%90   M:TRTN                     BACK TO MAIN PROGRAM.
         PAGE
************************************ * * * * * * * * * * * * * * * * * *
*                                                                      *
*  KEYIN% FINDS OUT WHAT THE OPERATOR WANTS AND DOES IT FOR HIM.       *
*                                                                      *
************************************ * * * * * * * * * * * * * * * * * *
         @T
KEY#ECB  RES      1                 SPACE FOR ECB FOR M:KEYIN.
KEY#REPLY  RES    8                 SPACE FOR OPERATOR TO SAY THINGS.
         @S
KEY#ASK  TEXTC    'TPLM HERE '      ASK OPERATOR WHAT HE WANTS.
         OPEN     X,I,N
X,N      SET      0
KEYIN    CNAME                      THIS PROC MAKES IT EASIER TO
         PROC                       DEFINE LEGAL KEYINS.
N        SET      N+1
X(N)     SET      S:NUMC(AF(1)),BA(%),AF(2)  TEXTLEN,TEXTADDR,ROUTINE.
         TEXT     AF(1)
         PEND
*
         KEYIN    'X',KEYIN%TERM
         KEYIN    'REGULATE',KEYIN%REGULATE
         KEYIN    'DISPLAY',KEYIN%DISPLAY
*
#KEYINS  EQU      N                 NUMBER OF LEGAL KEYINS.
         RES      -1
KEY#KEYWORD  RES  1                 POINTERS TO KEYWORDS OF SAME.
I        DO       N
         GEN,8,24  X(I,1),X(I,2)
         FIN
         RES      -1
KEY#ROUTINE  RES  1                 ADDRESSES OF ASSOCIATED ROUTINES.
I        DO       N
         B        X(I,3)
         FIN
         CLOSE    X,I,N
*
*
*
*
KEYIN%   ENTRY
KEY%01  M:KEYIN (MESS,KEY#ASK),(REPLY,KEY#REPLY),(SIZE,31),(ECB,KEY#ECB)
KEYIN%05 LC       KEY#ECB           WAIT UNTIL DONE.
         BCS,8    KEYIN%05
         LB,R3    KEY#REPLY         GET LAST CHARACTER OF ANSWER.
         CI,R3    1                 IF ONLY ONE CHAR (THEREFORE C/R),
         BE       KEYIN%RET           JUST GO AWAY.
         LB,R3    KEY#REPLY,R3      SEE IF THE MESSAGE
         CI,R3    X'08'               WAS CANCELLED.
         BE       KEY%01            IF SO, ASK AGAIN.
*
         LI,R3    #KEYINS           NUMBER OF LEGAL REQUESTS.
         LI,R6    BA(KEY#REPLY)+1   START OF OPERATOR AREA.
KEYIN%10 LW,R7    KEY#KEYWORD,R3    GET A KEYWORD POINTER.
         CBS,R6   0                 SEE IF THIS IS THE ONE.
         CI,R6    BA(KEY#REPLY)+1   IT IS IF ANY PART OF IT MATCHES.
         BNE      KEYIN%15            THIS IS IT.
         BDR,R3   KEYIN%10          THIS ISN'T IT.  KEEP TRYING.
         B        KEYIN%LOSER         TOTAL LOSER.
KEYIN%15 @P
         LW,R1    R6                FOUND IT.  R6=> CHAR AFTER KEYWORD.
         MTB,-1   R1                SCAN PAST ANY BLANKS.
         CBS,R0   BA(BLANK#)        R1=> CHAR AFTER BLANKS.
         B        KEY#ROUTINE,R3    GO TO APPROPRIATE ROUTINE.
*
KEYIN%LOSER       @P                BAD NEWS EXIT.
         MESSAGE,K  'ILLEGAL KEYIN'
         B        KEY%01            GIVE ANOTHER CHANCE AFTER ERROR.
KEYIN%RET         @P                NORMAL EXIT.
         LB,R3    KEY#REPLY         GET LAST CHARACTER
         AI,R3    -1                BEFORE
         LB,R3    KEY#REPLY,R3      CARRIAGE RETURN.
         CI,R3    ';'               SEE IF IT'S A CONTINUER.
         BE       KEY%01            IF SO, REQUEST ANOTHER KEYIN.
         RETURN   KEYIN%            RETURN TO CALLER.
*
KEYIN%TERM        @P                X KEYIN:  KILL THE TPC.
         SETT     F#XKEYIN          SAY WE WANT TO STOP.
         LB,R3    0,R1              SEE IF IT IS 'X NOW'.
         CI,R3    'N'
         BNE      KEYIN%RET         ---> NO. CONTINUE.
         CLEAR    F#USER              YES. KEEP OUT OF XCON TROUBLES,
         M:XXX                        AND DIE DIE DIE.
*
*                 REGULATE KEYIN:  TURN ONE OR ALL TPM'S ON OR OFF.
KEYIN%REGULATE    @P
         LI,R12   1                 1 = ONE TPM.
         CALL     KEY%%TPM
         LI,R12   0                 0 = ALL TPM'S.
         ANLZ,R6  WA@TPM#ACTIVE#TABLE  R6=> BYTE TABLE OF TPM ON/OFFNESS.
         ANLZ,R7  WA@TPM#INDEX#TABLE   R7=> BYTE TABLE OF REL TPM NUMBER.
         LB,R9    0,R1
         CI,R9    'O'               KEYIN MUST SAY 'ON' OR 'OFF'
         BNE      KEYIN%LOSER        OR ELSE IT'S A LOSER.
         AI,R1    +1
         LB,R9    0,R1              THIS ONE MUST BE 'F' OR 'N'.
         CI,R9    'F'
         BE       KEY%R%18          'OF' MEANS OFF.
         CI,R9    'N'
         BNE      KEYIN%LOSER       NEITHER MEANS KEYIN IS A LOSER.
         LI,R13   0                 00 = REGULATE ON.
         B        KEY%R%20
KEY%R%18 LI,R13   X'40'             40 = REGULATE OFF.
KEY%R%20 CI,R12   0                 ONE TPM OR ALL OF THEM...
         BE       KEY%R%30            ALL OF THEM.
         MTB,0    *R7,R3            ONE OF THEM. DOES IT EXIST?
         BEZ      KEYIN%LOSER       NONEXISTENT; KEYIN IS A LOSER.
         STB,R13  *R6,R3            REGULATE EXISTENT TPM ON OR OFF.
         B        KEY%R%50
*
KEY%R%30 LI,R3    99                REGULATE ALL EXISTENT TPM'S.
KEY%R%40 MTB,0    *R7,R3            DOES THIS ONE EXIST?
         BEZ      KEY%R%44           NO.
         STB,R13  *R6,R3             YES. REGULATE IT.
KEY%R%44 AI,R3    -1                STEP TO
         BGEZ     KEY%R%40           NEXT TPM.
KEY%R%50 SETT     F#SORT            SAY TO SORT CRITERIA.
         B        KEYIN%RET         THAT'S ALL.
*
*
*                 DISPLAY KEYIN:  SHOW STATUS OF INDIVIDUAL TPM'S.
KEYIN%DISPLAY     @P
         CALL     KEY%%TPM
         B        KEY%D%50          GO IF TPLM'S STATUS IS WANTED.
         ANLZ,R6  WA@TPM#ACTIVE#TABLE  R6=> BYTE TABLE OF TPM ON/OFFNESS.
         ANLZ,R7  WA@TPM#INDEX#TABLE   R7=> BYTE TABLE OF REL TPM NUMBER.
         LB,R7    *R7,R3            DOES THE TPM EXIST?
         BNEZ     KEY%D%08          YES. R7 IS NOW ITS INDEX IN TABLES.
         MESSAGE,K 'NONEXISTENT.'   NO. SAY IT DOESN'T EXIST.
         B        KEYIN%RET         THAT'S ALL.
*
KEY%D%08 LC       *R6,R3            IS IT SUSPENDED?
         BCR,4    KEY%D%12          NO.
         MESSAG,K 'SUSPENDED. '     YES.
         B        KEY%D%20
KEY%D%12 BOFF,F#USER  KEY%D%16      IF F#USER SET
         CW,R3    TPM#NUMBER,R4      AND CURRENT TPM IS ONE ASKED FOR,
         BNE      KEY%D%16
         MESSAG,K 'RUNNING. '       SAY IT'S RUNNING.
         B        KEY%D%20
KEY%D%16 MESSAG,K 'ACTIVE. '        SAY IT'S UP BUT NOT NOW RUNNING.
*
KEY%D%20 LW,R2    TPM#TRAN#COUNT,R4 GET THE COUNT OF TRANSACTIONS
         LW,R2    *R2,R7             PROCESSED BY THIS TPM.
         BEZ      KEY%D%90          IF NONE, SHIP OUT MESSAGE & QUIT.
         LW,R3    TPM#TIME,R4       GET TIME THIS TPM WAS LAST
         LW,R8    *R3,R7             STARTED OR STOPPED.
         LB,R3    R8                R3 = HH.
         INT,R8   R8
         AND,R8   L(X'FF')          R8 = MM.
         SLS,R9   -6                R9 = THOUSANDTHS.
         ESSAG,K  (R2,4,1),' PROCESSED. LAST TIME ',;
                  (R3,2,0),':',(R8,2,0),'.',(R9,3,0)
         B        KEY%D%90          GO DISPLAY MESSAGE AND QUIT.
*
KEY%D%50 BOFF,F#USER KEY%D%60       TPLM DISPLAY.
         MESSAGE,K  ((TPM#NUMBER,R4),2,0),' RUNNING.'
         B        KEY%D%70
KEY%D%60 LW,R8    TRAN#TIME,R4      NOBODY RUNNING; SHOW LAST RUNTIME.
         LB,R3    R8                R3 = HH.
         INT,R8   R8
         AND,R8   L(X'FF')          R8 = MM.
         SLS,R9   -6                R9 = THOUSANDTHS.
         MESSAGE,K 'LAST RUNNING AT ',(R3,2,0),':',(R8,2,0),'.',;
                  (R9,3,0)
*
KEY%D%70 ANLZ,R6  WA@TPM#ACTIVE#TABLE  R6=> BYTE TABLE OF TPM ON/OFFNESS.
         ANLZ,R7  WA@TPM#INDEX#TABLE   R7=> BYTE TABLE OF REL TPM NUMBER
         LB,R2    0,R1              R2 IS CHAR AFTER DISPLAY 'A'=>ALL.
         LI,R3    0
KEY%D%74 LC       *R6,R3            IS THIS TPM SUSPENDED?
         BCR,4    KEY%D%76           NO.
         MESSAGE,K 'TPM',(R3,2,0),' SUSPENDED.'  PRINT IT.
         B        KEY%D%80
KEY%D%76 CI,R2    'A'               IF TPM NOT SUSPENDED, ONLY
         BNE      KEY%D%80          DISPLAY IT IF 'ALL'.
         MTB,0    *R7,R3            IN ANY CASE, DON'T DISPLAY IT
         BEZ      KEY%D%80          IF IT DOESN'T EXIST.
         MESSAGE,K 'TPM',(R3,2,0),' ACTIVE.'  PRINT IT.
KEY%D%80 AI,R3    +1                LOOK AT NEXT TPM.
         CI,R3    99
         BLE      KEY%D%74
         B        KEYIN%RET
*
KEY%D%90 ESSAGE,K                   SHIP OUT LAST MESSAGE.
         B        KEYIN%RET         FINI.
*
*
*
KEY%%TPM ROUTINE,R7  ;
         'R7 LINK. 0,R7 NO TPM#. 1,R7 TPM# IN R3.  R2,R3 ZAP. R1=>BUF.'
         LB,R3    0,R1              GET NEXT CHARACTER OF KEYIN.
         CI,R3    '0'               IF IT'S NOT A DIGIT,
         BL       0,R7               RETURN +0.
         AI,R1    +1
         LB,R2    0,R1              GET NEXT CHARACTER.
         CI,R2    '0'               IF IT'S NOT A DIGIT,
         BL       KEY%%TP1          THE IT'S A ONE-DIGIT TPM NUMBER.
         AI,R1    +1                OTHERWISE IT'S A TWO-DIGIT NUMBER.
         SLS,R3   +8                MERGE
         AW,R3    R2                 THE DIGITS.
KEY%%TP1 CVA,R3   BIN#TO#DEC        CONVERT TPM# TO BINARY IN R3.
         CBS,R0   BA(BLANK#)        SCAN PAST ANY BLANKS.
         B        1,R7               RETURN +1.
         PAGE
************************************ * * * * * * * * * * * * * * * * * *
*                                                                      *
*  TRAN% IS ENTERED AFTER GETTING A TRANSACTION.                       *
*        IT DOES SOME SETUP AND ENTERS THE APPROPRIATE TPM AT TPMXNN.  *
*  SR1 = GETLIST INDEX WHEN TRAN% IS ENTERED.                          *
*                                                                      *
************************************ * * * * * * * * * * * * * * * * * *
TRAN%    @P
         AI,SR1   -1
         AW,SR1   CRI#POINTER,R4    SR1=> CRITERION POINTER.
         LW,R5    TRAN#POINTER,R4   R5 => TRANSACTION.
         LW,R2    *SR1              GET CRITERION POINTER FOR XACTION.
         LI,R6    0
         LI,R3    4*R6+1            GET
         MTB,+3   R3                  USER-SPECIFIED ABORT LOCATION
         MBS,R2   #C#ABORT-#C#CRI     FROM CRITERION ENTRY.
         STW,R6   TRAN#ABORT,R4
         AI,R2    -3+#C#TPM-#C#CRI  GET TPM NUMBER
         LB,R6    0,R2                FROM CRITERION ENTRY.
         CW,R6    TPM#NUMBER,R4     IS IT THE SAME AS LAST TIME?
         BE       TRAN%10             YES.
         STW,R6   TPM#NUMBER,R4     NO.  SAVE NEW NUMBER.
         SETT     F#SORT              SORT CRITERIA WHEN CHANGING TPM'S.
TRAN%10  @P                         BUILD DEFAULT JOURNALFLAGS:
         LW,R2    L(##JQUEUE**24)   THIS ITEM ENQUEUED.
         LW,R3    #J#FLAGSW,R5      IF ORIGINAL TRANSACTION
         CW,R3    L(##JJRNLO**24)    WAS JOURNALED,
         BAZ      TRAN%12
         AW,R2    L((##JJRNLI+##JJRNLO+##JJRNLD)**24) SO IS THIS ITEM.
TRAN%12  STW,R2   TRAN#JOURNAL,R4   SAVE DEFAULT JOURNALFLAGS.
*
         LI,R2    X'F00FF'          THROW AWAY GARBAGE BYTE
         AND,R2   #J#LENGTHSW,R5     FROM LENGTHS WORD IN
         STW,R2   #J#LENGTHSW,R5      ORIGINAL TRANSACTION.
*
         INT,R7   #J#LENGTHSW,R5    R7= LENGTH OF TRANSACTION NAME.
         AI,R7    #J#NAMEB-8          = DISPLACEMENT TO TID IN NAME.
         LI,R6    8                 CONVERT TO BINARY:
TRAN%20  LB,R3    *R5,R7              GET A TID CHARACTER.
         CI,R3    X'30'                 IF 0 - 9,
         BANZ     TRAN%23               BRANCH;
         AI,R3    '9'+1-'A'            ELSE CONVERT.
TRAN%23  SCS,R3   -4                  PUT BINARY
         SLD,R2   +4                  INTO R2(28-31).
         AI,R7    +1                  BUMP POINTER.
         BDR,R6   TRAN%20             REPEAT 8 TIMES.
*
         LI,R3    Q:TID             IF EDMS IS BEING USED,
         BEZ      TRAN%26
         STW,R2   Q:TID             TELL HIM THE ID OF TRANSACTION.
TRAN%26  STW,R2   TRAN#ID,R4        IN ANY CASE, REMEMBER OURSELVES.
*
         CALL     GET%TIME
         LCI      2
         STM,R14  TRAN#TIME,R4      REMEMBER DATE/TIME THAT WE STARTED.
         LW,R3    TPM#NUMBER,R4     R3= NUMBER OF TPM TO BE USED.
         ANLZ,R2  WA@TPM#INDEX#TABLE
         LB,R2    *R2,R3            R2= INDEX OF TPM IN EXISTENT TPMS.
         STW,R2   TPM#INDEX,R4         (REMEMBER IT)
         LW,R6    TPM#TRAN#COUNT,R4
         MTW,+1   *R6,R2            COUNT THE TRAN AS DONE BY THIS TPM.
         LW,R6    TPM#TIME,R4
         STW,R15  *R6,R2            REMEMBER WHAT TIME WE STARTED.
*
         MESSAGE,T '*ENTER TPMX',(R3,2,0),'.'
         LI,R14   0                 R14= # OF ARGS (FOR CALLING TPM).
         STW,R14  TRAN#EXTIME,R4    NO EXECUTION TIME YET.
         CLEAR,R14  F#FAIL          THE TPM HASN'T CALLED FAILURE YET,
         CLEAR,R14  F#KEEP          SO IT HASN'T SAID KEEP-IT-IN-QUEUE
         CLEAR,R14  F#ABORTME       NOR HAS IT ASKED TO BE R-OFF'ED.
         CLEAR,R14  F#TPMABORT      IT ALSO HASN'T DONE ANY NO-NO'S.
*        CLEAR,R14  F#TPLMABORT     AND OF COURSE THE TPLM HASN'T DIED.
         CLEAR,R14  F#TIMEDOUT      ALSO THE TIMER HASN'T RUN OUT YET.
*
         LI,R15   TRAN%END          R15= RETURN ADDR (FOR CALLING TPM).
         SETT,R15   F#USER          TPM HAS BEEN CALLED.
         PROTECT                    KEEP THE TPM FROM STOMPING OUR DATA
*        SET UP TIMEOUT FOR LOOPING TPM.
         M:STIMER (TUN,TPM#TIMEOUT#TUN),TIMEOUT%
         LI,R15   TPC               MAKE TPM RETURN TO TPC.
         B        TPMX%%,R3         GO TO TPM.
*             V   V
*             V   V
*             V   V
*          VVVV   VVVV
*           V       V
*            V     V
*             V   V
*              V V
*               V
         PAGE
TRAN%END @P
         FINDPROTECTED              GET ADDRESS OF OUR PRECIOUS DATA.
         BON,F#FAIL TRANE%05        IF THE TPM CALLED FAILURE
         BOFF,F#TPMABORT TRANE%10    OR ABORTED,
TRANE%05 BON,F#TPLMABORT TRANE%10    AND THE WHOLE TPLM ISN'T ABORTED,
         LI,R7    Q:TID               AND WE'RE RUNNING WITH EDMS,
         BEZ      TRANE%10
         MTW,0    Q:CCBADR             AND THE DATABASE HAS BEEN OPENED,
         BEZ      TRANE%10
         LI,R14   1                 TELL THE DBM
         BAL,R15  DMSRLSE           TO RESTORE THE DATABASE
         DATA     BA(L('RECV'))     FROM THE TRANSIENT JOURNAL.
         FINDPROTECTED              GET ADDRESS OF DATA AGAIN.
TRANE%10 UNPROTECT                  ALLOW US TO MODIFY OUR DATA.
         M:TTIMER TUN,CANCEL        RESET THE TIMEOUT TIMER.
         LCW,SR1  SR1               COMPUTE
         AI,SR1   TPM#TIMEOUT#TUN     ELAPSED RUNNING TIME IN TUN'S.
         AWM,SR1  TRAN#EXTIME,R4      AND ACCUMULATE IT.
         CLEAR    F#USER
         CLEAR    F#USER#TPC
         PAGE
*
*  WE HAVE REPORTS ON REPORT#CHAIN AND SPAWNED TRANSACTIONS ON
*  TRANOUT#CHAIN.  EACH HAS A HEADER.  THE HEADER:
*
*LOOKS LIKE(REPORT)     *LOOKS LIKE(XACTION)    *WANTS TO LOOK LIKE    *
*
*  0                    0 JNLFLAG, ENTRY LNTH   0 JNLFLAG,RCDTYPE,LNTH
* CHAINWORD             1 CHAINWORD             1 ID OF CURRENT XACTION
* BA(TEXTEND)+1         2  ***                  2  DATE
* NAMELNTH,BA(NAME)     3  ***                  3  TIME
*  0                    4  ***                  4 ID OF ENTITY
* TEXT LNTH,NAME LNTH   5 TEXT LNTH, NAME LNTH  5 TEXT LNTH, NAME LNTH
*
*  IN ADDITION, A TRANSACTION ID MUST BE ADDED TO NAMES
*  AND A CHECKSUM MUST BE ADDED AT THE END.
*
         CALL     GET%TIME
         LCI      2                 REMEMBER THE DATE/TIME THAT
         STM,R14  TRAN#TIME,R4        PROCESSING WAS COMPLETED.
         LW,R2    TPM#INDEX,R4
         LW,R3    TPM#TIME,R4       ENDTIME-> TPM'S TPM#TIME WORD;
         XW,R15   *R3,R2            R15<= PROCESSING START TIME.
         LW,R14   TRAN#EXTIME,R4    R14<= ELAPSED EXECUTION TIME.
         SLS,R14  +1                      (IN MILLISECONDS).
         LW,R5    TRAN#POINTER,R4   R5 =>TRANSACTION BEING PROCESSED.
         LCI      2                      SAVE START & EXECUTION TIMES
         STM,R14  #J#TEXTW,R5            FOR LATER JOURNALIZATION.
         LW,R2    F#TPMABORT,R4     ACCUMULATE
         SLS,R2   1                  .....
         AW,R2    F#FAIL,R4           FLAGS
         SLS,R2   1                    .....
         AW,R2    F#KEEP,R4             FOR
         SLS,R2   1                      .....
         AW,R2    F#ABORTME,R4            JOURNAL
         SLS,R2   1                        .....
         AW,R2    F#TPLMABORT,R4            RECORD.
         STW,R2   #J#ORIGIDW,R5     SAVE THEM HERE FOR NOW.
         LW,R2    TRAN#ID,R4
         STW,R2   #J#IDW,R5         ALSO PUT TID INTO JOURNALING AREA.
*
         BOFF,F#KEEP  TRANE%28      GET A TID FOR REPORTS::::
         CALL     GET%ID              GET A NEW ONE IF FAILED/KEEPINQ.
         LW,R2    L((##JQUEUE+##JIP+##JFAIL)**24;
                     +#JOURNAL#ET**16+17*4)
         LW,R3    L((##JQUEUE+##JIP+##JFAIL)**24;
                     +X'00FFFFFF')
         STS,R2   #J#FLAGSW,R5      FIX JNLWORD 0 FOR FAIL/KEEP.
         B        TRANE%30
TRANE%28 ANLZ,R2  BA@R5               USE CURRENT TID IF NOT.
         INT,R7   #J#LENGTHSW,R5
         AW,R2    R7                R2 =>'.TTTTTTTT' IN TRANNAME.
         LW,R3    L(9**24+(R13*4+3)) R13='.'
         MBS,R2   #J#HDR#LEN-9      R14/R15= TID(EBCDIC).
         LW,R12   TRAN#ID,R4        R12= TID(HEX).
         LW,R2    L((##JIP)**24;
                     +#JOURNAL#ET**16+17*4)
         LW,R3    L((##JQUEUE+##JIP+##JFAIL)**24;
                     +X'00FFFFFF')
         STS,R2   #J#FLAGSW,R5      FIX JNLWORD 0 FOR NO-KEEP.
TRANE%30 LW,R6    TRAN#ID,R4        R6 = ID OF ORIGINAL XACTION.
         LW,R7    R5                R7 => M:QUEUE/PUT LIST AREA
         AI,R7    #J#TEXTW+3          (AFTER XACTION-END RECORD)
*
         LW,R5    REPORT#CHAIN,R4   R5 =>ONE REPORT.
TRANE%35 BEZ      TRANE%40               >>> GO IF NO MORE REPORTS.
         STW,R12  #J#IDW,R5           PUT HEX ID IN REPORT HEADER.
         INT,R3   #J#LENGTHSW,R5    R3 = USER REPORT NAME LENGTH.
         AI,R3    #J#NAMEB             = DISPLACEMENT TO NAME END +1.
         ANLZ,R3  BA@R5:R3             =>END OF USER REPT NAME + 1.
         LI,R2    9                   (WE WILL ADD 9 CHAR TO NAME)
         AWM,R2   #J#LENGTHSW,R5      ADD 9 TO NAME LENGTH.
         STB,R2   R3                  SET TO MOVE 9 CHAR TO NAME
         MBS,R2   (R13*4+3)-9         FROM '.' AND TID IN R13-R15.
         INT,R2   #J#LENGTHSW,R5    R2 = USER REPORT TEXT LENGTH.
         AI,R2    #J#HDR#LEN+#J#NAME#LEN+3+4  +HEADER+CKSUM+ROUND.
         AND,R2   L(X'FFFC')          MAKE AN EVEN # OF WORDS.
         AW,R2    L(#JOURNAL#OR**16)  ADD JNL RCD TYPE IN 8-15.
         LW,R3    L(X'00FFFFFF')      PUT RECORD TYPE AND RECORD
         STS,R2   #J#FLAGSW,R5          LENGTH INTO REPORT HEADER.
         EOR,R2   #J#FLAGSW,R5      R2 = FLAGS ONLY.
         AW,R2    R5                R2 = FLAGS AND REPORT ADDRESS.
         STW,R2   0,R7                PUT INTO LIST FOR QUEUEPUT.
         AI,R7    +1                  INCREMENT QUEUEPUT LIST POINTER.
         CALL     JOURNAL%WRITE
         LW,R5    #J#CHAINW,R5      R5 =>NEXT REPORT.
         BNEZ     TRANE%35          -----> GO DO NEXT REPORT.
TRANE%40 STW,R5   REPORT#CHAIN,R4   ZERO RPTCHAIN; NOW IN Q/PUT LIST.
*
         LW,R5    TRANOUT#CHAIN,R4  R5 =>ONE SPAWNED TRANSACTION.
TRANE%45 BEZ      TRANE%50               >>> GO IF NO MORE SPAWNEDS.
         CALL     GET%ID            SPAWNED TRANSACTIONS GET NEW TIDS.
         STW,R12  #J#IDW,R5         PUT HEX ID IN XACTION HEADER.
         INT,R3   #J#LENGTHSW,R5    R3 = USER XACTION NAME LENGTH.
         AI,R3    #J#NAMEB             = DISPLACEMENT TO NAME END +1.
         ANLZ,R3  BA@R5:R3             =>END OF USER TRAN NAME + 1.
         LI,R2    9                   (WE WILL ADD 9 CHAR TO NAME)
         AWM,R2   #J#LENGTHSW,R5      ADD 9 TO NAME LENGTH.
         STB,R2   R3                  SET TO MOVE 9 CHAR TO NAME
         MBS,R2   (R13*4+3)-9         FROM '.' AND TID IN R13-R15.
         INT,R2   #J#LENGTHSW,R5    R2 = USER XACTION TEXT LENGTH.
         AI,R2    #J#HDR#LEN+#J#NAME#LEN+3+4  +HEADER+CKSUM+ROUND.
         AND,R2   L(X'FFFC')          MAKE AN EVEN # OF WORDS.
         AW,R2    L(#JOURNAL#BT**16)  ADD JNL RCD TYPE IN 8-15.
         LW,R3    L(X'00FFFFFF')      PUT RECORD TYPE AND RECORD
         STS,R2   #J#FLAGSW,R5          LENGTH INTO XACTION HEADER.
         EOR,R2   #J#FLAGSW,R5      R2 = FLAGS ONLY.
         AW,R2    R5                R2 = FLAGS AND XACTION ADDRESS.
         STW,R2   0,R7                PUT INTO LIST FOR QUEUEPUT.
         AI,R7    +1                  INCREMENT QUEUEPUT LIST POINTER.
         CALL     JOURNAL%WRITE
         LW,R5    #J#CHAINW,R5      R5 =>NEXT SPAWNED TRANSACTION.
         BNEZ     TRANE%45          -----> GO DO NEXT TRANSACTION.
TRANE%50 STW,R5   TRANOUT#CHAIN,R4  ZERO TRANLIST; NOW IN Q/PUT LIST.
*
         LW,R5    TRAN#POINTER,R4   R5 =>ORIGINAL TRANSACTION.
         STW,R5   0,R7                PUT INTO LIST FOR QUEUEPUT.
         LW,R3    L(X'FF000000')
         AND,R3   #J#FLAGSW,R5      R3 = FLAGS FOR ORIGINAL XACTION.
         AWM,R3   0,R7                ADD FLAGS TO QUEUEPUT ENTRY.
         SW,R7    R5
         AI,R7    -#J#TEXTW-2       R7 = LENGTH OF QUEUEPUT LIST.
         STW,R7   OUT#COUNT,R4
*
         BON,F#FAIL      TRANE%70   IF TPM DIDN'T FAIL,
         BON,F#TPMABORT  TRANE%70   AND TPM DIDN'T ABORT,
         BON,F#TPLMABORT TRANE%70   AND TPLM DIDN'T ABORT,
         LI,R7    Q:TID
         BEZ      TRANE%70          AND EDMS DBM IS PRESENT,
         MTW,0    Q:CCBADR
         BEZ      TRANE%70          AND DATABASE HAS BEEN OPENED,
         CLEAR    F#UARLSE              (SET RETURNFLAG FOR BUM RLSE)
         PROTECT
         LI,R14   0                 TELL THE DBM
         BAL,R15  DMSRLSE           TO DISCARD THE TRANSIENT JOURNAL.
         FINDPROTECTED
         UNPROTECT
TRANE%70 LW,R5    TRAN#POINTER,R4   JOURNALIZE END OF
         LW,R6    #J#ORIGIDW,R5     ORIGINAL TRANSACTION.
         CALL     JOURNAL%WRITE
         AI,R5    #J#TEXTW+3        PUT REPORTS & SPAWNED INTO QUEUE;
         LW,R6    OUT#COUNT,R4       REMOVE ORIGINAL TRANSACTION.
         CALL     QUEUE%PUT
*
         LW,R3    TPM#NUMBER,R4
         ANLZ,R2  WA@TPM#ACTIVE#TABLE
         BOFF,F#FAIL  TRANE%87
         MTB,1    *R2,R3
         LB,R5    *R2,R3
         CI,R5    SYSTEM#THRESHOLD#FOR#FAILED#TRANSACTIONS
         BGE      TRANE%85
         BOFF,F#ABORTME  TRANE%87
TRANE%85 SETT     F#TPMABORT
TRANE%87 BOFF,F#TPMABORT MASTER%
         SETT     F#SORT            NEED TO SORT WHEN ROFF'ING.
         LCI      4                 REGULATE OFF
         STCF     *R2,R3
         MESSAGE,E  '*** TPM',(R3,2,0),' REGULATED OFF.'
         BON,F#TPLMABORT  MASTER%ABORT  QUIT IF WE ARE SICK SICK SICK.
         B        MASTER%
         PAGE
*
*
*
TIMEOUT% @P
         FINDPROTECTED              GET ADDRESS OF TPC DATA.
         STCF     R1                REMEMBER WHETHER IT WAS PROTECTED.
         BOFF,F#USER  TIMO%50       IF TPC WAS RUNNING, IGNORE TIMOUT.
         BON,F#USER#TPC  TIMO%40    IF TPM CALLED TPC,SAY TIMOUT & RET.
         LC       R1                WAS TPC DATA PROTECTED...
         BNE      TIMO%40           NO.  SET FLAG & RET.
         LI,R7    Q:TID             IF DMS
         BEZ      TIMO%30            EXISTS,
         MTW,0    Q:DBEXC             AND WAS RUNNING,
         BNEZ     USER%ABORT        DON'T CLEAR THE TCB.
TIMO%30  LI,R2    0                   YES.
         XW,R2    -1,R1             REMOVE 21
         AI,R2    -20                OR 20 WORDS
         MSP,R2   *R0                 FROM TEMP STACK,
         B        USER%ABORT        AND ABORT THE TPM.
*
         NEEDSMOREWORK  TIMEOUT%,NEEDSMOREWORK
TIMO%40  SETT     F#TIMEDOUT        SAY THAT TPM HAS TIMED OUT.
TIMO%50  M:TRTN
         PAGE
*
*
*
XCON#REG @T                         SAVE REGISTERS FROM XCON ENTRY
         RES      16                HERE.
*
XCON%    @P
XCONDMS% @P
         LCI      0                 SAVE ALL REGISTERS ON ENTRY
         STM,0    XCON#REG           TO EXIT-CONTROL.
         FINDPROTECTED              GET ADDRESS OF TPC DATA.
         STCF     R1                REMEMBER WHETHER IT WAS PROTECTED.
         BOFF,F#USER  XCON%50       IF TPC WAS RUNNING, BAD NEWS.
         BON,F#USER#TPC  XCON%50    IF TPM CALLED TPC, BAD NEWS.
         LI,R7    Q:TID             IF DMS
         BEZ      XCON%10            EXISTS,
         MTW,0    Q:DBEXC             AND WAS RUNNING,
         BEZ      XCON%10
         LW,0     DMS#XCON,R4       GO TO
         XW,0     XCON#REG           DMS'S
         LCI      15                  EXIT
         LM,1     XCON#REG+1           CONTROL
         B        *XCON#REG             ROUTINE.
XCON%10  LI,R2    USER%ABORT        PREPARE TO
         LI,R3    X'1FFFF'            GO TO
         STS,R2   0,R1                USER%ABORT.
         M:INT    INTERRUPT%         (RESTORE INT ADDR FIRST).
         M:TRTN   XCON              GO THERE.
*
XCON%50  @P
         LC       12
         BCS,4    XCON%70
         AI,8     0
         BNEZ     XCON%70
         M:XCON   0
         B        END%
XCON%70  @P
         MESSAGE,E  'XCON ENTERED.'
         M:XCON   0
         B        DIE%
*
*
*
DMSABORT%         @P
         LW,R14   Q:ENTCOD          SEE IF WE ABORTED DURING
         CI,R14   35                  A DMSRLSE CALL.
         BNE      DMSA%10             NO.
         CI,R15   42                YES. MAY BE OKAY IF DB CLOSED.
         BE       DMSA%80             GO IF DB-CLOSED ERROR.
         MESSAGE,E 'CANNOT RESTORE DATABASE!!'
         B        MASTER%ABORT%TIP   GET VERY VERY SICK.
*
DMSA%10  MESSAGE,T ' EDMS ERROR ',(R15,3,0),'.'
         FINDPROTECTED
         UNPROTECT
         CI,R15   89
         BG       DMSA%15           ERR > 89 IS TPLM ABORT.
         CI,R15   46
         BE       DMSA%15           ERR 46 IS TPLM ABORT.
         CI,R15   47
         BNE      DMSA%17           ERR 47 IS TPLM ABORT.
DMSA%15  SETT     F#TPLMABORT
DMSA%17  CLEAR    F#USER
         CLEAR    F#USER#TPC
         B        ABRT%10           SKIP DMSRLSE; DBM ALREADY HAS.
DMSA%80  FINDPROTECTED              DMSRLSE WITH DB CLOSED.
         UNPROTECT
         BON,F#USER#TPC  FAIL%10    ---> CALLED BY FAILURE.
         BON,F#USER      DMSA%90    --->       (...%END)
         BON,F#UARLSE    ABRT%10    ---> CALLED BY USER%ABORT.
         B               TRANE%70   ---> CALLED TO PURGE JOURNAL.
DMSA%90  BON,F#INIT      INITE%10   ---> CALLED BY INIT%END.
         B               TRANE%10   ---> CALLED BY TRAN%END.
         PAGE
*
*
*
USER%ABORT        @P
         FINDPROTECTED
         UNPROTECT
         CLEAR    F#USER
         CLEAR    F#USER#TPC
         LI,R3    Q:TID             IF DBM IS PRESENT,
         BEZ      ABRT%10
         MTW,0    Q:CCBADR             AND THE DATABASE HAS BEEN OPENED,
         BEZ      ABRT%10
         SETT     F#UARLSE              (SET RETURNFLAG FOR BUM RLSE)
         PROTECT
         LI,R14   1                 TELL HIM TO
         BAL,R15  DMSRLSE             RESTORE THE DATABASE
         DATA     BA(L('RECV'))         FROM THE TRANSIENT JOURNAL
         FINDPROTECTED
         UNPROTECT
ABRT%10  CALL     DELETE%TPM%OUTPUT
         BON,F#INIT  INIT%ABORT     GO IF WE WERE INITIALIZING.
         M:TTIMER TUN,CANCEL        RESET THE TIMEOUT TIMER.
         LCW,SR1  SR1               COMPUTE
         AI,SR1   TPM#TIMEOUT#TUN     ELAPSED RUNNING TIM IN TUN'S.
         AWM,SR1  TRAN#EXTIME,R4      AND ACCUMULATE IT.
         MESSAGE,T '*TPM ABORT.'
         CLEAR    F#FAIL
         CLEAR    F#ABORTME
         CLEAR    F#KEEP
         CLEAR    F#TIMEDOUT
         LI,R15   TRAN%END          SAY WE ARE IN THE TPM.
         SETT,R15 F#USER            (MUSTBESET GOING TO TRAN%END).
         SETBON,F#TPMABORT TRAN%END IF ABORTED ALREADY, JUST QUIT.
         LW,R3    TRAN#ABORT,R4     DID USER SPECIFY ABORT-LOC?
         BEZ      TRAN%END          NO.  QUIT.
         LI,R14   0                 YES.  SET # ARGS = 0,
         LI,R15   TPC                 RETURN = TPC,
         PROTECT                    DON'T LET USER DESTROY US,
         M:STIMER (TUN,TPM#TIMEOUT#TUN),TIMEOUT%  RE-ARM TIMER,
         B        0,R3              AND GO TO ABORT ROUTINE.
         TITTLE   'TPC SUBROUTINES (CALLED BY TPM''S)'
************************************ * * * * * * * * * * * * * * * * * *
*                                                                      *
*  USERENTRY PROC INVOKES THE USERENT% ROUTINES. THESE ROUTINES        *
*        VALIDATE AND SET UP PARAMETERS FROM THE TPM.                  *
*                                                                      *
************************************ * * * * * * * * * * * * * * * * * *
         OPEN     X,Y,I,J,K
*
*         NAME      TEXT      VALUE     JOURNAL   PROG
X  SET   (USERENT%A,USERENT%B,USERENT%C,USERENT%F,USERENT%G),; *
         (USERENT%D,USERENT%E,'NO GOOD','NO GOOD','NO GOOD')   NO *
*
USERENTRY   CNAME
         PROC
LF       @P       0
         STW,R15  USER#R15TEMP
         EXPLAIN  ;
         'SET UP AND VERIFY PARAMETERS PASSED FROM TPM.',;
         'NEEDS R15=>PARAMETER LIST, R14= LIST LENGTH.',;
         'R1-R6,R14,R15 ZAPPED. RETURNS R15=>TPM RETURN,R4=>DYN.AREA.'
Y        SET      S:KEYS(2,NAM,TEXT,VALUE,JOURNAL,PROG)
J        SET      1                 J IS TPM PARAMETER INDEX.
I        DO       Y(1)              INVOKE ONCE FOR EACH KEYWORD.
K          DO     5                 K SELECTS KEYWORD FOR THIS PARAMETER
           GOTO,AF(Y(K+2),2)=J J      (GO WHEN WE GET THE RIGHT ONE).
           FIN
K         SET     500               ** BAD CALL.
J         SET     J+1+(K<=3)        INCREMENT PARAMETER INDEX.
          BAL,R6  X(2-AFA(Y(K+2),2),K)  INVOKE THE VALIDATION ROUTINE.
          DO1     K<=4&AFA(Y(K+2),2)  FOR NAME,TEXT,VALUE:
          GEN,16,16 AF(Y(K+2),3)      SUPPLY LIMITS ON VALUES.
         FIN
         BAL,R6   USERENT%Z         INVOKE THE CLEANUP ROUTINE.
         PEND
         CLOSE    X,Y,I,J,K
         PAGE
*
*
*
USERRETURN   CNAME
         PROC
LF       @P       0
         B        USER%RETURN
         PEND
USER%RETURN  LI,R6 0
         CLEARBOFF,F#USER#TPC,R6    USER%ABORT
         PROTECT
         BON,F#TIMEDOUT  USER%ABORT  TIMED OUT WHILE IN TPC SUBR.
         B        0,R6
         PAGE
************************************ * * * * * * * * * * * * * * * * * *
*                                                                      *
*                 USERENTRY SECTION.                                   *
*                                                                      *
*  ROUTINES USERENT%A...USERENT%Z ARE INVOKED BY THE USERENTRY PROC.   *
*  OTHER ROUTINES IN THIS SECTION ARE USED INTERNALLY ONLY.            *
*                                                                      *
*  THE USERENTRY ROUTINES VALIDATE, AND COPY WHERE APPROPRIATE,        *
*  PARAMETERS SUPPLIED BY THE TPM.                                     *
*  THESE ARE PLACED IN DATA AREAS WITH NAMES WHICH BEGIN WITH "USER#". *
*WARNING: THIS CODE IS VERY DEPENDENT ON FORM OF STD CALLING SEQUENCE.**
*                                                                      *
************************************ * * * * * * * * * * * * * * * * * *
         @T
USER#NAME         RES 1             BA OF NAME AREA IN TPM.
USER#NAME#LEN     RES 1             NAME LENGTH OR WA(LEN WORD) IN TPM.
USER#NAME#TEXT    RES  32//4        NAME TEXT (XACTION/REPORT/CRITERION)
USER#TEXT         RES 1             BA OF TEXT AREA IN TPM.
USER#TEXT#LEN     RES 1             TEXT LENGTH OR WA(LEN WORD) IN TPM.
USER#VALUE#1      RES 1             FIRST VALUE FROM TPM.
USER#VALUE#2      RES 1             SECOND VALUE FROM TPM.
USER#JOURNAL      RES 1             FLAG FROM TPM.
USER#LOCATION     RES 1             PROGRAM LOCATION FROM TPM.
USER#R15TEMP      RES 1             REMEMBER IN CASE OF TROUBLE.
*
*  REGISTER USAGE:
*        R15 => PARAMETER LIST IN TPM.  (INCREMENTED)
*        R14 = LENGTH OF TPM PLIST.     (DECREMENTED)
*        R6 IS LINK FROM USERENTRY INVOKER.
*        R5 (USUALLY) TYPE FIELD OF PARAMETER WORD.
*        R4 (USUALLY) ADDRESS FROM PARAMETER WORD.
*        R3 (USUALLY) VALUE OF CORRESPONDING ARGUMENT.
*        R2 INTERNAL LINKING
*        R1 INTERNAL LINKING
*
         PAGE
*
USERENT%Z         @P
         AW,R15   R14
         BEZ      USERENT%ERR
         FINDPROTECTED              GET ADDRESS OF OUR PRECIOUS DATA,
         ESSAGE,T
         B        0,R6
*
*
USERENT%ERR       @P
         SW,R15   USER#R15TEMP      R15= PARAMETER IN ERROR.
         BLZ      USERENT%ERREXIT   IF NOT A PARAMETER, DIE.
         CI,R15   6                 IF TOO LARGE TO BE A PARAMETER,
         BG       USERENT%ERREXIT     DIE.
         ESSAG,T  ' PARAM # ',(R15,1,0)
USERENT%ERREXIT   @P
         ESSAGE,T ' ERROR.'
         B        USER%ABORT        ABORT THE TPM.
*
USERENT%A         @P                NAME OR CRITERION SUPPLIED BY TPM.
         BAL,R2   USERENT%TEXT      GET BA(TPM NAME STRING)
         STW,R4   USER#NAME           REMEMBER IT.
         BAL,R2   USERENT%VALUE     GET AND VERIFY NAME LENGTH
         STW,R3   USER#NAME#LEN       REMEMBER IT.
         LW,R1    L(#J#NAME#LEN**24+BA(USER#NAME#TEXT))
         MBS,R0   BA(BLANK#)        BLANK OUT TPC NAME AREA.
         LI,R5    BA(USER#NAME#TEXT) MOVE
         STB,R3   R5                  TPM NAME
         LW,R4    USER#NAME             TO
         MBS,R4   0                       TPC NAME AREA.
         ESSAG,T  ' ',(*USER#NAME,*R3) DISPLAY NAME IF SIMULATOR.
         B        1,R6              RETURN PAST VALUE-CHECK WORD.
*
USERENT%B         @P                REPORT/XACTION TEXT SUPPLIED BY TPM.
         BAL,R2   USERENT%TEXT      GET BA(TPM TEXT STRING)
         STW,R4   USER#TEXT           REMEMBER IT.
         MTB,0    0,R4              ** TRAP IF BAD ADDRESS **
         BAL,R2   USERENT%VALUE     GET AND VERIFY LENGTH OF TEXT
         STW,R3   USER#TEXT#LEN       REMEMBER IT.
         AW,R3    USER#TEXT         R3= BA(TEXTEND)+1.
         AI,R3    -1                R3= BA(TEXTEND).
         MTB,0    0,R3              ** TRAP IF BAD ADDRESS **
         B        1,R6              RETURN PAST VALUE-CHECK WORD.
*
USERENT%C         @P                VALUES (PRIORITIES) SUPPLIED BY TPM.
         BAL,R2   USERENT%VALUE     GET AND VERIFY FIRST VALUE
         STW,R3   USER#VALUE#1        REMEMBER IT.
         ESSAG,T  ' ',(R3,4,1)        DISPLAY IT (ZERO-SUPPRESSED).
         BAL,R2   USERENT%VALUE     GET AND VERIFY SECOND VALUE
         STW,R3   USER#VALUE#2        REMEMBER IT.
         ESSAG,T  ' ',(R3,4,1)        DISPLAY IT (ZERO-SUPPRESSED).
         B        1,R6              RETURN PAST VALUE-CHECK WORD.
*
USERENT%D         @P                TPM WANTS NAME.
         BAL,R2   USERENT%TEXT      GET BA(TPM NAME AREA)
         STW,R4   USER#NAME           REMEMBER IT.
         BAL,R1   USERENT%PARAM     GET WA(TPM NAME-LENGTH WORD)
         BDR,R5   USERENT%ERR         (MUST BE INTEGER TYPE)
         STW,R4   USER#NAME#LEN       REMEMBER IT.
         B        0,R6              RETURN.
*
USERENT%E         @P                TPM WANTS TEXT.
         BAL,R2   USERENT%TEXT      GET BA(TPM TEXT AREA)
         STW,R4   USER#TEXT           REMEMBER IT.
         BAL,R1   USERENT%PARAM     GET WA(TPM TEXT-LENGTH WORD)
         BDR,R5   USERENT%ERR         (MUST BE INTEGER TYPE)
         STW,R4   USER#TEXT#LEN       REMEMBER IT.
         B        0,R6              RETURN.
*
USERENT%F         @P                FLAG SUPPLIED BY TPM (OPTIONAL).
         CI,R14   0                 IS IT THERE? (I.E., ANY MORE ARGS?)
         BLE      USERENT%FFF         NO.
         BAL,R2   USERENT%VALUE     YES. GET AND VERIFY FLAG VALUE.
         ESSAG,T  ' ',(R3,4,1)        DISPLAY IT (ZERO-SUPPRESSED).
         LI,R2    0                 CONVERT FLAG VALUE INTO
         DW,R2    L(10)             UNITS DIGIT AND TENS DIGIT.
         CLR,R2   L(2)              NEITHER DIGIT CAN BE >2.
         BCS,10   USERENT%ERR       IF THEY ARE, BAD NEWS.
         STH,R3   R2                R2= TENS(0-15),  UNITS(16-31).
         STW,R2   USER#JOURNAL        REMEMBER IT.
         B        1,R6              RETURN PAST VALUE-CHECK WORD.
USERENT%FFF       @P
         LI,R3    0                 USE VALUE OF ZERO FOR FLAG
         STW,R3   USER#JOURNAL      IF NOT SPECIFIED BY USER.
         B        1,R6              RETURN PAST VALUE-CHECK WORD.
*
USERENT%G         @P                PROGRAM ADDR SUPPLIED BY TPM (OPT).
         LI,R4    0                   (USE ZERO IF NOT SUPPLIED)
         CI,R14   0                 IS IT THERE? (I.E., ANY MORE ARGS?)
         BLE      USERENT%GGG         NO.
         BAL,R1   USERENT%PARAM     YES. GET WA(PROGRAM PLACE).
         CI,R5    X'40'             MUST BE WORD-ADDR DATA TYPE
         BGE      USERENT%ERR         ELSE ERROR.
         AND,R4   L(X'1FFFF')       TRUNCATE TO ADDRESS ONLY.
USERENT%GGG       @P
         STW,R4   USER#LOCATION       REMEMBER IT.
         B        0,R6              RETURN.
*
*
USERENT%VALUE     @P                GET & CHECK ARGUMENT FROM TPM PLIST.
         BAL,R1   USERENT%PARAM     FETCH ADDRESS FIRST.
         BDR,R5   USERENT%ERR         (MUST BE INTEGER TYPE)
         LW,R3    0,R4              NOW GET VALUE.
         INT,R4   0,R6              GET LOWER/UPPER VALUE LIMITS.
         CLR,R4   R3                SEE IF VALUE IS WITHIN LIMITS.
         BCR,6    0,R2                YES.
         B        USERENT%ERR         NO.
*
USERENT%TEXT      @P                FETCH BYTE ADDRESS FROM TPM PLIST.
         BAL,R1   USERENT%PARAM     GET PARAMETER ADDRESS.
         CI,R5    X'40'             IS IT WORD-ADDRESSED DATA...
         BL       USERENT%TEXTWA      YES.
         CI,R5    X'50'             IS IT BYTE-ADDRESSED DATA...
         BLE      USERENT%TEXTBA      YES.
         B        USERENT%ERR         NO. BAD PARAMETER.
USERENT%TEXTWA    @P
         SLS,R4   +2                CONVERT WORD ADDRESS TO BYTE ADDR.
USERENT%TEXTBA    @P
         AND,R4   L(X'7FFFF')       DISCARD HIGH-ORDER GARBAGE.
         B        0,R2              RETURN.
*
USERENT%PARAM     @P                GET CALLER'S PARAMETER ADDR & FLAGS.
         AI,R14   -1                DID HE SPECIFY THIS PARAMETER?
         BLZ      USERENT%ERR         IF NOT, IT'S A BAD CALL.
         LB,R5    *R15              R5 = PARAMETER FLAGS.
         LW,R4    *R15              R4 = PARAMETER ADDRESS.
         BGEZ     USERENT%PARMD       IF INDIRECTLY ADDRESSED,
         LW,R4    0,R4                GET DIRECT PARAMETER ADDRESS AND
         AI,R5    -X'80'              REMOVE INDIRECT BIT FROM FLAGS.
USERENT%PARMD     @P
         AI,R15   +1                INCREMENT CALLER'S P-LIST POINTER.
         B        0,R1              RETURN.
         PAGE
************************************ * * * * * * * * * * * * * * * * * *
*                                                                      *
*  INITATPC SUPPLIES A CRITERION FOR ACCEPTING TRANSACTIONS FOR THIS TP*
*                                                                      *
*                                                                      *
*                                                                      *
*                                                                      *
************************************ * * * * * * * * * * * * * * * * * *
         @T
CRI#HOLD RES      #C#MAX#LEN//4
*
INITATPC @P
         MESSAG,T ' INITATPC'
         USERENTRY   (NAM,*1,(0,21)),(VALUE,*3,(0,255)),(PROG,*5)
         BOFF,F#INIT  USER%ABORT    INITATPC FORBIDDEN WHILE PROCESSING.
*
         LI,R7    BA(CRI#HOLD)+#C#NORMP  BUILD CRITERION ENTRY:
         LW,R6    USER#VALUE#1
         STB,R6   0,R7              NORMAL-PRIORITY.
         LI,R7    BA(CRI#HOLD)+#C#NEXTP
         LW,R6    USER#VALUE#2
         STB,R6   0,R7              NEXT-PRIORITY.
         LI,R7    BA(CRI#HOLD)+#C#ABORT
         LI,R6    BA(USER#LOCATION)+1
         MTB,+3   R7
         MBS,R6   0                 ABORT-LOCATION.
         LI,R7    BA(CRI#HOLD)+#C#TPM
         LW,R6    TPM#NUMBER,R4
         STB,R6   0,R7              TPM NUMBER.
         LI,R7    BA(CRI#HOLD)+#C#NAME
         LI,R6    '?'
         STB,R6   0,R7              CRITERION IS
         AI,R7    +1                QUESTION MARK
         LW,R3    USER#NAME#LEN
         BEZ      INTP%07
         STB,R3   R7
         LI,R6    BA(USER#NAME#TEXT) THEN USER-SUPPLIED CRITERION
         MBS,R6   0
         LI,R6    '.'
         STB,R6   0,R7              THEN PERIOD.
         AI,R7    +1
         AI,R3    +1
INTP%07  AI,R3    +1                R3 IS NOW TOTAL CRITERION LENGTH.
         LI,R6    0
         STB,R6   0,R7              FLAGBYTE OF 0 AFTER CRI FOR Q MGR.
         LI,R7    BA(CRI#HOLD)+#C#LNTH
         STB,R3   0,R7              CRITERION LENGTH.
*
         UNPROTECT
         SETT,R15 F#USER#TPC
         AI,R3    #C#NONCRI#LEN     R3 IS NOW TOTAL ENTRY LENGTH.
         LW,R6    CRI#POINT#CURRENT,R4
         SW,R6    R3                R6 IS WHERE TO MOVE ENTRY TO.
         LI,R7    X'7F800'
         CS,R6    CRI#POINT#CURRENT,R4
         BE       INTP%20
*
         LW,R2    R6
         SLS,R2   -2
         CALL     GET%COMMON
*
INTP%20  STW,R6   CRI#POINT#CURRENT,R4
         LW,R7    R6
         LI,R6    BA(CRI#HOLD)
         STB,R3   R7
         MBS,R6   0
         MTW,1    CRI#COUNT#TOTAL,R4
         SETT     F#SORT            MAKE SURE CRITERIA GET SORTED.
         USERRETURN                 FINI.
         PAGE
************************************ * * * * * * * * * * * * * * * * * *
*                                                                      *
*  OUTALINE ADDS A LINE TO A REPORT.                                   *
*                                                                      *
************************************ * * * * * * * * * * * * * * * * * *
OUTALINE @P
         MESSAG,T ' OUTALINE'
         USERENTRY   (NAM,*1,(1,22)),(TEXT,*3,(0,1980)),;
                  (JOURNAL,*5,(0,22))
         BON,F#INIT  USER%ABORT     NO REPORTS DURING INITIALIZATION.
         UNPROTECT
         SETT,R15 F#USER#TPC
*
         LW,R3    USER#NAME#LEN     GET LENGTH OF USER-SUPPLIED NAME.
         LI,R2    REPORT#CHAIN-#J#CHAINW       LOOK AT CURRENT REPORTS.
         AW,R2    R4
OUTL%10  LW,R5    #J#CHAINW,R2      ANY MORE?
         BEZ      OUTL%20             NO.  CREATE A NEW ONE.
         LW,R7    #J#NAMECBSW,R5
         CB,R3    R7                DOES THIS REPORT HAVE SAME NAME LNTH
         BNE      OUTL%15             NO.  CAN'T BE THE SAME.
         LI,R6    BA(USER#NAME#TEXT)
         CBS,R6   0                 DOES THIS REPORT HAVE SAME NAME?
         BE       OUTL%40             YES.  ADD LINE TO REPORT.
OUTL%15  LW,R2    R5                NO.
         B        OUTL%10           KEEP LOOKING.
*
OUTL%20  M:GSP    512               CREATE A NEW REPORT.
         BCS,8    USER%ABORT        IF NO ROOM FOR IT, DIE.
         STW,R5   #J#CHAINW,R2      ADD TO CHAIN OF REPORTS.
         ANLZ,R1  BA@R5             PUT
         AW,R1    L(#J#HDR#LEN**24)   ZEROES
         MBS,R0   BA(L(0))              INTO NEW-REPORT SPACE.
         LI,R6    BA(USER#NAME#TEXT) MOVE REPORT NAME
         LW,R7    R1
         AW,R7    L(#J#NAME#LEN**24)  INTO
         MBS,R6   0                 NAME AREA IN REPORT.
         ANLZ,R7  BA@R5
         AI,R7    #J#TEXTB
         STW,R7   #J#TEXTMBSW,R5    THIS IS BA(TEXT END SO FAR)+1.
         ANLZ,R7  BA@R5
         AI,R7    #J#NAMEB
         STB,R3   R7                THIS IS NAME LENGTH (00-07),
         STW,R7   #J#NAMECBSW,R5            BA(NAME)    (08-31).
         STW,R3   #J#LENGTHSW,R5    (0-15)=TEXTLEN=0. (16-31)=NAMELEN.
         LI,R3    512*4             SAY REPORT IS 512W LONG FOR NOW.
         OR,R3    TRAN#JOURNAL,R4   GET DEFAULT JOURNALIZATION.
         INT,R6   USER#JOURNAL      GET USER'S OVERRIDE.
         EXU      OUT%JJRNLD,R6     OVERRIDE DELIVERYJOURNAL MAYBE.
         EXU      OUT%JJRNLO,R7     OVERRIDE OUTJOURNAL MAYBE.
         STW,R3   #J#FLAGSW,R5
*
OUTL%40  INT,R2   #J#LENGTHSW,R5    R2= TEXT LENGTH
         AW,R2    USER#TEXT#LEN       + LENGTH OF THIS LINE.
         CI,R2    1980              IS REPORT TOO BIG?
         BG       USER%ABORT          YES.  QUIT.
         LW,R6    USER#TEXT         POINT TO TEXT TO BE ADDED.
         LW,R7    #J#TEXTMBSW,R5    POINT TO WHERE TO PUT IT.
         LW,R8    USER#TEXT#LEN     GET LENGTH OF REPORT LINE.
OUTL%60  CI,R8    255               MOVE
         BLE      OUTL%65           REPORT
         AI,R8    -255              LINE
         MTB,-1   R7                TO
         MBS,R6   0                 END OF
         B        OUTL%60           REPORT AREA.
OUTL%65  STB,R8   R7                MOVE LAST PIECE OF LINE
         MBS,R6   0                 TO REPORT TEXT AREA.
         STH,R2   R3                PUT LENGTHS
         STW,R3   #J#LENGTHSW,R5      BACK INTO REPORT HEADER.
         STW,R7   #J#TEXTMBSW,R5    PUT TEXT POINTER BACK.
         USERRETURN                 FINI.
*
*
OUT%JJRNLO  NOP                     USER DIDN'T OVERRIDE OUTJOURNAL.
         OR,R3    L(##JJRNLO**24)   USER SAID OUTJOURNAL.
         AND,R3   L((~##JJRNLO)**24) USER SAID DON'T OUTJOURNAL.
OUT%JJRNLD  NOP                     USER DIDN'T OVERRIDE DELIJOURNAL.
         OR,R3    L(##JJRNLD**24)   USER SAID DELIJOURNAL.
         AND,R3   L((~##JJRNLD)**24) USER SAID DON'T DELIJOURNAL.
OUT%JQUEUE  NOP                     USER DIDN'T OVERRIDE QUEUE.
         OR,R3    L(##JQUEUE**24)   USER SAID QUEUE.
         AND,R3   L(~(##JQUEUE**24)&X'FFFFFFFF')  DON'T QUEUE.
         PAGE
************************************ * * * * * * * * * * * * * * * * * *
*                                                                      *
*  OUTATRAN SPAWNS A TRANSACTION.                                      *
*                                                                      *
************************************ * * * * * * * * * * * * * * * * * *
OUTATRAN @P
         MESSAG,T ' OUTATRAN'
         USERENTRY   (NAM,*1,(0,21)),(TEXT,*3,(0,1980)),;
                  (JOURNAL,*5,(0,22))
         BON,F#INIT  USER%ABORT     CAN'T SPAWN DURING INITIALIZATION.
         UNPROTECT
         SETT,R15 F#USER#TPC
*
         LW,R2    USER#NAME#LEN     NAME LENGTH.
         AI,R2    +1                ALLOW FOR Q/M TO BE ADDED.
         LW,R3    USER#TEXT#LEN     TEXT LENGTH.
         STH,R3   R2                R2 IS LENGTH WORD.
         AI,R3    #J#HDR#LEN+#J#NAME#LEN+4+3
         SLS,R3   -2                R3 IS JOURNAL RECORD LENGTH.
         M:GSP    *R3               GET SPACE FOR IT.
         BCS,8    USER%ABORT        IF NO ROOM, DIE.
         ANLZ,R1  BA@R5
         AW,R1    L(#J#HDR#LEN**24)
         MBS,R0   BA(L(0))          ZERO OUT HEADER AREA.
         SLS,R3   +2                CONVERT RECORDLENGTH TO BYTES.
         STW,R2   #J#LENGTHSW,R5    REMEMBER LENGTHS.
         OR,R3    TRAN#JOURNAL,R4   GET DEFAULT QUEUEING/JOURNALIZATION.
         INT,R6   USER#JOURNAL      GET USER'S OVERRIDE.
         EXU      OUT%JQUEUE,R6     OVERRIDE QUEUEING MAYBE.
         EXU      OUT%JJRNLO,R7     OVERRIDE OUTJOURNAL MAYBE.
         EXU      OUT%JJRNLD,R7      (DELIJOURNAL = OUTJOURNAL).
         STW,R3   #J#FLAGSW,R5
         ANLZ,R7  BA@R5
         AW,R7    L((#J#NAME#LEN-1)**24+#J#HDR#LEN)
         LI,R6    '?'               START NAME AREA OF RECORD
         STB,R6   0,R7                WITH
         AI,R7    +1                QUESTION MARK.
         LI,R6    BA(USER#NAME#TEXT)  MOVE NAME OF TRANSACTION
         MBS,R6   0                 INTO RECORD.
         LI,R3    TRANOUT#CHAIN-#J#CHAINW
         AW,R3    R4                GO OUT
OUTT%10  LW,R2    #J#CHAINW,R3      TO END
         BEZ      OUTT%12           OF CURRENT
         LW,R3    #J#CHAINW,R3      SPAWNED
         B        OUTT%10           TRANSACTION
OUTT%12  STW,R5   #J#CHAINW,R3      CHAIN & ADD THIS ONE TO IT.
         LW,R6    USER#TEXT
         LW,R3    USER#TEXT#LEN
OUTT%20  CI,R3    255               MOVE
         BLE      OUTT%25           TRANSACTION
         AI,R3    -255              TEXT
         MTB,-1   R7                TO
         MBS,R6   0                 TRANSACTION
         B        OUTT%20           AREA.
OUTT%25  STB,R3   R7
         MBS,R6   0
         USERRETURN                 FINI.
         PAGE
************************************ * * * * * * * * * * * * * * * * * *
*                                                                      *
*  TPC IS WHERE USER PROGRAMS COME WHEN THEY ARE FINISHED.             *
*                                                                      *
************************************ * * * * * * * * * * * * * * * * * *
TPC      @P
         MESSAG,T '*ENTER TPC.'
         USERENTRY
         LW,R7    F#USER,R4         GET WHERE TO RETURN TO WITHIN TPC,
         B        0,R7              AND RETURN THERE.
         PAGE
************************************ * * * * * * * * * * * * * * * * * *
*                                                                      *
*  GETATRAN SUPPLIES TRANSACTION NAME AND TEXT TO USER.                *
*                                                                      *
************************************ * * * * * * * * * * * * * * * * * *
GETATRAN @P
         MESSAG,T ' GETATRAN'
         USERENTRY   (NAM,1),(TEXT,3)
         BON,F#INIT  USER%ABORT     CAN'T GET ONE DURING INITIALIZATION.
         LW,R5    TRAN#POINTER,R4   R5=> TRANSACTION.
         INT,R2   #J#LENGTHSW,R5    R2= TRANSACTION TEXT LENGTH.
         LW,R3    R2                R3= TRANSACTION TEXT LENGTH TOO.
         LW,R9    USER#TEXT         R9= BA(USER TEXT AREA).
         ANLZ,R8  BA@R5             R8= BA(TRANSACTION AREA).
GETA%20  CI,R2    255
         BLE      GETA%25           COPY
         AI,R2    -255              TRANSACTION
         MTB,-1   R9                TEXT
         MBS,R8   #J#TEXTB          TO
         B        GETA%20           USER
GETA%25  STB,R2   R9                AREA.
         MBS,R8   #J#TEXTB
*
         INT,R9   #J#LENGTHSW,R5    R9= TRANSACTION NAME LENGTH.
         LW,R7    USER#NAME         R7= BA(USER NAME AREA).
         STB,R9   R7                    ADD NAME LENGTH TO R7.
         ANLZ,R6  BA@R5             R6= BA(TRANSACTION AREA).
         MBS,R6   #J#NAMEB          COPY TRANSACTION NAME TO USER AREA.
         STW,R9   *USER#NAME#LEN    COPY NAME LENGTH TO USER.
         STW,R3   *USER#TEXT#LEN    COPY TEXT LENGTH TO USER.
         B        *R15              FINI.
         PAGE
************************************ * * * * * * * * * * * * * * * * * *
*                                                                      *
*  FAILURE FAILS THE TRANSACTION.                                      *
*                                                                      *
************************************ * * * * * * * * * * * * * * * * * *
FAILURE  @P
         MESSAG,T ' FAILURE'
         USERENTRY   (JOURNAL,*1,(0,11))
         BON,F#INIT   USER%ABORT    FAIL DURING INITIALIZATION = ABORT.
         UNPROTECT
         SETT,R15 F#USER#TPC
         PROTECT
         LI,R7    Q:TID             IF WE'RE RUNNING WITH EDMS,
         BEZ      FAIL%10
         MTW,0    Q:CCBADR             AND THE DATABASE HAS BEEN OPENED,
         BEZ      FAIL%10
         LI,R14   1                 TELL THE DBM
         BAL,R15  DMSRLSE           TO RESTORE THE DATABASE
         DATA     BA(L('RECV'))     FROM THE TRANSIENT JOURNAL.
         FINDPROTECTED              GET ADDRESS OF DATA AGAIN.
FAIL%10  UNPROTECT                  ALLOW US TO MODIFY OUR DATA.
         SETT     F#FAIL            SAY WE'VE FAILED.
         CALL     DELETE%TPM%OUTPUT
         INT,R2   USER#JOURNAL      REMEMBER WHETHER
         SETT,R2  F#ABORTME           TO R-OFF THE TPM AND WHETHER
         SETT,R3  F#KEEP              TO DELETE ORIGINAL TRANSACTION.
         USERRETURN                 FINI.
         PAGE
************************************ * * * * * * * * * * * * * * * * * *
*                                                                      *
*  JOURNAL ALLOWS THE USER TO WRITE ON THE JOURNAL.                    *
*                                                                      *
************************************ * * * * * * * * * * * * * * * * * *
JOURNAL  @P
         MESSAG,T ' JOURNAL'
         USERENTRY   (TEXT,*1,(0,X'10000'-7*4-4))
         LW,R5    USER#TEXT         R5 = BA(USER'S TEXT).
         CI,R5    3                 IS IT ON A WORD BOUNDARY?
         BANZ     USER%ABORT        IF NOT, BAD NEWS FOR HIM.
         SLS,R5   -2                R5 => USER'S TEXT.
         AI,R5    -6                ALLOW FOR OUR HEADER.
         LW,R6    USER#TEXT#LEN     R6= LENGTH OF TEXT.
         AI,R6    #J#HDR#LEN+4+3    ALLOW FOR HEADER AND CHECKSUM.
         AND,R6   L(X'FFFC')        MUST BE INTEGER # WORDS IN RECORD.
         AW,R6    L(#JOURNAL#US**16)  PUT IN RECORDTYPE.
         OR,R6    TRAN#JOURNAL,R4   GET DEFAULT JOURNALFLAGS.
         AND,R6   L(~(##JQUEUE**24)&X'FFFFFFFF')  THIS ISN'T QUEUED.
         OR,R6    L((##JJRNLO+##JJRNLD)**24) IT IS BEING JOURNALIZED.
         STW,R6   #J#FLAGSW,R5      INSTALL TYPE WORD IN RECORD.
         LW,R6    TRAN#ID,R4
         STW,R6   #J#IDW,R5         PUT TRANSACTION ID INTO RECORD.
         LW,R6    USER#TEXT#LEN     PUT
         SLS,R6   +16                USER'S TEXT LENGTH
         STW,R6   #J#LENGTHSW,R5     INTO LENGTH WORD IN RECORD.
         LI,R6    0                  (ZERO IN OTHER ID WORD).
         CALL     JOURNAL%WRITE
         B        *R15
         TITTLE   'SERVICE ROUTINES'
*
*        PUT DATE/TIME INTO RECORDS & WRITE TO JOURNAL IF JOURNAL BIT SET
*
JOURNAL%WRITE     ENTRY  ;
         'WRITE A RECORD ON THE JOURNAL IF ITS JOURNAL BIT IS SET.',;
         'PUT DATE/TIME/ORIG.ID/CKSUM IN IF WRITTEN (PRESERVE CHAINW).';
        ,'NEEDS R5=> RECORD, R6= ORIG.ID, R4=> DYN.AREA.',;
         'R2,R3,R8,R9 ZAPPED.'
         LW,R8    #J#FLAGSW,R5      GET FLAGBYTE AND RECORD LENGTH.
         CW,R8    L(##JJRNLO**24)   SEE IF JOURNALIZATION REQUESTED.
         BAZ      JNL%W%90          GO IF IT ISN'T TO BE JOURNALIZED.
         LCI      2
         LM,R8    TRAN#TIME,R4      GET LATEST DATE/TIME AND
         STM,R8   #J#DATEW,R5        PUT IT INTO RECORD.
JNL%W%20 XW,R6    #J#ORIGIDW,R5     R6<=>ORIG.ID (CHAIN WORD).
         INT,R9   #J#FLAGSW,R5      R9 = LENGTH OF RECORD IN BYTES.
         SLS,R9   -2                   = NUMBER OF WORDS IN RECORD.
         AI,R9    -2                     -1 CHKSUM, -1 WORD ZERO.
         LW,R3    0,R5              R3 WILL BE CHECKSUM.
         LW,R2    R5                R2 =>ALL WORDS OF RECORD.
JNL%W%30 AW,R3    1,R2                ACCUMULATE CHECKSUM:
         BNC      JNL%W%35            IF CARRY,
         AI,R3    +1                   ADD IN END-AROUND.
JNL%W%35 AI,R2    1                   KEEP ADDING WORDS TOGETHER
         BDR,R9   JNL%W%30             FOR ALL OF RECORD.
JNL%W%70 XW,R3    1,R2              R3<=>CHECKSUM WORD IN RECORD.
         INT,R9   #J#FLAGSW,R5      R9 = RECORD SIZE IN BYTES.
     M:WRITE F:JRNL,(BUF,*R5),(SIZE,*R9),(ERR,JNL%W%EA),(ABN,JNL%W%EA)
         XW,R6    #J#ORIGIDW,R5       RESTORE CHAINWORD.
         XW,R3    1,R2                RESTORE WORD UNDER CHECKSUM.
JNL%W%90 RETURN   JOURNAL%WRITE     EXIT.
*
JNL%W%EA XW,R6    #J#ORIGIDW,R5       RESTORE CHAINWORD.
         XW,R3    1,R2                RESTORE WORD UNDER CHECKSUM.
         LB,R8    SR3               R8 = ERR/ABN CODE.
         CI,R8    X'1C'               IS IT END-OF-VOLUME?
         BNE      JNL%W%EE            IF NOT, GO...
         SLS,SR3  -17               SR3= SUBCODE.
         CI,SR3   X'1C'**7+1          HAS RECORD BEEN WRITTEN?
         BNE      JNL%W%90            YES.  GO ON; LET MONITOR DO CVOL.
         M:WAIT   5                   NO. (COMMON JOURNAL). WAIT A BIT,
         B        JNL%W%20             AND TRY AGAIN.
JNL%W%EE MESSAGE,E 'I/O ERR ',(R8,2,2),' ON F:JRNL.'
         B        MASTER%ABORT%TIP    ANYTHING BUT EOV IS BAD BAD NEWS.
         PAGE
*
*        DELETE ALL OUTPUT CREATED BY THE TPM.
*
DELETE%TPM%OUTPUT ENTRY  ;
         'DISCARD REPORTS & SPAWNED TRANSACTIONS.  FREE THE SPACE.',;
         'R2,R3,R7,R8,R9 ZAPPED. NEEDS R4=> DYN. AREA (UNPROTECTED).'
         LI,R3    0
         XW,R3    REPORT#CHAIN,R4   DELETE ALL REPORTS.
         BEZ      DTO%15            GO IF NONE.
DTO%10   LW,R2    #J#CHAINW,R3      REMEMBER CHAIN.
         M:FSP    512,R3            FREE REPORT SPACE.
         LW,R3    R2                IF THERE ARE MORE REPORTS,
         BNEZ     DTO%10              KEEP DELETING.
DTO%15   XW,R3    TRANOUT#CHAIN,R4  DELETE ALL SPAWNED TRANSACTIONS.
         BEZ      DTO%25            GO IF NONE.
DTO%20   LW,R2    #J#CHAINW,R3      REMEMBER CHAIN.
         INT,R7   #J#FLAGSW,R3      GET SIZE
         SLS,R7   -2                OF TRANSACTION AREA.
         M:FSP    *R7,R3            FREE THE SPACE.
         LW,R3    R2                IF THERE ARE MORE TRANSACTIONS,
         BNEZ     DTO%20              KEEP DELETING.
DTO%25   M:GL                       RE-INITIALIZE
         STW,SR1  SPACE#AVAIL,R4      DYNAMIC SPACE POINTER.
         RETURN   DELETE%TPM%OUTPUT
         PAGE
*
*        RETURN DATE AND TIME IN REGISTERS 14 AND 15.
*
         @T
TIME#TEMP  RES    4                 AREA FOR HOLDING TIME.
*
GET%TIME ENTRY    ;
         'R14/R15 <= DATE/TIME (YYYYDDDD/HHMMSS**).'
         LD,R14   SR1               PRESERVE REGISTERS.
         M:TIME   TIME#TEMP,TMS     DATE & TIME TO SR1,SR2,SR3.
         LI,SR3+1 X'3FF'            EXTRACT THOUSANDTHS OF A MINUTE
         SLD,SR3  +6                 FROM SR3(22-31).
         STS,SR3  SR2               PUT INTO SR2(16-25).
         XW,SR1   R14               R14= (00-15) YEAR     (16-31) DAY
         XW,SR2   R15               R15= (0-7) HOUR (8-15) MINUTE
*                                        (16-25) THOUS (26-31) TMS
         RETURN   GET%TIME
         PAGE
*
*        GET A COMMON PAGE, SET UP MEM.PROTECT FPT'S, AND
*        CLEAR IT TO ZEROS.
*
GET%COMMON  ENTRY ;
         'GET A COMMON PAGE.  ONLY CALLABLE DURING INITIALIZATION.',;
         'SR1<=WA(PAGE). SR2<=X''1FE00''.',;
         'NEEDS R2(15-22) = EXPECTED PAGE, R4=>DYNDATA(UNPROTECTED).'
         M:GCP    1                 SR2=>NEW COMMON PAGE.
         BCS,8    INIT%ABORT%NOSPACE     (UNLESS NO MORE, SO DIE).
         LW,SR1   SR2               SR1=>NEW COMMON PAGE ALSO.
         LI,11    0                   CLEAR
         LI,10    256                 PAGE
GET%C%20 STD,11   *SR2                TO
         AI,SR2   2                   ZEROS.
         BDR,10   GET%C%20
         LI,SR2   X'1FE00'
         CS,SR1   R2                DID WE GET THE RIGHT PAGE?
         BNE      INIT%ABORT%SPACEBAD  NO.. ABORT.. BAD NEWS.
         STS,SR1  FPT#PROTECT,R4       FIX UP PROTECT-IT FPT.
         STS,SR1  FPT#UNPROTECT,R4     FIX UP UNPROTECT-IT FPT.
         RETURN   GET%COMMON        RETURN TO CALLER.
         PAGE
*
*
         @S                         LITERALS ARE STATIC.
         END      TPC%              THAT'S ALL, FOLKS.

