*M* TPC  INTERFACE BETWEEN USER TP PROGRAMS AND CPV TP SERVICES.
*P*
*P*      NAME:    TPC
*P*
*P*      PURPOSE: TO PROVIDE AN INTERFACE BETWEEN USER-WRITTEN
*P*               TRANSACTION PROCESSING PROGRAM MODULES AND THE
*P*               CP-V MONITOR TP TRANSACTION AND REPORT QUEUING
*P*               AND DELIVERY SERVICES.  THE TPC ALSO PROVIDES
*P*               ERROR DETECTION AND RECOVERY FOR USER MODULES.
*P*
         SPACE    10
SIMULATE EQU      1 FOR TPC SIMULATOR, 0 FOR REAL TPC.
PRINTALL EQU      SIMULATE          (SET =1 FOR TRACE IN REAL TPC)
*
DATE     EQU      '061876'          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   TPPROCS           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
#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
LF       DO1      NUM(CF)<2         IF NO REGISTER SPECIFIED,
         LI,11    NAME                LOAD 11 WITH NONZERO OR ZERO.
         OPEN     I
I        DO       NUM(AF)           SET OR CLEAR ALL SPECIFIED FLAGS.
         ERROR,7,1-TCOR(AF(I),S:AAD) 'NOT A FLAG'
         STW,S:S(NUM(CF)<2,CF(2),11) AF(I),R4
         FIN
         CLOSE    I
         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)
*
*        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#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#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#POINT#CURRENT REZ 1
*
*
S#SPAWN  REZ      1                 => SPAWNED-XACTION CHAIN(SIMULATOR).
SPACE#BASE   REZ  1                 => END OF OUTPUT WORKSPACE.
*                                     (=TRAN#POINTER IF NOT 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
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#EBC REZ   2                 ID OF CURRENT TRANSACTION(EBCDIC).
            REZ   1                     (FOR '.' BEFORE EBCDIC ID)
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   'MESSAGE GENERATOR'
************************************ * * * * * * * * * * * * * * * * * *
*                                                                      *
*  MESSAGE PROC AND MESS%AGE ROUTINE BUILD MESSAGES.                   *
*  MESSAGES COME IN SEVERAL FLAVORS:                                   *
*  ,T    PROGRAM TRACE IN TPC SIMULATOR.                               *
*  ,EO   ERROR MESSAGES TO THE OPERATOR.                               *
*  ,E    ERROR EXPLANATIONS IN PRINTED OUTPUT ONLY.                    *
*  ,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,0)  - - - - - - S IS WA OF A TEXTC STRING                  *
*                             OR *WA OF WA OF TEXTC STRING.            *
*        (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,#CT
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 EXPLANATION M:PRINT M:PRINT
*             EO  ERROR MESSAGE     M:TYPE  M:PRINT
*             K   OPERATOR KEYIN    M:TYPE  M:TYPE
J        SET      SCOR(CF(2),T,E,EO,K)
         ERROR,7,J=0  'SYNTAX'
*
         DO       J>1|PRINTALL      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      SET      AF(I,2)=0         TEXTPOINTER: (SOURCE),(LENGTH).
         GEN,1,000000000003,4,00004,3*AFA(I,1,1),20-3*AFA(I,1,1) ;
             0,2+AFA(I,1,1),0,3+#CT,AF(I,1,2),AF(I,1,1)
         DO1      1-#CT
         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-PRINTALL<3,MESS%TYPE,MESS%PRINT))
         ELSE
LF       @P                         (JUST DEFINE LF IF NOT MESSAGING)
         FIN
         CLOSE    I,J,#L,#CT
         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 #
         BCR,12   MESS%50           3:TEXT         --  BA(TEXT)
*                                   4:TEXTC        --  WA(TEXTC)
         LB,10    *11               10 = LENGTH OF TEXT.
         SLS,11   +2                11 = BA(TEXTC)
         AI,11    +1                11 = BA(TEXT)
         B        MESS%52             ENTER MIDDLE OF TEXT CODE.
MESS%50  ANLZ,10  *MESS#RET         10 = LENGTH OF TEXT.
         MTW,+1   MESS#RET
MESS%52  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.
         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=>MATCHING CRITERION, R5=>TRANSACTION.',;
         '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 =>FIRST WAITING TRANSACTION.
         BNEZ     M%Q%G%MATCH            IF ANY, GO MATCH TO CRITERIA.
******************* R4>DYNAREA
M%Q%G%READ        @P                ** READ ANOTHER TRANSACTION.
         BON,F#SORT  MASTER%          (KEYIN CHANGED US; GO FIX.)
         LW,R5    TRAN#POINTER,R4   R5 =>SPACE FOR TRANSACTION.
         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.
         LW,R2    R1                R2 = BA(BUFFER FOR NAME RECORD)
         SLS,R1   -2                R1 = WA(BUFFER FOR NAME RECORD)
         M:SETDCB M:SI,(ERR,M%Q%G%ABORTSR3),; MAKE SURE WE INTERCEPT
                       (ABN,M%Q%G%ABORTSR3)   ALL I/O ERRORS.
         M:READ   M:SI,(BUF,*R1),;       READ NAME RECORD OF NEXT
                  (BTD,0),(SIZE,80),;    SIMULATED TRANSACTION.
                  (ERR,M%Q%G%ABORTSR3),(ABN,M%Q%G%ABN)
         LI,R15   ' '               R15= 'BLANK' FOR FINDING BLANKS.
         LW,R6    M:SI+ARS
         SLS,R6   -17               R6 = RECORD SIZE + SIGN BIT.
         OR,R6    L(X'80000000')    (I.E., BDR FAILS ARS TIMES)
M%Q%G%10 BDR,R6   M%Q%G%ERR              ERROR IF RECORD TOO SHORT.
         CB,R15   *R1,R6                 IF LAST CHAR OF RECORD IS
         BG       M%Q%G%10               FUNNY(CR,LF,ETC), IGNORE IT.
********** R2>INBUF,R4>DYNAREA,R5>XACTIONSPACE,R6=ARS-1+Y8,R15=BLANK
         LB,R13   0,R2              R13= JOURNAL INDICATOR (TEMP)
         LI,R9    0                 R9 WILL BE TRANSACTION TEXT LENGTH
M%Q%G%20 AI,R2    +1                R2 =>CURRENT CHAR IN NAME RECORD.
         BDR,R6   M%Q%G%ERR              (OOPS, RECORD IS TOO SHORT)
         LB,R8    0,R2              R8 = CURRENT CHARACTER.
         AI,R8    -'0'                   IS IT A DIGIT...
         BGEZ     M%Q%G%23               YES.
         AI,R8    '0'-' '                IS IT A BLANK...
         BNEZ     M%Q%G%25               NO. MUST BE START OF NAME.
M%Q%G%23 MI,R9    10                   ADD THIS CHARACTER'S VALUE
         AW,R9    R8                   INTO TEXT LENGTH.
         CI,R9    1980                 TEXT IS NOT ALLOWED TO BE
         BLE      M%Q%G%20             LONGER THAN 1980 CHARACTERS.
         B        M%Q%G%ERR            (OOPS, TEXT LENGTH TOO BIG)
