ASMB,R,L,C
      HED "IDDUP" FTN/SPL SUBROUTINE TO DUPLICATE ID SEGMENTS 
      NAM IDDUP,6 92067-16185 REV.1903 790122 
*     SOURCE: 92067-18234 
*     RELOC:  92067-16185 
*     PGMR:   D.L.B.
* 
*  ***************************************************************
*  * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979.  ALL RIGHTS     *
*  * RESERVED.  NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED,      *
*  * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT*
*  * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY.       *
*  ***************************************************************
* 
*  MODIFICATION RECORD: 
*   OLD DATE   NEW DATE   REASON   BY WHOM
* 1) 12-3-75   1-30-76    TO FIX BUG IF PROGRAM IS ON DISC LU=3  (DLB)
* 2) 1-30-76   10-5-76    TO REMOVE DUPLICATION OF PERMANENT PROGRAMS (DLB) 
* 3) 10-5-76    9-2-77    TO SUPPORT EXTENDED ID SEGMENT
* 4)  9-2-77    4-3-78    CROSS-MAP ACCESS TO ID SEGMENTS FOR RTE-IV
*                         TYPE 4 PROGRAMS USING THIS ROUTINE
* 5)  4-3-78   9-20-78    TO ALLOW DUPLICATION OF PERMANENT PGMS (GLM)
* 6) 9-20-78   1-22-79    TO SKIP ERR 23 IF DISC ADDRESSES MATCH
*                         TO RETURN EXISTING AND NEW IDSEG ADDRESSES
* 
      ENT IDDUP 
      EXT $LIBR,$LIBX,IDSGA,.ENTP,NAM..,$OPSY,$IDEX 
      EXT .OWNR 
