ASMB
  HED .         **   T M S - I M A G E - M O D U L E   ** 
      NAM $ITMS,7 92903-16100 REV.1913  781219
  SPC 3 
**********************************************************************
*                                                                    *
*     NAME:   $ITMS     TMS-IMAGE MODULE                             *
*     SOURCE: &$ITMS    92903-18111                                  *
*     BINARY: %$ITMS    ----NONE---    PART OF  %TMSLB  92903-16100  *
*                                                                    *
*     PGMR:   FRANCOIS GAULLIER                                      *
*                                                                    *
**********************************************************************
      SPC 2 
*     **************************************************************
*     * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978.  ALL RIGHTS    *
*     * RESERVED.  NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- *
*     * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH-  *
*     * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY.  *
*     **************************************************************
  SPC 3 
      ENT $ITMS 
  SPC 1 
      EXT RMPAR,PNAME,EXEC,CNUMD,PRTN,KLCLS 
      EXT $PARS,DBCRC 
      EXT DBINT,DBOPN,DBCLS,DBUPD,DBDEL 
      EXT DBPUT,DBFND,DBINF,DBGET,DBLCK 
      EXT HASH
  SPC 1 
A     EQU 0 
B     EQU 1 
      SUP 
  SPC 4 
$ITMS STA LOCTB     SAVE LOCK TABLE ADDR
      STA LOCTE     AND INIT LOCK TABLE POINTERS
      STB PROTB 
      STB PROTE 
      LDB A,I       RECALL B REG VALUE
      JSB RMPAR     AND RETREIVE PARAMETER
      DEF *+2 
      DEF P1
  SPC 1 
      JSB EXEC      SWAP THE WHOLE AREA 
      DEF *+3 
      DEF D22 
      DEF D3        SWAP THE ENTIRE PARTITION 
  SPC 2 
   IFZ
      JSB .DBUG     CALL DBUG: INTERNAL USE ONLY !!!!!!!!!!!!!!!!!!!!!
      EXT .DBUG     CALL DBUG: INTERNAL USE ONLY !!!!!!!!!!!!!!!!!!!!!
   XIF
   SPC 2
      JSB PNAME     GET PROGRAM NAME
      DEF *+2 
.ILIS DEF ILIST+1 
   SKP
*                   SHEDULE REQUEST ACCEPTED BY THIS PROGRAM: 
*                  ===========================================
* 
* 
* - IF NO STRING IS PASSES: 
* 
*     * THE 4TH PARAMETER IS CHECKED, IF = -1 THEN THE PROGRAM TRY TO 
*       GET A REQUEST BUFFER ON SPECIAL CLASS ALLOCATED BY THIS PROGRAM 
*       AND RETURNED TO USER ON THE DBOPN CALL. IF THE GET FAIL THE 
*       PROGRAM TERMINATES FOR EVER IF IT WAS DORMANT, OR WITH 'SAVE
*       SUSPENSION POINT' OPTION IF IT WAS IN THAT STATE. 
*     * IF THE 4TH PARAMATER IS NOT -1, THEN IT IS ASSUMED TO BE A
*       CLASS I/O WORD AND A CLASS I/O GET IS EXECUTED ON THAT CLASS. 
*         * IF THE GET FAIL, A ERROR MESSAGE IS PRINTED ON THE SYSTEM 
*           CONSOLE AND THE PROGRAM TERMINATES WITH THE CURRENT OPTION. 
*         * IF THE GET SUCCEED, THE FIRST WORD OF THE BUFFER IS ASSUMED 
*           TO BE THE REQUEST CODE. IF IT IS LEGAL (0 =< RQ =<8), THE 
*           REQUEST IS PERFORMED, ELSE THE ERROR MESSAGE IS PRINTED ON
*           THE SYSTEM CONSOLE AND THE PROGRAM TERMINATES WITH THE
*           CURRENT OPTION. 
* 
* 
* - IF A STRING IS PASSES:
* 
*     * THE FIRST WORD OF THE STRING IS ASSUMED TO BE THE REQUEST CODE
*       IF IT IS LEGAL (BETWEEN 0 & 8) THE REQUEST IS PERFORMED.
*       IF THE REQUEST CODE IS NOT LEGAL, THE STRING IS CHECKED AGAINST 
*       ",,1" OPTAIN FROM THE FOLLOWING RTE/FMGR COMMAND "RU,TMSIM,,,1" 
*        * IF THE STRING DOES NOT MATCHE, A MESSAGE IS PRINTED ON THE 
*          TERMINAL USED TO SHEDULE THE PROGRAM, AND THE PROGRAM
*          TERMINATES WITH THE CURRENT OPTION.
*        * IF THE STRING MATCHES, AND THE DATA-BASE IS CLOSE, THE 
*          FOLLOWING MESSAGE IS PRINTED:
*                   NO DATA-BASE CURRENTLY OPEN.
*        * IF THE STRING MATCHES, AND A DATA-BASE IS STILL OPEN, THE
*          USER IS PROMPTED WITH THE FOLLOWING: 
*                   DATA-BASE=
*                   LEVEL WORD= 
*                   SEC-CODE= 
*         IF THE USER ANSWER CORRECTLY, THE DATA-BASE IS CLOSED IMMEDIATLY
*         REGARDLESS OF ANY LOCKING CONSIDERATION, AND THE PROGRAM
*         TERMINATES FOR EVER. (NO SAVE SUSP. OPTION) 
* 
*     THIS PROCEDURE SHOULD BE USE ONLY IN CASE OF EMMERGENCY !!
* 
* 
*     THE ERROR MESSAGE PRINTED ON THE TERMINAL IS THE FOLLOWING: 
* 
*                   /XXXXX : ILLEGAL SCHEDULE REQUEST ! 
   SKP
