!! PACKAGE Updated to IMP8 27/11/81 and 01/03/83 (V3.6)
!! PACKAGE program to assign elements to chips 03/10/79
!!         Updated 27/11/81 - bug fix + change to IMP8
!!         Some changes to the assignment algorithm
!!         Constraint bug fixed 14/12/81
!!         Error trap put in 5/6/85 JHB. (see {jhb})
%BEGIN
%CONSTSTRING(31) HEADING="PACKAGE version 3.7 (APM)"

%systemstring (255) %fnspec itos(%integer v,p)
!%EXTERNALROUTINESPEC RESET INPUT
%EXTERNALINTEGERFNSPEC DEF STREAMS(%STRING(127) STREAMS, DEFAULTS)
%INTEGER RETURN CODE
%OWNSTRING(47) DEFAULTS=".FIC,.LIB,ESDL:TTL74.LIB/%I1.CIC"

!!*******************************************************
!! PACKAGE: Program to assign UNITS to CHIPs            *
!! The list of UNITs is read in from stream 1.          *
!! CHIPs are read in from streams 2 and 3. By           *
!! convention stream 3 is used for the 'system library' *
!! and stream 2 for a user provided library. The user   *
!! library is searched first.                           *
!!                                                      *
!! ASSIGNment works by firstly doing a naive assignment *
!! where UNITs are allocated to CHIPs as densely as     *
!! is permitted by the constraints, and then this       *
!! assignment is 'improved' by (a) cluster building     *
!! and (b) optimising the use of 'empty slots'.         *
!!*******************************************************

!! all strings are stored in a chained hash-table so that
!! commonly used strings are shared. strings may 'own'
!! the object of which they are the name.
%RECORDFORMAT FTAG(%RECORD(*)%NAME OWNER, %INTEGER HNEXT,
                   %STRING(255) NAME)
%CONSTINTEGER TAGLEN=2

!! description of a terminal of a chip - consists of the
!! logical terminal number<<2, flags, and the pin name
%RECORDFORMAT FTERMINAL(%INTEGER INFO,
                        %RECORD(FTAG)%NAME PIN)
%CONSTINTEGER TERMINALLEN=2

!! maximum number of parameters currently used by the system
!! (largest value of PNO in ^P <PNO> )
%CONSTINTEGER MAX PARMS=8

!! description of a chip header. also used when re-reading
!! the source file to produce the updated source.
%RECORDFORMAT FHEAD(%INTEGER OPTIONS,
                    %BYTEINTEGER NIN, NOUT, NIO, NT,
                    %RECORD(FTAG)%NAME UNAME, NAME,
                    %RECORD(FTAG)%NAME %ARRAY PARM(1:MAX PARMS),
                    %RECORD(FTERMINAL)%ARRAY T(1:255))
%CONSTINTEGER HEADLEN=5+MAXPARMS

!! fan element. number of the subinstance and terminal of that
!! subinstance which is being referenced.
%RECORDFORMAT FFANEL(%INTEGER SUBNO, TNO)
%CONSTINTEGER FANLEN=2

!! A net is a list of net fragments. Each net fragment may
!! have its own name and an unlimited (<32767) number of
!! fan elements. A net is a list of all terminals (SUBNO,TNO)
!! at the same electrical potential and has multiple names.
%RECORDFORMAT FFRAGMENT(%RECORD(FTAG)%NAME NAME,
                        %INTEGER FAN,
                        %RECORD(FFANEL)%ARRAY F(1:1023))
%CONSTINTEGER FRAGMENTLEN=2

%RECORDFORMAT FNET(%RECORD(FNET)%NAME NEXT,
                   %BYTEINTEGER FLAGS, NF, DUMMY1, DUMMY2,
                   %RECORD(FFRAGMENT)%NAME %ARRAY F(1:255))
%CONSTINTEGER NETLEN=2

%RECORDFORMAT FTAGLIST(%INTEGER NT,
                       %RECORD(FTAG)%NAME %ARRAY NAME(1:32767))
%CONSTINTEGER TAGLISTLEN=1

!! Description of a subunit. Note that not all parameters are
!! stored, but only AT, ON, PACKAGE, and SUBPACK
!! It is assumed that SUBPACK is an integer.
%RecordFormatSpec Fpackage

%RECORDFORMAT FSUBUNIT(%RECORD(FTAG)%NAME UNAME, NAME, ON, AT, PACKNAME,
                       %BYTEINTEGER NIN, NOUT, NIO, NT,
                       %BYTEINTEGER FLAGS, SUBPACK, DUMMY1, DUMMY2,
                       %RECORD(FSUBUNIT)%NAME NEXT,
                       %RECORD(FPACKAGE)%NAME PACK,
                       %INTEGER SUBNO,
                       %INTEGERARRAY INFO(1:255))
%CONSTINTEGER SUBUNITLEN=10

!! Reference to a chip's terminal.
%RECORDFORMAT FTERMREF(%INTEGER INFO, %RECORD(FTERMINAL)%NAME T)
%CONSTINTEGER TERMREFLEN=2

%RECORDFORMAT FSUBCHIP(%RECORD(FTAG)%NAME UNAME, NAME,
                       %BYTEINTEGER NIN,NOUT,NIO,NT,
                       %RECORD(FTERMREF)%ARRAY TREF(1:254))
%CONSTINTEGER SUBCHIPLEN=3

!! Description of a CHIP. Chips contain SUBCHIPs to which UNITs
!! are assigned.
%RECORDFORMAT FCHIP(%RECORD(FTAG)%NAME NAME,
                    %RECORD(FHEAD)%NAME HEADER,
                    %RECORD(FNET)%NAME GNETS,
                    %BYTEINTEGER FLAGS, NSUBS, DUMMY1, DUMMY2,
                    %RECORD(FSUBCHIP)%NAME %ARRAY SUB(1:253))
%CONSTINTEGER CHIPLEN=4

!! Packages are instances of chips, and reference the relevant
!! chip, as well as recording any constraints applicable to
!! the instance of the chip (such as position or unique name).
%RECORDFORMAT FPACKAGE(%RECORD(FPACKAGE)%NAME NEXT,
                       %RECORD(FCHIP)%NAME CHIP,
                       %RECORD(FTAG)%NAME AT, ON, PACKNAME,
                       %INTEGER PNO,
                       %RECORD(FSUBUNIT)%NAME %ARRAY SUB(1:252))
%CONSTINTEGER PACKLEN=6

%RECORDFORMAT FTASK(%RECORD(FSUBUNIT)%NAME %ARRAY S(1:3987))

!! miscellaneous records used by ASSIGNment improvement
!! routines. Essentially they are used to map the
!! stack for these routines.
%RECORDFORMAT FWORK(%RECORD(FSUBUNIT)%NAME S, %INTEGER C)
%RECORDFORMAT FWORKLIST(%RECORD(FWORK)%ARRAY W(1:3985))
%CONSTINTEGER WORKLEN=2

!! working space
%CONSTINTEGER STACKLEN=50000
%INTEGERARRAY STACK(0:STACKLEN)
%OWNINTEGER TOS,   STACKTOP,   MAXTOS

!! maximum number of fragments allowed in a net
%CONSTINTEGER MAX FRAGS=20

!! i/o streams and associated constants
!! END OF FILE must be <0 and mask to NL.
%CONSTINTEGER ENDFILE=9,   CNTRL=128,   END OF FILE=NL-CNTRL
%CONSTINTEGER CNTRL CHAR='^'
%CONSTINTEGER CONSOLE=0,   MIN=1,   MOUT=1,   SOUT=2
%CONSTINTEGER USERLIB=2,   DEFAULTLIB=3
%OWNINTEGER CH

!! useful constants
%CONSTINTEGER NULL=0
%CONSTINTEGER AT=1,   ON=2,   SUB=4,   PACKNO=3
%CONSTINTEGER SELECTED=1,   NOT SELECTED=2,   CONSTRAINT=4
%CONSTINTEGER SUBCONSTRAINT=8
%CONSTINTEGER GLOBAL=1,   YES=0,   NO=-1
%CONSTINTEGER SELECT ERROR=8
%RECORD(FTAG)%NAME NULL TAG

!! Constants used by the assignment improvement routines
%CONSTINTEGER INFINITY=32767
%CONSTINTEGER IMPROVED=16,   SWOPPED=32
%CONSTINTEGER OPTIMISED=64,   CONSIDERED=128
%CONSTINTEGER FIXED=CONSTRAINT+NOT SELECTED+SELECT ERROR

!! machine dependent constants
%CONSTINTEGER CPW=4;    !! characters per word
%CONSTINTEGER BPW=32;   !! bits per word
%CONSTINTEGER LCPW=2;   !! log characters per word
%CONSTINTEGER AUPW=4;   !! addressing units per word
%CONSTINTEGER LAUPW=2;  !! log addressing units per word

!! TAG types
%CONSTINTEGER GENERAL   =0
%CONSTINTEGER UNITNAME  =1
%CONSTINTEGER CHIPNAME  =2
%CONSTINTEGER PACKNAME  =3
%CONSTINTEGER NETNAME   =4
%CONSTINTEGER DISCARD=-1,   KEEP=0

!! Error message numbers
%CONSTINTEGER NERRORS=6
%CONSTINTEGER D1=1,   D2=2,   D3=3,   D4=4,   D5=5,   D6=6

!! variables used by FAIL etc.
%OWNINTEGER INSTREAM=0
%STRING(63) ERROR CONTEXT

!!************************************************************
!!    Start of utility routines  etc.                        *
!!************************************************************

!! remember the selected input stream
%ROUTINE SELIN(%INTEGER STREAM)
   SELECTINPUT(STREAM)
   INSTREAM=STREAM
%END

%ROUTINE BREAD(%BYTEINTEGERNAME B)
   %INTEGER I
   READ(I)
   B=I&255