TAT   EQU 1656B 
KEYWD EQU 1657B 
TATSD EQU 1756B 
*10-5SECT2 EQU 1757B
*10-5SECT3 EQU SECT2+1
*10-5DSCUT EQU 1763B
A     EQU 0 
B     EQU 1 
* 
*  PURPOSE: 
* 
*     TO DUPLICATE AN ID SEGMENT ALREADY IN AN RTE-II/III/IV
*     SYSTEM GIVING IT ANOTHER NAME AT THE SAME TIME. 
* 
*  CALLED:
* 
*     CALL IDDUP (IDNAM,NWNAM,IERR,OID,NID) 
*                -OR- 
*     IF ( IDDUP (IDNAM,NWNAM,IERR,OID,NID) .NE.0) GO TO IERROR 
* 
*  WHERE: 
* 
*     IDNAM = AN EXISTING PROGRAM NAME IN THE SYSTEM. (MUST HAVE BEEN 
*             ':RP,IDNAM' OR BE A PERMANENT PROGRAM IN THE SYSTEM.
*     NWNAM = THE NAME OF THE NEWLY CREATED ID SEGMENT        
*     IERR = (OPTIONAL) RETURN ERROR CODE (SAME AS ERROR CODES IN FMGR) 
*     OID  = (OPTIONAL) RETURN ADDRESS OF EXISTING ID SEGMENT 
*     NID  = (OPTIONAL) RETURN ADDRESS OF NEW ID SEGMENT
* 
* 
*  RETURN:
* 
*     IERR = 0   > SUCCESSFUL INSTALLATION OF ID SEGMENT INTO SYSTEM
*     IERR = 14  > IDNAM TYPE NOT EQUAL TO DISC RESIDENT PROGRAM. 
*     IERR = 17  > NWNAM IS AN ILLEGAL PROGRAM TYPE (1,4 OR 5)
*                  TYPE 4 IS ALLOWED IF SYSTEM IS RTE-IV
*     IERR = 23  > NWNAM IS ALREADY IN THE SYSTEM WITH DIFFERENT DISC 
*                  ADDRESS  
*     IERR = -15 > ILLEGAL NAME (NWNAM) 
*  NOTES: 
* 
*    (1)  A-REG = IERR ON RETURN, THEREFORE MAY BE USED AS FUNCTION 
*         E-REG = 1, IF ERROR, ELSE E-REG = 0 ON RETURN(FRETURN SPL)
*    (2)  IDNAM MUST BE PROGRAM TYPE 2,3 OR 12B,13B (REVERSE COMMON?) 
*         TYPE 4 IS ALLOWED IF THE SYSTEM IS RTE-IV 
*    (3)  IDNAM MUST BE A PROGRAM THAT WAS ':RP,IDNAM' OR BE A PERMANENT
*         PROGRAM                                                     
*    (4)  THE TRACK THAT THE ID SEGMENT POINTS TO, WILL ALWAYS BE 
*         AS A 'FMP' TRACK IN THE TAT WHEN EXIT FROM THIS SUBROUTINE. 
*         THIS IS DONE SO THAT ON '*OF,PROG,8' DIRECTIVE DOES NOT 
*         RELEASE THE TRACKS, BUT DOES RELEASE THE ID SEGMENT.
*         (DO YOU KNOW WHAT THE 'LOADR' DOES WITH A PERMANENT 
*         PROGRAM (TM=0) WHEN THE 1ST TRACK IT IS ON IS MARKED
*         AS A 'FMP' TRACK? (77776B)) (DLB) 
*    (5)  NWNAM MUST BE A 3 WORD BUFFER CONTAINING A NAME THAT  
*         COULD BE USED AS A FILE NAME. (ALL SIX CHARACTERS ARE TESTED
*         FOR LEGALITY. THE "FMP" NAM.. ROUTINE IS USED TO CHECK FOR
*         NAME CORRECTNESS.)
* 
*  TEST PROGRAM:
*FTN,L
*      PROGRAM TYDUP(2,99)
*      DIMENSION NAME(3),LU(5),NUNAM(3) 
*      CALL RMPAR(LU) 
*      IF (LU.EQ.0) LU = 1
*    1 WRITE (LU,11)
*   11 FORMAT ("INPUT SYS PROGRAM NAME? _") 
*      READ (LU,12) NAME
*      IF (NAME.EQ.2H/E) GO TO 9999 
*      WRITE (LU,13)
*   13 FORMAT ("INPUT NEW NAME FOR PROG? _")
*      READ (LU,12) NUNAM 
*      IF (NUNAM.EQ.2H/E) GO TO 9999
*   12 FORMAT (3A2) 
*      IF(IDDUP(NAME,NUNAM,IERR).EQ.0) GO TO 9999 
*      WRITE (LU,46) IERR 
*   46 FORMAT ("FMGR ERROR "I3) 
*      GO TO 1
* 9999 END
*      END$ 
      SPC 1 
IDNAM NOP 
NWNAM NOP 
IERR  NOP           IERR ADDRESS
OID   NOP           ADDRESS OF EXISTING ID SEGMENT
NID   NOP           ADDRESS OF NEW ID SEGMENT 
IDDUP NOP           ENTRY 
      JSB $LIBR     TURN OF INTERRUPTS
MCNT  NOP 
      JSB .ENTP     PICK UP PARAMETER ADDRESSES 
      DEF IDNAM 
      SPC 1 
      LDA $OPSY     OP SYSTEM IDENTIFIER           *780403* 
      ERA           MOVE MAPPED BIT FOR SLA        *780403* 
      STA STYPE     FOR LOADA,STORA,LOAD2 ROUTINES *780403* 
      JSB IDSGA     CHECK IF IDNAM EXISTS 
      DEF *+2 
      DEF IDNAM,I 
      CCE,SZA,RSS   CHECK IF FOUND? 
      JMP ERR14     NO, TELL CALLER 
      STA B         SAVE IN B-REG 
      STA OID,I     RETURN ADDR OF EXISTING ID SEGMENT
      ADA O6        BUMP TO ID(7) PRIORITY WORD 
      STA ID7       SAVE FOR LATER USE
      ADB D14       BUMP TO ID(15)
      JSB LOADA     GET THE PROGRAM TYPE WORD      *780403* 
      STA NAM5Y     SAVE PROGRAM TYPE WORD
      AND O3        CHECK IF TYPE IS 2 OR 3 
      ARS           LEAVE E-REG SET!! 
      CPA O1        BIT 1 MUST BE SET 
      JMP OK        OK
      LDA $OPSY     OP SYSTEM IDENTIFIER
      CPA M9        RTE-IV? 
      RSS           YES 
      JMP ERR17     NON-RTEIV AND TYPE=1,4 OR 5 
      LDA NAM5Y     PROGRAM TYPE
      AND O7        TYPE=4? 
      CPA O4
      RSS           YES, TYPE 4 ALLOWED FOR RTE-IV
      JMP ERR17     NO, MUST BE 1 OR 5
OK    ADB O7        BUMP TO ID(22)
      STB ID22      AND SAVE FOR LATER USE
      ADB O5        BUMP TO ID(27)
      STB ID27      SAVE FOR LATER USE
      ADB O2        BUMP TO ID(29)
      STB ID29      AND SAVE
      ADB O3        ADVANCE TO 2ND SESSION WORD    *780920* 
      JSB LOADA     FETCH CONTENTS                 *780920* 
      ALF,RAL       IF "DON'T COPY" BIT IS SET,    *780920* 
      SSA           REJECT REQUEST                 *780920* 
      JMP ERR17                                    *780920* 
* 
*  COPY EVERYTHING EXCEPT TEMPORARY LOADS BY THE LOADER.
*  IF TL BIT IS SET, CHECK THE "I'M A COPY" BIT.  IF THIS 
*  BIT IS SET, WE CAN DO THE COPY, OTHERWISE REPORT ERROR.
*  NOTE:  THE "I'M A COPY" BIT IS SET WHEN A PROGRAM IS RP'ED.
* 
      RAL,ELA       MOVE "I'M A COPY" BIT TO E     *780920* 
      LDA NAM5Y     MOVE THE TEMPORARY LOAD BIT    *780920* 
      ALF,ALF                                      *780920* 
      SSA           IF TEMP LOAD BIT CLEAR(PERM.PGM) *0920* 
      SEZ,CCE       OR THE "I'M A COPY" BIT IS SET *780920* 
      JMP TYPOK     THEN THIS ID MAY BE COPIED     *780920* 
* 
ERR17 LDA D17       ERR 17 >> ID SEGMENT NOT SET UP BY RP 
      JMP EXIT      E-REG=1 OR NOT A PERMANENT SYSGEN PROGRAM 
ERR23 CCE 
      LDA D23       ERR 23 >> DUPLICATE PROGRAM NAME
      JMP EXIT
ERR14 LDA D14       ERR 14 >> REQUIRED ID SEGMENT NOT FOUND 
      JMP EXIT
      SPC 1 
TYPOK JSB IDSGA     SEARCH IF NEW NAME ALREADY EXISTS 
      DEF *+2 
      DEF NWNAM,I 
      CCE,SZA,RSS   NOT FOUND IS OK 
      JMP CKNAM                           
      SPC 1 
      STA NID,I     RETURN AS NEW ID SEG ADDRESS
      ADA D26       OFFSET TO DISC ADDRESS WORD 
      STA B         SAVE IN B 
      JSB LOADA     GET DISC ADDRESS TO A 
      STA TEMP      SAVE TEMPORARILY
      LDB ID27      DISC ADDRESS IN "OLD" ID
      JSB LOADA 
      CPA TEMP      COMPARE THE TWO DISC ADDRESSES
      CLA,CLE,RSS   MATCH - RETURN AS IF WE DID IT
      JMP ERR23     NO MATCH - ERROR
      JMP EXIT      RETURN
      SPC 1 
*  NOW CHECK NEW NAME FOR CONTAINING PRINTABLE CHARACTERS 
      SPC 1 
CKNAM JSB NAM..     USE FMP NAME CHECKING ROUTINE 
      DEF *+2 
      DEF NWNAM,I 
      CCE,SZA       CHECK IF -15 ERROR
      JMP EXIT      YES, GET OUT -15 ERROR
      JMP SERCH     E-REG MUST = 1 AT THIS POINT!!!!! 
      SPC 1 
*            BLANK ID'S ARE SEARCHED IN FOLLOWING PRECEDENCE
* 
*      TYPE 2 OR 3 PROG 
*    1)LONG BLANK WITHOUT TRACKS
*    2)LONG BLANK & DON'T CARE
*      <RETURN FMGR ERROR 14> 
      SPC 1 