*      FATAL ERROR #                     MEANING
* 
*        1  [DBOPN]      TMSIM COPY MISSING, NOT LOADED (DONE 
*                        LOCALLY BY TMLIM)
*        2  [DBOPN]      LEVEL ACCESS WORD IS NOT THE GREATER ONE 
*        3  [DBOPN]      USE OF THIS PROGRAM TO ACCES AN OTHER DATA-BASE
*      500               THE PROGRAM HAS NOT BEEN INITAILIZED 
*                        (NO DBOPN REQUEST) 
*      501               UPDATE A FILE NOT SAVED IN THE AUTOMATIC 
*                        SAVED RUN TABLE. 
  SPC 2 
*     NEW IMAGE STATUS                   MEANING
* 
*      397  [IMG-STAT]   LOCK TABLE OVERFLOW. 
*      399  [IMG-STAT]   IMAGE  TBXXX CALL WITH DATA-BASE NAME THAT HAS NOT 
*                        BEEN OPENED TO THIS PROCESS. 
*      400  [IMG-STAT]   ERROR RETURNED WHEN PROCESS SHOULD BE SUSPENDED
*                        AND THE 'NO WAIT' OPTION HAS BEEN SPECIFIED
*      401  [IMG-STAT]   DEADLOCK ERROR ! 
*      403  [IMG-STAT]   UNLOCK RECORD LOCKED BY AN OTHER PROCESS 
*      404  [IMG-STAT]   UNLOCK RECORD WITHOUT HAVING A LOCKID (NEVER 
*                        REQUEST ANY LOCK)
*      405  [IMG-STAT]   DBPUT IN A MASTER WITHOUT HAVING LOCK THE ENTRY
*                        IN ADVANCE 
*      406  [IMG-STAT]   A PROCESS THAT OWN NON-EXCLUSIVELY A RECORD, TRY 
*                        TO LOCK THAT RECORD EXCLUSIVELY. 
  SKP 