%END

%ROUTINESPEC FAIL(%INTEGER MSGNO)

!! routine to claim NWORDS of the workspace (stack organised)
!! and moan if no space is left.
%ROUTINE CLAIM(%INTEGER NWORDS)
   TOS=TOS>>LAUPW+NWORDS
   FAIL(D4) %IF TOS>=STACKTOP
   MAXTOS=TOS %IF TOS>MAXTOS
   TOS=TOS<<LAUPW
%END

%ROUTINE FAIL(%INTEGER MSGNO)
   %SWITCH MESS(1:NERRORS)

   SELECTOUTPUT(CONSOLE)
   PRINTSTRING("* ")
   ->MESS(MSGNO)

MESS(1):
MESS(2): PRINTSTRING("Invalid I-code");                ->ENDERR
MESS(3): PRINTSTRING("No subunits to ASSIGN");         ->STOP
MESS(4): PRINTSTRING("Workspace full");                ->ENDERR
MESS(5): PRINTSTRING("Assignment abandonned");         ->STOP
MESS(6): PRINTSTRING("Too many fragments in net");     ->ENDERR
ENDERR:
   %IF INSTREAM#CONSOLE %START
      PRINTSTRING(" reading stream ")
      WRITE(INSTREAM,0)
   %FINISH
   PRINTSTRING(" (in ");   PRINTSTRING(ERROR CONTEXT);   PRINTSYMBOL(')')
STOP:
   NEWLINE
   %STOP
%END

%ROUTINESPEC SKIP TO(%INTEGER WHERE)

%ROUTINE RCH
   %INTEGER I,   LEN
!! Read the next character from the input
!! Ignore newlines, and build control characters
!! from ^+character.
!! Ignore I-code comments (^K ...)

   %ON %EVENT 3,ENDFILE %START
      CH=END OF FILE
      ->OUT
   %FINISH
START:
   %CYCLE
      READSYMBOL(CH)
   %REPEAT %UNTIL CH#NL

   %IF CH=CNTRL CHAR %START
      READSYMBOL(CH)
      CH=CH+CNTRL
   %FINISH
   %IF CH=CNTRL+'K' %START
      !! skip an I-code comment
      READ(LEN);   RCH
      RCH %FOR I=1,1,LEN
      ->START
   %FINISH
OUT:
%END

%ROUTINE ZERO(%INTEGER NWORDS)
   !! ZERO the top NWORDS of the stack
   %INTEGER I,   P
   P=TOS
   %FOR I=1,1,NWORDS %CYCLE
      INTEGER(P)=0
      P=P+AUPW
   %REPEAT
%END

!!**********************************************
!! hashtable manipulation routines             *
!!**********************************************

!! hashtable for cross referencing UNIT names, NET names, PIN names, etc.
%CONSTINTEGER HASHTABLE LEN=255;   !! must be 2**N-1
%OWNINTEGERARRAY HASHTABLE(0:HASHTABLE LEN)=NULL(*)

%ROUTINE CLEANUP(%INTEGER STACKTOP)
!! Remove references to objects in workspace above
!! STACKTOP (I.E. references to objects which will
!! be overwritten).
   %INTEGER I
   %INTEGERNAME H
   %RECORD(FTAG)%NAME TAG
   STACKTOP=STACKTOP>>LAUPW
   %FOR I=0,1,HASHTABLE LEN %CYCLE
      !! for each hashtable entry
      H==HASHTABLE(I)
      %WHILE H#NULL %CYCLE
         !! for each TAG that hashes to the same entry
         TAG==RECORD(H)
         %IF H>>LAUPW>=STACKTOP %START
            H=TAG_HNEXT
         %ELSE
            H==TAG_HNEXT
         %FINISH
      %REPEAT
   %REPEAT
   TOS=STACKTOP<<LAUPW
%END

%RECORD(FTAG)%MAP READ TAG(%INTEGER TYPE)
   %RECORD(FTAG)%NAME OLD,   NEW
   %INTEGER HASH,   I,   LEN
   %INTEGERNAME H
!! read a name on to the stack and return the name of its TAG.
!! Create a new TAG if one doesn't exist. 
!! Tags of different TYPEs are chained from different
!! hashtable entries, so that a tag of one type can never
!! be confused with an identical tag of another type.
!! (This is important as tags sometimes point to the
!! object of that name. Caveat chip and unit with same name).
   READ(LEN);   RCH
   %IF LEN>0 %START
      !! Not a null string
      HASH=LEN
      ZERO(TAGLEN)
      NEW==RECORD(TOS);   new_name = ""
      %FOR I=1,1,LEN %CYCLE
         RCH
         new_name = new_name.tostring(ch)
         HASH=HASH+CH*i
      %REPEAT
   %FINISH
   !! No TAG if name is null or to be thrown away.
   %RESULT==RECORD(NULL) %IF LEN=0 %OR TYPE=DISCARD

   !! Lookup the name
   HASH=HASH+TYPE
   H==HASHTABLE(HASH & HASHTABLE LEN)
   %WHILE H#NULL %CYCLE
      !! for each name that hashes to the same entry
      OLD==RECORD(H)
      %RESULT==OLD %IF OLD_NAME=NEW_NAME
      H==OLD_HNEXT
   %REPEAT

   !! name not found, so enter into table and create a new TAG.
   H=TOS
   CLAIM(TAGLEN+(LEN+CPW)>>LCPW);   !! Space for string
   %RESULT==NEW
%END

!!*******************************************
!! more miscellaneous input and output      *
!! routines. Used to read I-code objects,   *
!! output I-code objects, and to skip past  *
!! chunks of I-code.                        *
!!*******************************************

%ROUTINE SKIP TAG
   %RECORD(FTAG)%NAME GASH
   GASH==READ TAG(DISCARD)
%END

%RECORD(FHEAD)%MAP READ CHIP HEADER
!! Read an I-code header and map it.
!! This is used by SELECT A CHIP to read in chips.
   %RECORD(FHEAD)%NAME H
   %RECORD(FTERMINAL)%NAME T
   %INTEGER I,   PNO,   PTYPE

   ZERO(HEADLEN);         ! Clear the top of the stack
   H==RECORD(TOS);      ! and map the header
   READ(H_OPTIONS);
   BREAD(H_NIN);   BREAD(H_NOUT);  BREAD(H_NIO);   BREAD(H_NT)
   !! claim space for the header record
   CLAIM(HEADLEN+H_NT*TERMINALLEN)

   H_UNAME==READTAG(GENERAL);      ! Read the unique name of the instance
   H_NAME==READ TAG(CHIPNAME)

   !! Read in the terminal information
   %FOR I=1,1,H_NT %CYCLE
      RCH;            ! Skip ^T
      T==H_T(I)
      READ(T_INFO)
      T_PIN==READTAG(GENERAL);   SKIP TAG
   %REPEAT

   !! Read in the parameter strings
   %CYCLE
      RCH
      %EXIT %UNLESS CH=CNTRL+'P'
      READ(PNO);   SKIPSYMBOL
      %IF PNO=ON %THEN PTYPE=PACKNAME %ELSE PTYPE=GENERAL
      H_PARM(PNO)==READ TAG(PTYPE)
   %REPEAT
   RCH;   !! skip ^G

   !! CH is set to the next control character ^H, ^J, etc.
   %RESULT==H
%END

!! length and max length of an I-code line (for output)
%OWNINTEGER LINECT=0
%CONSTINTEGER LINELEN=60

%ROUTINE PCH(%INTEGER CHAR)
!! put a character to the I-code. Take care of control
!! characters and increment the current line length.
   %IF CHAR>=CNTRL %START
      PRINTSYMBOL(CNTRL CHAR)
      LINECT=LINECT+1
   %FINISH
   PRINTSYMBOL(CHAR&16_7F)
   LINECT=LINECT+1
%END

%ROUTINE SKIPCH
!! Read and print a character. Print NL at end of file
   RCH
   PCH(CH)
%END

%ROUTINE SKIP TO(%INTEGER WHERE)
!! Skip to the character WHERE. Don't move if already there.
   %CYCLE
      %EXIT %IF CH=WHERE %OR CH<0 %OR CH=CNTRL+'E'
      RCH
   %REPEAT
%END

%ROUTINE SKIP UNITS TO(%INTEGER WHERE)
!! Skip past any UNITs to character WHERE.
!! Don't move if already there.
   %CYCLE
      %EXIT %IF CH=WHERE %OR CH<0
      RCH
      SKIP UNITS TO(CNTRL+'E') %IF CH=CNTRL+'U'
   %REPEAT
%END

%ROUTINE SEPARATE
!! Put out a newline to the I-code if required.
   NEWLINE %AND LINECT=0 %IF LINECT>=LINELEN
%END

%ROUTINE PUT TO(%INTEGER WHERE)
!! Skip past characters, putting them out to the I-code
!! until we get to character WHERE.
   %CYCLE
      SEPARATE %IF CH>=CNTRL
      SKIPCH
      PUT TO(CNTRL+'E') %IF CH=CNTRL+'U'
      %EXIT %IF CH=WHERE %OR CH<0
   %REPEAT
%END

%ROUTINE PDEC(%INTEGER N)
!! put a decimal number to the I-code
   WRITE(N,0)
   LINECT=LINECT+2;   ! approximate length
   SEPARATE
%END

%ROUTINE BLANK
   PCH(' ')
%END

%ROUTINE PUT STR(%STRING(255)%NAME S)
   %INTEGER L
!! print out a string in I-code format
   %IF S==STRING(NULL) %THEN L=0 %ELSE L=LENGTH(S)
   WRITE(L,0);   PCH(':')
   PRINTSTRING(S) %UNLESS L=0
   LINECT=LINECT+L+2
   SEPARATE
%END