LOOP1 SEZ,CME,RSS   IF DOWN TO LONG BLANK & DONT CARE 
      JMP ERR14     THEN GET OUT FMGR ERROR 14
      SPC 1 
SERCH LDA KEYWD     RESET FOR KEYWORD SEARCH
      STA TEMP1 
      RSS           SKIP 1ST ISZ
      SPC 1 
* E-REG=1>>SEARCH ID WITHOUT TRACKS  E-REG=0>>DON'T CARE ABOUT TRACKS 
      SPC 1 
LOOP2 ISZ TEMP1     BUMP AND CHECK IF DONE WITH 
      LDB TEMP1     KEYWORD SEARCH                 *780403* 
      JSB LOADA                                    *780403* 
      SZA,RSS       DONE?                          *780403* 
      JMP LOOP1     YES, TRY NEXT TYPE OF BLANK ID
      STA B                                        *780403* 
      ADB D14       BUMP TO WORD 15 IN IDSEG (NAME/TYPE)
      JSB LOADA     GET VALUE                      *780403* 
      AND OM360     MASK TO CHAR 5 & SHORT/LONG BIT(177420B)
      SZA           FOUND ONE BLANK & LONG
      JMP LOOP2     NO, TRY NEXT IDSEG
      ADB D12       BUMP TO WORD 27 
      JSB LOADA     EQUAL TO 0 IF NO TRACKS        *780403* 
      SEZ,SZA       CHECK IF HAS TRACKS & CARE FLAG*780403* 
      JMP LOOP2     WELL THIS DUDE HAS TRACKS, SKIP 
      LDB TEMP1     GET BLANK IDSEG(1) ADDRESS     *780403* 
      JSB LOADA                                    *780403* 
      STA B                                        *780403* 
      STA NID,I     RETURN ADDRESS OF NEW ID SEGMENT
      STB MOVE1     SAVE FOR MOVE ROUTINE 
      INB           SET UP FOR XB SET 
      STB TEMXB 
      SPC 1 