M%Q%G%25 AI,R8    ' '-'?'   **NOTE: THIS IS BLANK MINUS QUESTIONMARK.
         BNEZ     M%Q%G%ERR         (OOPS, NAME DOESN'T START W/ QM)
         LW,R14   R9                R14 WILL BE FLAG/SIZE WORD.
         AW,R14   L((##JQUEUE+##JIP)**24+#J#TEXTB+4+3)
         AND,R14  L(X'FFFFFFFC')    R14(16-31)=LENGTH(HDR+TEXT+CKSUM)
         CI,R13   3                      SEE IF JRNL OR DELIJRNL SPEC.
         BAZ      M%Q%G%28          R14(0-7)=APPROPRIATE FLAGS.
         AW,R14   L((##JJRNLO+##JJRNLD)**24)
M%Q%G%28 STW,R14  #J#FLAGSW,R5           SET UP FLAGWORD IN XACTION.
** R2>INNAME,R4>DYNAREA,R5>XACTION,R6=REM.ARS-1+Y8,R9=TEXTLEN,R15=BLANK
         LI,R3    #J#NAMEB          R3 = DISPL TO NAME AREA IN XACTION
M%Q%G%30 LB,R12   0,R2                COPY NAME TO XACTION NAME.
         STB,R12  *R5,R3              (WE KNOW FIRST CHAR IS QM)
         AI,R3    +1                  BUMP DESTINATION.
         AI,R2    +1                  BUMP SOURCE.
         BDR,R6   M%Q%G%33               (NO MORE INPUT LEFT)
         CB,R15   0,R2                IS NEXT INPUT A BLANK...
         BE       M%Q%G%33               (YES. USED ALL OF INPUT NAME)
         CI,R3    #J#NAMEB+#J#NAME#LEN
         BL       M%Q%G%30            REPEAT TILL NAMESPACE ALL USED.
M%Q%G%33 CI,R12   '.'               IS LAST CHAR IN NAME A PERIOD...
         BNE      M%Q%G%36            NO.
         CI,R3    #J#NAMEB+#J#NAME#LEN-8  YES. ADD A TID TO THE END.
         BGE      M%Q%G%ERR              (OOPS, NO ROOM FOR TID)
         CALL     GET%ID
         ANLZ,R7  BA@R5:R3          R7 = BA(NAME END)+1.
         LI,R6    8                      ADD AN 8-CHARACTER TID
         STB,R6   R7                     TO THE END OF THE
         MBS,R6   (R14*4)-8              TRANSACTION NAME,
         AI,R3    +8                     AND SAY NAME IS 8 LONGER.
M%Q%G%36 AI,R3    -#J#NAMEB         R3 = TRANSACTION NAME LENGTH.
         STH,R9   R3                R3 = TEXTLENGTH, NAMELENGTH.
         STW,R3   #J#LENGTHSW,R5         SET UP LENGTHWORD IN XACTION.
******************* R4>DYNAREA,R5>XACTION,R9=TEXTLEN.
         ANLZ,R7  BA@R5
         AI,R7    #J#TEXTB          R7 = BA(START OF TEXT AREA)
         AW,R9    R7                R9 = BA(END OF NEEDED TEXT)+1
M%Q%G%40 CW,R7    R9                     HAVE WE GOT ALL WE NEED...
         BGE      M%Q%G%MATCH            YES. GO MATCH TO CRITERIA.
         LCW,R3   R7                R7 = BA(WHERE TO READ NEXT)
         AND,R3   L(X'7FF')         R3 = # BYTES LEFT IN PAGE
         LW,R6    R7                     (MIGHT AS WELL READ SO MUCH)
         SLS,R6   -2                R6 = WA(WHERE TO READ NEXT)
         M:READ   M:SI,(BUF,*R6),(BTD,*R7),(SIZE,*R3),;
                  (ABN,M%Q%G%46),(ERR,M%Q%G%ABORTSR3)
         LW,R3    M:SI+ARS
         SLS,R3   -17               R3 = AMOUNT READ.
         CI,R3    72                     IF IT'S MORE
         BLE      M%Q%G%44               THAN 72 BYTES,
M%Q%G%42 AI,R7    72                     USE THE FIRST 72 ONLY
         B        M%Q%G%40               AND READ AGAIN.
M%Q%G%44 AW,R7    R3                   IF IT'S 72 OR LESS,
         AI,R7    -1                   ASSUME WE'LL USE ONLY N-1.
         LB,R2    0,R7              R2 = LAST CHARACTER OF RECORD.
         CI,R2    X'15'                  IF N/L,
         BE       M%Q%G%40               DON'T USE IT.
         CI,R2    X'0D'                  IF CR,
         BE       M%Q%G%40               DON'T USE IT.
         AI,R7    1                      OTHERWISE USE IT.
         B        M%Q%G%40
M%Q%G%46 LB,R12   SR3               R12= ABN CODE FROM TEXT READ.
         CI,R12   X'07'                  SEE IF IT'S RECORD-TOO-LONG.
         BE       M%Q%G%42               YES. PRETEND 72 BYTES.
         B        M%Q%G%ABORTSR3         NO. DIE HORRIBLY.
******************* R4>DYNAREA,R5>FIRST WAITING TRANSACTION.
M%Q%G%MATCH       @P                ** MATCH SPAWNEES AGAINST CRITERIA
         LW,R6    CRI#POINTER,R4    R6 =>CRITERIA LIST.
         LW,R8    CRI#COUNT#GOOD,R4 R8 = NUMBER OF ACTIVE CRITERIA.
         BEZ      M%Q%G%63               IF NONE, NO MATCH POSSIBLE.
M%Q%G%60 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%60               TRY NEXT CRITERION.
M%Q%G%63 ANLZ,R12 BA@R5             THIS XACTION LOSES; TELL USER.
         AI,R12   #J#NAMEB          R12=>TRANNAME.
         INT,R13  #J#LENGTHSW,R5    R13= NAMELENGTH.
         MESSAGE,T '*** ',(*R12,*R13),' DISCARDED. (NOT REQUESTED)'
         LW,R5    #J#CHAINW,R5      R5 =>NEXT WAITING TRANSACTION.
         STW,R5   S#SPAWN,R4            (WHICH IS NOW HEAD OF QUEUE)
         BNEZ     M%Q%G%MATCH            GOT ONE; GO MATCH IT.
         B        M%Q%G%READ             NO WAITEES; GO READ INPUT.
******************* R4>DYNAREA,R5>XACTION,R6>MATCHING CRITERION.
M%Q%G%FOUND       @P                ** GOT A MATCH. CLEAN UP & RETURN.
         LW,R7    TRAN#POINTER,R4   R7 =>REAL TRANSACTION AREA.
         LI,R2    255                    COPY THIS TRANSACTION TO
M%Q%G%70 LD,R12   *R5,R2                 REAL TRANSACTION AREA.
         STD,R12  *R7,R2                 MOVE IT,
         AI,R2    -1                       DOUBLEWORD BY DOUBLEWORD.
         BGEZ     M%Q%G%70
         LW,R2    #J#CHAINW,R5           NEXT AWAITEE IS NOW
         STW,R2   S#SPAWN,R4             FIRST AWAITEE.
         BNEZ     M%Q%G%75               IF ANY, NO CLEANUP TILL QPUT.
         STW,R7   SPACE#BASE,R4     CLEANUP: SAY NO RESERVED SPACE,
         CALL     DELETE%TPM%OUTPUT         AND FREE UNRESERVED SPACE.
M%Q%G%75 LW,R2    L(#ECBP)          --- POSTED
         LI,R3    1                 --- WITH CC OF 1
         STD,R2   QGET#ECB          --- INTO TRANSACTION-GET ECB.
         LW,SR1   R6                --- SR1=>MATCHING CRITERION.
         LW,R5    TRAN#POINTER,R4   --- R5 =>TRANSACTION.
         RETURN   QUEUE%GET
******************* R4>DYNAREA,R5>XACTION WORKSPACE.
M%Q%G%ERR         @P                ** BAD DATA READ. TELL USER & REDO
         MESSAGE,T '<<< EVIL INPUT. TRY AGAIN.'
         B        M%Q%G%READ
******************* R4>DYNAREA
M%Q%G%ABN         @P                ** ASSUME ABN ON NAME READ IS EOF.
         MESSAGE,T '* END OF TRANSACTION INPUT FILE'
         B        MEXIT%            --->EXIT. TRIGGER XCON & CLOSEDCBS.
         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      M%Q%G%ABORTSR3    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,11   M%Q%G%ABORT       ANY BUT NO-SPACE-TO-WAIT 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 AI,SR1   -1
         AW,SR1   CRI#POINTER,R4    --- SR1=>MATCHING CRITERION.
         RETURN   QUEUE%GET         >>>>>RETURN WITH A XACTION.
         FIN
M%Q%G%ABORT       @P                ** KILL TPLM FROM GET. IGNORE SR3.
         LI,SR3   0
M%Q%G%ABORTSR3    @P                ** KILL TPLM FROM GET. DISPLAY SR3.
         LW,R12   SR3
         MESSAGE,E 'M:QUEUE/GET ERROR.SR3=',(R12,8,2)
         B        MASTER%ABORT
         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.'
         STD,R5   R2                R2,R3=>PUTLIST.
M%Q%P%10 LW,R8    0,R2                 GET A PUTLIST ENTRY POINTER.
         CW,R8    L((##JQUEUE+##JIP)**24)  DOES QM WANT IT...
         BAZ      M%Q%P%14             NO. SKIP IT.
         STW,R8   0,R3                 YES. LEAVE IT IN LIST.
         AI,R3    +1                     AND INCREMENT NEW-LIST.
M%Q%P%14 AI,R2    +1                  IN ANY CASE, BUMP OLD-LIST.
         BDR,R6   M%Q%P%10          REPEAT THRU WHOLE OLD LIST.
         SW,R3    R5                R3= NEW SIZE OF LIST.
         BEZ      M%Q%P%31             (QUIIT NOW IF NOTHING TODO)
         LW,R6    R3
         DO       SIMULATE
         LW,R3    R5
M%Q%PUT  @P
******************* R3>CURR.PUTLISTWORD,R4>DYNAREA,R6=REM.PUTLISTLEN.
         LW,R5    0,R3              R5 =>PUTLIST ENTITY.
         INT,R12  #J#LENGTHSW,R5    R12= TEXT LENGTH.
         CVS,R12  BIN#TO#DEC        R13= TEXT LENGTH (EBCDIC).
         LB,R12   R5                R12= ENTITY'S FLAGS.
         CI,R12   ##JIP
         BANZ     M%Q%P%END              (IGNORE ORIGINATING XACTION)
         SLS,R12  -##JJRNLDS
         AND,R12  L(3)              R12= JRNL & DELIJRNL BITS.
         AI,R12   '0'                    IN EBCDIC.
         INT,R14  #J#LENGTHSW,R5    R14= TEXTLENGTH, R15= NAMELENGTH.
         AI,R15   5                 R15= NAMELNTH+5 (NAMERECORD LEN)
         XW,R12   #J#NAMEW-2,R5        PUT JOURNALBYTE AND EBCDIC
         XW,R13   #J#NAMEW-1,R5        TEXTLEN BEFORE ENTITY'S NAME.
         LW,R7    R5
         AI,R7    #J#NAMEW-2        R7 = BUFFER ADDRESS.
         M:WRITE  M:LO,(BUF,*R7),(BTD,3),(SIZE,*R15),WAIT
         STW,R12  #J#NAMEW-2,R5        RESTORE ENTITY'S ENTRY TO ITS
         STW,R13  #J#NAMEW-1,R5        FORMER DECENT CONDITION.
         AI,R7    #J#TEXTW-(#J#NAMEW-2) R7 =>TEXT OF ENTITY.
******* R3>PUTLIST,R4>DYNAREA,R5>ENTITY,R6=PUTLEN,R7>TEXT,R14=TEXTLEN
M%Q%P%20 AI,R14   -72
         BLZ      M%Q%P%25               (LESS THAN 72 CHAR TEXTLEFT)
         M:WRITE  M:LO,(BUF,*R7),(BTD,0),(SIZE,72),WAIT
         AI,R7    72/4
         B        M%Q%P%20
M%Q%P%25 AI,R14   +72
         BEZ      M%Q%P%30               (LAST RECORD =72 EXACTLY)
         M:WRITE  M:LO,(BUF,*R7),(BTD,0),(SIZE,*R14),WAIT
******************* R3>PUTLIST,R4>DYNAREA,R5>ENTITY,R6=PUTLEN
M%Q%P%30 LW,R8    #J#NAMEW,R5
         SLS,R8   -24
         CI,R8    '?'               THIS IS A QUESTION MARK.
         BNE      M%Q%P%END         GO IF ENTITY IS A 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.
M%Q%P%END         @P
         AI,R3    1
         BDR,R6   M%Q%PUT           REPEAT UNTIL LIST FINISHED.
*
*
         LW,R7    TRAN#POINTER,R4   R7 = WA(END OF SAVESPACE)+1.
         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.
         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%Q%P%78 LW,R5    #J#CHAINW,R5           PROCEED DOWN
         B        M%Q%P%70               THE CHAIN.
*
M%Q%P%90 STW,R7   SPACE#BASE,R4     ESTABLISH NEW BASE OF WORKAREA.
         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%ABORTSR3    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,11   M%Q%P%ABORT       ANY BUT NO-SPACE-TO-WAIT 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.
         FIN
M%Q%P%31 RETURN   QUEUE%PUT
M%Q%P%ABORT       @P                ** KILL TPLM FROM PUT. IGNORE SR3.
         LI,SR3   0
M%Q%P%ABORTSR3    @P                ** KILL TPLM FROM PUT. DISPLAY SR3.
         LW,R12   SR3
         MESSAGE,E 'M:QUEUE/PUT ERROR.SR3=',(R12,8,2)
         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,11   MASTER%ABORT      ANY BUT NO-SPACE-TO-WAIT 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:TRAP   (IGNORE,FX)       D O   T H I S   FIRST FIRST FIRST
         M:GL                       SR2=>LAST WORD OF COMMON STORAGE.
         CW,SR1   SR2                    MAKE SURE NO COMMON GOT YET.
         BNE      INIT%ABORT%SPACEBAD    (OOPS IF SO).
         LI,R4    X'1FE00'
         AND,R4   SR2               R4 = WA(LAST COMMON PAGE).
         CALL     GET%COMMON             GET FIRST(LAST) COMMON PAGE.
         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
         CALL     GET%COMMON        WE'LL NEED ATLEAST 2; GET #2 NOW.
         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.
         LCI      4                 YES. SAVE IT.
         STM,R12  TRAN#ID,R4
*
         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
*        LI,R3    0                   START WITH TPM NUMBER 0.
*        STW,R3   TPM#NUMBER,R4       (THIS CELL ZEROED BY GET%COMMON)
*
INIT%LOOP         @P
         LW,R3    TPM#NUMBER,R4     GET NUMBER OF CURRENT TPM.
         LI,R7    X'1FFFF'
WA@TPMS:R3 CW,R7  TPMS%%,R3         IF NO INITIALIZATION ENTRY POINT,
         BAZ      INIT%ZAP%TPM        THIS TPM DOESN'T EXIST.
WA@TPMX:R3 CW,R7  TPMX%%,R3         IF NO PROCESSING ENTRY POINT,
         BAZ      INIT%ZAP%TPM        THIS TPM DOESN'T EXIST.
*
         ANLZ,R6  WA@TPMS:R3        R6 =>BRANCH TO TPMSNN.
         BAL,R7   TRAN%               GO TO THE TPM.
         TEXTC    'TPMS'
*                                   (ON RETURN, COME TO INIT%END)
INIT%END @P
         MTW,+1   TPM#INDEX,R4      BUMP GOOD-TPM COUNT.
         LW,R2    TPM#INDEX,R4
         B        INIT%20
INIT%ABORT        @P
         MESSAGE,EO 'UNABLE TO START UP TPM ',((TPM#NUMBER,R4),2,0),'.'
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  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.
*
         SETT     F#SORT            MUST SORT CRITERIA FIRST THING.
         CLEAR    F#INIT
         B        MASTER%
         PAGE
*
INIT%ABORT%NOTP   @P
         MESSAGE,EO 'TP NOT UP - WAITING'
         M:WAIT   25
         B        TPC%18            AND TRY AGAIN AFTER 30 SECONDS
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,EO ' -- INITIALIZATION ABORTED.'
         B        MXXX%             ---> TERMINATE TPC ABNORMALLY.
*        (IF WE HAVE XCON, IT WILL CALL DIE% TO CLOSE DCBS (SAVE);
*         IF WE DON'T YET HAVE XCON, THERE AREN'T ANY OPEN ANYWAY).
         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  MEXIT%       IF OPERATOR X'ED US, GO QUIT.
         BON,F#SORT  CRI%PROC       GO IF CRITERIA NEED REARRANGING.
         CALL     QUEUE%GET           GET A TRANSACTION.
         LI,R2    X'F00FF'            CLEAN UP GARBAGE BYTE
         AND,R2   #J#LENGTHSW,R5      IN LENGTHS WORD OF
         STW,R2   #J#LENGTHSW,R5      TRANSACTION.
         LW,R3    #J#FLAGSW,R5
         OR,R3    L(##JIP**24)        SHOW TRANSACTION BEING
         STW,R3   #J#FLAGSW,R5        IN PROGRESS.
         LW,R2    L(##JQUEUE**24)
         CW,R3    L(##JJRNLO**24)
         BAZ      MAST%10
         AW,R2    L((##JJRNLI+##JJRNLO+##JJRNLD)**24)
MAST%10  STW,R2   TRAN#JOURNAL,R4     SET DFLT OUTPUT QUEUE/JNL.
         INT,R3   #J#LENGTHSW,R5
         ANLZ,R6  BA@R5:R3
         LW,R7    L(8**24+(R14*4))
         MBS,R6   #J#HDR#LEN-8      R14/R15= EBCDIC TRANSACTION ID.
         LI,R6    -8                     CONVERT TRANID TO HEX:
MAST%20  LB,R13   R14+2,R6               GET A TID CHARACTER.
         CI,R13   X'30'
         BANZ     MAST%23                IF 'A'-'F',
         AI,R13   '9'+1-'A'              ADJUST IT.
MAST%23  SCS,R13  -4
         SLD,R12  +4                R12= HEXADECIMAL TRANSACTION ID.
         BIR,R6   MAST%20
         LI,R13   '.'               R13= PERIOD FOR START OF TRANID.
         LI,R3    Q:TID
         BEZ      MAST%27             IF EDMS IS BEING USED,
         STW,R12  Q:TID               TELL DBM THE ID OF XACTION.
MAST%27  LCI      4
         STM,R12  TRAN#ID,R4          SET UP TRANSACTION ID AREA.
         LW,R6    *SR1              R6 =>CRITERION FOR XACTION.
         AI,R6    #C#TPM-#C#CRI
         LB,R3    0,R6              R3 = NUMBER OF THIS TPM.
         CW,R3    TPM#NUMBER,R4       IS IT SAME AS PREVIOUS ONE...
         BE       MAST%30                YES.
         STW,R3   TPM#NUMBER,R4       NO.  SAVE NEW NUMBER
         SETT     F#SORT              AND REMEMBER TO SORT CRITERIA.
MAST%30  LW,R7    L(3**24+(R13*4+1))
         MBS,R6   #C#ABORT-#C#TPM     GET USER-SPEC ABORT-LOC FROM
         STW,R13  TRAN#ABORT,R4       CRITERION. (NOTE R13(0-7)=0).
         ANLZ,R2  WA@TPM#INDEX#TABLE
         LB,R2    *R2,R3            R2 = INDEX OF THIS TPM.
         STW,R2   TPM#INDEX,R4        SET UP TPM#INDEX FOR XACTION.
         LW,R6    TPM#TRAN#COUNT,R4
         MTW,+1   *R6,R2              COUNT ONE MORE XACTION FOR TPM.
         CALL     GET%TIME
         LCI      2
         STM,R14  TRAN#TIME,R4        REMEMBER DATE/TIME WE STARTED.
         LI,R14   0
         STW,R14  TRAN#EXTIME,R4      NO EXECUTION TIME YET.
         ANLZ,R6  WA@TPMX:R3        R6 =>BRANCH TO TPMXNN.
         BAL,R7   TRAN%             --->>> GO TO THE TPM.
         TEXTC    'TPMX'
         PAGE
*
*        DEATH MESSAGES . . . . . . . . . . . . . . . . . . . . . . .
*
MASTER%ABORT      @P
         MESSAGE,EO 'TPLM PROBLEM. ABORTING. NO TRANSACTION LOST.'
         B        MXXX%             ---> TERMINATE TPC ABNORMALLY.
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,EO 'TPLM ABORTING. ',(*R3,*R1),' IN PROGRESS.'
         B        MXXX%             ---> TERMINATE TPC ABNORMALLY.
         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.
         BEZ      END%30               GO IF NO MORE DCBS THIS BLOCK.
         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   B        END%10               GO ON TO NEXT DCB.
END%30   LW,R3    0,R3              R3 =>NEXT DCBNAME BLOCK.
         BNEZ     END%10               GO IF MORE BLOCKS, ELSE DONE.
         CI,R2    0                 YES.
         BNE      MXXX%
MEXIT%   M:EXIT                     NORMAL TERMINATION.
MXXX%    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
         M:PC     ':'
         CALL     KEYIN%            SEE WHAT THE OPERATOR WANTS.
         M:PC     '>'
         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,
         B        MXXX%             ---> 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%18
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.
         LW,R8    TRAN#TIME+1,R4    GET TIME IT STARTED.
         B        KEY%D%20
KEY%D%16 MESSAG,K 'ACTIVE. '        SAY IT'S UP BUT NOT NOW RUNNING.
KEY%D%18 LW,R3    TPM#TIME,R4       GET TIME THIS TPM WAS LAST
         LW,R8    *R3,R7              FINISHED WITH A TRANSACTION.
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.
         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+1,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.  *
*        ON ENTRY:
*        R3       TPM NUMBER.
*        R4       ADDRESS OF PRECIOUS-DATA PAGE.
*        R6       ADDRESS TO GO TO IN TPM.
*        R7       ADDRESS OF TEXTC TO PRINT BEFORE GOING.
*                                                                      *
************************************ * * * * * * * * * * * * * * * * * *
TRAN%    @P
         CLEAR    F#FAIL,F#KEEP,F#ABORTME,F#TPMABORT,F#TIMEDOUT
TRAN%ABORT        @P                (ENTER HERE FOR ABORT-LOC)
         MESSAGE,T '*ENTER ',(*R7,0),(R3,2,0),'.'
         SETT     F#USER            SAY WE'RE IN THE TPM.
         PROTECT                    KEEP THE TPM FROM STOMPING OUR DATA
*        SET UP TIMEOUT FOR LOOPING TPM.
         M:STIMER (TUN,TPM#TIMEOUT#TUN),TIMEOUT%
         LI,R14   0                 R14= 0 (# ARGS FOR TPM)
         BAL,R15  0,R6              CALL THE TPM.
TPC      MESSAGE,T '*ENTER TPC.'    COME BACK FROM TPM.
TRAN%END FINDPROTECTED
         UNPROTECT                  LET US SET OUR PRECIOUS DATA.
         M:TTIMER TUN,CANCEL        RESET THE TIMEOUT TIMER.
         LCW,R9   SR1               COMPUTE
         AI,R9    TPM#TIMEOUT#TUN     ELAPSED RUNNING TIME IN TUN'S,
         AWM,R9   TRAN#EXTIME,R4      AND ACCUMULATE IT.
         CLEAR    F#USER            SAY WE'RE NO LONGER IN THE TPM.
*
*  WE HAVE REPORTS AND SPAWNED TRANSACTIONS ON OUTPUT#CHAIN.
*  EACH HAS A HEADER.  THE HEADER:
*LOOKS LIKE(REPORT)     *LOOKS LIKE(XACTION)    *WANTS TO LOOK LIKE    *
*
* JNLFLAG,ENTRY LNTH    0 JNLFLAG,ENTRY LNTH    0 JNLFLAG,RCDTYPE,LNTH
* CHAINWORD             1 CHAINWORD             1 ID OF CURRENT XACTION
*  0                    2  0                    2  DATE
*  0                    3  0                    3  TIME
*  0                    4  0                    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.
*
         LW,R5    TRAN#POINTER,R4   R5 =>TRANSACTION BEING PROCESSED.
         CALL     GET%TIME
         STW,R14  TRAN#TIME,R4        REMEMBER DATE WE FINISHED.
         XW,R15   TRAN#TIME+1,R4      REMEMBER STOPTIME; GET START.
         LW,R14   TRAN#EXTIME,R4    R14= ELAPSED EXECUTION TIME
         SLS,R14  +1                     (IN MILLISECONDS)
         LCI      2                      SAVE START & EXECUTION TIMES
         STM,R14  #J#TEXTW,R5            FOR LATER JOURNALIZATION.
         BON,F#INIT  TRANE%28         (NO TPM#TIME IF INITTING)
         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,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::::
         LW,R6    TRAN#ID,R4        R6 = ID OF ORIGINAL XACTION.
         CALL     GET%ID              GET ANOTHER IF FAILED/KEEPING.
         LCI      4                   PUT NEW FAKE ID INTO TRAN#ID,
         STM,R12  TRAN#ID,R4          FOR USE IN REPORT NAMES.
         LW,R2    L((##JQUEUE+##JFAIL)**24+#JOURNAL#ET**16+17*4)
         B        TRANE%30            (ALSO SHOW FAIL/KEEPINQUEUE)
TRANE%28 LW,R6    TRAN#ID,R4        R6 = ID OF ORIGINAL XACTION.
         LW,R2    L(0+#JOURNAL#ET**16+17*4)  SHOW DELFROMQ/NOFAIL
TRANE%30 LW,R3    L((##JQUEUE+##JFAIL)**24+X'00FFFFFF')
         STS,R2   #J#FLAGSW,R5      FIX FLAGS FOR KEEP OR DELETE.
         LW,R7    R5
         AI,R7    #J#TEXTW+3        R7 =>M:QUEUE/PUT LIST AREA.
*
         LW,R5    OUTPUT#CHAIN      R5 =>ONE OUTPUT ENTITY.
TRANE%45 BEZ      TRANE%50               >>> GO IF NO MORE OUTPUT.
         LW,R8    #J#NAMEW,R5
         SLS,R8   -24
         CI,R8    '?'                  SEE IF IT'S XACTION OR REPT.
         BE       TRANE%46             (TRANSACTION)
         LCI      4                   REPORT:
         LM,R12   TRAN#ID,R4        R12131415= ID OF ORIG XACTION.
         LW,R8    L(#JOURNAL#OR**16) R8= 'REPORT' JOURNAL TYPE.
         B        TRANE%48
TRANE%46 CALL     GET%ID              TRANSACTION:
         LW,R8    L(#JOURNAL#BT**16) R8= 'XACTION' JOURNAL TYPE.
TRANE%48 STW,R12  #J#IDW,R5           PUT HEX ID IN OUTPUT HEADER.
         INT,R3   #J#LENGTHSW,R5    R3 = USER 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 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    R8                  ADD JNL RCD TYPE IN 8-15.
         LW,R3    L(X'00FFFFFF')      PUT RECORD TYPE AND RECORD
         STS,R2   #J#FLAGSW,R5          LENGTH INTO RECORD HEADER.
         EOR,R2   #J#FLAGSW,R5      R2 = FLAGS ONLY.
         AW,R2    R5                R2 = FLAGS AND RECORD 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 OUTPUT ENTITY.
         BNEZ     TRANE%45          -----> GO DO NEXT ITEM.
TRANE%50 STW,R5   OUTPUT#CHAIN    ZERO OUTLIST; 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#TPLMABORT TRANE%70   IF 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,R5    CRITERIA#CHAIN    R5 =>CRITERIA ASKED BY THIS TPM.
TRANE%73 BEZ      TRANE%80               >>> GO IF NO MORE CRITERIA.
         INT,R12  #J#FLAGSW,R5      R12= BD(FIRST CRI THIS PAGE)
         AWM,R13  CRI#COUNT#TOTAL,R4 R13=# CRITERIA THIS PAGE
         ANLZ,R6  BA@R5
         AW,R6    R12               R6 =>FIRST CRITERION THIS PAGE.
         LW,R7    CRI#POINT#CURRENT,R4
         AI,R7    -X'800'
         AW,R7    R12               R7 =>WHERE TO MOVE CRITERIA.
         STW,R7   CRI#POINT#CURRENT,R4   (ALSO NEW CRITERIABASE).
TRANE%75 AI,R12   255                  IF MORE THAN 255 BYTES
         CI,R12   X'800'               OF CRITERIA TO MOVE,
         BG       TRANE%77
         MTB,-1   R7                   MOVE 255 BYTES
         MBS,R6   0                    TO NEW LOCATION.
         B        TRANE%75
TRANE%77 AI,R12   -X'800'-255          IF 255 BYTES OR LESS,
         LCW,R12  R12
         STB,R12  R7                   MOVE THAT MANY
         MBS,R6   0                    TO NEW LOCATION.
         LW,R5    #J#CHAINW,R5      R5 =>NEXT PAGE OF CRITERIA.
         LW,R2    CRI#POINT#CURRENT,R4
         SLS,R2   -2                R2 = WA(CURRENT CRITERIABASE)
         LI,R3    X'1FE00'
         CS,R2    TRAN#POINTER,R4        IF NOT CROSSED PAGE BOUND,
         BNE      TRANE%79               GO PROCESS OTHER CRITERIA.
         AI,R2    -X'200'
         M:FVP    *R2                    OTHERWISE FREE PAGE VIRTUAL
         LW,R6    SPACE#AVAIL       ***** FUDGE *****
         CALL     GET%COMMON             TO GET IT COMMON.
         STW,R6   SPACE#AVAIL       ***** FUDGE *****
TRANE%79 LW,R5    R5
         B        TRANE%73               THEN CONTINUE PROCESSING.
*
TRANE%80 CALL     DELETE%TPM%OUTPUT    RESET POINTERS NOW.
         BON,F#INIT INIT%END          GO NOW IF INITTING.
         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,EO '*** 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.
         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.
*
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.
         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
XCON%05  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
         UNPROTECT                    **  M:EXIT FROM IN TPC  **
         LI,0     0
         XW,0     DMS#XCON,R4       SHOULD WE TELL DBM TO CLOSE DB...
         BNEZ     XCON%05           ---> YES. (HE'LL COME BACK HERE).
         M:XCON   0                   NO. CLEAR OUT XIT CONTROL,
         B        END%              ---> CLOSE DCBS, AND REALLY XIT.
XCON%70  CI,8     X'40'             WAS IT M:XXX IN TPC...
         BANZ     XCON%80           ---> YES. SKIP MESSAGE.
         MESSAGE,EO 'XCON ENTERED.'
         MESSAGE,E 'PSW0=',(*R1,8,2),'. R8=',(XCON#REG+8,8,2),;
                  ' R9=',(XCON#REG+9,8,2),' R10=',(XCON#REG+10,8,2),;
                  ' R11=',(XCON#REG+11,8,2)
XCON%80  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--EDMS ERROR ',(R15,3,0)
         B        MASTER%ABORT%TIP   GET VERY VERY SICK.
*
DMSA%10  FINDPROTECTED
         UNPROTECT
         CI,R15   30                ERR 30 MEANS DB WAS ROLLED BACK
         BNE      DMSA%13              DUE TO UPDATE LOCKOUT(SHARED)
         CALL     DELETE%TPM%OUTPUT  SO MAKE IT LOOK LIKE WE NEVER
         LW,R3    TPM#NUMBER,R4       SAW THE XACTION, & RESTART IT.
         ANLZ,R6  WA@TPMX:R3        R6 =>BRANCH TO TPMXNN.
         BAL,R7   TRAN%
         TEXTC    'AGAIN TPMX'
DMSA%13  MESSAGE,E ' EDMS ERROR ',(R15,3,0),'.'
         BON,F#INIT  INIT%ABORT%COMMON   --->DIE IF INIT EDMS ERR.
         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
         B        ABRT%10           SKIP DMSRLSE; DBM ALREADY HAS.
DMSA%80  FINDPROTECTED              DMSRLSE WITH DB CLOSED.
         UNPROTECT
         BON,F#USER      FAIL%10    ------> CALLED IN USER.
         BON,F#UARLSE    ABRT%10    ---> CALLED BY USER%ABORT.
         B               TRANE%70   ---> CALLED FOR NORMAL EXIT.
         PAGE
*
*
*
USER%ABORT        @P
         FINDPROTECTED
         UNPROTECT
         CLEAR    F#USER
         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
         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,F#ABORTME,F#KEEP,F#TIMEDOUT
         BON,F#INIT INIT%ABORT
         SETBON,F#TPMABORT TRAN%END   IF ABORTED ALREADY, JUST QUIT.
         LW,R6    TRAN#ABORT,R4     R6 =>USER ABORT-LOC.
         BEZ      TRAN%END             IF NOT SPECIFIED, JUST QUIT.
         BAL,R7   TRAN%ABORT           ELSE GO TO ABORT-LOC.
         TEXTC    'ABORT-LOC'
         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
         BAL,R6   USERENT%FIRST     INVOKE THE SETUP SUBROUTINE.
         EXPLAIN  ;
         'SET UP AND VERIFY PARAMETERS PASSED FROM TPM.',;
         'NEEDS R15=>PARAMETER LIST, R14= LIST LENGTH.',;
         'R1-R6,R14,R15 ZAPPED. RETURNS R4=>DYN.AREA.'
         TEXTC    CF(2)
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<=3&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%LAST      INVOKE THE CLEANUP ROUTINE.
         PEND
         CLOSE    X,Y,I,J,K
         PAGE
************************************ * * * * * * * * * * * * * * * * * *
*                                                                      *
*                 USERENTRY SECTION.                                   *
*                                                                      *
*  ROUTINES USERENT%... ARE INVOKED BY USERENTRY PROC TO VALIDATE,     *
*        AND COPY WHERE APPROPRIATE, PARAMETERS SUPPLIED BY TPM.       *
*  DATA AREAS USER#... ARE USED TO RECEIVE TPM DATA & ADDRESSES.       *
*  ROUTINES USERERR%... ARE INVOKED FROM USERENT% ROUTINES AND         *
*        EXTERNALLY, AND REPORT ERRORS IN TPM SPECIFICATIONS.          *
*  OTHER ROUTINES IN THIS SECTION ARE USED INTERNALLY ONLY.            *
*WARNING: THIS CODE IS VERY DEPENDENT ON FORM OF STD CALLING SEQUENCE. *
************************************ * * * * * * * * * * * * * * * * * *
         @T
USER#NAME#TEXT  RES  #J#NAME#LEN//4 TEXT (NAME OR CRITERION)
USER#NAME       RES  1              ADDR BA(USER NAME AREA)
USER#TEXT       RES  1              ADDR BA(USER TEXT AREA)
USER#NAME#LEN   RES  1              ADDR WA(USER NAME LEN) OR VALUE
USER#TEXT#LEN   RES  1              ADDR WA(USER TEXT LEN) OR VALUE
USER#VALUE#1    RES  1              VALUE (FIRST USER-SPEC VALUE)
USER#VALUE#2    RES  1              VALUE (SECOND USER-SPEC VALUE)
USER#JOURNAL    RES  1              VALUE (USER JOURNALING FLAGS)
USER#LOCATION   RES  1              VALUEADDR (USER PROGRAM LOC.)
USER#RETURN     RES  1              **** USER PLIST PTR / RETURN.
OUTPUT#CHAIN  DATA 0                => CHAIN OF TPM OUTPUT.
SPACE#AVAIL   DATA 0                = WA(LAST PAGE USED).
CRITERIA#CHAIN DATA 0               => CHAIN OF CRITERIA THIS TPM.
***  REGISTER USAGE:
****     R15 => START OF PARAMETER LIST IN TPM.
****     R14 = LENGTH OF TPM PLIST +Y8. (DECREMENTED)
****     R6 IS LINK FROM USERENTRY INVOKER.
****     R5 (USUALLY) ADDRESS OF PARAMETER.
****     R4 (USUALLY) TYPE ENTRY OF PARAMETER.
****     R3 VALUE OF PARAMETER OR INTERNAL LINKING.
****     R2 INTERNAL LINKING.
****     R1 INTERNAL LINKING.
         PAGE
USERENT%FIRST     @P                FIRST TO BE CALLED ON ENTRY.
         STW,R15  USER#RETURN       USER#RETURN=> CURR USER PARAM.
         MESSAG,E (*R6,0)             DISPLAY NAME OF SUBROUTINE.
         LB,R1    *R6                  INCREMENT
         SLS,R1   -2                   INTERNAL RETURN REGISTER
         AW,R6    R1                   OVER NAME TEXTC.
  LW,R1  L((BA(USER#NAME)-BA(USER#NAME#TEXT))**24+BA(USER#NAME#TEXT))
         MBS,R0   BA(BLANK#)        CLEAR USER# TEXT TO BLANKS.
  AW,R1  L((BA(USER#RETURN)-BA(USER#NAME))**24)
         MBS,R0   BA(L(0))          CLEAR USER# ADDRESSES TO ZEROS.
         EOR,R14  L(X'80000000')    (BDR,R14) WILL FAIL #PARAM TIMES.
         BLZ      1,R6              RETURN TO PARAMETER SETUP.
*        B        USERENT%ERR          (OOPS, USER #PARAM NEGATIVE)
USERENT%ERR       @P                ERROR IN USER PLIST PROCESSING.
         SW,R15   USER#RETURN       R15= -(#PARAM DONE SO FAR)
         LCW,R15  R15               R15= # PARAMETERS DONE SO FAR.
         ESSAG,E  ' PARAM # ',(R15,1,0)  SAY WHICH PARAM BAD.
         B        USERERR%Y            AND CONTINUE DYING.
*
USERENT%LAST      @P                LAST TO BE CALLED DURING ENTRY.
         AWM,R14  USER#RETURN       USER#RETURN= USER RETURN ADDRESS.
         FINDPROTECTED                   GET ADDRESS OF PRECIOUS DATA.
         ESSAGE,T                     PRINT CALL LINE IF SIMULATOR.
         B        0,R6              RETURN TO SUBROUTINE PROCESSING.
*
USERERR%NOSPACE   @P                ERR: NO PAGE AVAILABLE.
         BAL,R13  USERERR%X
         TEXTC    'NO CORE'
USERERR%ILLEGAL   @P                ERR: CAN'T CALL THIS NOW.
         BAL,R13  USERERR%X
         TEXTC    'ILLEGAL HERE'
USERERR%BUFBAD    @P                ERR: BUFFER NOT ON WORD BOUND.
         BAL,R13  USERERR%X
         TEXTC    'BAD BUF'
USERERR%TTLONG    @P                ERR: SUM OF LINES TOO LONG.
         BAL,R13  USERERR%X
         TEXTC    '>1980'
USERERR%X         @P
         ESSAG,E  '*** ',(*R13,0)
USERERR%Y         @P
         ESSAGE,E ' ERROR.'
         B        USER%ABORT
*
*
USERENT%A         @P                NAME OR CRITERION SUPPLIED BY TPM.
         BAL,R2   UE%BAPAR          GET BA(TPM NAME STRING)
         STW,R5   USER#NAME           REMEMBER IT.
         BAL,R1   UE%VALUE          GET AND VERIFY NAME LENGTH
         STW,R3   USER#NAME#LEN       REMEMBER IT.
         LI,R5    BA(USER#NAME#TEXT)+1 MOVE  (LEAVE SPACE FOR Q.M.)
         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                TEXT SUPPLIED BY TPM.
         BAL,R2   UE%BAPAR          GET BA(TPM TEXT STRING)
         STW,R5   USER#TEXT           REMEMBER IT.
         BAL,R1   UE%VALUE          GET AND VERIFY LENGTH OF TEXT
         STW,R3   USER#TEXT#LEN       REMEMBER IT.
         B        1,R6              RETURN PAST VALUE-CHECK WORD.
*
USERENT%C         @P                VALUES (PRIORITY) SUPPLIED BY TPM.
         BAL,R1   UE%VALUE          GET AND VERIFY FIRST VALUE
         STW,R3   USER#VALUE#1        REMEMBER IT.
         ESSAG,T  ' ',(R3,4,1)        DISPLAY IT (ZERO-SUPPRESSED).
         BAL,R1   UE%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   UE%BAPAR          GET BA(TPM NAME AREA)
         STW,R5   USER#NAME           REMEMBER IT.
         BAL,R2   UE%WAPAR          GET WA(TPM NAME-LENGTH WORD)
         STW,R5   USER#NAME#LEN       REMEMBER IT.
         B        0,R6              RETURN.
*
USERENT%E         @P                TPM WANTS TEXT.
         BAL,R2   UE%BAPAR          GET BA(TPM TEXT AREA)
         STW,R5   USER#TEXT           REMEMBER IT.
         BAL,R2   UE%WAPAR          GET WA(TPM TEXT-LENGTH WORD)
         STW,R5   USER#TEXT#LEN       REMEMBER IT.
         B        0,R6              RETURN.
*
USERENT%F         @P                FLAG SUPPLIED BY TPM (OPTIONAL).
         CW,R14   L(X'80000000')    DID TPM SPECIFY FLAG...
         BE       0,R6                NO.  RETURN NOW.
         BAL,R2   UE%WAPAR          GET VALUE & VERIFY INTEGER.
         ESSAG,T  ' ',(R3,2,0)      DISPLAY FLAG VALUE.
         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         (OOPS, BAD FLAG VALUE)
         STH,R3   R2                R2= TENS(0-15),  UNITS(16-31).
         STW,R2   USER#JOURNAL        REMEMBER IT.
         B        0,R6              RETURN PAST VALUE-CHECK WORD.
*
USERENT%G         @P                PROGRAM-LOC SUPPLIED BY TPM (OPT).
         CW,R14   L(X'80000000')    DID TPM SPECIFY PROGRAM-LOC...
         BE       0,R6                NO.  RETURN NOW.
         BAL,R3   UE%PARAM          YES. GET WA(PROGRAM PLACE).
         CI,R4    X'40'             MUST BE WORD-ADDR DATA TYPE
         BGE      USERENT%ERR         ELSE ERROR.
         AND,R5   L(X'1FFFF')       TRUNCATE TO ADDRESS ONLY.
         STW,R5   USER#LOCATION       REMEMBER IT.
         B        0,R6              RETURN.
*
*
** R1=LINK,R2***,R3<VALUE,R4***,R5***,R6=LINK2,R14=REM.PARMCOUNT.
UE%VALUE BAL,R2   UE%WAPAR          VERIFY INTEGER & GET VALUE.
         INT,R4   0,R6              GET LOWER/UPPER VALUE LIMITS.
         CLR,R4   R3                SEE IF VALUE IS WITHIN LIMITS.
         BCR,6    0,R1                YES.
         B        USERENT%ERR         (OOPS, VALUE NOT WITHIN LIMITS)
*
********** R2=LINK,R3<VALUE,R4***,R5<WA(PARM),R14=REM.PARMCOUNT.
UE%WAPAR BAL,R3   UE%PARAM          GET PARAMETER ADDRESS.
         BDR,R4   USERENT%ERR         (OOPS, NOT INTEGER TYPE.)
         LW,R3    0,R5              GET PARAMETER VALUE.
         B        0,R2              RETURN.
*
********** R2=LINK,R3***,R4***,R5<BA(PARM),R14=REM.PARMCOUNT.
UE%BAPAR BAL,R3   UE%PARAM          GET PARAMETER ADDRESS.
         CI,R4    X'40'             IS IT WORD-ADDRESSED DATA...
         BANZ     UE%BA10             NO.
         SLS,R5   +2                CONVERT WORD ADDRESS TO BYTE ADDR.
UE%BA10  CI,R4    X'50'             IS IT DATA AT ALL...
         BG       USERENT%ERR         (OOPS, NOT DATA-TYPE PARAMETER)
         AND,R5   L(X'7FFFF')       DISCARD HIGH-ORDER GARBAGE.
         B        0,R2              RETURN.
*
********** R3=LINK,R4<PARMADDR,R5<PARMFLGS,R14=REM.PARMCOUNT.
UE%PARAM BDR,R14  USERENT%ERR         (OOPS, NO MORE PARAMETERS)
         LB,R4    *USER#RETURN      R4 = PARAMETER FLAGS.
         LW,R5    *USER#RETURN      R5 = PARAMETER ADDRESS.
         BGEZ     UE%PAR10            IF INDIRECTLY ADDRESSED,
         LW,R5    0,R5                GET DIRECT PARAMETER ADDRESS AND
         AI,R4    -X'80'              REMOVE INDIRECT BIT FROM FLAGS.
UE%PAR10 MTW,+1   USER#RETURN       INCREMENT CALLER'S P-LIST POINTER.
         B        0,R3              RETURN.
         PAGE
************************************ * * * * * * * * * * * * * * * * * *
*                                                                      *
*  INITATPC SUPPLIES A CRITERION FOR ACCEPTING TRANSACTIONS FOR THIS TP*
*                                                                      *
*                                                                      *
*                                                                      *
*                                                                      *
************************************ * * * * * * * * * * * * * * * * * *
INITATPC USERENTRY,' INITATPC'  (NAM,*1,(0,21)),(VALUE,*3,(0,255)),;
                                (PROG,*5)
         LI,R3    '?'               ADD QUESTION MARK
         STB,R3   USER#NAME#TEXT    TO START OF USER'S CRITERION.
         MTW,+1   USER#NAME#LEN     ITS LENGTH IS NOW ONE LONGER.
         BOFF,F#INIT USERERR%ILLEGAL INITATPC ILLEGAL UNLESS INITTING.
         LI,R2    '.'                  ADD A PERIOD
         LW,R3    USER#NAME#LEN        TO THE END OF THE
         STB,R2   USER#NAME#TEXT,R3    USER'S CRITERION.
         MTW,+1   USER#NAME#LEN        ITS LENGTH IS NOW ONE LONGER.
         AI,R3    #C#NONCRI#LEN+1   R3 = TOTAL CRITERION ENTRY LENGTH.
         LI,R5    CRITERIA#CHAIN-#J#CHAINW R5=>PAGE OF CRITERIA.
         MTW,0    #J#CHAINW,R5           ANY CRITERIA YET...
         BNEZ     INTP%30                YES. FIND END OF CHAIN.
INTP%10  LW,R2    R5                R2 =>LAST CRITERIAPAGE SO FAR.
         LI,R12   512
         CALL     GET%SPACE
         BCS,8    USERERR%NOSPACE      (OOPS, NO SPACE TO GET)
         STW,R5   #J#CHAINW,R2      R5 =>NEW CRITERIAPAGE.
         LI,R13   0                 R13= #CRITERIA THIS PAGE.
         LI,R12   X'800'            R12= BD(LAST CRI THIS PAGE)
         B        INTP%36                GO TO HAVE-LAST-PAGE.
INTP%30  LW,R5    #J#CHAINW,R5      R5 =>NEXT PAGE IN CHAIN.
         MTW,0    #J#CHAINW,R5           IS IT THE LAST...
         BNEZ     INTP%30                NO. KEEP CHAINING.
         INT,R12  #J#FLAGSW,R5      R12=BD(LASTCRI); R13=#CRITERIA.
INTP%36  SW,R12   R3                R12= BD(NEW CRITERION).
         CI,R12   #J#CHAINW*4+4          IS THERE ROOM FOR IT...
         BL       INTP%10                NO. GET A NEW PAGE.
         AI,R13   1                      YES. BUMP CRICOUNT THISPAGE.
         STH,R12  R13
         STW,R13  #J#FLAGSW,R5         STORE NEW BD & CRICOUNT.
         ANLZ,R7  BA@R5
         AW,R7    R12               R7 =>WHERE CRITERION TO GO.
*                                   BUILD CRITERION ENTRY::::::::::
         LW,R6    USER#VALUE#1
         AI,R7    #C#NORMP                    NORMAL-PRIORITY.
         STB,R6   0,R7
         LW,R6    USER#VALUE#2
         AI,R7    #C#NEXTP-#C#NORMP           NEXT-PRIORITY.
         STB,R6   0,R7
         LI,R6    BA(USER#LOCATION)+1
         AI,R7    #C#ABORT-#C#NEXTP           ABORT-LOCATION.
         MTB,3    R7
         MBS,R6   0
         LW,R6    TPM#NUMBER,R4
         AI,R7    #C#TPM-(#C#ABORT+3)         TPM NUMBER.
         STB,R6   0,R7
         LW,R6    USER#NAME#LEN
         AI,R7    #C#LNTH-#C#TPM              CRITERION LENGTH.
         STB,R6   0,R7
         STB,R6   R7
         LI,R6    BA(USER#NAME#TEXT)
         AI,R7    #C#NAME-#C#LNTH             CRITERION ITSELF.
         MBS,R6   0
         LI,R6    0                           *** THEN A BYTE OF ZERO
         STB,R6   0,R7                        *** (DONT GET FAILEDS)
         B        *USER#RETURN      FINI.
         PAGE
************************************ * * * * * * * * * * * * * * * * * *
*                                                                      *
*  OUTALINE ADDS A LINE TO A REPORT.                                   *
*                                                                      *
************************************ * * * * * * * * * * * * * * * * * *
OUTALINE USERENTRY,' OUTALINE'  (NAM,*1,(1,22)),(TEXT,*3,(0,1980)),;
                                (JOURNAL,*5)
         LW,R3    L((#J#NAME#LEN-1)**24+BA(USER#NAME#TEXT))
         MBS,R3   1                 SHIFT NAME LEFT 1; NO Q.M. NEEDED.
         BON,F#INIT  USERERR%ILLEGAL  OUTALINE ILLEGAL DURING INIT.
         LI,R2    OUTPUT#CHAIN-#J#CHAINW  LOOK AT CURRENT REPORTS.
OUTL%10  LW,R5    #J#CHAINW,R2      ANY MORE...
         BEZ      OUTL%12              NO.
         LW,R7    L(#J#NAME#LEN**24+BA(USER#NAME#TEXT))  YES.
         ANLZ,R6  BA@R5             SEE IF NEW REPORT NAME IS
         CBS,R6   #J#NAMEB          THE SAME AS OLD REPORT NAME.
         BE       OUT%60            ---> YES. ADD LINE TO REPORT.
         LW,R2    R5                NO.
         B        OUTL%10           KEEP LOOKING.
OUTL%12  LI,R12   512               CREATE A NEW REPORT.
         CALL     GET%SPACE
         BCS,8    USERERR%NOSPACE      (OOPS, NO SPACE TO GET)
         SLS,R12  +2                R12= LENGTH OF SPACE IN BYTES.
         OR,R12   TRAN#JOURNAL,R4        ADD DEFAULT JOURNALIZATION.
         INT,R6   USER#JOURNAL           GET USER'S OVERRIDE.
         EXU      OUT%JJRNLD,R6          OVERRIDE DELIJRNL MAYBE.
         EXU      OUT%JJRNLO,R7          OVERRIDE OUTJRNL MAYBE.
         B        OUT%40
         PAGE
************************************ * * * * * * * * * * * * * * * * * *
*                                                                      *
*  OUTATRAN SPAWNS A TRANSACTION.                                      *
*                                                                      *
************************************ * * * * * * * * * * * * * * * * * *
OUTATRAN USERENTRY,' OUTATRAN'  (NAM,*1,(0,21)),(TEXT,*3,(0,1980)),;
                                (JOURNAL,*5)
         LI,R3    '?'               ADD QUESTION MARK
         STB,R3   USER#NAME#TEXT    TO START OF USER'S TRAN NAME.
         MTW,+1   USER#NAME#LEN     ITS LENGTH IS NOW ONE LONGER.
         BON,F#INIT  USERERR%ILLEGAL  OUTATRAN ILLEGAL DURING INIT.
         LI,R2    OUTPUT#CHAIN-#J#CHAINW   GO OUT
OUTT%10  MTW,0    #J#CHAINW,R2             TO END
         BEZ      OUTT%12                  OF CURRENT
         LW,R2    #J#CHAINW,R2             SPAWNED
         B        OUTT%10                  TRANSACTION CHAIN.
OUTT%12  LW,R12   USER#TEXT#LEN
         AI,R12   #J#HDR#LEN+#J#NAME#LEN+4+3
         SLS,R12  -2                R12 = #WORDS NEEDED FOR XACTION.
         CALL     GET%SPACE
         BCS,8    USERERR%NOSPACE      (OOPS, NO SPACE TO GET)
         SLS,R12  +2                R12= LENGTH OF SPACE IN BYTES.
         OR,R12   TRAN#JOURNAL,R4        ADD DEFAULT JOURNALIZATION.
         INT,R6   USER#JOURNAL           GET USER'S OVERRIDE.
         EXU      OUT%JQUEUE,R6          OVERRIDE QUEUEING MAYBE.
         EXU      OUT%JJRNLO,R7          OVERRIDE OUTJRNL MAYBE.
         EXU      OUT%JJRNLD,R7            (DELIJRNL = OUTJRNL)
*
OUT%40   STW,R12  #J#FLAGSW,R5      R12==FLAG & SPACESIZE WORD.
         LW,R13   USER#NAME#LEN        FIX UP LENGTHS WORD:
         STW,R13  #J#LENGTHSW,R5    (0-15)=TEXTLEN=0. (16-31)=NAMELEN.
         LI,R6    BA(USER#NAME#TEXT)   MOVE USER-SPECIFIED NAME
         ANLZ,R7  BA@R5
         AW,R7    L(#J#NAME#LEN**24+#J#HDR#LEN)  INTO
         MBS,R6   0                         NAME AREA OF SPACE.
         STW,R5   #J#CHAINW,R2      CHAIN ONTO OUTPUT CHAIN.
OUT%60   INT,R2   #J#LENGTHSW,R5    R2 = PREVIOUS TEXT LENGTH.
         AW,R2    USER#TEXT#LEN         + LENGTH OF CURRENT TEXT.
         CI,R2    1980                   DOES THAT MAKE IT TOO BIG...
         BG       USERERR%TTLONG         (OOPS, IT'S TOO BIG NOW.)
         STH,R2   R3
         XW,R3    #J#LENGTHSW,R5       PUT NEW LENGTH INTO HEADER.
         SLS,R3   -16               R3 = PREVIOUS TEXT LENGTH.
         ANLZ,R7  BA@R5:R3
         AI,R7    #J#TEXTB          R7 =>PREVIOUS TEXT END +1.
         LW,R6    USER#TEXT         R6 =>NEW TEXT TO BE ADDED.
         LW,R3    USER#TEXT#LEN     R3 = LENGTH OF NEW TEXT.
OUT%80   CI,R3    255                    IF MORE THAN
         BLE      OUT%85                 255 CHAR OF NEW TEXT,
         AI,R3    -255                   MOVE
         MTB,-1   R7                     255 CHAR INTO TEXT AREA.
         MBS,R6   0
         B        OUT%80
OUT%85   STB,R3   R7                     IF 255 OR LESS LEFT, MOVE
         MBS,R6   0                      THE REST.
         B        *USER#RETURN      FINI.
*
*
OUT%JJRNLO  NOP                     USER DIDN'T OVERRIDE OUTJOURNAL.
         OR,R12   L(##JJRNLO**24)   USER SAID OUTJOURNAL.
         AND,R12  L((~##JJRNLO)**24) USER SAID DON'T OUTJOURNAL.
OUT%JJRNLD  NOP                     USER DIDN'T OVERRIDE DELIJOURNAL.
         OR,R12   L(##JJRNLD**24)   USER SAID DELIJOURNAL.
         AND,R12  L((~##JJRNLD)**24) USER SAID DON'T DELIJOURNAL.
OUT%JQUEUE  NOP                     USER DIDN'T OVERRIDE QUEUE.
         OR,R12   L(##JQUEUE**24)   USER SAID QUEUE.
         AND,R12  L(~(##JQUEUE**24)&X'FFFFFFFF')  DON'T QUEUE.
         PAGE
************************************ * * * * * * * * * * * * * * * * * *
*                                                                      *
*  GETATRAN SUPPLIES TRANSACTION NAME AND TEXT TO USER.                *
*                                                                      *
************************************ * * * * * * * * * * * * * * * * * *
GETATRAN USERENTRY,' GETATRAN'  (NAM,1),(TEXT,3)
         BON,F#INIT  USERERR%ILLEGAL  OUTATRAN ILLEGAL DURING INIT.
         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        *USER#RETURN      FINI.
         PAGE
************************************ * * * * * * * * * * * * * * * * * *
*                                                                      *
*  FAILURE FAILS THE TRANSACTION.                                      *
*                                                                      *
************************************ * * * * * * * * * * * * * * * * * *
FAILURE  USERENTRY,' FAILURE'  (JOURNAL,*1)
         BON,F#INIT  USERERR%ILLEGAL  FAILURE ILLEGAL DURING INIT.
         CALL     DELETE%TPM%OUTPUT
         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.
         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.
         PROTECT
         BON,F#TIMEDOUT  USER%ABORT   GO IF TIMED OUT WHILE UNPROTECT.
         B        *USER#RETURN      FINI.
         PAGE
************************************ * * * * * * * * * * * * * * * * * *
*                                                                      *
*  JOURNAL ALLOWS THE USER TO WRITE ON THE JOURNAL.                    *
*                                                                      *
************************************ * * * * * * * * * * * * * * * * * *
JOURNAL  USERENTRY,' JOURNAL'  (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     USERERR%BUFBAD    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        *USER#RETURN      FINI.
         TITTLE   'SERVICE ROUTINES'
*
*        SET UP A RECORD TO WRITE TO THE JOURNAL.
*        WRITE THE RECORD IF ITS JOURNAL BIT IS 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  ;
         'ZERO OUTPUT#CHAIN, CRITERIA#CHAIN.',;
         'FREE PAGES FROM SPACE#AVAIL TO SPACE#BASE; RESET #AVAIL.',;
         'R3,R8 ZAPPED. NEEDS R4=>DYNDATA.'
         LI,R3    0
         STW,R3   OUTPUT#CHAIN      NO TPM OUTPUT ANY MORE.
         STW,R3   CRITERIA#CHAIN    NO NEW CRITERIA ANY MORE.
         LW,R3    SPACE#BASE,R4
         XW,R3    SPACE#AVAIL       CLAIM NO WORKSPACE IS IN USE.
         BLZ      DTO%20            ---> LEAVE IF POINTER BAD.
DTO%10   CW,R3    SPACE#BASE,R4     ANY WORKSPACE GOTTEN...
         BGE      DTO%20            ---> NO. EXIT.
         M:FVP    *R3               YES. FREE A PAGE OF IT.
         AI,R3    512               AND TRY
         B        DTO%10            ---> FOR MORE.
*
DTO%20   RETURN   DELETE%TPM%OUTPUT
         PAGE
*
*        RETURN DATE AND TIME IN REGISTERS 14 AND 15.
*
GET%TIME ENTRY    ;
         'R14/R15 <= DATE/TIME (YYYYDDDD/HHMMTMSS).'
         LD,R14   SR1               PRESERVE REGISTERS.
         M:TIME   0,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 CHUNK OF VIRTUAL SPACE FOR A REPORT, SPAWNED
*        TRANSACTION, OR CRITERIA. ZERO THE HEADER AREA OF IT.
*
GET%SPACE ENTRY   ;
         'GET DYNAMIC SPACE.  ZERO THE HEADER AREA OF IT.',;
         'RETURN R5=WA(SPACE). CC=8 IF NONE. ADJUST SPACE#AVAIL.',;
         'R1 ZAPPED. NEEDS R12=SIZE BUT ALWAYS GETS 512 WORDS.'
         LW,R5    SPACE#AVAIL       R5 = CURRENT BOTTOM OF SPACE.
         AI,R5    -512                   BACK UP TO NEXT PAGE.
         STW,R5   SPACE#AVAIL            UPDATE SPACE#AVAIL.
         M:GVP    *R5                  GET THE NEXT PAGE.
         BCS,8    GET%S%90             (OOPS, NO SPACE TO GET.)
         ANLZ,R1  BA@R5             R1 = BA(NEW SPACE).
         AW,R1    L(#J#HDR#LEN**24)    (NOTE:CC(8) RESET BY THIS)
         MBS,R0   BA(L(0))             CLEAR HEADER TO ZEROS.
GET%S%90 RETURN   GET%SPACE         RETURN TO CALLER.
         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.',;
         'FIX FPT#(UN)PROTECT,TRAN#POINTER,SPACE#BASE,SPACE#AVAIL.',;
         'R8,R9 ZAPPED. NEEDS 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
         CW,SR2   TRAN#POINTER,R4   DID WE GET THE PAGE WE WANTED...
         BE       GET%C%40             YES.
         MTW,0    TRAN#POINTER,R4     MAYBE, IF FIRST TIME THRU.
         BNEZ     INIT%ABORT%SPACEBAD  NO.(OOPS, COMMON IS CONFUSED)
GET%C%40 LI,SR2   X'1FE00'
         STS,SR1  FPT#PROTECT,R4       FIX UP PROTECT-IT FPT.
         STS,SR1  FPT#UNPROTECT,R4     FIX UP UNPROTECT-IT FPT.
         STW,SR1  TRAN#POINTER,R4   WILL BE TRAN PAGE IF NOT USURPED.
         STW,SR1  SPACE#BASE,R4     ALSO IS END OF AVAIL WORKSPACE,
         STW,SR1  SPACE#AVAIL       WHICH HAS NOTHING IN IT NOW.
         RETURN   GET%COMMON        RETURN TO CALLER.
         PAGE
*
*
         @S                         LITERALS ARE STATIC.
         END      TPC%              THAT'S ALL, FOLKS