%ROUTINE PUT TAG(%RECORD(FTAG)%NAME T)
   %STRING(255)%NAME NAME
!! print out a TAG's name in I-code format
   %IF T==RECORD(NULL) %THEN NAME==STRING(NULL) %ELSE NAME==T_NAME
   PUT STR(NAME)
%END

%ROUTINE SKIP NUM
   %INTEGER DISCARD
   READ(DISCARD)
%END

%ROUTINE COPY NUM
   %INTEGER N
   READ(N);   PDEC(N)
%END

%ROUTINE PUT HEAD(%RECORD(FHEAD)%NAME H)
!! output a UNIT or instance header in I-code format
!! This is used to output chip descriptions, and also
!! when rescanning the primary input.
   %INTEGER I
   %RECORD(FTERMINAL)%NAME T
   %RECORD(FTAG)%NAME P

   PCH(CNTRL+'H')
   PDEC(H_OPTIONS);   BLANK
   PDEC(H_NIN);       BLANK
   PDEC(H_NOUT);      BLANK
   PDEC(H_NIO);       BLANK
   PDEC(H_NT);        BLANK
   PUT TAG(H_UNAME);   PUT TAG(H_NAME)

   !! output the TERMINALs
   %FOR I=1,1,H_NT %CYCLE
      T==H_T(I)
      PCH(CNTRL+'T')
      PDEC(T_INFO);   BLANK
      PUT TAG(T_PIN);   PUT TAG(NULL TAG)
   %REPEAT

   !! output the parameters, if present
   %FOR I=1,1,MAX PARMS %CYCLE
      P==H_PARM(I)
      %UNLESS P==RECORD(NULL) %START
         PCH(CNTRL+'P')
         PDEC(I);   BLANK
         PUT TAG(P)
      %FINISH
   %REPEAT
   PCH(CNTRL+'G')
%END

%INTEGERFN STOI(%STRING(255)%NAME S)
!! Read a string as a (positive) integer
!! Ignore characters that are not digits
   %INTEGER I,   N,   D
   N=0
   %FOR I=1,1,LENGTH(S) %CYCLE
      D=CHARNO(S,I)-'0'
      N=N*10+D %If 0<=D<=9
   %REPEAT
   %RESULT=N
%END

%RECORD(FSUBUNIT)%MAP READ SUBUNIT
   %RECORD(FTAG)%NAME TAG
   %RECORD(FSUBUNIT)%NAME S
   %INTEGER PNO,   OPTIONS,   I
   %SWITCH PARM(AT:SUB)
!! Read a subunit (including any enclosed subUNITs)
!! from the primary input.
!! Pin and terminal-name information is thrown away.
!! Only AT, ON, PACKNO, and SUB parameters are retained.
   SKIP NUM
   S==RECORD(TOS);  ZERO(SUBUNITLEN)
   BREAD(S_NIN);   BREAD(S_NOUT);   BREAD(S_NIO);   BREAD(S_NT)
   CLAIM(SUBUNITLEN+S_NT)
   S_UNAME==READ TAG(GENERAL);   TAG==READ TAG(UNITNAME)
   ERROR CONTEXT=TAG_NAME
   S_NAME==TAG;   S_NEXT==TAG_OWNER;   TAG_OWNER==S

   !! Skip terminals
   %FOR I=1,1,S_NT %CYCLE
      RCH;   READ(S_INFO(I));   SKIP TAG;   SKIP TAG
   %REPEAT

   !! Get parameters if any. ON, AT, PACKNO, SUBPACK
   RCH
   %WHILE CH=CNTRL+'P' %CYCLE
      READ(PNO)
      %IF PNO>SUB %START
         SKIP TAG;   ->NEXT
      %FINISH %ELSE %IF PNO=ON %START
         OPTIONS=CHIPNAME
      %ELSE
         OPTIONS=GENERAL
      %FINISH
      TAG==READ TAG(OPTIONS)
      ->PARM(PNO)
PARM(AT):
      S_AT==TAG;   S_FLAGS=S_FLAGS!CONSTRAINT
      ->NEXT
PARM(ON):
      S_ON==TAG
      ->NEXT
PARM(PACKNO):
      S_PACKNAME==TAG;   S_FLAGS=S_FLAGS!CONSTRAINT
      ->NEXT
PARM(SUB):
      S_SUBPACK=STOI(TAG_NAME);   S_FLAGS=CONSTRAINT+SUBCONSTRAINT
      ->NEXT
NEXT:
      RCH
   %REPEAT
   RCH;   !! skip ^G
   %RESULT==S
%END

%RECORD(FNET)%MAP READ NET
   %RECORD(FNET)%NAME NET
   %RECORD(FFRAGMENT)%NAME FRAG
   %RECORD(FFRAGMENT)%NAME %ARRAY TEMP(1:MAX FRAGS)
   %RECORD(FFANEL)%NAME F
   %RECORD(FTAG)%NAME TAG
   %INTEGER I, NF, GLOBALNET
!! Read a NET from the I-code and map it. 
!! A net consists of a number of net-fragments, each of
!! which has a name and a list of fan-elements.
!! A net containing any fragment with a name beginning with '.'
!! is deemed to be 'global' and flagged as such. All global
!! fragments must be collected together before being output.
   NF=0;   GLOBALNET=NO
   !! CH=^N
   %CYCLE
      RCH;   %EXIT %UNLESS CH=CNTRL+'A'
      !! got a fragment
      TAG==READ TAG(NETNAME)
      GLOBALNET=YES %IF CHARNO(TAG_NAME,1)='.'
      FRAG==RECORD(TOS);   FRAG_NAME==TAG;   READ(FRAG_FAN)
      %FOR I=1,1,FRAG_FAN %CYCLE
         F==FRAG_F(I);      READ(F_SUBNO);   READ(F_TNO)
      %REPEAT
      CLAIM(FRAGMENTLEN+FRAG_FAN*FANLEN)
      NF=NF+1
      FAIL(D6) %IF NF>MAX FRAGS
      TEMP(NF)==FRAG
   %REPEAT

   !! CH set to next control char (not ^A)
   NET==RECORD(TOS);   ZERO(NETLEN)
   CLAIM(NETLEN+NF)
   %FOR I=1,1,NF %CYCLE
      NET_F(I)==TEMP(I)
   %REPEAT
   NET_NF=NF;   NET_FLAGS=GLOBAL %IF GLOBALNET=YES
   %RESULT==NET
%END

!!**************************************************
!! start of routine used to select chips from the  *
!! chip library.                                   *
!!**************************************************

%PREDICATE SAME KIND(%RECORD(FSUBUNIT)%NAME U, %RECORD(FSUBCHIP)%NAME S)
   %INTEGER I
!! Decide whether or not a subUNIT and a subCHIP are of the same sort.
!! They must have the same name, same number of terminals,
!! and corresponding terminals must have the same type and number (INFO).
   %IF U_NAME==S_NAME %AND U_NT=S_NT %START
      %FOR I=1,1,U_NT %CYCLE
         ->OUT %UNLESS U_INFO(I)=S_TREF(I)_INFO
      %REPEAT
      %TRUE
   %FINISH
OUT:
   %FALSE
%END

!! Global variables for the selection and assignment processes
%INTEGER NSUBUNITS,   NPACKAGES,   NO TO SELECT,   NO NOT SELECTED
%RECORD(FTASK)%NAME TASK
%RECORD(FPACKAGE)%NAME PACKAGES
%RECORD(FNET)%NAME NETS

%ROUTINE SELECT CHIPS
   %INTEGER FLAG,   OLDTOS,   OPTIONS,   TYPE,   LEN
   %INTEGER I,   J
   %RECORD(FSUBUNIT)%NAME U
   %RECORD(FNET)%NAME NET
   %RECORD(FCHIP)%NAME CHIP
   %RECORD(FSUBCHIP)%NAME SC
   %RECORD(FHEAD)%NAME H
!! select chips from the I-code. A chip is selected if (a) it
!! is explicitly named in an ON string or (b) there is a UNIT
!! which has no ON string and which is the SAME KIND as some
!! sub-element of the chip (subchip).

%PREDICATE IN DICTIONARY(%RECORD(FTAG)%NAME TAG)
!! decide whether TAG was already in dictionary
!! before the last call of SELECT A CHIP.
   %TRUE %IF (ADDR(TAG)>>LAUPW) < (OLDTOS>>LAUPW)
   %FALSE
%END

%ROUTINE XREF(%RECORD(FNET)%NAME NET)
   %RECORD(FFANEL)%NAME F,   F1
   %RECORD(FFRAGMENT)%NAME FR
   %RECORD(FHEAD)%NAME H
   %RECORD(FTERMINAL)%NAME TERMINAL
   %INTEGER I, N
!! First find whether the net references an external terminal of the chip.
!! If so then make all sub-chip terminals referenced by the net
!! reference this external terminal. This provides a quick mapping
!! between subUNIT logical terminal numbers and chip logical terminal
!! numbers for later on when nets have to be 'relocated'.
   %FOR N=1,1,NET_NF %CYCLE
      FR==NET_F(N)
      %FOR I=1,1,FR_FAN %CYCLE
         F==FR_F(I)
         ->GOT NET %IF F_SUBNO=0
      %REPEAT
   %REPEAT
   !! net id completely internal to the chip
   %RETURN
GOT NET:
   !! make subchip terminals point at the relevant chip terminal
   !! taking care to point to the correct terminal in the
   !! presence of input-outputs
   H==CHIP_HEADER
   %FOR I=F_TNO,1,H_NT %CYCLE
      TERMINAL==H_T(I)
      %EXIT %IF TERMINAL_INFO>>2 = F_TNO
   %REPEAT
   %FOR N=1,1,NET_NF %CYCLE
      FR==NET_F(N)
      %FOR I=1,1,FR_FAN %CYCLE
         F1==FR_F(I)
         %CONTINUE %IF F1_SUBNO=0
         !! got a reference to a subchip
         CHIP_SUB(F1_SUBNO)_TREF(F1_TNO)_T==TERMINAL
      %REPEAT
   %REPEAT