*  NOW CREATE THE NEW ID SEGMENT  
      SPC 1 
      JSB .OWNR     FETCH OWNER FLAG               *780920* 
      IOR B1000     MERGE IN COPY FLAG             *780920* 
      STA OWID      SAVE FOR ID BUILD              *780920* 
      CLA                                          *780403* 
      JSB MOVE      CLEAR 1ST 6 WORDS OF PROGRAMS ID
O6    DEC 6 
      LDA ID7       GET IDNAM'S ID(7) ADDRESS 
      JSB XMOV      GET PRIORITY & ENTRY PT ADDR.  *780403* 
      OCT 2 
      CLA           CLEAR WORDS 9-10
      JSB MOVE      FIX UP WORD 11 LATER (XB) 
      OCT 2 
      LDA DEFXB     SET XB TO POINT TO XTEMP
      JSB MOVE      AND ZERO ID(12) 
      OCT 2 
      LDA NWNAM     MOVE NEW NAME CHARS 1-4 
      JSB MOVE      INTO NEW ID SEGMENT 
      DEC 2 
      LDA A,I       GET 3RD WORD OF NAME
      AND OM400     MASK OFF 6TH CHAR 
      XOR NAM5Y     MERGE IN 6TH CHAR OF OLD ID 
      AND OM20      OM20  = 177760B 
      XOR NAM5Y     RESTORE BITS 8-15 OF NWNAM 0-3 OF NAM5Y 
      IOR O200      MERGE IN THE "TM" BIT 
      STA NAM5Y     SAVE IN "TIME" BUFFER 
      LDA TIMEB     GET TIME BUFFER ADDRESS 
      JSB MOVE      COPY INTO ID
