*DECK PUTLINK 
          IDENT  PUTLINK
          TITLE  PUTLINK -  PUT A LINK TABLE ON BINARY FILE 
  
          MACHINE  ANY,I
          COMMENT  PUT A LINK TABLE ON BINARY FILE
          SPACE  4
**        PUTLINK -  PUT OUT TABLE FOR A LINK  (EXTERNAL) 
* 
*         PUTLINK(NAME, POSITION, BASE, ADDRESS)
*                NAME = 42/EXTERNAL NAME, 18/JUNK 
*                POSITION = BIT NUMBER OF LEFT-MOST BIT OF 18-BIT FIELD 
*                             (LEFT BIT = 0,  RIGHT BIT = 59) 
*                BASE = RELOCATION BASE REGISTER OF WORD CONTAINING FLD.
*                ADDRESS = ADDRESS WITHIN BLOCK *BASE* OF WORD
* 
*         DOES-  WRITES OUT *LINK* TABLE IF POSSIBLE
*                ELSE WRITES OUT *XLINK* TABLE. 
* 
*                DOES NOT CHECK IF 18-BIT ADDRESS CROSSES WORD BOUNDARY 
*                OUTPUT IS PROBABLY JUNK. 
  
  
          ENTRY  PUTLINK
 PUTLINK  CON    *
          SB1    1           B1=1 
          SA2    X1          42/EXTERNAL NAME, 18/JUNK
          RJ     CLEANUP     STRIP JUNK AND CONVERT BLANKS TO ZEROS 
          SA1    A1+B1       ADDRESS OF POSITION
          SA3    X1          POSITION 
          SA1    A1+B1       ADDRESS OF BASE REGISTER 
          SA4    X1          BASE REGISTER
          SA1    A1+B1       ADDRESS OF ADDRESS 
          SA5    X1          ADDRESS
          SX7    42          X3 = NUMBER OF RIGHT-MOST BIT OF ADDRESS 
          IX3    X7-X3         (LEFT BIT = 59, RIGHT BIT = 0) 
          SX6    210422B     1/15 S20 = 0.06667S20
          IX6    X3*X6
  SX3 X3 ******** RESET X3 FROM IXX*X MACRO ****************************
          AX6    20 
          BX7    X6 
          LX7    4           16*PARCEL NUMBER 
          IX7    X7-X6       15*PARCEL NUMBER 
          BX7    X7-X3       BITS BEYOND PARCEL BOUNDARY
          NZ     X7,PUTLINKX IF NEED *XLINK* TABLE
  
*    *LINK* TABLE 
  
          BX7    X2          EXTERNAL NAME, LEFT-JUSTIFIED, ZERO-FILLED 
          SA7    LNKTBL+1 
          SX6    4+X6        SET UPPER BIT AND PARCEL NUMBER
          LX6    9
          BX6    X6+X4       RELOCATION BASE REGISTER 
          LX6    18 
          BX6    X6+X5       ADDRESS
          LX6    30          PUT IN UPPER 30 BITS 
          SA6    A7+B1
          SA1    CALL1
          RJ     =XPUTBIN    PUTBIN(LINKTBL,3)
          EQ     PUTLINK     EXIT 
          SPACE  4
*    *XLINK* TABLE
  
 PUTLINKX BX7    X2          EXTERNAL NAME, LEFT-JUSTIFIED, ZERO-FILLED 
          SA7    XLNKTBL+1
          LX5    6           ADDRESS
          BX6    X5+X3       POSITION 
          LX6    6
          SX7    18          SIZE 
          BX6    X6+X7
          LX6    18 
          BX6    X6+X4       RELOCATION BASE REGISTER 
          SA6    A7+B1
          SA1    CALL2
          RJ     =XPUTBIN    PUTBIN(XLINKTBL,3);
          EQ     PUTLINK     RETURN;
          SPACE  4
**        CLEANUP -  CLEAN UP EXTERNAL NAME 
* 
*         GIVEN- X2 = 42/EXTERNAL NAME, 18/JUNK 
*                         (POSSIBLY BLANK-FILLED) 
* 
*         DOES-  X2 = 42/EXTERNAL NAME, ZERO FILLED, 18/0 
* 
*         USES   B    * - - - - - 7   *B1=1 
*                X  0 - - - - - 6 7 
*                A  - - - - - - - - 
  
  
 CLEANUP  CON    *
          MX0    7*6         STRIP JUNK 
          BX2    X0*X2
          MX0    -6          CHARACTER MASK 
          LX2    6           CHARACTER 1 IN LOWER 6 BITS
          SB7    6           EXAMINE CHARACTERS 2 THROUGH 7 
          SX7    1R 
 CLEANUP1 ZR     B7,CLEANUP2 IF NO MORE CHARACTERS TO EXAMINE, DONE 
          LX2    6           NEXT CHARACTER IN LOWER 6 BITS 
          BX6    -X0*X2 
          SB7    B7-B1       DECREMENT CHARACTER COUNT
          IX6    X6-X7
          NZ     X6,CLEANUP1 IF NONBLANK CHARACTER, LOOP
          BX2    X2-X7       CONVERT BLANK CHARACTER TO BINARY ZERO 
          EQ     CLEANUP1    LOOP 
  
 CLEANUP2 LX2    18          LEFT-JUSTIFY EXTERNAL NAME 
          EQ     CLEANUP     EXIT 
          SPACE  4
 CALL1    CON    LINKTBL
          CON    =3 
          CON    0
 CALL2    CON    XLINKTBL 
          CON    =3 
          CON    0
* 
 WC       EQU    2           WORD COUNT 
 CR       EQU    0           CONDITIONAL REGISTER 
 P        EQU    0           PARCEL NUMBER
 POS      EQU    0           POSITION 
 SIZE     EQU    0           SIZE OF FIELD
 R        EQU    0           RELOCATION BASE REGISTER 
 A        EQU    0           ADDRESS WITHIN BLOCK *R* 
  
 LINKTBL  CON    LNKTBL 
 LNKTBL   VFD    12/4400B,12/WC,15/,9/CR,12/
          VFD    42/0LNAME,18/
          VFD    1/1,2/P,9/R,18/A 
-         VFD    30/
  
 XLINKTBL CON    XLNKTBL
 XLNKTBL  VFD    12/4500B,12/WC,15/,9/CR,12/
          VFD    42/0LNAME,18/
          VFD    6/,24/A,6/POS,6/SIZE,18/R
          LIST   X           LIST *COMDECK EXTDEFS
          SPACE  4
**        DEFEXTS -  DEFINE EXTERNAL NAMES IN CORE
* 
*         DEFEXTS[0] = N = NUMBER OF EXTERNAL NAMES IN TABLE
*         DEFEXTS[1]
*            ...    = EXTERNAL NAME, LEFT-JUSTIFIED, ZERO-FILLED
*         DEFEXTS[N]
  
  
          USE    /DEFEXTS/
 DEFEXTS  BSS    1           NUMBER OF EXTERNAL NAMES 
  
*CALL     EXTDEFS 
  
 N        EQU    *-DEFEXTS
          ORG    DEFEXTS
          CON    N
          USE    *           (GO BACK TO END OF /DEFEXTS/)
          USE    *           (GO BACK TO NORMAL BLOCK)
          SPACE  4
          END 