%END

   !! start of SELECT A CHIP
   RCH
   %RETURN %IF CH=END OF FILE
   !! Expect ^U or ^S
   %IF CH=CNTRL+'S' %THEN READ(FLAG) %AND RCH
   FAIL(D2) %UNLESS CH=CNTRL+'U'

   !! read the chip header
   OLDTOS=TOS
   READ(TYPE);   RCH
   H==READ CHIP HEADER

   !! ignore the chip if it is a duplicate
   %UNLESS H_NAME_OWNER==RECORD(NULL) %START
      PRINTSTRING("*Duplicate chip ")
      PRINTSTRING(H_NAME_NAME)
      PRINTSTRING(" ignored");   NEWLINE
      CLEANUP(OLDTOS)
      ->OUT
   %FINISH

   !! build the fixed part of the chip
   SKIP UNITS TO(CNTRL+'J')
   CHIP==RECORD(TOS);   ZERO(CHIPLEN)
   BREAD(CHIP_NSUBS);   CLAIM(CHIPLEN+CHIP_NSUBS)
   CHIP_HEADER==H;   CHIP_NAME==H_NAME
   ERROR CONTEXT=CHIP_NAME_NAME

   !! Build the subchips
   FLAG=DISCARD
   %FOR I=1,1,CHIP_NSUBS %CYCLE
      !! get to the sub-element's header
      SKIP TO(CNTRL+'H');   Skip Num
      !! build the subchip record
      SC==RECORD(TOS);   CLAIM(SUBCHIPLEN)
      !! and reference it
      CHIP_SUB(I)==SC
      BREAD(SC_NIN); BREAD(SC_NOUT); BREAD(SC_NIO); BREAD(SC_NT)
      !! claim and initialise space for the terminal references.
      LEN=SC_NT*TERMREFLEN;   ZERO(LEN);   CLAIM(LEN)

      !! read name of subchip
      SC_UNAME==READ TAG(GENERAL);   SC_NAME==READ TAG(UNITNAME)

      !! read the terminal info. discard pin and terminal names
      %FOR J=1,1,SC_NT %CYCLE
         RCH;   READ(SC_TREF(J)_INFO)
         SKIP TAG;   SKIP TAG
      %REPEAT

      !! if the subchip has been referred to then possibly
      !! select it. select it only if the UNIT referencing
      !! the subchip explicitly requests this chip (ON string)
      !! or if the subchip is of the same kind as the UNIT.
      %IF IN DICTIONARY(SC_NAME) %START
         U==SC_NAME_OWNER
         !! select this chip for all UNITs of the same kind as U.
         %WHILE %NOT U==RECORD(NULL) %CYCLE
            %IF (U_ON==CHIP_NAME %OR U_ON==RECORD(NULL)) %AND %C
                  SAME KIND(U,SC) %START
               %IF U_FLAGS&SELECTED=0 %START
                  U_FLAGS=U_FLAGS!SELECTED
                  U_ON==CHIP_NAME
                  FLAG=KEEP;   !! and keep the chip
                  NO TO SELECT=NO TO SELECT - 1
               %FINISH
            %FINISH
            U==U_NEXT
         %REPEAT
      %FINISH
   %REPEAT

   %IF FLAG=DISCARD %START
      !! Throw away the chip
      !! First see if anything was constrained to it.
      !! set SELECT ERROR if a UNIT was constrained to a chip
      !! containing no such sub-chip.
      %FOR I=1,1,CHIP_NSUBS %CYCLE
         U==CHIP_SUB(I)_NAME_OWNER
         %WHILE %NOT U==RECORD(NULL) %CYCLE
            %IF U_ON==CHIP_NAME %AND U_FLAGS&(SELECTED+SELECT ERROR)=0 %START
               U_FLAGS=U_FLAGS!SELECT ERROR
               NO TO SELECT=NO TO SELECT-1
               NO NOT SELECTED=NO NOT SELECTED+1
               U_ON_OWNER==RECORD(DISCARD)
            %FINISH
            U==U_NEXT
         %REPEAT
      %REPEAT
      !! remove dictionary entries (dangling references)
      CLEANUP(OLDTOS)
      ->OUT
   %FINISH

   !! keep the chip, so make its name own it, and
   !! read in all the nets local to the chip. Only
   !! 'global signals' (net name begins with '.')
   !! are kept, as these must be amalgamated with
   !! the other global signals at output time.
   CHIP_NAME_OWNER==CHIP
   SKIP TO(CNTRL+'N')
   %WHILE CH=CNTRL+'N' %CYCLE
      OLDTOS=TOS;   NET==READ NET
      !! make all terminals referenced by the net reference the
      !! chip's terminals if this is possible.
      XREF(NET)
      %IF NET_FLAGS&GLOBAL#0 %START
         !! keep the net -  chain it to the chip
         NET_NEXT==CHIP_GNETS;   CHIP_GNETS==NET
      %ELSE
         !! throw away the net and remove dangling references
         CLEANUP(OLDTOS)
      %FINISH
   %REPEAT

OUT:
   SKIP TO(CNTRL+'E')
%END

%PREDICATE SAME(%RECORD(FSUBUNIT)%NAME U, V)
   %INTEGER I
!! Decide whether U and V are the same kind of UNIT.
!! To be the same U and V must have the same name,
!! the same number of terminals, and corresponding
!! terminals must have the same type and terminal number (INFO).
   %IF U_NAME==V_NAME %AND U_NT=V_NT %START
      %FOR I=1,1,U_NT %CYCLE
         ->OUT %UNLESS U_INFO(I)=V_INFO(I)
      %REPEAT
      %TRUE
   %FINISH
OUT:
   %FALSE
%END

%RECORD(FTAG)%MAP UNKNOWN
   %OWNINTEGER P=NULL
   %RECORD(FTAG)%NAME TAG
!! create a tag with name "UNKNOWN" if one
!! hasn't already been created. Return its address
   %IF P=NULL %START
      P=TOS;    TAG==RECORD(P);   ZERO(TAGLEN)
      TAG_NAME="UNKNOWN";   CLAIM(TAGLEN+(7+CPW)>>LCPW)
   %ELSE
      TAG==RECORD(P)
   %FINISH
   %RESULT==TAG
%END

%RECORD(FTAG)%MAP INT TO TAG(%INTEGER N)
   %RECORD(FTAG)%NAME TAG
!! create a tag having the character value of N as name.
   TAG==RECORD(TOS);   ZERO(TAGLEN)
   TAG_NAME=ITOS(N,0)
   CLAIM(TAGLEN+(LENGTH(TAG_NAME)+CPW)>>LCPW)
   %RESULT==TAG
%END

%PREDICATE COMPATIBLE(%RECORD(FTAG)%NAME A, B)
!! %TRUE if A=B, or A=null or B=null.
   %IF A==B %OR A==NULL TAG %OR B==NULL TAG %THEN %TRUE
   %FALSE
%END

!!********************************************************
!! Naive assignment. This routine assigns elements to    *
!! packages in the order in which the elements occur in  *
!! the source text. Packages are filled as fully as      *
!! poossible subject to constraints. Constraints may be  *
!! of two kinds: AT and PACKNO/SUBPACK. Two elements with*
!! different constraints CANNOT be assigned to the same  *
!! package. Two elements with the same constaints MUST be*
!! assigned to the same package.                         *
!!********************************************************

%ROUTINE NAIVE ASSIGNMENT
   %INTEGER PASS,   I,   FLAGS
   %RECORD(FSUBUNIT)%NAME SU
   %CONSTINTEGER CONSTRAINED=1,   UNCONSTRAINED=2

%ROUTINE ALLOCATE(%RECORD(FSUBUNIT)%NAME SU)
   %CONSTINTEGER OK=1,   WRONG SORT=2,   NO ROOM=3
   %RECORD(FCHIP)%NAME CHIP
   %RECORD(FPACKAGE)%NAME PACK,   LPACK
   %INTEGER RESULT,   LEN

   %ROUTINE PLACE(%RECORD(FSUBUNIT)%NAME U, %INTEGERNAME RESULT)
      %INTEGER I,   R,   SUBPACK
!! place subunit U on the current chip if this is possible.
!! RESULT takes the value NO ROOM if the chip is full, and
!! the value WRONG SORT if there is no empty slot of the
!! same kind as U (or no slots at all of kind U).
      R=NO ROOM;   SUBPACK=U_SUBPACK
      %FOR I=1,1,CHIP_NSUBS %CYCLE
         %CONTINUE %IF SUBPACK#0 %AND SUBPACK#I
         %IF PACK_SUB(I)==RECORD(NULL) %START
            !! Got a free slot for the subUNIT
            R=WRONG SORT
            %IF SAME KIND(U,CHIP_SUB(I)) %START
               !! And the slot is of the right sort
               R=OK;   PACK_SUB(I)==U
               PACK_PACKNAME==SU_PACKNAME %IF PACK_PACKNAME==NULL TAG
               PACK_AT==SU_AT %IF PACK_AT==NULL TAG
               U_PACK==PACK;   U_SUBPACK=I
               ->OUT
            %FINISH
         %FINISH
      %REPEAT
   OUT:
      RESULT=R
   %END