O7    OCT 7 
      LDA ID22      COPY MEMORY/DISC ADDRESS
      JSB XMOV                                     *780403* 
      OCT 6 
      SPC 1 
*10-5*  NOW CALCULATE NUMBER OF TRACKS USED BY PROGRAM
*10-5*    THE ASSUMPTION IS MADE THAT A PROGRAM OWNS A TRACK IF IT OWNS 
*10-5*    THE FIRST SECTOR OF THAT TRACK. (IT IS POSSIBLE THAT A SHORT
*10-5*    PROGRAM OWNS NOTHING)  THIS IS TO BE COMPATABLE WITH THE
*10-5*    SYSTEM '*OF,PROG,8' PROCESSOR.
*10-5*  NOW AN EXCEPTION IS MADE TO THE PREVIOUS STATEMENT: 
*10-5*    THIS SUBROUTINE SETS THE FIRST TRACK THIS PROGRAM IS ON TO
*10-5*    BELONG TO 'FMP' BECAUSE THE ':RP,,PROG' FMGR DIRECTIVE WON'T
*10-5*    WORK IF THIS NOT SO.  ('*OF,PROG,8' IS CONSIDERED TOO NOISY 
*10-5*    A DIRECTIVE TO THE SYSTEM CONSOLE AT PRESENT)  IF THE 'OF,PROG,8' 
*10-5*    DIRECTIVE IS FIXED, THERE IS 2 LINES OF CODE MARKED '*' THAT CAN
*10-5*    BE INSERTED LATER. (DLB)
*10-5      SPC 1
*10-5      ISZ ID22      BUMP TO ID(23) HI-MAIN ADDRESS 
*10-5      JSB SUM       CALCULATE # SECT USED FOR MAIN MEM.
*10-5      STA TEMP1
*10-5      JSB SUM       CALCULATE # SECT OF BASE PAGE
*10-5      ADA TEMP1     CALCULATE TOTAL - 1
*10-5      ADA OM1
*10-5      STA TEMP1     AND SAVE FOR LATER ADDITION
*10-5      LDA ID22,I    GET LU/TRACK/SECTOR ADDRESS OF START 
*10-5      AND O177      GET SECTOR NUMBER
*10-5      STA SUM       SAVE TEMP
*10-5      XOR ID22,I    GET TRACK #
*10-5      LDB ASCT2     GET DEF TO SECT2 ON BASE PAGE
*10-5      STB SECPT     SAVE FOR CALCULATIONS
*10-5      CLE,ELA       SAVE LU IN E-REG 
*10-5      SEZ           IF LU=3 BUMP TO SECT3 WORD 
*10-5      ISZ SECPT     ON BASE PAGE 
*10-5      ALF,ALF       POSITION TRACK BITS 0-7
*10-5      MPY SECPT     CALCULATE # SECTORS
*10-5SECPT EQU *-1       SAVE SOME CORE 
*10-5      ADA SUM       ADD IN STARTING SECTOR 
*10-5      ADA TEMP1     LAST USED SECTOR BY PROG 
*10-5      DIV SECPT,I   NOW CALCULATE LAST TRACK 
*10-5      SEZ           CHECK IF LU=2 OR LU=3
*10-5      ADA TATSD     LU=3, MOVE UP TO THAT PART OF TAT
*10-5      ADA TAT       ADD IN BASE ADDRESS OF TAT 
*10-5*
*10-5*     SZB           CHECK IF OWNS 1ST SECTOR OF TRACK
*10-5*     JMP *+3       NO, DON'T BUY 1ST TRACK IT IS ON.
*10-5*
*10-5NEXTK LDB FMPTK     GET FMP TRACK OWNERSHIP WORD 
*10-5      STB TATAD,I   AND BUY
*10-5      CPA TATAD     CHECK IF LAST TRACK PROG IN ON?
*10-5      JMP DONE      YES, CONTINUE
*10-5      ISZ TATAD     NO, BUMP TO NEXT TRACK AND BUY 
*10-5      JMP NEXTK
*10-5      SPC 1
DONE  CLA 
      STA INDX
      JSB MOVE      NOW ZERO WORD 28