*                    MAXIMUM VALUE CONSIDERATION
*                    ===========================
* 
*   - IMAGE MAXIMUM VALUE:
* 
*     MAXIMUM NUMBER OF DATA-SET PER DATA-BASE  :  50 
*     MAXIMUM NUMBER OF ITEM PER DATA-BASE      : 255 
*     MAXIMUM NUMBER OF ITEM PER DATA-SET ENTRY : 127 
* 
*     MAXIMUM ENTRY LENGTH (MEDIA+DATA)         : 256 WORDS 
*     MAXIMUM ITEM LENGTH                       :  63 WORDS 
* 
* 
*   - TMS-IMAGE COMMUNICATION MAXIMUM BUFFER LENGTH:
* 
*     MAXIMUM BUFFER LENGTH RECEIVED BY THIS PROGRAM IS 
*     FOR A  DBPUT CALL : 4+1+1+3+128+256 = 393 = RBULN 
*     WHERE 4,1,1,3 ARE TMS INTERNAL BUFFER 
*     128 IS INBR (MAX # OF ITEM/DATA-SET  + 1) 
*     AND 256 IS IVALUE (MAX ENTRY LENGTH)
* 
*     MAXIMUM BUFFER LENGTH SEND BY THIS PROGRAM IS 
*     FOR A  DBGET CALL : 2+8+4+1+256 = 271 = SBULN 
*     WHERE 2,8,4,1 ARE TMS INTERNAL BUFFER 
*     AND 256 IS THE ENTRY VALUE (MAX ENTRY LENGTH) 
* 
*     ANY BUFFER RETURNED BY  DBINF SHOULD BE SMALLER THAN THAT.
   SKP
      LDA LOCTB     GET FWA OF BUFFER 
      LDB PROTB     GET LWA OF BUFFER 
      CMB,INB 
      ADB LOCTB     COMPUTE LENGTH
      STA PT        SAVE FWA
      CLA 
      STA PT,I
      ISZ PT        CLEAR THE BUFFER
      INB,SZB 
      JMP *-3 
  SPC 1 
*          ALLOCATE A CLASS I/O WORD, PASSES IT BACK TO THE 
*          CALLER, SO WHEN THE CALLER NEED TO REQUEST THAT PROGRAM
*          IT CAN USE A SCHEDULE REQUEST OR IF THE PROGRAM IS NOT 
*          DORMANT IT CAN SEND A MAIL BOX USING THIS CLASS I/O
*          IN ORDER TO NOT SUSPEND ITSELF.
* 
      JSB GTCLW     ALLOCATE A CLASS I/O
      STA CLASS     SAVE THE CALSS I/O WORD 
* 
      JMP DEB05 
   SPC 3
ILSHR LDA P1        SET UP LU 
      SZA,RSS 
ILSH3 CLA,INA 
      STA P1
      LDA .ILIS     SET PROGRAM NAME IN THE MESSAGE 
      LDB .MES1 
      MVW D3
      JSB EXEC      OUTPUT
      DEF *+5         "ILLEGAL SHEDULE REQUEST ! "
      DEF D2
      DEF P1
      DEF MES 
      DEF D18 
      LDA ACTIV     GET ACTIVE FLAG 
      SZA,RSS       PROGRAM ACTIVE ?
      JSB ABORT     NO, TERMINATE PROGRAM 
      JMP EXIT4     YES, SAVE SUSPENSION POINT
* 
MES   ASC 5, /XXXXX : 
      ASC 13,ILLEGAL SCHEDULE REQUEST ! 
D18   DEC 18
D14   DEC 14
D8    DEC 8 
.MES1 DEF MES+1 
D22   DEC 22
D7    DEC 7 
* 
ILIST DEC 1 
      BSS 3 
* 
SBULN DEC 271       MAX BUF LEN TO SEND 
RBULN DEF 393       MAX BUF LEN TO RECEIVE
* 
ISTAT BSS 10
* 
CLASS NOP 
* 
  SPC 1 
P1    BSS 3         PARAMETERS GET BY RMPAR 
CLAS# OCT 0         P4 MAY BE THE CLASS I/O WORD
      NOP 
   HED T-M  LIBRARY  <--->   TMS-IMAGE MODULE   COMMUNICATION 
EXIT5 ADA D2        ADJUST MAIL BOX LENGTH
      CLB 
      STB ERCOD     NO FATAL ERROR REPORTED 
      LDB SCODE     RETURN THE TMS-IMSGE-RQ-CODE
      STB ERCOD+1   TO THE CALLER 
  SPC 1 
EXIT6 STA LTEM      SET MAIL BOX LENGTH 
* 
      LDA CLAS#     RELEASE CLASS I/O IF NOT ALREADY DONE 
      JSB KLCLX 
      LDA ECLAS     RECALL CLASS I/O THAT SHOULD BE USED
      STA CLAS#     TO SEND THE RESULT
      LDA PARM      SET UP OPTIONAL CLASS I/0 PARAMETERS
      LDB PARM+1    WITH THOSE SUPPLIED BY THE USER 
      JSB PSAM      SEND ANSWER TO THE USER USING HIS CLASS I/O 
      DEF ERCOD     BUFFER ADDR 
LTEM  NOP           BUFFER LENGTH 
  SPC 1 
EXIT3 LDA RSTAR,I   GET RESTART QUEUE HEAD
      SZA,RSS       SOMETHING TO RESTART ?
      JMP EXIT4     NO, EXIT
      RAL,CLE,ERA   YES, CLEAR BIT 15 
      LDB A,I       REMOVE THAT PROCESS FROM THE
      STB RSTAR,I   RESTART QUEUE 
      CLB 
      STB A,I       CLEAR LINK WORD IN THE PROCESS DIRECTORY
      INA 
      LDB A,I       RECALL CLASS I/O
      STB CLAS#     SET CLASS I/O WORD
      CLB 
      STB A,I       CLEAR CALL I/O IN THE PROCESS DIRECTORY 
      LDA CLAS#     SET CLASS I/O WORD IN A REG.
      JMP DEB15     AND RESTART PROGRAM 
  SPC 1 
EXIT4 LDA CLASS     TRY TO GET A REQUEST ON THE SPECIAL CLASS 
      JSB GSAM      GET NO-WAIT & NO-ABORT
      SSA,RSS       SOMETHING GET ? 
      JMP DEB20     YES, GO PROCESS REQUEST 
* 
RTNFL OCT 0         RETURN FLAG (NOP/RSS) TO RTN PARAM TO CALLER
      JMP EXIT9     IF NOP; EXIT WITHOUT  'PRTN'
* 
SPCLF RSS           CLEARED ONLY WHEN SPECIAL CLOSE 
      JMP SPCLS     REQUEST IS REQUESTED, RETURN TO SPECIAL PROCESS 
* 
      JSB PRTN      SEND RETURN PARAMETERS TO CALLER
      DEF *+2 
      DEF RTPAR     RETURN PARAMETRS BUFFER 
* 
EXIT9 JSB EXEC      COMPLETE THIS PROGRAM 
      DEF *+4       SAVING SUSPENSION POINT.
      DEF D6
.D0   DEF D0
      DEF D1
  SPC 1 
****************************************************************
  SPC 1 
      JSB RMPAR     RETREIVE SCHEDULE PARAMETERS
      DEF *+2 
      DEF P1        SAVE PARAMETER
* 
DEB05 CLA           SET RETURN FLAG TO NOT USE 'PRTN' 
      STA RTNFL 
  SPC 1 
      JSB EXEC      GET STRING REQUEST
      DEF *+5 
      DEF D14 
      DEF D1
.SCOD DEF SCODE     BUFFER ADDR 
      DEF RBULN     BUFFER LENGTH 
      DST PARM1     SAVE STATUS & LENGTH
      SZA,RSS       STRING GET SUCCED ? 
      JMP DEB18     YES, GO PROCESS REQUEST 
* 
      LDA CLAS#     NO STRING, CHECK FOR A MAIL BOX 
      CPA DM1       WANTS TO GET FROM THE SPECIAL CLASS ? 
      JMP EXIT4     YES, GO DO THE GET
      SZA,RSS       CLASS I/O DEFINED ? 
      JMP ILSH3     NO, PRINT 'ILLEGAL SCHEDULE REQUEST'
DEB15 AND =B17777   YES, RELEASE BUFFER ON THE NEXT GET 
      IOR B20K      BUT DO NOT DEALLOCATE THE CLASS I/O 
      JSB GSAM      GET  NO-WAIT & NO-ABORT 
      SSA           SOMETHING GET ? 
      JMP ILSH3     NO, PRINT MESSAGE AND EXIT
      JMP DEB25     YES, PROCESS THE REQUEST
   SPC 2
DEB18 BLS           SET TLOG IN CHARACTERS
      LDA .SCOD     BUFFER ADDR 
      JSB $PARS     PARSE THE BUFFER
      DEF BTEMP     AND STORE RESULTE INTO  BTEMP 
* 
      LDA BTEMP+1   RECALL FIRST PARAM VALUE
      CPA ARU       IS IT A "RU, .... " COMMAND ? 
      JMP SPCL3     YES, CHECK FOR EMERGENCY PROCEDURE
  SPC 1 
DEB20 CLA           NO CLASS I/O IS DEFINE IN THAT WORD 
      STA CLAS# 
  SPC 2 
DEB25 LDA SCODE     GET REQUEST CODE
      SSA           NEGATIVE ?
      JMP ILSH3     YES, ERROR
      ADA =D-9      GREATER THAN 9
      SSA,RSS 
      JMP ILSH3     YES, ERROR
      LDA SCODE     NO, RECALL SUBROUTINE CODE
      LDB ACTIV     RECALL ACTIVE FLAG
      SZB           DATA BASE OPEN ?
      JMP DEB30     YES, CONTINUE 
      SZA           NO, OPEN REQUEST ?
      JMP ER500     NO, REJECT THIS CALL
  SPC 1 
DEB30 ADA C.TAB     INDEX IN TABLE
      JMP A,I 
  HED  EMERGENCY CLOSE PROCEDURE
SPCL3 LDA BTEMP+8   VERIFY THAT THE 1ST PARAM 
      SZA           IS NOT DEFINED
      JMP ILSH3     ERROR ! 
      LDA BTEMP+12  VERIFY THAT THE 2ND PARAM 
      SZA           IS NOT DEFINED
      JMP ILSHR     ERROR ! 
      LDA BTEMP+16  VERIFY THAT THE 3RD PARAM 
      ADA BTEMP+17  IS "1"
      CPA D2        COMPARE  TYPE+VALUE 
      RSS           OK, DO SPECIAL CLOSE REQUEST
      JMP ILSHR 
  SPC 1 
      LDA P1        RECALL LU 
      SZA,RSS 
      CLA,INA 
      STA P1        SAVE LU 
      IOR =B400 
      STA P1+1      SAVE LU FOR INPUT 
  SPC 1 
      LDA ACTIV     DATA-BASE OPEN
      SZA,RSS       OPEN ?
      JMP SPCL9     NO, REPORT ERROR
  SPC 1 
SPCL5 JSB EXEC      PRINT "DATA-BASE="
      DEF *+5 
      DEF D2
      DEF P1        LU
      DEF MSDB      BUFFER
      DEF D7
      JSB SPCL0     READ AND PARSE ANSWER 
      CPB D2        ASCII ? 
      RSS           YES, OK 
      JMP SPCL5     NO, TRY AGAIN 
      LDB .DBNM     CHECK IF CORRECT
      CMW D3
      JMP SPCL6     OK, ASK LEVEL WORD
      NOP           DO NOT COMPARE
      JMP ILSHR     REJECT THE SHEDULE REQUEST
* 
SPCL6 JSB EXEC      PRINT "LEVEL =" 
      DEF *+5 
      DEF D2
      DEF P1
      DEF MSLE
      DEF D5
      JSB SPCL0     READ AND PARSE ANSWER 
      SZB,RSS       NUL ? 
      LDA .SP       YES, TAKE DEFAULT ASCII VALUE 
      SZB 
      CPB D2        ASCII ? 
      RSS           YES, OK 
      JMP SPCL6     NO, TRY AGAIN 
      LDB .DBN3     CHECK IF CORRECT
      CMW D3
      JMP SPCL7     OK, ASK LEVEL WORD
      NOP           DO NOT COMPARE
      JMP ILSHR     REJECT THE SHEDULE REQUEST
* 
SPCL7 JSB EXEC      PRINT "SEC.-CODE="
      DEF *+5 
      DEF D2
      DEF P1        LU
      DEF MSSC      BUFFER
      DEF D7
      JSB SPCL0     READ AND PARSE ANSWER 
      SZB           NUL ? 
      CPB D1        NUMERIC ? 
      RSS           YES, OK 
      JMP SPCL7     NO, TRY AGAIN 
      LDB A,I       CHECK IF CORRECT
      CPB DBNAM+6 
      RSS 
      JMP ILSHR     REJECT THE SHEDULE REQUEST
* 
      CLA,INA       SET SCODE FOR  DBCLOSE
      STA SCODE 
      CLA           SET SPECIAL CLOSE FLAG
      STA SPCLF     TO RETURN AFTER THE CLOSE 
      JMP XDBC0 
* 
SPCLS LDA .DBNM     MOVE DATA-BASE NAME INTO THE MESSAGE
      LDB .MS9X 
      MVW D3
      LDA RTPAR     RECALL DBCLOSE IMAGE STATUS 
      SZA,RSS       OK ?
      JMP SPCL8     YES, PRINT MESSAGE
      SSA           NO, PRINT ERROR MESSAGE 
      CMA,INA 
      STA TEMP
      JSB CNUMD 
      DEF *+3 
      DEF TEMP
      DEF MS9+16
      LDA .MS8
      LDB .MS9Y 
      MVW D8
SPCL8 JSB EXEC      PRINT "DATA-BASE XXXXXX SUCCESSFULLY CLOSE" 
      DEF *+5 
      DEF D2
      DEF P1
      DEF MS9 
      DEF D20 
      JMP EXIT9 
  SPC 1 
SPCL9 JSB EXEC      PRINT "NO DATA-BASE CURRENTLY OPEN" 
      DEF *+5 
      DEF D2
      DEF P1
      DEF MS7 
      DEF D16 
      JSB ABORT     TERMINATE PROGRAM 
      JMP EXIT9 
  SPC 1 
MSDB  ASC 7, DATA-BASE = _
MSLE  ASC 5, LEVEL = _
MSSC  ASC 7, SEC.-CODE = _
MS9   ASC 20, DATA-BASE: XXXXXX SUCCESSFULLY CLOSED.
MS7   ASC 16, NO DATA-BASE CURRENTLY OPEN ! 
.MS8  DEF *+1 
      ASC 8,; CLOSE ERROR : 
.SP   DEF *+1 
      ASC 3,
.MS9Y DEF MS9+9 
.MS9X DEF MS9+6 
ARU   ASC 1,RU
.DBN3 DEF DBNAM+3 
D16   DEC 16
  SPC 1 
SPCL0 NOP 
      JSB EXEC      READ ANSWER 
      DEF *+5 
      DEF D1
      DEF P1+1
.BUF  DEF BUF 
      DEF DM7 
      LDA .BUF      RECALL BUFFER ADDR
      JSB $PARS     PARSE BUFFER
      DEF BTEMP     OUTPUT BUFFER 
      LDA .BTE1     ADDR. OF DATA 
      LDB BTEMP     TYPE OF DATA
      JMP SPCL0,I 
* 
.BTE1 DEF BTEMP+1 
DM7   DEC -7
  HED  IMAGE / INTERNAL  ERROR PROCESSING 
ERR?  NOP           FOR INTERNAL IMAGE RQ, CHECK STATUS 
      LDA ISTAT     RECALL IMAGE STATUS 
      JSB .ERR? 
      JMP ERR?,I
  SPC 2 
*                   FATAL ERROR PROCESSING  --->  ABORT CALLER
* 
.ERR? NOP 
      SZA,RSS       OK ?
      JMP .ERR?,I   YES, CONTINUE 
EROR  JSB CHECK     !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 
      LDB SCODE 
      SZB,RSS       OPEN REQUEST ?
      JMP RTPRG     YES, USE SPECIAL RETURN WITH 'PRTN' 
      CPB D1        CLOSE REQUEST ? 
      JMP RTPRG 
      CPB D8        TBULK REQUEST ? 
      JMP RTPRG 
      DST ERCOD     SET UP ERROR CODE & REQUEST CODE
      LDA D2        SET BUFFER LENGTH 
      JMP EXIT6     AND GO SEND THE ANSWER TO THE CALLER
  SPC 1 
ER500 JSB ABORT     TERMINATE THE PROGRAM 
      LDA =D500     DATA-BASE HAS NOT BEEN OPENED 
      JMP EROR
  SPC 2 
*                   IMAGE ERROR PROCESSING  --->  THE ERROR NUMBER
*                        IS RETURNED TO THE USER, IN PLACE OF 
*                        THE IMAGE STATUS.
* 
SIMST LDB SCODE     SET IMAGE STATUS
      ADB S.TAB     A REG = ERROR CODE
      JMP B,I       JUMP TO RIGHT CODE
  SPC 1 
SIMS1 STA BTEMP+8   SET IMAGE STATUS
      JSB CHECK     !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      JMP XDBF3     AND RETURN
* 
SIMS2 STA BTEMP     SET IMAGE STATUS
      JSB CHECK     !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      JMP XDBP5     AND RETURN
  SPC 1 
S.TAB DEF *+1,I 
      DEF ILRQ      DBOPN 
      DEF ILRQ      DBCLS 
      DEF SIMS1     DBGET 
      DEF SIMS1     DBFND 
      DEF SIMS2     DBPUT 
      DEF SIMS2     DBUPD 
      DEF SIMS2     DBDEL 
      DEF ILRQ      DBINF 
      DEF ILRQ      TBULK 
   SPC 2
*                TERMINATE THIS PROGRAM WITHOUT ANY OPTION
*                TO MAKE IT ACTUALLY DORMANT. 
  SPC 1 
ABORT NOP 
      LDA .D0 
      STA .D0+1     SUPPRESS TERMINATE OPTION 
      JMP ABORT,I   AND TERMINATE PROGRAM.
  SPC 1 
RSTAR DEF *+1       RESTART PROCESS QUEUE 
      OCT 0 
  SPC 1 
ACTIV OCT 0         # OF OPEN/CLOSE REQUEST 
  HED DBOPN PROCESSOR 
* 
*     INPUT BUFFER FORMAT:
* 
*                   HEADR        (4)  RQ/CLASS#/PARM1/PARM2 
*                   BUF[1:3]     (3)  DATA-BASE NAME
*                   BUF[4:6]     (3)  LEVEL ACCESS WORD 
*                   BUF[7]       (1)  SECURITY CODE 
  SPC 1 
*     RETURN VALUE USING 'PRTN' SUBROUTINE: 
* 
*                   RTPAR[1]     (1)  0 / ERROR CODE
*                   RTPAR[2]     (1)  TMS-SUBROUTINE CODE IF ERROR
*                   RTPAR[3]     (1)  DATA-BASE CRC 
*                   RTPAR[4]     (1)  MAXIMUM ITEM LENGTH 
*                   RTPAR[5]     (1)  MAXIMUM ENTRY LENGTH
  SPC 1 
XDBOP LDA CLAS#     RELEASE MAIL BOX & CLASS
      JSB KLCLX 
* 
      LDA ACTIV     GET ACTIVE FLAG 
      SZA           IS IT THE FIRST ENTRY ? 
      JMP XDBO4     NO, CHECK THAT IT IS THE SAME DATA BASE 
  SPC 1 
      LDA .BUF      SAVE DATA-BASE NAME & LEVEL WORD
      LDB .DBNM     & SECURITY CODE 
      MVW D7
  SPC 1 
      JSB DBINT     INITIALIZE RUN TABLE AREA 
      DEF *+5 
      DEF BUF       DATA BASE NAME
      DEF BUF+6     SECURITY CODE 
      DEF ILIST     LIST OF PROGRAM 
      DEF ISTAT 
      JSB ERR?      OK ?
  SPC 1 
      JSB DBOPN     OPEN THE DATA BASE
      DEF *+6 
      DEF BUF       DATA BASE NAME
      DEF BUF+3     LEVEL ACCESS WORD 
      DEF BUF+6     SECURITY CODE 
      DEF D2        MODE
      DEF ISTAT     STATUS
      JSB ERR?      OK ?
      LDA ISTAT+1   RECALL LEVEL ACCESS 
      CPA =D15      IS IT THE HIGHEST LEVEL ? 
      JMP XDBO2     YES, GO LOCK THE DATA BASE
      LDA D2        NO, DBOPN ERR#2: BAD LEVEL ACCESS WORD
      JMP EROR      PASSES ERROR BACK TO CALLING PRG & TERMINATE
  SPC 1 
XDBO2 JSB DBLCK     LOCK THE WHOLE DATA BASE
      DEF *+3 
      DEF D2        LOCK WITHOUT WAIT 
      DEF ISTAT 
      JSB ERR?      SUCCESFUL LOCK ?
* 
      JSB DBCRC     CALCULATE THE DATA-BASE CRC 
      DEF *+6       AND RETURN MAXIMUM VALUE
      DEF BUF       DATA BASE NAME
      DEF RTPAR+2   CRC 
      DEF RTPAR+3   MAX ITEM LENGTH 
      DEF RTPAR+4   MAX ENTRY LENGTH
      DEF ISTAT     STATUS
      JSB ERR?      OK ?
* 
OKOPN ISZ ACTIV     BUMP ACTIVE FLAG
      LDB CLASS     RETURN SPECIAL CLASS# TO CALLER 
OKRTN CLA           RETURN GOOD SATUS 
   SPC 1
RTPRG DST RTPAR     SAVE RETURN PARAMETERS
      LDA .RSS      AND SET THE RETURN FLAG TO
      STA RTNFL     USE 'PRTN' SUBROUTINE 
      JMP EXIT3     RETURN
  SPC 2 
XDBO4 LDA .BUF      CHECK THAT NAME, LEVEL WORD AND SC
      LDB .DBNM     ARE THE SAME
      CMW D7
      JMP OKOPN     OK, SAME DATA-BASE
                                                                                                                                                                                                                                                              