!! allocate subunit SU. First try to place it on an existing
!! package. This may fail if all existing packages are full, if
!! the constraints for U are incompatible with those of all
!! existing packages, or if there is no element of kind U
!! on any of the existing packages. In this case a new 
!! package is constructed and added to the list of packages.

   PACK==PACKAGES
   %WHILE %NOT PACK_NEXT==RECORD(NULL) %CYCLE
      PACK==PACK_NEXT;   CHIP==PACK_CHIP
      !! check that element's ON string is compatible
      !! with the name of the package.
      %CONTINUE %UNLESS COMPATIBLE(SU_ON,CHIP_NAME)
      !! see if element is constrained or package is constrained.
      %IF (%NOT PACK_AT==NULL TAG %AND %NOT SU_AT==NULL TAG) %C
     %OR (%NOT PACK_PACKNAME==NULL TAG %AND %NOT SU_PACKNAME==NULL TAG) %START
         !! both are constrained
         %IF SU_FLAGS&CONSTRAINT#0 %AND %C
            ((SU_AT==PACK_AT %AND COMPATIBLE(SU_PACKNAME,PACK_PACKNAME)) %OR %C
            (SU_PACKNAME==PACK_PACKNAME %AND COMPATIBLE(SU_AT,PACK_AT))) %START

            !! Element constrained to this pack
            PLACE(SU,RESULT)
            ->OUT %IF RESULT=OK
            !! can't meet the constraint.
            PRINTSTRING("* ")
            %IF RESULT=NO ROOM %START
               !! no room on package
               PRINTSTRING("Too many elements constrained ")
               %UNLESS SU_SUBPACK=0 %START
                  PRINTSTRING("to subposition ")
                  WRITE(SU_SUBPACK,0)
                  %IF %NOT SU_PACKNAME==NULL TAG %START
                     PRINTSTRING(" on pack ")
                     PRINTSTRING(SU_PACKNAME_NAME)
                  %FINISH
                  SU_SUBPACK=0
               %FINISH
               %IF %NOT PACK_AT==NULL TAG %START
                  PRINTSTRING(" at ")
                  PRINTSTRING(PACK_AT_NAME)
               %FINISH
            %ELSE
               !! constrained element to wrong sort of chip
               PRINTSTRING(SU_NAME_NAME)
               PRINTSTRING(" is not on ")
               PRINTSTRING(CHIP_NAME_NAME)
            %FINISH
            NEWLINE
            SU_FLAGS=SU_FLAGS&(\CONSTRAINT)
            ->OUT
         %FINISH
      %ELSE
         !! Pack unconstrained, or subunit unconstrained
         !! Pack may be constrained to a particular subpackage posn.
         PLACE(SU,RESULT)
         -> OUT %IF RESULT=OK
      %FINISH
   %REPEAT

   !! Build a new package
   NPACKAGES=NPACKAGES+1;   PACK_NEXT==RECORD(TOS);   PACK==PACK_NEXT
   CHIP==SU_ON_OWNER;   !! Must exist as all SELECTED units have chips 
   LEN=PACKLEN+CHIP_NSUBS;   ZERO(LEN);   CLAIM(LEN)
   PACK_CHIP==CHIP;   PACK_ON==CHIP_HEADER_PARM(ON)
   PLACE(SU,RESULT);   !! RESULT must be OK !!!
   PACK_ON==UNKNOWN %IF PACK_ON==RECORD(NULL)
   LPACK==PACK_ON_OWNER;   LPACK==PACK %IF LPACK==RECORD(NULL)
   PACK_PNO=LPACK_PNO+1;   PACK_ON_OWNER==PACK
OUT:
%END