O1    OCT 1 
      SPC 1 
      LDB $OPSY     OP SYSTEM IDENTIFIER
      CPB M9        RTE-IV? 
      RSS           YES, SAVE RTE-IV WORDS
      JMP EXIT      NO
      LDB ID29      GET EMA WORD                   *780403* 
      JSB LOADA                                    *780403* 
      SZA,RSS       EMA?
      JMP NOEMA     NO, ZERO THE EMA WORD 
      JSB GTEXT     FIND FREE ID EXTENSION
      SZB,RSS       AVAILABLE?                     *780403* 
      JMP ERR14     NO, RETURN NO AVAILABLE ID EXT
      STB IDEXT     YES, SET UP DESTINATION ADDR.  *780403* 
      LDB ID29      GET EMA WORD                   *780403* 
      JSB LOADA                                    *780403* 
      CLB           GET READY FOR SHIFT            *780503* 
      ASL 6         GET CURRENT ID EXT # TO B 
      XLA $IDEX     GET ID EXT LIST HEAD           *780503* 
      ADB A         OFFSET TO ID EXT ADDR          *780503* 
      JSB LOADA     AND FETCH IT                   *780403* 
      STA B                                        *780403* 
      STA TEMP1                                    *780403* 
      JSB LOADA     GET ID EXT WORD 0              *780403* 
      AND MSKMS     MASK OFF MSEG#
      LDB IDEXT     SAVE IN ID EXTENSION WORD 0    *780403* 
      JSB STORA                                    *780403* 
      ISZ IDEXT     BUMP DESTINATION ADDRESS
      LDB TEMP1                                    *780403* 
      INB           BUMP TO NEXT ID EXT WORD
      JSB LOADA     CONTENTS OF NEXT ID EXT WORD   *780403* 
      AND MSKH6     MASK OFF EMA START PAGE 
      LDB IDEXT     SAVE IN ID EXTENSION WORD 1    *780403* 
      JSB STORA                                    *780403* 
      INB           BUMP DESTINATION ADDRESS       *780403* 
      CLA           ZERO ID EXTENSION WORD 2
      JSB STORA     SAVE IN ID EXTENSION WORD 2    *780403* 
      SPC 1 
      LDB INDX      GET NEW ID EXTENSION #
      ASR 6         MOVE TO HIGH 6 BITS 
      STA TEMP1     TEMPORARY SAVE                 *780403* 
      LDB ID29      GET ID SEGMENT EMA WORD        *780403* 
      JSB LOADA                                    *780403* 
      AND O1777     MASK OFF HIGH 6 BITS
      IOR TEMP1     MERGE TO CREATE NEW EMA WORD   *780403* 
NOEMA LDB MOVE1     COPY TO NEW ID SEGMENT         *780403* 
      JSB STORA                                    *780403* 
      ISZ MOVE1     BUMP DESTINATION ADDRESS
      SPC 1 
      LDB ID29                                     *780403* 
      INB                                          *780403* 
      JSB LOADA     GET HI-ADDR+1 OF LARGEST SEG.  *780403* 
      LDB MOVE1     DESTINATION ADDRESS            *780403* 
      JSB STORA     COPY TO NEW ID SEGMENT         *780403* 
      INB           BUMP DESTINATION ADDRESS       *780403* 
      CLA 
      JSB STORA     ZERO ID(30)                    *780403* 
      INB                                          *780403* 
      JSB LOADA     FETCH ID(31)                   *780920* 
      AND B170K     ISOLATE SEQUENCE COUNTER       *780920* 
      IOR OWID      MERGE IN OWNER & COPY FLAGS    *780920* 
      JSB STORA     RESTORE ID(31)                 *780920* 
      CLA 
      INB                                          *780403* 
      JSB STORA     ZERO ID(32)                    *780403* 
      SPC 1 