!! NAIVE ASSIGNMENT: Firstly assign all the constrained elements.
!! then assign the unconstrained elements, packing them onto
!! packages as tightly as possible.
   %FOR PASS=CONSTRAINED,1,UNCONSTRAINED %CYCLE
      %FOR I=1,1,NSUBUNITS %CYCLE
         SU==TASK_S(I)
         FLAGS=SU_FLAGS
         %IF FLAGS&SELECTED#0 %START
            %IF (PASS=CONSTRAINED %AND FLAGS&CONSTRAINT#0) %OR %C
             (PASS=UNCONSTRAINED %AND FLAGS&CONSTRAINT=0) %START
               ALLOCATE(SU)
            %FINISH
         %FINISH
      %REPEAT
   %REPEAT
%END

%ROUTINE COUNT PACKAGES
   %RECORD(FPACKAGE)%NAME PACK
   WRITE(NSUBUNITS-NO NOT SELECTED,0)
   PRINTSTRING(" subunits assigned to ")
   WRITE(NPACKAGES,0); PRINTSTRING(" packages"); NEWLINE

   %IF NPACKAGES>0 %START
      PRINTSTRING("Package requirements:"); NEWLINE
      PACK==PACKAGES_NEXT
      %WHILE %NOT PACK==RECORD(NULL) %CYCLE
         %IF PACK_ON_OWNER==PACK %START
            WRITE(PACK_PNO,3); SPACE
            PRINTSTRING(PACK_ON_NAME); NEWLINE
         %FINISH
         PACK==PACK_NEXT
      %REPEAT
   %FINISH

   %IF NO NOT SELECTED>0 %START
      PRINTSTRING("* "); WRITE(NO NOT SELECTED,0)
      PRINTSTRING(" elements not assigned to packages")
      NEWLINE
   %FINISH
%END

!!*********************************************
!!  ASSIGNment improvement routines          *
!!*********************************************

!!*** ROUTINES TO BUILD AND INTERROGATE A CONNECTIVITY MATRIX ***
!!*** THESE ARE HIGHLY MACHINE DEPENDENT (FOR EFFICIENCY)     ***

%INTEGER MATRIX

%BYTEINTEGERMAP C(%INTEGER I,J)
%OWNBYTEINTEGER ZERO=0
   ZERO=0 %AND %RESULT==ZERO %IF I=J
   %IF I>J %THEN %RESULT==BYTEINTEGER(MATRIX+((I-1)*(I-2))>>1+J-1) %C
           %ELSE %RESULT==BYTEINTEGER(MATRIX+((J-1)*(J-2))>>1+I-1)
%END

%ROUTINE BUILD CONNECTIVITY MATRIX(%Integer NSUBS)
   %INTEGER I, J, S1, S2, F, MATRIXLEN, LEN
   %RECORD(FFRAGMENT)%NAME FR
   %RECORD(FNET)%NAME NET
   %BYTEINTEGERNAME CV
!! build a connectivity matrix.
!! this is done by scanning the nets which have been stored.
!! initisalise the matrix (machine dependent)
   MATRIXLEN=((NSUBS-1)*NSUBS)>>1-1
   MATRIX=TOS; LEN=(MATRIXLEN+AUPW)>>LAUPW
   ZERO(LEN);  CLAIM(LEN)

   NET==NETS_NEXT
   %WHILE %NOT NET==RECORD(NULL) %CYCLE
      %FOR F=1,1,NET_NF %CYCLE
         FR==NET_F(F)
         %FOR I=1,1,FR_FAN %CYCLE
            S1=FR_F(I)_SUBNO
            %CONTINUE %IF S1=0
            !! get the row number for the matrix entry
            S1=TASK_S(S1)_SUBNO
            %CONTINUE %IF S1=0;  ! Not selected for improvement
            %FOR J=1,1,FR_FAN %CYCLE
               S2=FR_F(J)_SUBNO
               %CONTINUE %IF S2=0
               S2=TASK_S(S2)_SUBNO
               ! Continue if not selected for improvement (S2=0)
               %CONTINUE %IF S2=0 %OR S1>=S2
               CV==C(S1,S2)
               CV=CV+1
            %REPEAT
         %REPEAT
      %REPEAT
      NET==NET_NEXT
   %REPEAT
%END

!!*************************************************
!! routine to improve the assignment of elements  *
!! of one kind. The improvement is effected by    *
!! growing clusters of highly connected elements  *
!! on each package. During this process the empty *
!! slots are allowed to float around.             *
!!*************************************************

%ROUTINE IMPROVE(%RECORD(FWORKLIST)%NAME SUBTASK, %INTEGER NSUBS)
   %INTEGER I, J, CONN, SPJ
   %RECORD(FWORK)%NAME WI, WJ, W
   %RECORD(FWORK) TEMP
   %RECORD(FSUBUNIT)%NAME SI, SJ, SLOT
   %RECORD(FPACKAGE)%NAME PI, PJ
   %BYTEINTEGERNAME CV

%RECORD(FWORK)%MAP MOST CONNECTED TO(%INTEGER A)
   %INTEGER MCOST, COST, I, NCTA, NCTB, NCBAB, NCBAS
   %RECORD(FWORK)%NAME WA,   WB,   W
!! find the element most connected to element A.
!! connectivity is defined as the number of connections
!! to A + number of connections to the element - twice
!! the number of connections between A and the element.
!! Thus the most connected element to A should share
!! a package with A in order to minimise the total connectivity.
   W==RECORD(NULL)
   WA==SUBTASK_W(A)
   NCTA=WA_C;   !! no of connections to A
   MCOST=INFINITY;   NCBAS=0
   %FOR I=A+1,1,NSUBS %CYCLE
      WB==SUBTASK_W(I)
      %CONTINUE %IF WB_S_FLAGS&SWOPPED#0
      NCTB=WB_C;   !! no of connections to B
      NCBAB=C(WA_S_SUBNO,WB_S_SUBNO);   !! no of connections between A and B
      COST=NCTA+NCTB-NCBAB-NCBAB;   !! cost of swop
      %IF COST<MCOST %OR (COST=MCOST %AND NCBAB>NCBAS) %START
         MCOST=COST;   NCBAS=NCBAB
         W==WB
      %FINISH
   %REPEAT
   %RESULT==W
%END

!! firstly set up the total number of connections (star connectivity)
!! to each element in the list (SUBTASK).
   %FOR I=1,1,NSUBS %CYCLE
      CONN=0
      %FOR J=1,1,NSUBS %CYCLE
         CONN=CONN+C(I,J)
      %REPEAT
      SUBTASK_W(I)_C=CONN
   %REPEAT

!! sort this list into order of descending connectivity
!! for convenience of later processing.
   %FOR I=1,1,NSUBS %CYCLE
      WI==SUBTASK_W(I)
      W==WI
      %FOR J=1,1,NSUBS %CYCLE
         WJ==SUBTASK_W(J)
         W==WJ %IF WJ_C>W_C
      %REPEAT
      TEMP=WI;   WI=W;   W=TEMP
   %REPEAT

!! for each element in turn that hasn't yet been swopped,
!! locate the package on which that element resides.
!! For each location on the package find the most connected
!! element (if there is one) and swop it with the slot.
   %FOR I=1,1,NSUBS %CYCLE
      WI==SUBTASK_W(I)
      SI==WI_S
      !! continue if already swopped or constrained to this sub-posn
      %CONTINUE %IF SI_FLAGS&(SWOPPED+SUBCONSTRAINT)#0
      PI==SI_PACK

      !! for each slot on the pack
      %FOR J=1,1,PI_CHIP_NSUBS %CYCLE
         SLOT==PI_SUB(J)
         %CONTINUE %IF SLOT==SI %OR %NOT SAME KIND(SI,PI_CHIP_SUB(J))
         %CONTINUE %UNLESS SLOT==RECORD(NULL) %OR SLOT_FLAGS&CONSTRAINT=0
         !! got a slot that is swoppable and not constrained
         WJ==MOST CONNECTED TO(I)
         %CONTINUE %IF WJ==RECORD(NULL)
         SJ==WJ_S;   PJ==SJ_PACK;   SPJ=SJ_SUBPACK
         %IF PI==PJ %THEN {same package - no point in swop} %START
            SJ_FLAGS=SJ_FLAGS!SWOPPED
            %CONTINUE
         %FINISH
         !! different packages - swop unless constrained
         %CONTINUE %UNLESS SJ_FLAGS&CONSTRAINT=0
         !! swop SJ with SLOT
         PI_SUB(J)==SJ;   PJ_SUB(SPJ)==SLOT
         SJ_PACK==PI;     SJ_SUBPACK=J
         %IF %NOT SLOT==RECORD(NULL) %START
            SLOT_PACK==PJ;   SLOT_SUBPACK=SPJ
         %FINISH
         SJ_FLAGS=SJ_FLAGS!SWOPPED
      %REPEAT
   %REPEAT
%END

!!*********************************************************
!! optimise the use of empty slots. swop elements to empty*
!! slots if there is an overall reduction in connectivity *
!! as a result.                                           *
!!*********************************************************

%ROUTINE OPTIMISE(%RECORD(FWORKLIST)%NAME SUBTASK, %INTEGER NSUBS)
   %INTEGER I, J, K, MGAIN, GAIN
   %RECORD(FSUBUNIT)%NAME SU, SA, SB
   %RECORD(FPACKAGE)%NAME PACK
   %RECORD(FCHIP)%NAME CHIP

%INTEGERFN CONNECTIONS(%RECORD(FSUBUNIT)%NAME S, %RECORD(FPACKAGE)%NAME P)
   %INTEGER NC, I, J
   %RECORD(FSUBUNIT)%NAME SU
!! calculate the number of connections between the element S
!! and the elements of the package P.
   I=S_SUBNO
   NC=0
   %FOR J=1,1,P_CHIP_NSUBS %CYCLE
      SU==P_SUB(J)
      %CONTINUE %IF SU==RECORD(NULL)
      NC=NC+C(I,SU_SUBNO)
   %REPEAT
   %RESULT=NC
%END

!! search for an empty slot. Then search for the
!! best element to fill it. Swop the element and
!! the empty slot if an overall reduction in 
!! connectivity results.
   %FOR I=1,1,NSUBS %CYCLE
      SU==SUBTASK_W(I)_S
      PACK==SU_PACK;   CHIP==PACK_CHIP
      %FOR J=1,1,CHIP_NSUBS %CYCLE
         SA==PACK_SUB(J)
         %UNLESS SA==RECORD(NULL) %START
            SA_FLAGS=SA_FLAGS!CONSIDERED
            %CONTINUE
         %FINISH
         %CONTINUE %UNLESS SAME KIND(SU,CHIP_SUB(J))
         !! Got an empty slot of the correct kind
         MGAIN=-1
         %FOR K=1,1,NSUBS %CYCLE
            SA==SUBTASK_W(K)_S
            %CONTINUE %UNLESS SA_FLAGS&FIXED=0 %AND SAME(SA,SU)
            GAIN=CONNECTIONS(SA,PACK)-CONNECTIONS(SA,SA_PACK)
            %IF GAIN>MGAIN %START
               SB==SA;   MGAIN=GAIN
            %FINISH
         %REPEAT
         %IF MGAIN>0 %START
            !! benefit from a swop
            SB_PACK_SUB(SB_SUBPACK)==RECORD(NULL)
            SB_PACK==PACK;   SB_SUBPACK=J
            PACK_SUB(J)==SB
            SB_FLAGS=SB_FLAGS!CONSIDERED
         %FINISH
      %REPEAT
   %REPEAT
%END

%ROUTINE IMPROVE KIND(%INTEGER INDEX, FLAG)
   %RECORD(FSUBUNIT)%NAME SU, SA
   %INTEGER I, OLDTOS, NSUBS,   LEN
   %RECORD(FWORKLIST)%NAME SUBTASK
!! if FLAG is IMPROVED then improve the assignment of elements
!! of kind INDEX. Otherwise optimise the use of empty slots
!! on packages containing elements of kind INDEX.
   SU==TASK_S(INDEX)
   OLDTOS=TOS;   SUBTASK==RECORD(TOS)
   NSUBS=0
   %FOR I=INDEX,1,NSUBUNITS %CYCLE
      !! select subunits for improvement
      SA==TASK_S(I)
      !! Ignore if fixed or on wrong sort of chip
      %CONTINUE %IF SA_FLAGS&FIXED#0 %OR %NOT SA_ON==SU_ON
      !! Ignore if element is of wrong kind (can only happen
      !! if more than one kind of element on a package)
      %CONTINUE %UNLESS SAME(SA,SU)
      NSUBS=NSUBS+1
      SUBTASK_W(NSUBS)_S==SA
      SA_SUBNO=NSUBS
      SA_FLAGS=SA_FLAGS!FLAG
      CLAIM(WORKLEN)
   %REPEAT
   BUILD CONNECTIVITY MATRIX(NSUBS)
   %IF FLAG=IMPROVED %THEN IMPROVE(SUBTASK,NSUBS) %C
                     %ELSE OPTIMISE(SUBTASK,NSUBS)
   SUBTASK_W(I)_S_SUBNO=0 %FOR I=1,1,NSUBS
   TOS=OLDTOS
%END

%ROUTINE IMPROVE ASSIGNMENT
   %INTEGER I,   FLAG,   PASS
   %RECORD(FSUBUNIT)%NAME SU
   FLAG=IMPROVED
   %FOR PASS=1,1,2 %CYCLE
   !! on the first pass we improve the assignment of
   !! particular kinds of subunits. On the second
   !! pass we optimise the use of empty slots on
   !! particular kinds of chip.
   %FOR I=1,1,NSUBUNITS %CYCLE
      SU==TASK_S(I)
      %IF SU_FLAGS&(FIXED+FLAG)=0 %AND SU_PACK_CHIP_NSUBS>=2 %START
         !! element is free to move, has not had its placement improved,
         !! and lives on a package with at least 2 subpackages.
         IMPROVE KIND(I,FLAG)
      %FINISH
   %REPEAT
   FLAG=OPTIMISED
   %REPEAT
%END

!!**********************************************
!!          Output  Routines                   *
!! These must cope with outputting subUNITs,   *
!! net fragments, and with outputting global   *
!! nets. Global nets must have all fragments   *
!! of the same name amalgamated before they are*
!! output. This is a transitive closure        *
!! operation.
!!**********************************************

!! variables used by output global nets routines
%RECORD(FTAGLIST)%NAME GTAGS,   WORKLIST

%ROUTINE LOOKUP(%RECORD(FTAG)%NAME NAME, %RECORD(FTAGLIST)%NAME DICT)
   %INTEGER I, NT
!! Assume that DICT is on the top of teh stack.
!! Lookup NAME in DICT and if not found the add NAME to DICT.
!! This is used to form the list of names of all global fragments,
!! and to form the list of names of all global fragments in a given
!! net.
   NT=DICT_NT
   %FOR I=1,1,NT %CYCLE
      %RETURN %IF DICT_NAME(I)==NAME
   %REPEAT
   NT=NT+1
   CLAIM(1)
   DICT_NAME(NT)==NAME
   DICT_NT=NT
%END

%ROUTINE GET GLOBAL NAMES
   %RECORD(FPACKAGE)%NAME PACK
   %RECORD(FCHIP)%NAME CHIP
   %RECORD(FFRAGMENT)%NAME FR
   %RECORD(FNET)%NAME NET
   %INTEGER I
!! form the list of all global fragment names in the record GTAGS.
!! This is done by searching the list of CHIPs, and searching the
!! list of global nets hung off each CHIP.
!! Multiple PACKs may point at one CHIP, so the CHIP is flagged
!! once it has been CONSIDERED.
   GTAGS==RECORD(TOS);   GTAGS_NT=0;   CLAIM(TAGLISTLEN)
   PACK==PACKAGES_NEXT
   %WHILE %NOT PACK==RECORD(NULL) %CYCLE
      PACK_PNO=0;   !! for later
      CHIP==PACK_CHIP
      PACK==PACK_NEXT
      %CONTINUE %IF CHIP_FLAGS&CONSIDERED#0
      CHIP_FLAGS=CONSIDERED
      NET==CHIP_GNETS
      %WHILE %NOT NET==RECORD(NULL) %CYCLE
         %FOR I=1,1,NET_NF %CYCLE
            FR==NET_F(I)
            LOOKUP(FR_NAME,GTAGS)
         %REPEAT
         NET==NET_NEXT
      %REPEAT
   %REPEAT
%END

%ROUTINE REMOVE NAME(%RECORD(FTAGLIST)%NAME LIST, %RECORD(FTAG)%NAME NAME)
   %INTEGER I
!! Remove the name NAME from the list of tags LIST
   %FOR I=1,1,LIST_NT %CYCLE
      %IF LIST_NAME(I)==NAME %START
         LIST_NAME(I)==LIST_NAME(LIST_NT)
         LIST_NT=LIST_NT-1
         %RETURN
      %FINISH
   %REPEAT
%END

%ROUTINE REMOVE(%RECORD(FTAGLIST)%NAME A, B)
   %INTEGER I
!! remove the list of global fragment names B from the list
!! of global fragment names A. This is used to remove the
!! contents of WORKLIST from GTAGS. Eventually GTAGS becomes
!! empty and there is no more work to do.
   %FOR I=1,1,B_NT %CYCLE
      REMOVE NAME(A,B_NAME(I))
   %REPEAT
%END

%INTEGERFN COUNT GLOBAL FAN(%RECORD(FTAG)%NAME NAME)
   %INTEGER COUNT, I, J
   %RECORD(FNET)%NAME NET
   %RECORD(FFRAGMENT)%NAME FR
   %RECORD(FPACKAGE)%NAME PACK
!! count the total number of terminals referenced from global
!! net fragments of name NAME. Only CHIP terminals are counted
!! (I.E. connections internal to a chip are ignored).
   COUNT=0;   PACK==PACKAGES_NEXT
   %WHILE %NOT PACK==RECORD(NULL) %CYCLE
      NET==PACK_CHIP_GNETS
      %WHILE %NOT NET==RECORD(NULL) %CYCLE
         %FOR I=1,1,NET_NF %CYCLE
            FR==NET_F(I)
            %CONTINUE %UNLESS FR_NAME==NAME
            %FOR J=1,1,FR_FAN %CYCLE
               COUNT=COUNT+1 %IF FR_F(J)_SUBNO=0
            %REPEAT
            ->NEXT PACK
         %REPEAT
         NET==NET_NEXT
      %REPEAT
NEXT PACK:
      PACK==PACK_NEXT
   %REPEAT
   %RESULT=COUNT
%END

%ROUTINE PUT GLOBAL FAN(%RECORD(FTAG)%NAME NAME)
   %RECORD(FNET)%NAME NET
   %RECORD(FFRAGMENT)%NAME FR
   %RECORD(FFANEL)%NAME F
   %RECORD(FPACKAGE)%NAME PACK
   %INTEGER I, J
!! output the list of terminals referenced by global net fragments
!! of name NAME. Only CHIP terminals are output. (references to
!! terminals internal to the chip are ignored).
!! At the same time the transitive closure of the net is formed
!! by adding all fragment names to WORKLIST if they are not 
!! already there. In this way WORKLIST comes to hold the names
!! of all global net fragments that are at the same electrical
!! potential as the fragment called NAME.
   PACK==PACKAGES_NEXT
   %WHILE %NOT PACK==RECORD(NULL) %CYCLE
      NET==PACK_CHIP_GNETS
      %WHILE %NOT NET==RECORD(NULL) %CYCLE
         %FOR I=1,1,NET_NF %CYCLE
            FR==NET_F(I)
            %CONTINUE %UNLESS FR_NAME==NAME
            %FOR J=1,1,FR_FAN %CYCLE
               F==FR_F(J)
               %CONTINUE %UNLESS F_SUBNO=0
               BLANK;   PDEC(PACK_PNO)
               BLANK;   PDEC(F_TNO)
            %REPEAT
            !! form closure of set of names
            %FOR J=1,1,NET_NF %CYCLE
               %CONTINUE %IF J=I
               LOOKUP(NET_F(J)_NAME,WORKLIST)
            %REPEAT
            ->NEXT PACK
         %REPEAT
         NET==NET_NEXT
      %REPEAT
NEXT PACK:
      PACK==PACK_NEXT
   %REPEAT
%END

%ROUTINE PUT GNET(%RECORD(FTAGLIST)%NAME LIST)
   %RECORD(FTAG)%NAME NAME
   %INTEGER I
!! output a global net consisting of the set of fragments
!! named in WORKLIST. As each fragment is output by PUT GLOBAL FAN,
!! so new names (of fragments at the same electrical potential as
!! the fragment called NAME) may be added to the end of WORKLIST.
!! Eventually the transitive closure will have been formed, and from
!! this point onwards the values of I and WORKLIST_NT must converge.
!! (thus the process terminates).
   I=0
   %WHILE I<LIST_NT %CYCLE
      I=I+1
      NAME==LIST_NAME(I)
      PCH(CNTRL+'A')
      PUT TAG(NAME)
      PDEC(COUNT GLOBAL FAN(NAME))
      PUT GLOBAL FAN(NAME)
   %REPEAT
%END

%ROUTINE PUT GLOBAL NETS
   %INTEGER OLDTOS
!! output all global nets that have not already been output.
!! GTAGS contains the list of names of global net fragments
!! that remain to be output. This procedure operates by building
!! a WORKLIST of 1 name, and calling PUT GNET which forms the transitive
!! closure of this and outputs it. Thus after the call to PUT GNET
!! WORKLIST contains the list of net fragment names for all fragments
!! at the same electrical potential as GTAGS_NAME(1). This is then
!! removed from GTAGS. The procedure inevitably terminates as the
!! set GTAGS gets smaller at each step.
   %WHILE GTAGS_NT>0 %CYCLE
      PCH(CNTRL+'N')
      OLDTOS=TOS
      WORKLIST==RECORD(TOS)
      WORKLIST_NT=1;   CLAIM(TAGLISTLEN+1)
      WORKLIST_NAME(1)==GTAGS_NAME(1)
      PUT GNET(WORKLIST)
      REMOVE(GTAGS,WORKLIST)
      TOS=OLDTOS
   %REPEAT
%END

%ROUTINE PUT FRAGMENT(%RECORD(FFRAGMENT)%NAME FR)
   %INTEGER TNO,   SUBNO,   I
   %RECORD(FFANEL)%NAME F
   %RECORD(FSUBUNIT)%NAME SU,ssu
!! output a non-global net fragment.
!! this is easy, except that if a fan-element (SUBNO,TNO)
!! references a subUNIT, then it must be translated so that
!! it references the appropriate package and pin numbers.
!! Logical pin numbers are obtained by following the chain from
!! PACKage to CHIP to SUBCHIP to SUBCHIP TERMINAL REFERENCE,
!! to CHIP TERMINAL.
   %FOR I=1,1,FR_FAN %CYCLE
      F==FR_F(I)
      SUBNO=F_SUBNO;   TNO=F_TNO
      %IF SUBNO>0 %START
         !! reference to an element
         !! must relocate the subinstance number.
         SU==TASK_S(SUBNO)
         %IF SU_FLAGS=NOT SELECTED %START
            !! element no assigned to a package
            SUBNO=SU_SUBNO
         %ELSE
            !! element is assigned - relocate the terminal number too
            SUBNO=SU_PACK_PNO
{jhb}       %if subno>=1000 %or tno>=1000 %start
{rwt}          selectoutput(0)
{jhb}          printstring("Pin reference out of range, Subno = "); write(subno,-1)
{jhb}          printstring(", tno = "); write(tno, -1); newline
{jhb}          %stop
{jhb}       %finish
            TNO=SU_PACK_CHIP_SUB(SU_SUBPACK)_TREF(TNO)_T_INFO>>2
         %FINISH
      %FINISH
{rwt}       %if subno>=1000 %or tno>=1000 %start
{rwt}          selectoutput(0)
{rwt}          printstring("Pin reference out of range, Subno = "); write(subno,-1)
{rwt}          printstring(", tno = "); write(tno, -1); newline
{rwt}          %stop
{rwt}       %finish
      BLANK;   PDEC(SUBNO)
      BLANK;   PDEC(TNO)
   %REPEAT
%END

!!**********************************************
!!*           MAINLINE                         *
!!**********************************************

%INTEGER OLDTOS,   I,   SUBNO,   J,   PNO
%RECORD(FFRAGMENT)%NAME FR
%RECORD(FNET)%NAME NET
%RECORD(FSUBUNIT)%NAME SU, U
%RECORD(FTAG)%NAME TAG
%RECORD(FHEAD)%NAME H
%RECORD(FPACKAGE)%NAME PACK

RETURN CODE=DEF STREAMS(CLIPARAM,DEFAULTS)
->OUT %UNLESS RETURN CODE=1

!! initialisation of variables
MAXTOS=0;   NULL TAG==RECORD(NULL)
TOS=ADDR(STACK(0));   STACKTOP=ADDR(STACK(STACKLEN))>>LAUPW
ERROR CONTEXT="?"
SELECTOUTPUT(CONSOLE);   PRINTSTRING(HEADING);   NEWLINE

!!**************************************************
!! Firstly read in the list of UNITs to be assigned*
!! to chips.                                       *
!!**************************************************

!! Read and output the header for the 'board'
SELIN(MIN);   SELECTOUTPUT(MOUT)
SKIPCH
%IF CH=CNTRL+'S' %START
   READ(I);   PDEC(2)
   SKIPCH
%FINISH
FAIL(D1) %UNLESS CH=CNTRL+'U'
PUT TO(CNTRL+'J');   NEWLINE;   LINECT=0
FAIL(D1) %UNLESS CH=CNTRL+'J'
READ(NSUBUNITS)
FAIL(D3) %UNLESS NSUBUNITS>0

!! read in the list of elements to be assigned to packages
TASK==RECORD(TOS)
ZERO(NSUBUNITS)
CLAIM(NSUBUNITS)
RCH
TASK_S(I)==READ SUBUNIT %FOR I=1,1,NSUBUNITS

!! read in the nets for the UNIT being assigned
NETS==RECORD(TOS);   ZERO(NETLEN);   CLAIM(NETLEN)
ERROR CONTEXT="Nets"
NET==NETS
%WHILE CH=CNTRL+'N' %CYCLE
   NET_NEXT==READ NET
   NET==NET_NEXT
%REPEAT

!! check that all of input file has been used
SKIP TO(CNTRL+'E')
RCH
SELECTOUTPUT(CONSOLE)
%UNLESS CH=END OF FILE %START
   PRINTSTRING("* Only part of input(1) used")
   NEWLINE
%FINISH

!!***************************************************
!! now read in the chips needed. Firstly from the   *
!! user's own library, then from the system library.*
!!***************************************************

NO TO SELECT=NSUBUNITS;   NO NOT SELECTED=0
SELIN(USERLIB)
ERROR CONTEXT="Userlib"
SELECT CHIPS %UNTIL NO TO SELECT=0 %OR CH=END OF FILE
%IF NO TO SELECT>0 %START
   ERROR CONTEXT="Defaultlib"
   SELIN(DEFAULTLIB)
   SELECT CHIPS %UNTIL NO TO SELECT=0 %OR CH=END OF FILE
%FINISH

!!**************************************************
!! Check that all elements have a chip to live on  *
!! and moan if this is not the case.               *
!!**************************************************

SELIN(CONSOLE);   !! reset stream no for error routine FAIL
NO TO SELECT=NO TO SELECT+NO NOT SELECTED
%FOR I=1,1,NSUBUNITS %CYCLE
   %EXIT %IF NO TO SELECT=0
   SU==TASK_S(I)
   ->NEXT %IF SU_FLAGS&(SELECTED+NOT SELECTED)#0

   PRINTSTRING("* ")
   %IF SU_ON==RECORD(NULL) %START
      PRINTSTRING(SU_NAME_NAME)
      PRINTSTRING(" is not on any chip")
   %ELSE
      %IF SU_ON_OWNER==RECORD(NULL) %START
         PRINTSTRING(SU_ON_NAME)
         PRINTSTRING(" is not in library")
      %ELSE
         PRINTSTRING(SU_NAME_NAME)
         PRINTSTRING(" is not on ")
         PRINTSTRING(SU_ON_NAME)
      %FINISH
   %FINISH
   NEWLINE
   U==SU_NAME_OWNER
   %WHILE %NOT U==RECORD(NULL) %CYCLE
      %IF U_FLAGS&SELECTED=0 %AND SAME(U,SU) %START
         U_FLAGS=NOT SELECTED
         NO TO SELECT=NO TO SELECT - 1
         NO NOT SELECTED=NO NOT SELECTED+1
      %FINISH
      U==U_NEXT
   %REPEAT
NEXT:
%REPEAT
FAIL(D5) %IF NO NOT SELECTED>=NSUBUNITS

!!*****************************************************
!! Now assign elements to packages. Firstly do a      *
!! Naive Assignment - pack them on to chips as tightly*
!! as the constraints allow. Then improve the assignment
!! by cluster-building and optimisation of the use of *
!! empty slots on the packages. Output a list of      *
!! package requirements after the Naive Assignment.   *
!!*****************************************************

NPACKAGES=0
PACKAGES==RECORD(TOS)
ZERO(PACKLEN);   CLAIM(PACKLEN)
ERROR CONTEXT="Assignment"
NAIVE ASSIGNMENT
COUNT PACKAGES
IMPROVE ASSIGNMENT

!!************************************************
!! Output any UNITs that couldn't be assigned    *
!! to packages (if there are such UNITs).        *
!!************************************************

SELECTOUTPUT(MOUT)
WRITE(NPACKAGES+NO NOT SELECTED,0)
SUBNO=0
%IF NO NOT SELECTED>0 %START
   SELIN(MIN);   RESET INPUT;   RCH
   SKIP TO(CNTRL+'J')
   %FOR I=1,1,NSUBUNITS %CYCLE
      SU==TASK_S(I)
      SKIP TO(CNTRL+'H')
      %IF SU_FLAGS=NOT SELECTED %START
         SUBNO=SUBNO+1;   SU_SUBNO=SUBNO
         PCH(CNTRL+'H')
         COPY NUM %AND BLANK %FOR J=1,1,5
         SKIP TAG
         %IF SU_UNAME==RECORD(NULL) %START
            PUT TAG(INT TO TAG(SUBNO))
         %ELSE
            PUT TAG(SU_UNAME)
         %FINISH
         PUT TO(CNTRL+'G')
      %FINISH
      CH=NULL;   !! to fool SKIP TO, if necessary
   %REPEAT
%FINISH

!!************************************************
!! Output the assigned UNIT in terms of chips    *
!! Then output the list of nets, relocating the  *
!! terminal references appropriately so they refer
!! to chip logical terminal numbers and not to   *
!! UNIT logical terminal numbers.                *
!!************************************************

ERROR CONTEXT="Output"
!! set all pack numbers to zero for the output code
GET GLOBAL NAMES
%FOR I=1,1,NSUBUNITS %CYCLE
   PACK==TASK_S(I)_PACK
   %CONTINUE %IF PACK==RECORD(NULL)
   %CONTINUE %UNLESS PACK_PNO<=0
   !! pack hasn't yet been output
   SUBNO=SUBNO+1
   PACK_PNO=SUBNO
   H==PACK_CHIP_HEADER
   H_PARM(AT)==PACK_AT
   PACK_PACKNAME==INT TO TAG(SUBNO) %IF PACK_PACKNAME==NULL TAG
   H_UNAME==PACK_PACKNAME
   PUT HEAD(H)
%REPEAT

!! and output all nets of the UNIT, appropriately relocated
NET==NETS_NEXT;   OLDTOS=TOS
%WHILE %NOT NET==RECORD(NULL) %CYCLE
   PCH(CNTRL+'N')
   WORKLIST==RECORD(TOS);   CLAIM(TAGLISTLEN)
   WORKLIST_NT=0
   %FOR I=1,1,NET_NF %CYCLE
      FR==NET_F(I)
      PCH(CNTRL+'A')
      PUT TAG(FR_NAME)
      %IF NET_FLAGS&GLOBAL=0 %START
         PDEC(FR_FAN)
      %ELSE
         TAG==FR_NAME
         PDEC(FR_FAN+COUNT GLOBAL FAN(TAG))
         PUT GLOBAL FAN(TAG)
         REMOVE NAME(GTAGS,TAG)
      %FINISH
      PUT FRAGMENT(FR)
   %REPEAT
   %IF NET_FLAGS&GLOBAL#0 %START
      PUT GNET(WORKLIST)
      REMOVE(GTAGS,WORKLIST)
   %FINISH
   TOS=OLDTOS
   NET==NET_NEXT
%REPEAT

!! and output the global nets (names begin with '.')
PUT GLOBAL NETS

PCH(CNTRL+'E');   NEWLINE

!!*****************************************************
!! re-read the primary input file and produce the     *
!! updated input. This consists of the original input *
!! with ON strings, PACKAGE names, and SUBPACK numbers*
!! added. This can then be fed back into ASSIGN to    *
!! produce the identical CHIP and UPDATED outputs.    *
!!*****************************************************

ERROR CONTEXT="Update"
SELIN(MIN);   SELECTOUTPUT(SOUT)
RESETINPUT;   LINECT=0

SKIPCH
%IF CH=CNTRL+'S' %START
   COPY NUM
   SKIPCH
%FINISH

PUT TO(CNTRL+'J')
COPY NUM

OLDTOS=TOS
%FOR I=1,1,NSUBUNITS %CYCLE
   H==RECORD(TOS);   ZERO(HEADLEN);   CLAIM(HEADLEN)
   %CYCLE
      RCH
      %EXIT %IF CH=CNTRL+'P' %OR CH=CNTRL+'G'
      SEPARATE %IF CH>=CNTRL
      PCH(CH)
   %REPEAT
   %WHILE CH=CNTRL+'P' %CYCLE
      READ(PNO)
      H_PARM(PNO)==READ TAG(GENERAL)
      RCH
   %REPEAT
   SU==TASK_S(I)
   %IF SU_FLAGS&NOT SELECTED=0 %START
      !! unit has been assigned to a chip
      H_PARM(ON)==SU_ON
      H_PARM(SUB)==INT TO TAG(SU_SUBPACK) %IF SU_PACK_CHIP_NSUBS>1
      H_PARM(PACKNO)==SU_PACK_PACKNAME
   %FINISH
   %FOR PNO=1,1,MAX PARMS %CYCLE
      TAG==H_PARM(PNO)
      %unless tag==record(null) %start{*compiler bug*%CONTINUE %IF TAG==RECORD(NULL)
         PCH(CNTRL+'P')
         PDEC(PNO);   BLANK
         PUT TAG(TAG)
      %finish{}
   %REPEAT
   PCH(CNTRL+'G');   SKIP TO(CNTRL+'G')
   CLEANUP(OLDTOS)
%REPEAT
PUT TO(END OF FILE)

!!******************************************
!! report on usage of space                *
!!******************************************

SELECTOUTPUT(CONSOLE)
MAXTOS=MAXTOS-ADDR(STACK(0))>>LAUPW
PRINTSTRING("Used ");   WRITE(MAXTOS,0)
PRINTSTRING(" out of ");WRITE(STACKLEN,0)
PRINTSTRING(" words."); NEWLINE

OUT:
%ENDOFPROGRAM