EXIT  STA IERR,I    TELL CALLER 
      CLB           CLEAR IERR FOR POSSIBLE NEXT USER 
      STB IERR
      STB OID       CLEAR OPTIONAL PARM 
      STB NID       CLEAR OPTIONAL PARM 
      JSB $LIBX     AND RETURN
      DEF IDDUP 
      SPC 1 
*10-5SUM   NOP           ROUTINE TO CALCULATE # SECTORS USED
*10-5      LDA ID22,I    GET LO-ADDRESS 
*10-5      CMA,INA       MAKE NEG 
*10-5      IOR O177      ROUND UP TO NEAREST MOD OF 128 WORDS 
*10-5      ISZ ID22      BUMP TO HI-ADDRESS 
*10-5      ADA ID22,I    SUM FOR TOTAL WORDS
*10-5      ISZ ID22 
*10-5      CLB           NOW CALCULATE # SECTORS
*10-5      LSR 7         DIVID BY 128 
*10-5      RAL           MPY BY 2 
*10-5      JMP SUM,I     RETURN A=# OF SECTORS NEEDED 
*10-5      SPC 1
*10-5ASCT2 DEF SECT2
*10-5      SPC 1
MOVE  NOP           ENTRY A=SOURCE ADDRESS, NEWID=DEST
      LDB MOVE,I    GET COUNTER 
      CMB,INB 
      STB MCNT
      LDB MOVE1                                    *780403* 
MORE  STA TEMP1                                    *780403* 
      LDA A,I       GET NEXT WORD OR ZERO          *780403* 
      JSB STORA     AND PUT IN SYSTEM              *780403* 
      LDA TEMP1     RESTORE TEMPORARY SAVE         *780403* 
      CLE,SZA       BUMP SOURCE ADDRESS ONLY IF NON 0 
      INA           RETURN E-REG = 0!!!!!!
      INB                                          *780403* 
      ISZ MOVE1 
      ISZ MCNT
      JMP MORE
      ISZ MOVE      P+2 RETURN
      JMP MOVE,I    RETURN DONE B=NEXT ADDRESS
      SPC 1 
MOVE1 NOP 
      SPC 1 
XMOV  NOP           ENTRY A=SOURCE ADDR (CROSS-MAP)*780403* 
      LDB XMOV,I    GET COUNTER OF WORDS TO MOVE   *780403* 
      CMB,INB                                      *780403* 
      STB MCNT                                     *780403* 
      LDB MOVE1     DESTINATION ADDRESS            *780403* 
MORE2 STA TEMP1     TEMPORARY SAVE                 *780403* 
      JSB LOAD2     GET NEXT WORD OR ZERO          *780403* 
      JSB STORA     AND PUT IN SYSTEM              *780403* 
      LDA TEMP1     RESTORE TEMPORARY WORD         *780403* 
      CLE,SZA       BUMP SOURCE ADDR ONLY IF NON-0 *780403* 
      INA           RETURN E-REG=0!                *780403* 
      INB           BUMP DESTINATION ADDRESS       *780403* 
      ISZ MOVE1                                    *780403* 
      ISZ MCNT                                     *780403* 
      JMP MORE2                                    *780403* 
      ISZ XMOV      P+2 RETURN                     *780403* 
      JMP XMOV,I    RETURN WITH B=NEXT ADDRESS     *780403* 
      SPC 1 
GTEXT NOP           RETURN B=ID EXTENSION ADDRESS 
      XLB $IDEX     RETURN B=0, E=1 IF NO ID EXT AVAIL. 
      STB IDX       GET & SAVE ID EXTENSION LIST HEAD 
      RSS                                          *780403* 
GTEX1 LDB IDX       GET NEXT ENTRY IN ID EXT LIST  *780403* 
      XLA B,I                                      *780403* 
      STA B                                        *780403* 
      SZB,RSS       END OF ID EXTENSION BLOCK?     *780403* 
      JMP GTEXT,I   YES, RETURN B=0, NO AVAIL EXT. *780403* 
      XLA B,I       NO, GET WORD 0 OF ID EXTENSION *780403* 
      SZA,RSS       AVAILABLE?                     *780403* 
      JMP GTEXT,I   RETURN B=ID EXTENSION ADDRESS  *780403* 
      ISZ INDX      NO, BUMP ID EXTENSION NUMBER
      ISZ IDX       BUMP ID EXTENSION ADDRESS 
      JMP GTEX1     TRY THE NEXT ID EXTENSION 
      SPC 1 
STYPE NOP                                          *780403* 
LOADA NOP           DOES XLA B,I IF MAPPED SYS     *780403* 
      LDA STYPE     OP SYS IDENTIFIER (AFTER ERA)  *780403* 
      SLA           MAPPED SYSTEM?                 *780403* 
      JMP MAPSY     YES                            *780403* 
      LDA B,I       NO, DO DIRECT LOAD             *780403* 
      JMP LOADA,I   RETURN                         *780403* 
MAPSY XLA B,I       DO CROSS-LOAD (2-WD INSTRUCT.) *780403* 
      JMP LOADA,I   RETURN                         *780403* 
      SPC 1 
STORA NOP           DOES XSA B,I IF MAPPED SYS     *780403* 
      STA TEMP      SAVE TEMPORARILY               *780403* 
      LDA STYPE     OP SYS IDENTIFIER (AFTER ERA)  *780403* 
      SLA           MAPPED SYSTEM?                 *780403* 
      JMP MAP       YES                            *780403* 
      LDA TEMP      RESTORE TEMP WORD              *780403* 
      STA B,I       NON-MAPPED, DO DIRECT LOAD     *780403* 
      JMP STORA,I   RETURN                         *780403* 
MAP   LDA TEMP      RESTORE TEMP WORD              *780403* 
      XSA B,I       DO CROSS-STORE (2 WD INSTRUCT) *780403* 
      JMP STORA,I   RETURN                         *780403* 
      SPC 1 
LOAD2 NOP           DOES XLA A,I IF MAPPED SYS     *780403* 
      STA TEMP      SAVE A-REG                     *780403* 
      LDA STYPE     OP SYS IDENTIFIER (AFTER ERA)  *780403* 
      SLA           MAPPED SYSTEM?                 *780403* 
      JMP XLOAD     YES                            *780403* 
      LDA TEMP,I    NO, DO DIRECT LOAD             *780403* 
      JMP LOAD2,I   RETURN                         *780403* 
XLOAD XLA TEMP,I    DO CROSS-LOAD (2 WD INSTRUCT.) *780403* 
      JMP LOAD2,I   RETURN                         *780403* 
      SPC 1 
TIMEB DEF *+1 
NAM5Y NOP           5TH CHAR & PROGRAM TYPE 
      DEC 0         ID(16)
      DEC 0         ID(17)
      DEC 0         ID(18)
      OCT 25000     ID(19) TIME = ONE DAY 
      OCT 177574    ID(20)
      DEC 0         ID(21)
      SPC 1 
DEFXB DEF *+1       DON'T CHANG ORDER OF NEXT 3 WORDS 
TEMXB NOP 
      DEC 0 
      SPC 1 
ID7   NOP           HOLDS ADDRESS IF ID(7)
ID22  NOP 
ID27  NOP 
*10-5TATAD NOP
ID29  NOP 
IDEXT NOP 
IDX   NOP 
INDX  NOP 
OWID  NOP                                          *780920* 
TEMP  NOP                                          *780403* 
TEMP1 NOP 
FMPTK OCT 77776 
MSKH6 OCT 176000
MSKMS OCT 100037
*10-5OM1   OCT -1 
O2    OCT 2 
O3    OCT 3 
O4    OCT 4 
O5    OCT 5 
M9    DEC -9
D12   DEC 12
D14   DEC 14
D17   DEC 17
D23   DEC 23
D26   DEC 26
*10-5O177  OCT 177
O200  OCT 200 
O1777 OCT 1777
B1000 OCT 1000
B170K OCT 170000
OM2   OCT -2
OM20  OCT -20 
OM400 OCT -400
OM360 OCT -360
      END 
                                                    