PROGRAM calloc2(INPUT,OUTPUT,adr_file,con_file,alloc_file);

{ 
			COPYRIGHT (c) 1985, 1986 BY
	      DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.

 THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY BE USED AND  COPIED
 ONLY  IN  ACCORDANCE  WITH  THE  TERMS  OF  SUCH  LICENSE AND WITH THE
 INCLUSION OF THE ABOVE COPYRIGHT NOTICE.  THIS SOFTWARE OR  ANY  OTHER
 COPIES  THEREOF MAY NOT BE PROVIDED OR OTHERWISE MADE AVAILABLE TO ANY
 OTHER PERSON.  NO TITLE TO AND OWNERSHIP OF  THE  SOFTWARE  IS  HEREBY
 TRANSFERRED.

 THE INFORMATION IN THIS SOFTWARE IS SUBJECT TO CHANGE  WITHOUT  NOTICE
 AND  SHOULD  NOT  BE  CONSTRUED  AS  A COMMITMENT BY DIGITAL EQUIPMENT
 CORPORATION.

 DIGITAL ASSUMES NO RESPONSIBILITY FOR THE USE OR  RELIABILITY  OF  ITS
 SOFTWARE ON EQUIPMENT WHICH IS NOT SUPPLIED BY DIGITAL.

 AUTHOR:
   Paul Rubinfeld

 CREATION DATE:
   11-April-85 1.00

 MODIFIED BY:
    26-Sep-86  1.06	  PIR	Fixed collect_set - "Impossilbe address constraint" check
    14-Jan-86  1.05	  PIR	Fixed dump_block; pre-allocated addresses 620-7DF
    23-Oct-85  1.04	  PIR	Fixed dump_block to dump all blocks
    13-Oct-85  1.03	  PIR	Fixed collect_set - "Impossible Address Allocation" check
     2-Sep-85  1.02	  PIR	Fixed collect_set - "Impossible Set Allocation" check

 LINKING INSTRUCTIONS:
  Use this command to link this program:
	$ LINK CALLOC2

This program is part of a set of three programs that are used to allocated microcode for
the CVAX microprocessror.  ALLOC2 uses the output of ALLOC1 (adr_file, con_file) and generates 
output that is used by ALLO3 (alloc_file).  The actual microcode allocation is performed in
ALLOC2.

	INPUTS (generated by ALLOC1)
	----------------------------
		adr_file - A file which contains a list of all possible MCR address, and the MCR listing
			   line number and page number associated with each MCR instruction

			; 11-JUN-84 16:40:07 <--- date and time stamp
			     0  1312    48
			     1  1427    50
			     2  1432    50
				...
			     n  l       p
                             ^  ^       ^
			     |  |       |
		MCR address -+  |       +---- page number
                                |
                line number-----+


		con_file - A file which contains a list of address contraints

			; 11-JUN-84 16:40:07 <--- date and time stamp
			D  1308    -1     0     0
			D  1322     3     4     1
			B  1371    12    14   128
			A  1373    -1    14    75
				...
                        ^   ^       ^     ^     ^
                        |   |       |     |     |
	constraint type-+   |       |     |     +-- third argument
                            |       |     |
        MCR line number-----+       |     +-------- second argument
                                    |
				    +-------------- first argument

			if contraint type is A (adress)
				first argument : -1 (not used)
				second argument: MCR address being contrained
				third argument : radix 3 number representing the '*','0', and '1' bit of the address
						  calculated as followed:

							'*' = 0
							'0' = 1
							'1' = 2

					symbolic address contraint	********010*
					radix 3 representation		 3      2      1      0
								 ... +	3 x1 + 3 x2 + 3 x1 + 3 x0
			if contraint type is B (block)
				first argument : the first MCR address
				second argument: the second MCR address; both address must be in the same block
				third argument : 128 (not used)

			if contraint type is D (delta) and first argument is -1
				first argument : -1 for absolute assignment
				second argument: MCR address being assigned
				third argument : absolute physical address assigned

			if contraint type is D (delta) and first argument is greater than 0
				first argument : base MCR address
				second argument: offset MCR address
				third argument : delta; the physical address of the offset is
						  the base physical address plus delta


	OUTPUT (used by ALLOC3)
	-----------------------
		bdr_file - A file which contains a list of all possible MCR address, the MCR listing
			   line number and page number associated with each MCR instruction, and the
			   physical address that is assigned to each MCR address.

			; 15-JUL-84 16:40:07 <--- date and time stamp
			     0  1312    48      0
			     1  1427    50     23
			     2  1432    50     49
				...
			     n  l       p       a
                             ^  ^       ^       ^
			     |  |       |       |
		MCR address -+  |       |       +---- physical address assigned to MCR address n
                                |       |
                line number-----+       +------------ page number



 Some definitions:
	addresses
	   mcr 	 -	logical (virtual) address assigned by Micro-II.
	   physical -	control store addresses, i.e., an actual address.
	block	-	physical addresses that have the same high order four address bits.
	set	-	collection of mcr addresses that define the destinations of a microcode case statement, or call
			return pair.
	group	-	collection of mcr addresses and sets that must be in the same block.


}

CONST
	max_adr		= 2047;						{ highest control store address}
	max_rad3_num	= 177146 ;					{ largest rad3 number that can be represented with 11 bits }
	max_group	= 1024;						{ maximum number of groups }
	max_group_len	= 127;						{ maximum number of entries in each group }
	max_group_size	= 127;						{ maximum number of MCR addresses in each group }
	max_set 	= 1024;						{ maximum number of sets }
	max_set_len	= 128;						{ maximum number of microinstructions in each set }

TYPE
	mcr_adr		= -1..max_adr;					{ MCR address }
	physical_adr	= UNSIGNED ;					{ physical address }
	entry_type	= (adr_t,set_t);				{ group list entry type }
	dont_care_mask	= PACKED ARRAY[1..11] OF CHAR;

	mcr_record	= RECORD
				weight : INTEGER ;			{ initialized to 0}
				line :	INTEGER;			{ initialized to 0}
				page :	INTEGER;			{ initialized to 0}
				p_adr :	physical_adr;			{ initialized to -1}
				group :INTEGER;				{ initialized to 0}
				setn : INTEGER;				{ initialized to 0}
				a_con :	RECORD
					line : INTEGER;			{ initialized to 0}
					ones_msk : UNSIGNED ;		{ initialized to 0}
					zero_msk : UNSIGNED ;		{ initialized to 0}
					END;
				b_con :	RECORD
					line : INTEGER;			{ initialized to 0}
					m_adr : mcr_adr;		{ initialized to -1}
					END;
				d_con :	RECORD
					abs1 : BOOLEAN;			{ initialized to FALSE}
					line1 : INTEGER;		{ initialized to 0}
					delta1 : UNSIGNED;		{ initialized to 0}
					m_adr1 : mcr_adr;		{ initialized to -1}
					abs2 : BOOLEAN;			{ initialized to FALSE}
					line2 : INTEGER;		{ initialized to 0}
					delta2 : UNSIGNED;		{ initialized to 0}
					m_adr2 : mcr_adr;		{ initialized to -1}
					END
			  END;

	group_entry	= RECORD
				CASE e_type : entry_type OF
					adr_t : (m_adr : mcr_adr);        { initialized to -1}
					set_t : (setn   : INTEGER);
			  END;

	group_record	= RECORD
				length : INTEGER;			{ initialized to 0}
				size : INTEGER;
				weight : INTEGER ;
				blk_ones_msk : UNSIGNED ;
				blk_zero_msk : UNSIGNED ;
				entry : ARRAY[1..max_group_len] of group_entry;
			  END;

	set_record	= RECORD
				abs : BOOLEAN;				{ initialized to FALSE }
				weight : INTEGER ;			{ initialized to 0 }
				length : INTEGER;			{ initialized to 0}
				entry : ARRAY[1..max_set_len] of mcr_adr;
				delta : ARRAY[1..max_set_len] of UNSIGNED ;
			  END;

VAR
	error,fail : BOOLEAN;
	debug, quiet : BOOLEAN;
	fil_nam : VARYING[132] OF CHAR ;
	adr_stamp, con_stamp : VARYING[80] OF CHAR;
	adr_file,con_file,alloc_file : TEXT;				{ file definitions }
	p_adr : ARRAY[0..max_adr] of INTEGER ;
	abs_count, a_con_count, b_con_count, d_con_count, float_count, last_mcr_adr,last_set,last_group,dum,ziltch : INTEGER;

	mcr : ARRAY[0..max_adr] OF mcr_record;
{		Variable		Definition							  Initialized
		--------		----------							  -----------
		mcr[n].line		MCR listing line number							 0
		mcr[n].page		MCR listing page number							 0
		mcr[n].p_adr		physical address assigned to MCR address n				-1
		mcr[n].group		group that MCR address n belongs to					 0
		mcr[n].setn		set that MCR address n belongs to					 0
		mcr[n].weight		MCR weight								 0
		mcr[n].a_con.line	MCR listing line number of adress contraint				 0
		mcr[n].a_con.ones_msk	1's mask defining address constraint					 0
		mcr[n].a_con.zero_msk	0's mask defining address constraint					 0
		mcr[n].b_con.line	MCR listing line number of block contraint				 0
		mcr[n].b_con.m_adr	MCR address pair that is in the same block as MCR address n		-1
		mcr[n].d_con.abs1	TRUE if delta contraint 1 set an absolute address; otherwise FALSE	FALSE
		mcr[n].d_con.line1	first MCR listing line number of delta contraint			 0
		mcr[n].d_con.delta1	first delta offset							 0
		mcr[n].d_con.m_adr1	first MCR address pair that offset is computed against			-1
		mcr[n].d_con.abs2	TRUE if delta contraint 2 set an absolute address; otherwise FALSE	FALSE
		mcr[n].d_con.line2	second MCR listing line number of delta contraint			 0
		mcr[n].d_con.delta2	second delta offset							 0
		mcr[n].d_con.m_adr2	second MCR address pair that offset is computed against			-1
}

	group : ARRAY[1..max_group] OF group_record;
{		Variable		Definition							  Initialized
		--------		----------							  -----------
		group[n].length		number of entries in group n						 0
		group[n].size		number of MCR addresses in group n
		group[n].weight		product of size and # of block possibilities				 0
		group[n].blk_zero_msk	
		group[n].blk_ones_msk
		group[n].entry[m].e_type	entry m type indication:					adr_t
					 'adr_t' if entry is an MCR address
					 'set_t' if entry is an set number
		group[n].entry[m].m_adr	used if type is 'adr' - MCR address that is in the group		-1
		group[n].entry[m].setn	used if type is 'set' - set number that is in the group
}

  setn : ARRAY[1..max_set] OF set_record;
{		Variable		Definition							  Initialized
		--------		----------							  -----------
		setn[n].length		number of MCR address in the set					 0
		setn[n].weight		set weight								 0
		setn[n].entry[m]	MCR address that is in the set						-1
		setn[n].delta[m]	offset
}


FUNCTION MASK(zero,one:UNSIGNED):dont_care_mask;
VAR
	ONE_STR, ZERO_STR, OUTSTR : dont_care_mask;
	ANS_STR : VARYING[4] OF CHAR;
	INDEX1 : INTEGER;
BEGIN
	one_str := BIN(one,11);
	zero_str := BIN(zero,11);
	OUTSTR := '           ';
	ans_str := '*01X';
	FOR INDEX1 := 1 TO 11 DO
	   outstr[index1] := ans_str[ORD(ONE_STR[INDEX1]) + ORD(ZERO_STR[INDEX1]) + ORD(ONE_STR[INDEX1]) - 143];
	MASK := OUTSTR;
END;

PROCEDURE dump_block ( filename : VARYING[T] OF CHAR; grp_num, fail_entry : INTEGER);
CONST
	dot_dmp = '.BLK' ;


VAR
	n, mcr_num, set_len, set_num, set_entry, grp_entry :INTEGER ;
	dmp_fil_nam : VARYING[132] OF CHAR ;
	row, col :UNSIGNED;
	block_num : UNSIGNED;

BEGIN
	dmp_fil_nam := filename + HEX(grp_num,3) + dot_dmp ;
	OPEN (alloc_file ,dmp_fil_nam,HISTORY:= NEW );
	REWRITE (alloc_file );

	WRITELN (alloc_file,' ');
	WRITELN (alloc_file,'GROUP ',grp_num:1,'  LENGTH ',group[grp_num].length:3,'  SIZE ',group[grp_num].size:3,
	  '  WEIGHT ',group[grp_num].weight:5,'  mask ',
	  mask(group[grp_num].blk_zero_msk, group[grp_num].blk_ones_msk));
        WRITELN (alloc_file,'             TYPE                WEIGHT      MCR        ADR          MASK ');
{                           '             mcr                 1000        xxxx(xx)   xxxx(xxx)    ******0000*
                            '             set  # 2            2346        
                            '                                             xxxx(xx)   unasssigned  *********0* }
	FOR grp_entry := 1 TO group[grp_num].length DO
	   BEGIN  (* each group entry *)
	     IF fail_entry = grp_entry THEN WRITE(alloc_file,'->') ELSE WRITE(alloc_file,'  ');
	     IF group[grp_num].entry[grp_entry].e_type = adr_t THEN
		BEGIN  (* mcr type *)
		  mcr_num := group[grp_num].entry[grp_entry].m_adr ;
		  WRITE (alloc_file,'           mcr                ',mcr[group[grp_num].entry[grp_entry].m_adr].weight:4,
			'         ',mcr_num:4,'(',HEX(mcr_num,3),')   ');
		  IF  mcr[mcr_num].p_adr = 2048 THEN WRITELN(alloc_file,'unassigned  ',
			mask(mcr[mcr_num].a_con.zero_msk,mcr[mcr_num].a_con.ones_msk))
		   ELSE  WRITELN(alloc_file, mcr[mcr_num].p_adr:4,'(',HEX(mcr[mcr_num].p_adr,3),')    ',
			  mask(mcr[mcr_num].a_con.zero_msk,mcr[mcr_num].a_con.ones_msk))
		END  (* mcr type *)
	     ELSE
		BEGIN  (* set type *)
		  set_num := group[grp_num].entry[grp_entry].setn;
		  WRITELN (alloc_file,'           set # ',set_num:4,
		    '         ',mcr[group[grp_num].entry[grp_entry].m_adr].weight:4);
		  set_len := setn[set_num].length;
		  FOR set_entry := 1 TO set_len DO
			BEGIN  (* each set entry *)
			  mcr_num := setn[set_num].entry[set_entry];
			  WRITE (alloc_file,'                                             ',
				mcr_num:4,'(',HEX(mcr_num,3),')   ');
			  IF  mcr[mcr_num].p_adr = 2048 THEN WRITELN(alloc_file,'unassigned  ',
				mask(mcr[mcr_num].a_con.zero_msk,mcr[mcr_num].a_con.ones_msk))
			   ELSE  WRITELN(alloc_file, mcr[mcr_num].p_adr:4,'(',
				  HEX(mcr[mcr_num].p_adr,3),')    ',
				  mask(mcr[mcr_num].a_con.zero_msk,mcr[mcr_num].a_con.ones_msk))
			END  (* each set entry *)
		END  (* set type *)
	   END ; (* each group entry *)

FOR block_num := 0 TO 15 DO 
   BEGIN {each block}
	page(alloc_file);
	WRITELN(alloc_file,'                                   Physical address map for block ',block_num:2);
	WRITELN(alloc_file,'         0            1            2            3            4            5            6            7');
	WRITELN(alloc_file,'    +-----------------------------------------------------------------------------------------------------');
	FOR row := 0 TO 15 DO
	  BEGIN  (* each row *)
	    WRITE(alloc_file,' ',HEX(row,1),'  |');
	    FOR col := 0 TO 7 DO
	       BEGIN  (* each column *)
		n := ( (block_num * 128) + (col * 16) + row)::INTEGER;
		IF p_adr[n] <> -1 THEN	WRITE(alloc_file,p_adr[n]:4,'(',HEX(p_adr[n],3),')   ')
		 ELSE WRITE(alloc_file,'            ');
	       END ; (* each column *)
	    WRITELN(alloc_file);
	  END ; (* each row *)
   END ; {each block}
	
WRITELN (alloc_file,' ');
WRITELN (alloc_file,'END OF FILE ');
CLOSE (alloc_file);
END;  (* PROCEDURE DUMP_blk *)

			(* INIT SETS TH DATA STRUCTURE TO VALUES THAT WOULD NOT NORMALLY BE CONSIDERED DATA *)

PROCEDURE INIT;
   VAR
	count1,count2,count3,count4 : INTEGER;


	BEGIN
	    debug := FALSE;
	    quiet := TRUE;
	    last_mcr_adr := 0 ;
	    last_set := 0 ;
	    last_group := 0 ;
	    a_con_count :=0 ;
	    b_con_count :=0 ;
	    d_con_count :=0 ;
	    float_count :=0 ;
	    abs_count := 0;
	    FOR count1 := 0 TO max_adr DO
		BEGIN
		    p_adr[count1] := -1 ;
		    mcr[count1].weight := 0 ;
		    mcr[count1].line := 0;
		    mcr[count1].page := 0;
		    mcr[count1].p_adr := 2048;
		    mcr[count1].group := 0;
		    mcr[count1].setn := 0;
		    mcr[count1].a_con.line := 0;
		    mcr[count1].a_con.ones_msk := 0;
		    mcr[count1].a_con.zero_msk := 0;
		    mcr[count1].b_con.line := 0;
		    mcr[count1].b_con.m_adr := -1;
		    mcr[count1].d_con.abs1 := FALSE;
		    mcr[count1].d_con.line1 := 0;
		    mcr[count1].d_con.delta1 := 0;
		    mcr[count1].d_con.m_adr1 := -1;
		    mcr[count1].d_con.abs2 := FALSE;
		    mcr[count1].d_con.line2 := 0;
		    mcr[count1].d_con.delta2 := 0;
		    mcr[count1].d_con.m_adr2 := -1;
		END;
{ 1.05 pre-allocate 620 to 7DF }

	    FOR count1 := %x'620' TO %x'7DF' DO
		    p_adr[count1] := count1 + %x'10' ;
	

	    FOR count2 := 1 TO max_group DO
		BEGIN
		    group[count2].length := 0;
		    group[count2].size := 0;
		    group[count2].weight := 0 ;
		    group[count2].blk_ones_msk := 0;
		    group[count2].blk_zero_msk := 0;
		    FOR count3 := 1 TO max_group_len DO
			BEGIN
			    group[count2].entry[count3].e_type := adr_t ;
			    group[count2].entry[count3].m_adr := -1 ;
			END;
		    setn[count2].weight := 0 ;
		    setn[count2].length := 0;
		    setn[count2].abs := FALSE ;
		    FOR count4 := 1 TO max_set_len DO
			BEGIN
			    setn[count2].entry[count4] := -1 ;
			    setn[count2].delta[count4] := 0 ;
			END;			    
		END;
	END;




		(* GET_FILENAME_AND_DEBUG RETURNS THE FILENAME WITH NO FILE EXTENTION.
			FUTURE :  CREATE A SWITCH CALLED "DEBUG" THAT , WHEN ON, WOULD DISPLAY MESSAGES THAT WOULD
				   INDICATE WHERE THE PROGRAM IS AT THE MOMENT .
				EX.  DOING ALLOCATE
				     STORING MCR# 30

				  ANOTHER SWITCH CALLED "ERR_FILE" WOULD PUT ALL ERROR MESSAGES IN AN ERROR FILE (.ERR)   *)




FUNCTION count_dont_cares(bits:UNSIGNED):INTEGER;
VAR
	n, index, sum : INTEGER;
BEGIN
	sum := 0;
	index := 1;
	FOR n :=1 TO 11 DO
	   BEGIN
		IF UAND( UNOT(bits),index) <> 0 THEN sum := sum +1;
		index := index * 2;
	  END ;
	count_dont_cares := sum ;
END;


PROCEDURE get_filename_and_debug ( var filename : VARYING[x] OF CHAR );
 VAR
	com_status,com_line_length : INTEGER;
	com_line_pt, dum, ziltch, switch_length, ext_length, dot_loc, slash_loc, file_end : INTEGER;
	left_loc, right_loc : INTEGER;
	directory, switch, root, com_line, switches : VARYING[132] OF CHAR;
	fail, have_dot, have_slash : BOOLEAN;

	[EXTERNAL] FUNCTION LIB$GET_FOREIGN
			(VAR INPUT_TEXT : VARYING[U] OF CHAR ;
				PROMPT : VARYING[V] OF CHAR := %IMMED 0;
			OUT_LEN : INTEGER := %IMMED 0 ) : INTEGER ;
		   EXTERN;
BEGIN

com_status := LIB$GET_FOREIGN (com_line,'FILENAME>',ziltch);

REPEAT
   BEGIN {parse command line}
	fail := FALSE;
	com_line_length := length(com_line);
	IF com_status <> 1 THEN 
	   BEGIN
		fail := TRUE;
		writeln('command line failure ',com_status);
	   END;
	FOR dum:=1 to com_line_length DO 
	 IF (com_line[dum] >= 'a') AND (com_line[dum] <= 'z') THEN com_line[dum] := CHR( ORD(com_line[dum]) - 32 );
	left_loc := index(com_line,'[');
	right_loc := index(com_line,']');
	IF (left_loc <> 0) OR (right_loc <> 0) THEN
	   BEGIN {directory found}
		IF (right_loc = com_line_length) OR (right_loc = 0) OR (left_loc = 0) OR (right_loc < left_loc) THEN
		   BEGIN
			WRITELN(com_line);
			FOR dum := 1 TO right_loc-1 DO write(' ');
			WRITELN('^');
			WRITELN(' Directory syntax error ');
			fail := TRUE;
		   END
		 ELSE
		   BEGIN
			directory := substr(com_line,1,right_loc);
			com_line := substr(com_line,right_loc+1,com_line_length-right_loc);
			com_line_length := length(com_line);
		   END
	   END {directory found}
	 ELSE directory := '';
		
	slash_loc := index(com_line,'/');
	IF slash_loc = 0 THEN 
	   BEGIN
		slash_loc := com_line_length + 1;
		file_end := com_line_length;
		have_slash := FALSE;
	   END
	 ELSE 
	   BEGIN
		file_end := slash_loc-1;
		have_slash := TRUE
	   END;
		dot_loc := index(com_line,'.');
	IF dot_loc = 0 THEN 
	   BEGIN
		dot_loc := file_end + 1;
		have_dot := FALSE
	   END
	 ELSE have_dot := TRUE;
		IF dot_loc > slash_loc THEN
	   BEGIN
		fail := TRUE;
		WRITELN(com_line);
		FOR dum := 1 TO slash_loc-1 DO write(' ');
		WRITELN('^');
		WRITELN(' Option syntax error ')
	   END
	 ELSE
	   BEGIN {good ./}
		root := substr(com_line,1,dot_loc-1);
		filename := root;
	   END; {good ./}

	IF have_slash THEN
	   BEGIN {have switch}
		com_line_pt := slash_loc;
		switch_length := com_line_length - slash_loc;
		IF switch_length = 0 THEN
		   BEGIN
			WRITELN(com_line);
			FOR dum := 1 TO com_line_pt DO write(' ');
			WRITELN('^');
			WRITELN(' Option ignored')
		   END
		 ELSE 
		   BEGIN {switch parse setup}
			switches := substr(com_line,slash_loc+1,switch_length);
			REPEAT
			   BEGIN {parse switches}
				switch_length := length(switches);
				slash_loc := index(switches,'/');
				IF (slash_loc = 0) OR (slash_loc = switch_length) THEN
				   BEGIN
					slash_loc := switch_length + 1;
					have_slash := FALSE
				   END;
				   
				switch := substr(switches,1,slash_loc-1);

				IF index('DEBUG',switch) = 1 THEN debug := TRUE
				 ELSE IF index('NODEBUG',switch) = 1 THEN debug := FALSE
				 ELSE IF index('QUIET',switch) = 1 THEN quiet := TRUE
				 ELSE IF index('VERBOSE',switch) = 1 THEN quiet := FALSE
				 ELSE IF index('HELP',switch) = 1 THEN 
				   BEGIN
					WRITELN;
					WRITELN('Valid switch        HELP DEBUG NODEBUG QUIET VERBOSE');
					WRITELN('Defaults switches              NODEBUG QUIET');
					have_slash := FALSE;
					fail := TRUE
				   END
				 ELSE
				   BEGIN
					WRITELN(com_line);
					FOR dum := 1 TO com_line_pt DO write(' ');
					WRITELN('^');
					WRITELN(' Invalid option');
					fail := true;
					have_slash := false
				   END;

				com_line_pt := com_line_pt + slash_loc;
				IF have_slash THEN
				   BEGIN
					switch_length := switch_length - slash_loc;
					switches := substr(switches,slash_loc+1,switch_length);
				   END;
			   END {parse switches}
			UNTIL NOT have_slash;
		   END {switch parse setup}
	   END; {have switch}

	IF fail THEN
	   BEGIN
		WRITE('FILENAME>');
		com_status := 0;
		READLN(com_line);
	   END;
	
   END; {parse command line}
 UNTIL NOT fail;

WRITELN;
WRITE('   Switches: ');
IF debug THEN write(' DEBUG ') ELSE write(' NODEBUG ');
IF quiet THEN writeln(' QUIET ') ELSE writeln(' VERBOSE ');
WRITELN;
end;


		(* RAD3_TO_BIN CONVERTS A DECIMAL REPRESENTATION OF A BASE 3 NUMBER TO A BINARY "ONES MASK" AND "ZERO MASK" .
			IT ACCOMPLISHES THIS BY THINKING OF THE NUMBER AS AN ELEVEN BIT BINARY NUMBER WITH 1'S,0'S,OR X'S

				BASE 3       BINARY
				  0	--->    X
				  1	--->    0
				  2	--->    1

			BY SUCCESSIVELY DIVIDING THE BASE 3 NUMBER BY A POSITION WEIGHT , STARTING FROM POSITION  ELEVEN,
			  IF THE QUOTIENT IS A "1" THEN SET THE SAME POSITION OF THE "ZERO MASK" TO A "1".
			  IF THE QUOTIENT IS A "2" THEN SET THE SAME POSITION OF THE "ONES MASK" TO A "1".
			  IF THE QUOTIENT IS A "0" THEN SET THE SAME POSITION OF THE "ZERO MASK" AND THE "ONES MASK"
			  TO A "0", EFFECTIVELY BECOMING A "DON'T CARE" ( X ).  *)


PROCEDURE rad3_to_bin ( rad3_num : UNSIGNED ;
			VAR mask0,mask1 : UNSIGNED );
 CONST
	bit10 = 10 ;
	bit0 = 0 ;

 VAR
	pos_cnt,num : INTEGER ;
	mask0_weight,mask1_weight : UNSIGNED ;

    BEGIN
	mask0 := 0;
	mask1 := 0;
	FOR pos_cnt := bit10 DOWNTO bit0 DO
		BEGIN
		    num := (rad3_num div (3**pos_cnt)) :: INTEGER ; 	(* FIND EACH BASE3 POSITION WEIGHT *)
		    rad3_num := rad3_num mod (3**pos_cnt); 		(* GET THE REMAINDER FOR NEXT POSITION CALCULATION *)
		      CASE num OF
		      0 :BEGIN
			     mask1_weight := 0;
			     mask0_weight := 0;
			     mask1 := mask1 + (mask1_weight * (2**pos_cnt));
			     mask0 := mask0 + (mask0_weight * (2**pos_cnt));
			END;
		      1 :BEGIN
			     mask1_weight := 0;
			     mask0_weight := 1;
			     mask1 := mask1 + (mask1_weight * (2**pos_cnt));
			     mask0 := mask0 + (mask0_weight * (2**pos_cnt));
			END;
		      2 :BEGIN
			     mask1_weight := 1;
			     mask0_weight := 0;
			     mask1 := mask1 + (mask1_weight * (2**pos_cnt));
			     mask0 := mask0 + (mask0_weight * (2**pos_cnt));
			END;
		      END;
		END;
     END; (* END PROCEDURE RAD3_TO_BIN *)


			(* LOAD_DATA READS THE .ADR AND .CON FILES AND STORES THE DATA INTO ITS CORRESPONDING PLACE
			    IN THE DATA STRUCTURE .

			.ADR FILE - SHOWS ALL MCRS USED AND THE LINE NUMBER WHERE THEY FIRST OCCUR

			.CON FILE - SHOWS CONSTRAINTS ( A,B,D ) ON MCRS. IT GIVES THE CONSTRAINT TYPE , THE LINE NUMBER
				    WHERE THE CONSTRAINT OCCURS, THE MCR(S) THAT ARE AFFECTED, AND SOME OTHER INFO
				    DEPENDING ON THE CONSTRAINT TYPE  (I.E. DELTA,PHYSICAL ADDRESS,BASE 3 ADDRESS ).   *)



PROCEDURE load_data ( filename : VARYING[z] OF CHAR );
 const
	dot_con = '.con' ;
	dot_adr = '.adr' ;
	spaces = '                         ' ;	(* 25 SPACES *)
	position1 = 1 ;
	position7 = 7 ;
 TYPE
	constraint = (a,b,d);


 VAR
	constr_field : CONSTRAINT ;
	con_line_num,column3,column4,
	companion_mcr,tmp_weight, n,num_of_x,comp_mcr,mcr_num,mcr_line_num,page_num : INTEGER ;
	new_zero_msk,new_ones_msk,not_ones_or_zero,
	position_of_x,field5,column5,mcr_delta,rad3_adrs,addres : UNSIGNED ;
	con_fil_nam,adr_fil_nam : VARYING[132] OF CHAR ;
	print_header : BOOLEAN;


BEGIN
	print_header := FALSE;
	con_fil_nam := filename + dot_con ;
	adr_fil_nam := filename + dot_adr ;
	OPEN (con_file,con_fil_nam,HISTORY:=READONLY);
	RESET (con_file);
	READLN (con_file,con_stamp);
	OPEN (adr_file,adr_fil_nam,HISTORY:=READONLY);
	RESET (adr_file);
	READLN (adr_file,adr_stamp);
	IF ( LENGTH(con_stamp) <> LENGTH(adr_stamp) )
			OR ( adr_stamp <> con_stamp) THEN
		    IF NOT quiet THEN WRITELN ('     Warning time stamps disagree.',adr_fil_nam );


	WHILE NOT EOF(adr_file) DO
	    BEGIN
		READLN (adr_file,mcr_num,mcr_line_num,page_num);
		IF (mcr_num >= 0 ) AND (mcr_num <= max_adr ) THEN
		  BEGIN
			mcr[mcr_num].line := mcr_line_num ;
			mcr[mcr_num].page := page_num ;
		  END
		ELSE
		  BEGIN
			error :=true ;
			WRITELN ;
			WRITELN ('          LOAD_DATA***ERROR**  MCR NUMBER OUT OF RANGE. IN ',adr_fil_nam );
			WRITELN ('LINE # =',mcr_line_num:5 );
			WRITELN ('PAGE # =',page_num:5 );
			WRITELN ('MCR #  =',mcr_num:4,'(',HEX(mcr_num,3),')    OUT OF RANGE' );
		  END;
	    END;
	last_mcr_adr := mcr_num ;
	CLOSE ( adr_file );



	WHILE NOT EOF(con_file) DO
	    BEGIN
		READLN (con_file,constr_field,con_line_num,column3,column4,column5);
		CASE constr_field OF
		   a : BEGIN
			   a_con_count := a_con_count + 1 ;
			   mcr_num := column4 ;
			   rad3_adrs := column5 ;
			   IF (mcr_num >= 0 ) AND (mcr_num <= last_mcr_adr) THEN
			      IF (rad3_adrs >= 0 ) AND (rad3_adrs <= max_rad3_num ) THEN
				BEGIN
				     rad3_to_bin (rad3_adrs,new_zero_msk,new_ones_msk );
				     new_zero_msk := UOR ( mcr[mcr_num].a_con.zero_msk, new_zero_msk );
				     new_ones_msk := UOR ( mcr[mcr_num].a_con.ones_msk, new_ones_msk );
				     IF UAND ( new_zero_msk, new_ones_msk ) = 0 THEN
					BEGIN  (* mask okay *)
					     mcr[mcr_num].a_con.line := con_line_num ;
					     mcr[mcr_num].a_con.zero_msk := new_zero_msk ;
					     mcr[mcr_num].a_con.ones_msk := new_ones_msk ;
					     IF (mcr[mcr_num].d_con.abs1 OR mcr[mcr_num].d_con.abs2) AND
						( (UOR(mcr[mcr_num].p_adr,new_ones_msk) <> mcr[mcr_num].p_adr) OR
       						( UOR( UNOT(mcr[mcr_num].p_adr),new_zero_msk) <> UNOT(mcr[mcr_num].p_adr))) THEN
							BEGIN (* conflict *)
							   error := TRUE;
				 			   WRITELN ;
							   WRITELN ('          LOAD_DATA***ERROR**  ABSOLUTE ASSIGNMENT CONFLICTS WITH ADDRESS CONTRAINT.  IN ',
							   adr_fil_nam );
							   WRITELN ('LINE # =',con_line_num:5 );
							   WRITELN ('MCR #  =',mcr_num:4,'(',HEX(mcr_num,3),')    MASK = ',
								mask(new_zero_msk,new_ones_msk) );
							   IF mcr[mcr_num].d_con.abs1 THEN
							     BEGIN (* use d_con*1 *)
								WRITELN ('LINE # =',mcr[mcr_num].d_con.line1:5 );
								WRITELN ('MCR #  =',mcr[mcr_num].d_con.m_adr1:4,'(',
								   HEX(mcr[mcr_num].d_con.m_adr1,3),')    @ ',
								   mcr[mcr_num].p_adr:4,'(',HEX(mcr[mcr_num].p_adr,3),')' );
							     END  (* use d_con*1 *)
							ELSE
							     BEGIN (* use d_con*2 *)
								WRITELN ('LINE # =',mcr[mcr_num].d_con.line2:5 );
								WRITELN ('MCR #  =',mcr[mcr_num].d_con.m_adr2:4,'(',
								   HEX(mcr[mcr_num].d_con.m_adr2,3),')    @ ',
								   mcr[mcr_num].p_adr:4,'(',HEX(mcr[mcr_num].p_adr,3),')' );
							     END  (* use d_con*2 *)
							END;  (* conflict *)

			(* CALCULATE THE WEIGHT OF MCR BY FINDING HOW MANY "X'S" ARE IN THE LOWER 7 BITS AND RAISING
			    2 TO THIS POWER ( # OF POSSIBILITIES ) AND SUBTRACTING THIS FROM 128   *)

					     not_ones_or_zero := UNOT ( UOR ( new_zero_msk , new_ones_msk ) ) ;
					     position_of_x := %b'00000000001' ;
					     num_of_x := 0 ;
					     FOR n := position1 TO position7 DO
						BEGIN
						    IF UAND ( position_of_x , not_ones_or_zero ) = position_of_x THEN
							num_of_x := num_of_x + 1 ;
						    position_of_x := position_of_x * 2 ;
						END;
					     tmp_weight := 128 - ( 2 ** num_of_x ) ;
					     IF mcr[mcr_num].weight < tmp_weight THEN mcr[mcr_num].weight := tmp_weight;
					END (* mask okay *)
				     ELSE
					BEGIN
					   error := true ;
					   WRITELN (' ');
					   WRITELN ('      LOAD_DATA***ERROR**  ADDRESS CONSTRAINT CONFLICT IN ',con_fil_nam);
					   WRITELN (' CANNOT MAKE A VALID ADDRESS' );
					   WRITELN (constr_field,' ',mcr[mcr_num].a_con.line,' ',column3,' ',column4,
						'(',HEX(column4,3),')' );
					   WRITELN (spaces, ' MASK = ',mask(mcr[mcr_num].a_con.zero_msk,mcr[mcr_num].a_con.ones_msk));
					   WRITELN ;
					   WRITELN (constr_field,' ',con_line_num,' ',column3,' ',column4,
						'(',HEX(column4,3),')' );
					   WRITELN (spaces,' MASK = ',mask(new_zero_msk,new_ones_msk) );
					END  (* ELSE *)
				END
			      ELSE
				BEGIN
				    error :=true ;
				    WRITELN ('');
				    WRITELN ('          LOAD_DATA***ERROR**  RAD3 ADDRESS OUT OF RANGE IN ',con_fil_nam);
				    WRITELN (' RAD3 ADDRESS   = ',column5,'    IS OUT OF RANGE');
				    WRITELN (constr_field,' ',con_line_num,' ',column3,' ',column4,
						'(',HEX(column4,3),') ',column5);
				END
			  ELSE
				BEGIN
				    error :=true ;
				    WRITELN (' ');
				    WRITELN ('         LOAD_DATA***ERROR**  MCR NUMBER OUT OF RANGE IN ',con_fil_nam);
				    WRITELN ('MCR #      =',column4:4,'    OUT OF RANGE' );
				    WRITELN (constr_field,' ',con_line_num,' ',column3,' ',column4,
						'(',HEX(column4,3),')  ',column5);
				END
		       END;  (* CASE A: *)

		   b : BEGIN
			 b_con_count := b_con_count + 1 ;
			 mcr_num := column3 ;
			 comp_mcr := column4 ;
			 IF mcr_num <> comp_mcr THEN
			   BEGIN
			     IF (mcr_num >= 0 ) AND (mcr_num <= last_mcr_adr ) THEN
			      IF (comp_mcr >= 0 ) AND (comp_mcr <= last_mcr_adr ) THEN
				BEGIN
				    IF mcr[mcr_num].b_con.line = 0 THEN
				      BEGIN
					  mcr[mcr_num].b_con.line := con_line_num ;
					  mcr[mcr_num].b_con.m_adr := comp_mcr ;
				      END
				    ELSE
				      BEGIN
				 	error :=true ;
					comp_mcr := mcr[mcr_num].b_con.m_adr ;
				    	WRITELN (' ');
				   	WRITELN ('          LOAD_DATA***ERROR** DUPLICATE BLOCK CONSTRAINT IN ',con_fil_nam);
					WRITELN (constr_field,' ',mcr[mcr_num].b_con.line,' ',column3,'(',HEX(column3,3),') ',
						comp_mcr,' ',column5,'(',HEX(column5,3),')');
					WRITELN (constr_field,' ',con_line_num,' ',column3,'(',HEX(column3,3),') ',column4,
						'(',HEX(column4,3),') ',column5);
				      END;
				END
			      ELSE
				BEGIN
				    error :=true ;
				    WRITELN (' ');
				    WRITELN ('          LOAD_DATA***ERROR** MCR NUMBER IS OUT OF RANGE IN ',con_fil_nam);
				    WRITELN (' MCR    =',column4:4,'   OUT OF RANGE' );
				    WRITELN (constr_field,' ',con_line_num,' ',column3,' ',column4,' ',column5);
				END
			     ELSE
				BEGIN
				    error :=true ;
				    WRITELN (' ');
				    WRITELN ('          LOAD_DATA***ERROR** MCR NUMBER IS OUT OF RANGE IN ',con_fil_nam);
				    WRITELN (' MCR    =',column3:4,'   OUT OF RANGE' );
				    WRITELN (constr_field,' ',con_line_num,' ',column3,' ',column4,' ',column5);
				END;
			   END; (* IF MCR <> COMP *)
		       END;

		   d : BEGIN   (* d_con *)
			   d_con_count := d_con_count + 1 ;
			   IF (column3 >= -1 ) AND (column3 <= last_mcr_adr ) AND
			   (column4 >= 0  ) AND (column4 <= last_mcr_adr )  AND
			   (column5 >= 0  ) AND (column5 <= max_adr) THEN
			     BEGIN   (* good mcr range *)
				   IF column3 = -1 THEN
				     BEGIN		(* ABSOLUTE PHYSICAL ADDRESS *)
					abs_count := abs_count + 1;
					mcr_num := column4 ;
					addres := column5 ;
					IF (addres >= 0 ) AND (addres <= max_adr ) THEN
					  BEGIN (* good absolute address *)
					     IF mcr[mcr_num].d_con.abs1 OR mcr[mcr_num].d_con.abs2 THEN
					       BEGIN   (* Duplicate absolute address contraint *)
				    		   WRITELN (' ');
					   	   WRITELN ('          LOAD_DATA***ERROR** DUPLICATE ABSOLUTE ADDRESS CONSTRAINT IN ',con_fil_nam);
						   WRITELN (constr_field,' ',mcr[mcr_num].d_con.line1,' ',comp_mcr,' ',column4,' ',mcr_delta);
						   WRITELN (constr_field,' ',con_line_num,' ',column3,' ',column4,' ',column5)
					       END  (* Duplicate absolute address contraint *)
					      ELSE IF mcr[mcr_num].d_con.line1 = 0 THEN   (* CHECK FOR EMPTY LOCATION *)
					       BEGIN  (* use d_con*1 *)
						   mcr[mcr_num].d_con.abs1 := TRUE ;
						   mcr[mcr_num].d_con.m_adr1 := addres::mcr_adr;
						   mcr[mcr_num].p_adr := addres ;
						   mcr[mcr_num].d_con.line1 := con_line_num ;
						   mcr[mcr_num].weight := 1000;
						   p_adr[addres::INTEGER] := mcr_num ;
					       END  (* use d_con*1 *)
					      ELSE IF mcr[mcr_num].d_con.line2 = 0 THEN   (* CHECK FOR EMPTY LOCATION *)
					       BEGIN   (* use d_con*2 *)
						   mcr[mcr_num].d_con.abs2 := TRUE ;
						   mcr[mcr_num].d_con.m_adr2 := addres::mcr_adr;
						   mcr[mcr_num].p_adr := addres ;
						   p_adr[addres::INTEGER] := mcr_num ;
						   mcr[mcr_num].weight := 1000;
						   mcr[mcr_num].d_con.line2 := con_line_num ;
					       END   (* use d_con*2 *)
					     ELSE
					       BEGIN  (*  Extra delta contraint *)
					 	   error :=true ;
						   comp_mcr := mcr[mcr_num].d_con.m_adr1 ;
						   mcr_delta := mcr[mcr_num].d_con.delta1 ;
				    		   WRITELN (' ');
				   		   WRITELN ('          LOAD_DATA***ERROR** EXTRA DELTA CONSTRAINT IN ',con_fil_nam);
						   WRITELN (constr_field,' ',mcr[mcr_num].d_con.line1,' ',comp_mcr,' ',column4,' ',mcr_delta);
						   WRITELN (constr_field,' ',con_line_num,' ',column3,' ',column4,' ',column5);
					       END;  (*  Extra delta contraint *)

					     IF mcr[mcr_num].a_con.line > 0 THEN
					      BEGIN  (* have address contraint *)
						new_ones_msk := mcr[mcr_num].a_con.ones_msk;	  
						new_zero_msk := mcr[mcr_num].a_con.zero_msk;
						IF (UOR(mcr[mcr_num].p_adr,new_ones_msk) <> mcr[mcr_num].p_adr) OR
(*                                                 x   y                               y                      x  *)
						   (UOR( UNOT(mcr[mcr_num].p_adr),new_zero_msk) <> UNOT(mcr[mcr_num].p_adr)) THEN
(*                                                 a   b     c                  c             b        d                  da *)
							BEGIN (* conflict *)
							   error := TRUE;
				 			   WRITELN ;
							   WRITELN ('          LOAD_DATA***ERROR**  ABSOLUTE ASSIGNMENT CONFLICTS WITH ADDRESS CONTRAINT.  IN ',
							   adr_fil_nam );
							   WRITELN ('LINE # =',con_line_num:5 );
							   WRITELN ('MCR #  =',mcr_num:4,'(',HEX(mcr_num,3),')    MASK = ',
								mask(new_zero_msk,new_ones_msk) );
							   IF mcr[mcr_num].d_con.abs1 THEN
							     BEGIN (* use d_con*1 *)
								WRITELN ('LINE # =',mcr[mcr_num].d_con.line1:5 );
								WRITELN ('MCR #  =',mcr[mcr_num].d_con.m_adr1:4,'(',
								   HEX(mcr[mcr_num].d_con.m_adr1,3),')    @ ',
								   mcr[mcr_num].p_adr:4,'(',HEX(mcr[mcr_num].p_adr,3),')' );
							     END  (* use d_con*1 *)
							ELSE
							     BEGIN (* use d_con*2 *)
								WRITELN ('LINE # =',mcr[mcr_num].d_con.line2:5 );
								WRITELN ('MCR #  =',mcr[mcr_num].d_con.m_adr2:4,'(',
								   HEX(mcr[mcr_num].d_con.m_adr2,3),')    @ ',
								   mcr[mcr_num].p_adr:4,'(',HEX(mcr[mcr_num].p_adr,3),')' );
							     END  (* use d_con*2 *)
							END  (* conflict *)
					      END (* have address contraint *)
					  END   (* good absolute address *)
					 ELSE
					    BEGIN   (* bad absolute address *)
						error := true ;
						WRITELN (' ');
						WRITELN ('          LOAD_DATA***ERROR** ADDRESS OUT OF RANGE IN ',con_fil_nam);
						WRITELN ('PHYS ADDRESS =',column5:4,'  OUT OF RANGE' );
						WRITELN (constr_field,' ',con_line_num,' ',column3,' ',mcr_num,' ',addres);
					    END   (* bad absolute address *)
				     END		(* ABSOLUTE PHYSICAL ADDRESS *)
				   ELSE
				     BEGIN		(* Delta relation *)
					 mcr_delta := column5 ;
					 mcr_num := column4 ;
					 comp_mcr := column3 ;
					 IF mcr[mcr_num].d_con.line1 = 0 THEN
					   BEGIN   (* use d_con*1 *)
					     mcr[mcr_num].d_con.line1 := con_line_num ;
					     mcr[mcr_num].d_con.m_adr1 := comp_mcr ;
					     mcr[mcr_num].d_con.delta1 := mcr_delta ;
					   END   (* use d_con*1 *)
					 ELSE IF mcr[mcr_num].d_con.line2 = 0 THEN
				 	   BEGIN    (* use d_con*2 *)
					     mcr[mcr_num].d_con.line2 := con_line_num ;
					     mcr[mcr_num].d_con.m_adr2 := comp_mcr ;
					     mcr[mcr_num].d_con.delta2 := mcr_delta ;
					     IF mcr[mcr_num].d_con.delta1 = mcr[mcr_num].d_con.delta2 THEN
						BEGIN  (* duplicate delta *)
						   error := true;
				    	     	   WRITELN (' ');
				   	     	   WRITELN ('          LOAD_DATA***ERROR** DUPLICATE DELTA CONSTRAINT IN ',con_fil_nam);
					     	   WRITELN (constr_field,' ',mcr[mcr_num].d_con.line1,' ',comp_mcr,' ',column4,' ',mcr_delta);
					     	   WRITELN (constr_field,' ',con_line_num,' ',column3,' ',column4,' ',column5);
						END;  (* duplicate delta *)
					     IF mcr[mcr_num].d_con.line1 = mcr[mcr_num].d_con.line2 THEN
						BEGIN  (* duplicate line *)
						   error := true;
				    	     	   WRITELN (' ');
				   	     	   WRITELN ('          LOAD_DATA***ERROR** DUPLICATE LINE DELTA NUMBER IN ',con_fil_nam);
					     	   WRITELN (constr_field,' ',mcr[mcr_num].d_con.line1,' ',comp_mcr,' ',column4,' ',mcr_delta);
					     	   WRITELN (constr_field,' ',con_line_num,' ',column3,' ',column4,' ',column5);
						END  (* duplicate line *)
					   END    (* use d_con*2 *)
					 ELSE
				           BEGIN  (*  Extra delta contraint *)
				 	     error :=true ;
					     comp_mcr := mcr[mcr_num].d_con.m_adr1 ;
					     mcr_delta := mcr[mcr_num].d_con.delta1 ;
				    	     WRITELN (' ');
				   	     WRITELN ('          LOAD_DATA***ERROR** EXTRA DELTA CONSTRAINT IN ',con_fil_nam);
					     WRITELN (constr_field,' ',mcr[mcr_num].d_con.line1,' ',comp_mcr,' ',column4,' ',mcr_delta);
					     WRITELN (constr_field,' ',con_line_num,' ',column3,' ',column4,' ',column5);
					   END   (*  Extra delta contraint *)
				     END		(* Delta relation *)
			     END   (* good mcr range *)
			   ELSE
			     BEGIN   (* bad mcr range *)
				   error := true;
				   WRITELN (' ');
				   WRITELN ('          LOAD_DATA***ERROR** MCR NUMBER OUT OF RANGE IN ',con_fil_nam);
				   WRITELN ('MCR  #     =',column3:4,'   OUT OF RANGE' );
				   WRITELN (constr_field,' ',con_line_num,' ',column3,' ',column4,' ',column5);
			     END  (* bad mcr range *)
		       END   (* d_con *)
		END
	    END; (* WHILE NOT EOF *)
	CLOSE ( con_file ) ;

(* Look for CASE TARGET ERRORS *)

	IF NOT quiet THEN FOR mcr_num := 1 TO last_mcr_adr DO
	 IF mcr[mcr_num].b_con.line > 0 THEN
	   BEGIN {b con found}
		companion_mcr := mcr[mcr_num].b_con.m_adr;
		IF (NOT mcr[companion_mcr].d_con.abs1) AND (mcr[companion_mcr].d_con.line1 > 0) THEN
		 IF mcr[companion_mcr].d_con.delta1 <> 0 THEN
		   BEGIN {warning}
			   IF NOT print_header THEN
				BEGIN
				   WRITELN (' ');
				   WRITELN ('          LOAD_DATA***WARNING** POSSIBLE CASE TARGET - ALIGN LIST CONFLICTS');
				   WRITELN ('   CASE LINE #		ALIGN LIST LINE #');
				   WRITELN ('   -----------		-----------------');
				   print_header := true;
				END;
			   WRITELN ('        ',mcr[mcr_num].b_con.line:5,'                     ',mcr[companion_mcr].d_con.line1:5);
		   END; {warning}
		IF (NOT mcr[companion_mcr].d_con.abs2) AND (mcr[companion_mcr].d_con.line2 > 0) THEN
		 IF mcr[companion_mcr].d_con.delta2 <> 0 THEN
		   BEGIN {warning}
			   IF NOT print_header THEN
				BEGIN
				   WRITELN (' ');
				   WRITELN ('          LOAD_DATA***WARNING** POSSIBLE CASE TARGET - ALIGN LIST CONFLICTS');
				   WRITELN ('   CASE LINE #		ALIGN LIST LINE #');
				   WRITELN ('   -----------		-----------------');
				   print_header := true;
				END;
			   WRITELN ('        ',mcr[mcr_num].b_con.line:5,'                     ',mcr[companion_mcr].d_con.line2:5);
		   END; {warning}
	   END {b con found}


END;  (* PROCEDURE LOAD_DATA *)



		(* COLLECT_SETS LOOKS THROUGH ALL MCRS, FIND THE ONES WITH DELTA CONSTRAINTS , AND USES THEM TO FORM SETS *)




PROCEDURE collect_sets ;
CONST
	block_msk = %b'11110000000' ;
	zero_delta = 0 ;
VAR
	a_con_mcr, abs_mcr, companion_mcr, mcr_num, s, set_length,
	tmp_weight,last_set_len,mcr_entry,tmp_mcr,set_len_minus_one,count,n,m,i : INTEGER ;
	ones_msk, zero_msk, a_con_delta, t_adr, adrx, addres, delta, ref_delta, tmp_delta, abs_delta, abs_adr : UNSIGNED ;
	okay, end_of_range, a_con, two_a_con : BOOLEAN ;
	s_mcr, b_mcr : INTEGER;
	care_bits, s_delta, b_delta, s_ones_msk, b_ones_msk, s_zero_msk, b_zero_msk : UNSIGNED;
	
     PROCEDURE put_data_into_set ( set_val,mcr_val : INTEGER ; delta : UNSIGNED ; ccase : INTEGER);
     VAR
	len : INTEGER ;

	BEGIN
		IF (set_val > max_set) OR (mcr_val < 0) OR (mcr_val > max_adr) OR (delta < 0) OR (delta > max_adr) THEN
		   BEGIN  (* parameter error *)
			   WRITELN (' ');
			   WRITELN ('DRY ROT (PUT_DATA_INTO_SET) - BAD VALUE');
			   WRITELN (' SET  # ',set_val:4,' MCR ',mcr_val:4,'(',HEX(mcr_val,3),')  DELTA ',delta::INTEGER:4,
				'   CASE ',ccase:4);
		   END  (* parameter error *)
		ELSE
		   BEGIN  (* no parameter error *)
			setn[set_val].length := setn[set_val].length + 1 ;
			len := setn[set_val].length ;
			IF len > max_set_len THEN
			   BEGIN  (* length error *)
				error := true ;
			   	WRITELN (' ');
			   	WRITELN ('DRY ROT (PUT_DATA_INTO_SET) - TOO MANY ENTRIES IN SET');
			   	WRITELN (' SET  # ',set_val:4,' MCR # ',mcr_val:4,' DELTA ',delta::INTEGER:4,'   CASE ',ccase:4);
			   END  (* length error *)
			ELSE
			   BEGIN  (* assign mcr to set *)
				IF mcr[mcr_val].d_con.abs1 OR mcr[mcr_val].d_con.abs2 THEN setn[set_val].abs := TRUE ;
				setn[set_val].entry[len] := mcr_val ;
				setn[set_val].delta[len] := delta ;
			   END  (* assign mcr to set *)
		   END  (* no parameter error *)
	END;  (* END PROCEDURE PUT_DATA_INTO_SET *)

	PROCEDURE CHK_FOR_SET (mcr_num: INTEGER; delta: UNSIGNED; companion_mcr: mcr_adr);
	VAR 
		adj_delta, c_set_num, c_set_len, set_num, set_len, entry_num, c_base_entry, base_entry: INTEGER;
		flag: BOOLEAN;
		low_delta, new_delta, c_base_delta, base_delta: UNSIGNED;
		c_mcr: mcr_adr;

	   BEGIN   (* procedure chk_for_set *)
		IF mcr[mcr_num].setn > 0 THEN
		  BEGIN   (* mcr in set *)
			IF mcr[companion_mcr].setn  = 0 THEN
			  BEGIN  (* companion not in set *)

		(* case II - mcr is in a set; companion is not in a set.  Add companion to set. *)

				set_num := mcr[mcr_num].setn;
				set_len := setn[set_num].length;
				entry_num := 0;
				flag :=FALSE;
				REPEAT 
					BEGIN   (* search for companion within set *)
					   entry_num := entry_num +1;
					   IF setn[set_num].entry[entry_num] = mcr_num THEN
					      BEGIN
						base_delta := setn[set_num].delta[entry_num];
						flag := true
					      END
					END  (* search for companion within set *)
				UNTIL flag OR (entry_num >= set_len);
				IF NOT flag THEN
				    BEGIN  (* impossible *)
				  	error := true ;
					base_delta := -1;
				  	WRITELN ('DRY ROT (CHK_FOR_SET) - CASE II - MCR',mcr_num,
						'(',HEX(mcr_num,3),') SHOULD BE ASSIGNED TO A SET ',set_num:4);
				    END;    (* impossible *)
				adj_delta := (base_delta - delta)::INTEGER;
				IF adj_delta < 0 THEN
					BEGIN
					new_delta := 0;
					FOR entry_num := 1 to set_len DO
						setn[set_num].delta[entry_num] := setn[set_num].delta[entry_num] - 
						  (base_delta-delta);
					END
				  ELSE new_delta := adj_delta::UNSIGNED;

				mcr[companion_mcr].setn := set_num ;
				put_data_into_set (set_num, companion_mcr, new_delta, 2);
			    END  (* companion not in set*)
			  ELSE
			    BEGIN  (* companion in set *)

		(* case IV - mcr is in a set; companion in a set.  Merge mcr set into companion set  *)

				set_num := mcr[mcr_num].setn;
				set_len := setn[set_num].length;
				c_set_num := mcr[companion_mcr].setn;
				c_set_len := setn[c_set_num].length;

			(* find companion entry with companion set *)

				entry_num := 0;
				flag := FALSE;
				REPEAT 
					BEGIN   (* search for companion within companion set *)
					   entry_num := entry_num +1;
					   IF setn[c_set_num].entry[entry_num] = companion_mcr THEN
					      BEGIN
						c_base_delta := setn[c_set_num].delta[entry_num];
						c_base_entry := entry_num;

						flag := true
					      END
					END  (* search for companion within set *)
				UNTIL flag OR (entry_num >= c_set_len);
				IF NOT flag THEN
				    BEGIN  (* impossible *)
				  	error := true ;
					c_base_entry := 1;
					c_base_delta := -1;
				  	WRITELN ('DRY ROT (CHK_FOR_SET) - CASE IV - MCR ',mcr_num,'(',HEX(mcr_num,3),
						') SHOULD BE ASSIGNED COMPANION SET ',c_set_num:4);
				    END;    (* impossible *)


			(* find mcr within mcr set *)

				entry_num := 0;
				flag := FALSE;
				REPEAT 
					BEGIN   (* search for mcr within set *)
					   entry_num := entry_num +1;
					   IF setn[set_num].entry[entry_num] = mcr_num THEN
					      BEGIN
						base_delta := setn[set_num].delta[entry_num];
						base_entry := entry_num;
						flag := true
					      END
					END  (* search for companion within set *)
				UNTIL flag OR (entry_num >= set_len);
				IF NOT flag THEN
				    BEGIN  (* impossible *)
				  	error := true ;
					base_entry := 1;
					base_delta := -1;
				  	WRITELN ('DRY ROT (CHK_FOR_SET) - CASE IV - MCR ',mcr_num,'(',
						HEX(mcr_num,3),') SHOULD BE ASSIGNED MCR SET ',set_num:4);
				    END;    (* impossible *)

				IF c_set_num = set_num THEN
				   BEGIN (* same set *)
					IF base_delta <> (c_base_delta + delta) THEN
					   BEGIN (* error *)
						WRITELN;
						WRITELN ('          COLLECT SETS***ERROR***   SET ',
							set_num:4,' HAVE DUPLICATE DELTA' );
						WRITELN ('             MCR            DELTA');
						WRITELN ('            ',setn[set_num].entry[base_entry]:4,'(',
							HEX(setn[set_num].entry[base_entry],3),')       ',
							setn[set_num].delta[base_entry]:4);
						WRITELN ('            ',setn[c_set_num].entry[c_base_entry]:4,'(',
							HEX(setn[c_set_num].entry[c_base_entry],3),')       ',
							setn[c_set_num].delta[c_base_entry]:4);
					   END (* error *)
				   END (* same set *)
				ELSE
				   BEGIN (* different sets *)

			(* determine if a negative delta is generated by the merge *)

					low_delta := 2048;
					FOR entry_num := 1 TO set_len DO
					   BEGIN
						new_delta := (setn[set_num].delta[entry_num] - base_delta) + (delta + c_base_delta);
						IF new_delta::INTEGER < low_delta::INTEGER THEN low_delta := new_delta;
					   END;

				(* adjust delta's in companion set if a negative delta is generated *)

					IF low_delta::INTEGER < 0 THEN
					   FOR entry_num := 1 TO c_set_len DO
						setn[c_set_num].delta[entry_num] := setn[c_set_num].delta[entry_num] - low_delta
					ELSE low_delta := 0 ;

				(* move all mcr set entries to the companion set *)

					FOR entry_num := 1 TO set_len DO
					   BEGIN
						new_delta := (setn[set_num].delta[entry_num] - base_delta) + 
						   (delta + c_base_delta) - low_delta;
						c_mcr := setn[set_num].entry[entry_num];
						mcr[c_mcr].setn := c_set_num;
						put_data_into_set (c_set_num, c_mcr, new_delta,4)
					   END;

				(* mark deleted set, i.e., the mcr set, as length 0 *)

					setn[set_num].length := 0;
					IF setn[set_num].abs THEN setn[c_set_num].abs := TRUE;

				   END (* different sets *)
			    END    (* companion in set *)
		  END    (* mcr in set *)
	    ELSE IF mcr[companion_mcr].setn > 0 THEN

		(* case III - mcr is not in a set; companion is in a set.  Add mcr to companion set with adjusted delta *)

		  BEGIN   (* case within case *)
		     c_set_num := mcr[companion_mcr].setn ;
		     c_set_len := setn[c_set_num].length ;

			(* find companion within companion set *)

		     entry_num := 0;
		     flag := false;
		     REPEAT 
			BEGIN
			   entry_num := entry_num +1;
			   IF setn[c_set_num].entry[entry_num] = companion_mcr THEN
				BEGIN
				   new_delta := setn[c_set_num].delta[entry_num] + delta;
				   flag := TRUE
				END
			END  (* search for companion within set *)
		     UNTIL flag OR (entry_num >= c_set_len);
		     IF NOT flag THEN
			    BEGIN  (* impossible *)
			  	error := true ;
			  	WRITELN ('DRY ROT (CHK_FOR_SET) - CASE III - ');
				WRITELN(' MCR ',companion_mcr,'(',HEX(companion_mcr,3),
					') SHOULD BE ASSIGNED TO THE COMPAINION SET ',c_set_num:4);
			    END;    (* impossible *)
		     mcr[mcr_num].setn := c_set_num ;
		     put_data_into_set (c_set_num,mcr_num,new_delta,3);
		  END  (* case within case *)
	    ELSE 

		(* case I - mcr is not in a set; companion is not in a set.  Create new set *)

   	          BEGIN  (* CREATE A NEW SET *)
		  last_set := last_set + 1 ;  (* LAST_SET IS THE EFFECTIVE "NEW SET NUMBER" *)
		  IF last_set <= max_set THEN
			  BEGIN (* valid set number *)
				mcr[mcr_num].setn := last_set ;
			        mcr[companion_mcr].setn := last_set ;
			        c_base_delta := 0 ;
				IF NOT mcr[companion_mcr].d_con.abs1 AND (mcr[companion_mcr].d_con.delta1 > c_base_delta) THEN
					c_base_delta := mcr[companion_mcr].d_con.delta1;
				IF NOT mcr[companion_mcr].d_con.abs2 AND (mcr[companion_mcr].d_con.delta2 > c_base_delta) THEN
					c_base_delta := mcr[companion_mcr].d_con.delta2;
				new_delta := c_base_delta + delta ;
				put_data_into_set (last_set,mcr_num,new_delta,1 );
				put_data_into_set (last_set,companion_mcr,c_base_delta,1 );
			  END  (* valid set number *)
		  ELSE
			  BEGIN  (* invalid set number *)
				error := true ;
				WRITELN ('SET #',last_set:4,' EXCEEDES MAX_SET!!!');
			  END  (* invalid set number  *)
   	          END  (* CREATE A NEW SET *)
	   END; (* procedure chk_for_set *)


BEGIN		(* BODY OF COLLECT SETS *)
    IF NOT error THEN
     BEGIN   (* no error *)
	FOR mcr_num := 0 TO last_mcr_adr DO
	   BEGIN  (* sequence *)
	      IF NOT mcr[mcr_num].d_con.abs1 AND (mcr[mcr_num].d_con.line1 > 0) THEN
			CHK_FOR_SET(mcr_num, mcr[mcr_num].d_con.delta1, mcr[mcr_num].d_con.m_adr1);
	      IF NOT mcr[mcr_num].d_con.abs2 AND (mcr[mcr_num].d_con.line2 > 0) THEN
			CHK_FOR_SET(mcr_num, mcr[mcr_num].d_con.delta2, mcr[mcr_num].d_con.m_adr2)
	   END;   (* sequence *)

		(*  CHECK EACH SET FOR DUPLICATE DELTA'S  and
		    CALCULATE THE WEIGHT OF each set *)

	FOR s:= 1 TO last_set DO
	  BEGIN   (* set sequence *)
		set_length := setn[s].length ;
		IF set_length >0 THEN
		BEGIN  (* set not empty *)
		  set_len_minus_one := set_length - 1 ;
		  tmp_weight := 0 ;

		  FOR n := 1 TO set_length DO
		     BEGIN	   (* calculate set weight *)
			mcr_entry := setn[s].entry[n] ;
			IF mcr[mcr_entry].weight > tmp_weight THEN tmp_weight := mcr[mcr_entry].weight
		     END;   (* calculate set weight *)
		  setn[s].weight := ( tmp_weight * 20 ) + set_length ;

		  FOR count := 1 TO set_len_minus_one DO
		     BEGIN  (* each entry *)
			n := count + 1 ;
			ref_delta := setn[s].delta[count] ;
			FOR m := n TO set_length DO
			  BEGIN	(* COMPARE REF DELTA *)
				IF ref_delta = setn[s].delta[m] THEN
				  BEGIN  (* error *)
					error := true ;
					WRITELN (' ' );
					WRITELN ('          COLLECT SETS***ERROR***   SET ',S:4,' HAVE DUPLICATE DELTA' );
					WRITELN ('             MCR            DELTA');
					WRITELN ('            ',setn[s].entry[count]:4,'(',HEX(setn[s].entry[count],3),')       ',
							setn[s].delta[count]:4);
					WRITELN ('            ',setn[s].entry[m]:4,'(',HEX(setn[s].entry[m],3),')       ',
							setn[s].delta[m]:4);
				  END; (* error *)
			  END; (* compare ref delta *)
		     END; (* each entry *)
		END;  (* set not empty *)
	  END; (* set sequence *)


		        (* WITHIN EACH SET, SORT ENTRIES BY DELTA ( SMALLEST DELTA FIRST )  *)

	FOR s:= 1 TO last_set DO
	 IF setn[s].length > 0 THEN
	  BEGIN  (* set sequence *)
	    FOR i:= 1 TO (setn[s].length - 1 ) DO
	      BEGIN  (* outer loop *)
	        FOR n:= 1 TO (setn[s].length - 1 ) DO
	          BEGIN  (* middle loop *)
		    IF setn[s].delta[n] > setn[s].delta[ (n+1) ] THEN
		     BEGIN (* inner loop *)
			tmp_delta := setn[s].delta[n] ;
			tmp_mcr := setn[s].entry[n] ;
			setn[s].delta[n] := setn[s].delta[ (n+1) ] ;
			setn[s].entry[n] := setn[s].entry[ (n+1) ] ;
			setn[s].delta[ (n+1) ] := tmp_delta ;
			setn[s].entry[ (n+1) ] := tmp_mcr ;
		     END (* inner loop *)
	          END  (* middle loop *)
	      END; (* outer loop *)

	(* check to see if set crosses a block boundary *)

	     two_a_con := FALSE;
	     a_con := FALSE;
	     FOR n:=1 TO setn[s].length DO
	      BEGIN  (* check each entry *)
		mcr_num := setn[s].entry[n];
		IF mcr[mcr_num].d_con.abs1 OR mcr[mcr_num].d_con.abs2 THEN
		   BEGIN   (* abs found *)
			setn[s].abs := TRUE ;
			abs_delta := setn[s].delta[n]  ;
			addres := mcr[mcr_num].p_adr ;
			abs_mcr := mcr_num ;
			abs_adr := addres ;
		   END; (* abs found *)

		IF mcr[mcr_num].a_con.line > 0 THEN
		   BEGIN  (* a_con found *)
			IF a_con THEN two_a_con := true ELSE a_con := true;
			ones_msk := mcr[mcr_num].a_con.ones_msk;
			zero_msk := mcr[mcr_num].a_con.zero_msk;
			a_con_delta := setn[s].delta[n];
			a_con_mcr := mcr_num;
		   END (* a_con found *)

	      END;  (* check each entry *)


	     IF two_a_con THEN
	      FOR n:=1 TO setn[s].length DO
	       BEGIN (* check each entry *)
		mcr_num := setn[s].entry[n];
		delta := setn[s].delta[n];
		IF mcr[mcr_num].a_con.line > 0 THEN
		   BEGIN  (* found a_con *)

			IF delta > a_con_delta THEN 
			   BEGIN
				s_mcr := a_con_mcr;
				b_mcr := mcr_num;
				s_delta := a_con_delta;
				b_delta := delta;
			   END
			ELSE
			   BEGIN
				s_mcr := mcr_num;
				b_mcr := a_con_mcr;
				s_delta := delta;
				b_delta := a_con_delta;
			   END;
			s_ones_msk := mcr[s_mcr].a_con.ones_msk;
			b_ones_msk := mcr[b_mcr].a_con.ones_msk;
			s_zero_msk := mcr[s_mcr].a_con.zero_msk;
			b_zero_msk := mcr[b_mcr].a_con.zero_msk;

{ ***BEGIN*** Version 1.06 change to fix impossible address contraint checking }
			care_bits := UNOT(UOR(s_ones_msk,s_zero_msk));
			okay := FALSE;
			end_of_range := FALSE;
			t_adr := s_ones_msk;

			REPEAT
			   adrx := t_adr + b_delta - s_delta;
			   IF NOT ( (UAND(adrx,b_ones_msk) <> b_ones_msk) OR
				    (UAND( UNOT(adrx),b_zero_msk) <> b_zero_msk) ) THEN
			      okay := TRUE
			   ELSE IF UAND( (t_adr+1),care_bits) <> (t_adr+1)  THEN
			      end_of_range := TRUE
			   ELSE 
			      t_adr := t_adr + 1;
			UNTIL end_of_range OR okay;
			
			IF NOT okay THEN
			   BEGIN (* error *)
				error := true ;
				WRITELN (' ' );
				WRITELN ('          COLLECT SETS***ERROR***   SET ',S:4,' IMPOSSIBLE ADDRESS CONSTRAINT' );
				WRITELN ('             MCR            DELTA    MASK');
				WRITELN ('            ',s_mcr:4,'(',HEX(s_mcr,3),')       ',
					s_delta:4,'    ',mask(s_zero_msk,s_ones_msk));
				WRITELN ('            ',b_mcr:4,'(',HEX(b_mcr,3),')       ',
					b_delta:4,'    ',mask(b_zero_msk,b_ones_msk));
			   END (* error *)

{ ***END***** Version 1.06 change to fix impossible address contraint checking }


		   END; (* found a_con *)
	       END; (* check each entry *)

	     IF setn[s].abs THEN 
	      FOR n:=1 TO setn[s].length DO
	       BEGIN  (* check each entry *)
		mcr_num := setn[s].entry[n];
		delta := setn[s].delta[n];
		IF UAND(abs_adr, block_msk) <> UAND( (abs_adr + delta - abs_delta),block_msk) THEN
			   BEGIN
				WRITELN (' ' );
				WRITELN ('          COLLECT SETS***ERROR***   SET ',S:4,' CROSSES BLOCK BOUNDARY' );
				WRITELN ('             MCR            DELTA    ADR');
				WRITELN ('            ',abs_mcr:4,'(',HEX(abs_mcr,3),')       ',
						abs_delta:4,'   @  ',abs_adr:4,'(',HEX(abs_adr,3),')');
				WRITELN ('            ',mcr_num:4,'(',HEX(mcr_num,3),')       ',
						delta:4,'       crosses block - can not be allocated ');
			   END
	       END;  (* check each entry *)

	(* assign all set entries if set contains an absolute assignment *)

	     IF setn[s].abs THEN
		FOR n:=1 TO setn[s].length DO
		   BEGIN
			mcr_num := setn[s].entry[n] ;
			addres := abs_adr - (abs_delta - setn[s].delta[n]) ;
			IF ( (mcr[mcr_num].p_adr <> 2048) AND (mcr[mcr_num].p_adr <> addres) ) OR
			   ( (p_adr[addres::INTEGER] <> -1) AND (p_adr[addres::INTEGER] <> mcr_num) ) THEN
				BEGIN
				   WRITELN;
				   WRITELN ('          COLLECT SETS***ERROR***   SET ',S:4,' ABSOLUTE ASSIGNMENT COLLISION');
				   WRITELN(' MCR ',mcr_num:4,'(',HEX(mcr_num,3),') needs to be at ',addres:4,'(',
					HEX(addres,3),')');
				   WRITELN(' MCR ',p_adr[addres::INTEGER]:4,'(',HEX(p_adr[addres::INTEGER],3),') is assigned to ',
					addres:4,'(',HEX(addres,3),')');
				   END
			ELSE
			   BEGIN
				mcr[mcr_num].p_adr := addres ;
				p_adr[addres::INTEGER] := mcr_num ;
			   END
		   END ;
					
	(* check to make sure there is a zero delta in the set *)

	     IF setn[s].delta[1] <> 0 THEN
		  BEGIN
			error := true ;
			WRITELN;
			WRITELN ('          COLLECT SETS***ERROR***   SET ',S:4,' BAD FORM');
			WRITELN ('  NO DELTA OF 0 FOUND' );
		  END;
	  END; (* set sequence *)

     END; (* END IF NOT error *)
END; (* END PROCEDURE COLLECT_SETS *)




PROCEDURE collect_groups ;
CONST
	position_8 = 8 ;
	position_11 = 11 ;

VAR
	grp_size,num_of_x,grp_num,grp_entry_type,pass,next,tmp_entry,tmp_set,next_set_num,
	companion_mcr,mcr_num,group_num,mcr_in_grp,mcr_in_set,set_num,set_len,grp_len,n,m,
	set_length,set_entry,mcr_grp,comp_mcr_grp,mcr_grp_len,comp_grp_len,entry,new_entry,mcr_entry,next_mcr,next_set : INTEGER ;
	max_set_weight, max_mcr_weight: INTEGER;
	merge_error: BOOLEAN ;
	not_ones_or_zero,position_of_x : UNSIGNED ;


PROCEDURE put_data_into_group ( grp_val, mcr_val, ccase : INTEGER );

VAR
	len,mcr_entry,set_length,set_num,n : INTEGER ;

BEGIN
    IF (grp_val < 0) OR (grp_val > max_group) OR (mcr_val < 0) OR (mcr_val > max_adr) THEN
	BEGIN  (* parameter error *)
	   error := TRUE;
	   WRITELN('DRY ROT (PUT_DATA_INTO_GROUP) - BAD PARAMETER');
	   WRITELN(' GROUP  ',grp_val:4,'    MCR ',mcr_val:4,'(',HEX(mcr_val,3),')   CASE ',ccase:2);
	END (* parameter error *)
    ELSE
	BEGIN  (* no parameter error *)
	    group[grp_val].length := group[grp_val].length + 1 ;
	    len := group[grp_val].length ;
	    IF len > max_group_len THEN
	     BEGIN  (* length error *)
		error := true ;
		WRITELN('GROUP ',grp_val:3,' HAS EXCEEDED MAXIMUM LENGTH.   CASE  ',ccase:2 );
	     END   (* length error *)
	    ELSE
	     BEGIN  (* no length error *)
		IF mcr[mcr_val].setn > 0 THEN
		   BEGIN  (* mcr is in a set so assign set *)
			set_num := mcr[mcr_val].setn ;
			set_length := setn[set_num].length ;
			group[grp_val].entry[len].e_type := set_t ;
			group[grp_val].entry[len].setn := set_num ;
			group[grp_val].size := group[grp_val].size + set_length ;
			FOR n := 1 TO set_length DO
			  BEGIN	 (* get each set entry *)
				mcr_entry := setn[set_num].entry[n] ;
				IF mcr[mcr_entry].group = 0 THEN mcr[mcr_entry].group := grp_val
				ELSE 
				  BEGIN  (* overwrite of a group *)
					error :=true ;
					WRITELN (' ');
					WRITELN ('           COLLECT GROUPS ERROR***  OVERWRITE OF MCR GROUP ASSIGNMENT.  CASE ',
						ccase:2);
					WRITELN ('MCR ',mcr_entry:4,'(',HEX(mcr_entry,3),')  IN SET ',set_num:4,
						' IS ASSIGNED TO GROUP ', mcr[mcr_entry].group:4);
					WRITELN ('MCR ',mcr_entry:4,'(',HEX(mcr_entry,3),')  IS ALSO ASSIGNED TO GROUP ',
						grp_val:4);
				  END  (* overwrite of a group *)
			  END 	 (* get each set entry *)
		   END  (* mcr is in a set so assign set *)
		ELSE
		   BEGIN  (* mcr is not in a set - assign mcr *)
			group[grp_val].entry[len].e_type := adr_t ;
			group[grp_val].entry[len].m_adr := mcr_val ;
			group[grp_val].size := group[grp_val].size + 1 ;
			IF mcr[mcr_val].group = 0 THEN mcr[mcr_val].group := grp_val
				 ELSE 
			  BEGIN  (* overwrite of a group *)
				error :=true ;
				WRITELN (' ');
				WRITELN ('           COLLECT GROUPS ERROR***  OVERWRITE OF MCR GROUP ASSIGNMENT.    CASE ',ccase:2);
				WRITELN ('MCR ',mcr_val:4,'(',HEX(mcr_val,3),')  IS ASSIGNED TO GROUP ',
					mcr[mcr_val].group:4);
				WRITELN ('MCR ',mcr_val:4,'(',HEX(mcr_val,3),')  IS ALSO ASSIGNED TO GROUP ',
					grp_val:4);
			  END  (* overwrite of a group *)
		   END;  (* mcr is not in a set - assign mcr *)
		IF group[grp_val].size > max_group_size THEN
		   BEGIN  (* size error *)
			error := true ;
			WRITELN ('SIZE OF GROUP ',grp_val:4,' IS ',group[grp_val].size,' - EXCEEDES MAX_GROUP_SIZE.    CASE  ',
				ccase:2 );
		   END  (* size error *)
	     END (* no length error *)
	END  (* no parameter error *)
END; (* END PROCEDURE PUT_DATA_INTO_GROUP *)

PROCEDURE add_to_blk_msk (group_value ,mcr_value : INTEGER ) ;
CONST
	block_msk = %b'11110000000' ;

VAR
	tmp_mask0,tmp_mask1 : UNSIGNED ;

BEGIN
     IF mcr[mcr_value].d_con.abs1 OR mcr[mcr_value].d_con.abs2 THEN
	BEGIN   (* absolute assignment *)
	    tmp_mask0 := UAND (block_msk ,UNOT(mcr[mcr_value].p_adr) );
	    tmp_mask1 := UAND (block_msk , mcr[mcr_value].p_adr);
	    group[group_value].blk_zero_msk := UOR (group[group_value].blk_zero_msk , tmp_mask0 );
	    group[group_value].blk_ones_msk := UOR (group[group_value].blk_ones_msk , tmp_mask1 );
	    IF UAND (group[group_value].blk_zero_msk,group[group_value].blk_ones_msk) <> 0 THEN
	      BEGIN
		  WRITELN ('GROUP ',group_value:4,' BLOCK MASK ERROR - MASK = ',
			mask(group[group_value].blk_zero_msk, group[group_value].blk_ones_msk) );
		  error :=true ;
	      END	
      	 END  (* absoulute assignment *)
    ELSE IF mcr[mcr_value].a_con.line > 0 THEN
      BEGIN
	    tmp_mask0 := UAND (block_msk , mcr[mcr_value].a_con.zero_msk);
	    tmp_mask1 := UAND (block_msk , mcr[mcr_value].a_con.ones_msk);
	    group[group_value].blk_zero_msk := UOR (group[group_value].blk_zero_msk , tmp_mask0 );
	    group[group_value].blk_ones_msk := UOR (group[group_value].blk_ones_msk , tmp_mask1 );
	    IF UAND (group[group_value].blk_zero_msk,group[group_value].blk_ones_msk) <> 0 THEN
	      BEGIN
		  error :=true ;
		  WRITELN ('GROUP ',group_value:4,' BLOCK MASK ERROR - MASK = ',
			mask(group[group_value].blk_zero_msk, group[group_value].blk_ones_msk) );
	      END
	END
END ; (* PROCDURE ADD_TO_BLK_MSK *)



BEGIN     (* BODY OF COLLECT_GROUPS *)
   IF NOT error THEN
    BEGIN  (* no error *)
	FOR mcr_num := 0 TO last_mcr_adr DO
	  BEGIN  (* mcr sequence *)
		mcr_in_grp := %b'00' ;
		IF  mcr[mcr_num].b_con.line > 0 THEN
		  BEGIN  (* mcr has b_con *)
			companion_mcr := mcr[mcr_num].b_con.m_adr ;
		 	IF mcr[mcr_num].group > 0 THEN	mcr_in_grp := %b'10' ;
			IF mcr[companion_mcr].group > 0 THEN mcr_in_grp := mcr_in_grp + 1 ;

			 CASE mcr_in_grp OF
			   %b'00' : BEGIN     (* MCR AND COMPANION MCR ARE NOT IN A GROUP - add both to a new group *)
					last_group := last_group + 1 ; (* LAST_GROUP IS THEN EFFECTIVE "NEW GROUP NUMBER" *)
					IF last_group <= max_group THEN
					  BEGIN  (* add mcr anc companion to group *)
						put_data_into_group (last_group,mcr_num,0);
						IF mcr[companion_mcr].group = 0 THEN
							put_data_into_group (last_group,companion_mcr,0); 
					  END (* add mcr anc companion to group *)
					ELSE
					  BEGIN
						error := true ;
						WRITELN ('GROUP #',last_group:4,'EXCEEDES MAX_GROUP!!!');
					  END;
			     	    END ;  (* MCR AND COMPANION MCR ARE NOT IN A GROUP *)

			   %b'01' : BEGIN    (* MCR IS NOT IN A GROUP, COMPANION MCR IS - add mcr to companion group *)
					comp_mcr_grp := mcr[companion_mcr].group ;
					put_data_into_group (comp_mcr_grp, mcr_num, 1 );
			   	    END ;    (* MCR IS NOT IN A GROUP, COMPANION MCR IS - add mcr to companion group *)

			   %b'10' : BEGIN   (* MCR IS IN A GROUP, COMPANION MCR IS NOT - add companion to mcr group *)
					mcr_grp := mcr[mcr_num].group ;
					put_data_into_group (mcr_grp,companion_mcr, 2 );
			   	    END ;  (* MCR IS IN A GROUP, COMPANION MCR IS NOT - add companion to mcr group *)

			   %b'11' : BEGIN   (* MCR AND COMPANION MCR ARE BOTH IN A GROUP - merge companion group with mcr group *)
					merge_error := FALSE ;
					mcr_grp := mcr[mcr_num].group ;
					comp_mcr_grp := mcr[companion_mcr].group ;
					mcr_grp_len := group[mcr_grp].length ;
					comp_grp_len := group[comp_mcr_grp].length ;
					IF  (mcr_grp <> comp_mcr_grp) AND (mcr_num <> companion_mcr )THEN
					   BEGIN  (* groups are merged *)
					     IF (group[mcr_grp].size + group[comp_mcr_grp].size ) > max_group_size THEN
					   	BEGIN
						   error := TRUE ;
						   merge_error := TRUE ;
						   WRITELN (' ');
						   WRITELN ('GROUP ',mcr_grp:4,' AND GROUP ',comp_mcr_grp:4,' CAN NOT BE MERGED');
						   WRITELN (' COMBINED SIZE EXCEEDS MAX_GROUP_SIZE');
						END;
					     IF (mcr_grp_len + comp_grp_len ) > max_group_len THEN
					   	BEGIN
						   error := TRUE ;
						   merge_error := TRUE ;
						   WRITELN (' ');
						   WRITELN ('GROUP ',mcr_grp:4,' AND GROUP ',comp_mcr_grp:4,' CAN NOT BE MERGED');
						   WRITELN (' COMBINED LENGTHS WILL EXCEED MAX_GROUP_LENGTH');
						END;

					     IF NOT merge_error THEN
					  	BEGIN    (* COPY CONTENTS OF COMPANION GROUP TO MCR GROUP *)
					    	   group[mcr_grp].length := mcr_grp_len + comp_grp_len ;
						   group[mcr_grp].size := group[mcr_grp].size + group[comp_mcr_grp].size ;
					    	   FOR entry := 1 TO comp_grp_len DO
						     BEGIN  (* move each companion entry *)
							new_entry := mcr_grp_len + entry ;
							group[mcr_grp].entry[new_entry].e_type := 
								group[comp_mcr_grp].entry[entry].e_type ;
					        	IF group[mcr_grp].entry[new_entry].e_type = adr_t THEN
					          	   BEGIN  (* companion entry is a mcr *)
								group[mcr_grp].entry[new_entry].m_adr := 
									group[comp_mcr_grp].entry[entry].m_adr ;
								mcr[ group[mcr_grp].entry[new_entry].m_adr ].group := mcr_grp ;
					          	   END (* companion entry is a mcr *)
							ELSE
						           BEGIN (* companion entry is a set *)
						    		group[mcr_grp].entry[new_entry].setn := group[comp_mcr_grp].entry[entry].setn ;
								set_num := group[mcr_grp].entry[new_entry].setn ;
								set_length := setn[set_num].length ;
						    		FOR set_entry :=1 TO set_length DO
						      		   BEGIN (* reassign each set entry to mcr group *)
									  mcr_in_set := setn[set_num].entry[set_entry] ;
									  mcr[mcr_in_set].group := mcr_grp ;
						      		   END  (* reassign each set entry to mcr group *)
						           END  (* companion entry is a set *)
						     END ; (* move each companion entry *)

										(* RE-INITIALIZE COMPANION MCR GROUP *)
					      	     FOR entry := 1 TO comp_grp_len DO
							BEGIN  (* companion group sequence *)
						    	   group[comp_mcr_grp].entry[entry].e_type := adr_t ;
						    	   group[comp_mcr_grp].entry[entry].m_adr := -1 ;
							END ; (* companion group sequence *)
					      	     group[comp_mcr_grp].size := 0 ;
					      	     group[comp_mcr_grp].length := 0 ;
					      	     group[comp_mcr_grp].weight := 0 ;
					      	     group[comp_mcr_grp].blk_zero_msk := 0 ;
					      	     group[comp_mcr_grp].blk_ones_msk := 0 ;

					  	END  (* COPY CONTENTS OF COMPANION GROUP TO MCR GROUP *)
					   END (* groups are merged *)
			  	    END  (* MCR AND COMPANION MCR ARE BOTH IN A GROUP - merge companion group with mcr group *)
			END
		  END (* mcr has b_con *)
	  END ; (* mcr sequence *)


					(* all set and all address constrained mcr that are not yet assigned to a group 
					   are assigned to a group *)

	FOR mcr_num := 0 TO last_mcr_adr DO
		IF ( ( mcr[mcr_num].group = 0 ) AND ( mcr[mcr_num].setn > 0 )) OR
		   ( ( mcr[mcr_num].group = 0 ) AND ( mcr[mcr_num].setn = 0 ) AND ( mcr[mcr_num].a_con.line > 0 ) ) THEN
		  BEGIN
			last_group := last_group + 1 ;
			put_data_into_group ( last_group , mcr_num, 3 ) ;
		  END; 


					(* CREATE BLOCK MASKS FOR GROUPS *)

	max_set_weight := 0;
	max_mcr_weight := 0;
	FOR group_num := 1 TO last_group DO
	   IF group[group_num].size > 0 THEN
		BEGIN  (* group exists *)
		     grp_len := group[group_num].length ;
		     FOR n := 1 TO grp_len DO
		    	IF group[group_num].entry[n].e_type = adr_t THEN
			      BEGIN  (* entry is a mcr *)
				 mcr_num := group[group_num].entry[n].m_adr ;
				 IF max_mcr_weight < mcr[mcr_num].weight THEN max_mcr_weight := mcr[mcr_num].weight;
				 add_to_blk_msk (group_num,mcr_num) ;
			      END   (* entry is a mcr *)
			ELSE
			      BEGIN  (* entry is a set *)
				 set_num := group[group_num].entry[n].setn ;
				 IF max_set_weight < setn[set_num].weight THEN max_set_weight := setn[set_num].weight;
				 set_length := setn[set_num].length ;
				 FOR m := 1 TO set_length DO
				   BEGIN  (* sequence thru the set *)
					mcr_num := setn[set_num].entry[m] ;
					add_to_blk_msk (group_num,mcr_num) ;
				   END   (* sequence thru the set *)
			      END  (* entry is a set *)
		END;  (* group exists *)

					(* FOR EACH GROUP , CREATE THE GROUP WEIGHT 
					  ( THE # OF POSSIBILITIES SUBTRACTED FROM 16 THEN MULTIPLIED BY 10
					    THEN ADDED TO THE SIZE OF THE GROUP )  *)
	FOR grp_num := 1 TO last_group DO
	  BEGIN
		not_ones_or_zero := UNOT ( UOR ( group[grp_num].blk_ones_msk , group[grp_num].blk_zero_msk ) );
		position_of_x := %b'00010000000' ;
		num_of_x := 0 ;
		FOR n := position_8 TO position_11 DO
		  BEGIN
			IF UAND ( position_of_x , not_ones_or_zero ) = position_of_x THEN num_of_x := num_of_x + 1 ;
			position_of_x := position_of_x * 2 ;
		  END; (* FOR N *)
		group[grp_num].weight := ( ( 16 - ( 2 ** num_of_x ) ) * 20 ) + 
					max_set_weight * 10 + max_mcr_weight * 5 + group[grp_num].size ;
	  END; (* FOR GROUP_NUM *)




					(* WITHIN EACH GROUP, SORT ENTRIES BY WEIGHT  *)
	FOR grp_num := 1 TO last_group DO
	  WITH group[grp_num] DO
	    BEGIN
	      IF size > 0 THEN
		BEGIN
		  FOR pass := 1 TO ( length - 1 ) DO
		    BEGIN
		       FOR n := 1 TO ( length - 1 ) DO
		        BEGIN
			  next := n + 1 ;
			  grp_entry_type := %b'00' ;
			  IF entry[n].e_type = set_t THEN grp_entry_type := %b'10' ;
			  IF entry[next].e_type = set_t THEN grp_entry_type := grp_entry_type + 1 ;

							(* SWAP THE TWO ENTRIES IF THE WEIGHT OF THE FIRST IS 
								LESS THAN THE WEIGHT OF THE SECOND *)
			  CASE grp_entry_type OF
			    %b'00' : BEGIN	(* ENTRY[ N ].TYPE = ADR_T   AND ENTRY[ NEXT].TYPE = ADR_T   *)
					 mcr_num := entry[n].m_adr ;
					 next_mcr := entry[next].m_adr ;
					 IF mcr[mcr_num].weight < mcr[next_mcr].weight THEN
					   BEGIN
						tmp_entry := entry[n].m_adr ;
						entry[n].m_adr := entry[next].m_adr ;
						entry[next].m_adr := tmp_entry ;
					   END;
				     END;

			    %b'01' : BEGIN	(* ENTRY[ N ].TYPE = ADR_T   AND ENTRY[ NEXT].TYPE = SET_T   *)
					 mcr_num := entry[n].m_adr ;
					 set_num := entry[next].setn ;
					 IF mcr[mcr_num].weight < setn[set_num].weight THEN
					   BEGIN
						tmp_entry := entry[n].m_adr ;
						entry[n].e_type := entry[next].e_type ;
						entry[n].setn := entry[next].setn ;
						entry[next].e_type := adr_t ;
						entry[next].m_adr := tmp_entry ;
					   END;
				     END;

			    %b'10' : BEGIN	(* ENTRY[ N ].TYPE = SET_T   AND ENTRY[ NEXT].TYPE = ADR_T   *)
					 set_num := entry[n].setn ;
					 mcr_num := entry[next].m_adr ;
					 IF setn[set_num].weight < mcr[mcr_num].weight THEN
					   BEGIN
						tmp_entry := entry[n].setn ;
						entry[n].e_type := entry[next].e_type ;
						entry[n].m_adr := entry[next].m_adr ;
						entry[next].e_type := set_t ;
						entry[next].setn := tmp_entry ;
					   END;
				     END;

			    %b'11' : BEGIN	(* ENTRY[ N ].TYPE = SET_T   AND ENTRY[ NEXT].TYPE = SET_T   *)
					 set_num := entry[n].setn ;
					 next_set := entry[next].setn ;
					 IF setn[set_num].weight < setn[next_set].weight THEN
					   BEGIN
						tmp_entry := entry[n].setn ;
						entry[n].setn := entry[next].setn ;
						entry[next].setn := tmp_entry ;
					   END;
				     END;
			  END;  (* CASE GRP_ENTRY_TYPE *)

		        END; (* FOR N *)
		    END ; (* FOR PASS *)
		END; (* IF SIZE *)
	    END; (* WITH GRP_NUM *)

    END; (* END IF NOT ERROR *)
END; (* END PROCEDURE COLLECT_GROUPS *)




					(* SORT GROUPS BY GROUP WEIGHT ONLY *)
PROCEDURE sort_groups  ;
TYPE
	pointer = RECORD
			group_num : INTEGER ;
			weight : INTEGER ;
		  END;

VAR
	grp_priority : ARRAY[1..max_group] OF pointer ;

			(* grp_priority[n].group_num       HOLDS THE NUMBER OF EACH GROUP AND IS INITIALIZED TO     0  *)
			(* grp_priority[n].weight    HOLDS THE WEIGHT OF EACH GROUP AND IS INITIALIZED TO     0  *)

	temp_priority : pointer ;

	tmp_grp : ARRAY[1..max_group] OF group_record ;	

	priority,lowest_priority,grp_num,len,grp_entry,num_of_x,n,next_grp_num,pass,
	next,last,count,
	loop_cnt,priority_num,mcr_num,set_num,set_len,set_entry,next_priority : INTEGER ;

	base_blk,x_mask,position : UNSIGNED ;


BEGIN
    IF not error THEN
       BEGIN
	  lowest_priority := last_group ;

						(* INITIALIZE GROUP_PRIORITY ARRAY *)
	  FOR priority := 1 TO lowest_priority DO
	    BEGIN
		grp_priority[priority].group_num := 0 ;
		grp_priority[priority].weight := 0 ;
	    END; (* FOR PRIORITY *)

						(* LOAD GRP_PRIORITY ARRAY WITH GROUP#'S AND GROUP WEIGHT'S *)
	  FOR grp_num := 1 TO last_group DO
	    BEGIN
		grp_priority[grp_num].group_num := grp_num ;
		grp_priority[grp_num].weight := group[grp_num].weight ;
	    END;


						(* SORT GRP_PRIORITY ARRAY BY WEIGHT *)
	  FOR loop_cnt := 1 TO (lowest_priority -1 )DO
	    BEGIN
	  	FOR priority := 1 TO (lowest_priority -1 )DO
		  BEGIN
			next_priority := priority + 1;
			IF grp_priority[priority].weight < grp_priority[next_priority].weight THEN
			  BEGIN
							(* SWAP ENTRIES IN GRP_PRIORITY ARRAY *)

			    temp_priority.group_num := grp_priority[priority].group_num ;
			    temp_priority.weight := grp_priority[priority].weight ;

			    grp_priority[priority].group_num := grp_priority[next_priority].group_num ;
			    grp_priority[priority].weight := grp_priority[next_priority].weight ;

			    grp_priority[next_priority].group_num := temp_priority.group_num ;
			    grp_priority[next_priority].weight := temp_priority.weight ;

			  END; (* IF GROUP... *)
		  END; (* FOR PRIORITY *)
	    END; (* FOR LOOP_CNT *)


					(* GO THROUGH EACH GROUP#, CHECK SIZE ORDERING AND FIND GROUPS WITH SIZE = 0 *)
					(* IF SIZE ORDERING IS OK THEN SUBTRACT NUMBER OF GROUPS WITH SIZE = 0  *)
					(*     FROM LAST_GROUP       *)
	last := lowest_priority - 1 ;
	count := 0 ;
  	FOR n := 1 TO last DO
	  BEGIN
		next := n + 1 ;
		grp_num := grp_priority[n].group_num ;
		next_grp_num := grp_priority[next].group_num ;
		IF group[grp_num].weight < group[next_grp_num].weight THEN
		  BEGIN
			error := true ;
			WRITELN (' SORT GROUPS ERROR *** ');
			WRITELN (' SORTING BY WEIGHT DID NOT WORK!!!');
		  END
		ELSE
		  IF group[grp_num].size = 0 THEN
		    BEGIN
			count := count + 1 ;
			IF ( n = last ) AND ( group[next_grp_num].size = 0 ) THEN
			  BEGIN
				count := count + 1 ;
			  END;
		    END; (* ELSE *)
	  END; (* FOR N *)
	last_group := last_group - count ;
	lowest_priority := last_group ;



							(* INITIALIZE TMP_GRP ARRAY *)
	  FOR priority := 1 TO lowest_priority DO
	    BEGIN
	        tmp_grp[priority].length := 0 ;
	        tmp_grp[priority].size := 0 ;
		tmp_grp[priority].weight := 0 ;
	        tmp_grp[priority].blk_zero_msk := 0 ;
	        tmp_grp[priority].blk_ones_msk := 0 ;
	        FOR N := 1 TO max_group_len DO
		   BEGIN
		       tmp_grp[priority].entry[n].e_type := adr_t ;
		       tmp_grp[priority].entry[n].m_adr := -1 ;
		   END; (* FOR N *)
	    END ; (* FOR PRIORITY *)


	  FOR priority := 1 TO lowest_priority DO       (* LOAD TMP_GRP ARRAY WITH PRIORITIZED GROUPS *)
	  BEGIN
	      grp_num := grp_priority[priority].group_num ;
	      tmp_grp[priority].size := group[grp_num].size ;
	      tmp_grp[priority].weight := group[grp_num].weight ;
	      tmp_grp[priority].blk_zero_msk := group[grp_num].blk_zero_msk ;
	      tmp_grp[priority].blk_ones_msk := group[grp_num].blk_ones_msk ;
	      tmp_grp[priority].length := group[grp_num].length ;
	      len := tmp_grp[priority].length ;
	      FOR grp_entry := 1 TO  len DO
	         BEGIN
		     tmp_grp[priority].entry[grp_entry].e_type := group[grp_num].entry[grp_entry].e_type ;
		     IF tmp_grp[priority].entry[grp_entry].e_type = adr_t THEN
		       BEGIN
			   tmp_grp[priority].entry[grp_entry].m_adr := group[grp_num].entry[grp_entry].m_adr ;
		       END
		     ELSE
		       BEGIN
			   tmp_grp[priority].entry[grp_entry].setn := group[grp_num].entry[grp_entry].setn ;
		       END;
	         END; (* FOR GRP_ENTRY *)
	  END; (* FOR PRIORITY *)

							(* CLEAR GROUP[N] ARRAY *)
	  FOR grp_num := 1 TO last_group DO
	    BEGIN
	        priority_num := grp_num ;
	        len := group[grp_num].length ;
	        group[grp_num].length := 0 ;
	        group[grp_num].size := 0 ;
	        group[grp_num].weight := 0 ;
	        group[grp_num].blk_zero_msk := 0 ;
	        group[grp_num].blk_ones_msk := 0 ;
	        FOR N := 1 TO len DO
		   BEGIN
		       group[grp_num].entry[n].e_type := adr_t ;
		       group[grp_num].entry[n].m_adr := -1 ;
		   END; (* FOR N *)

							(* RE-LOAD GROUP[N] ARRAY WITH TMP_GRP[N] ARRAY *)
		group[grp_num].length := tmp_grp[priority_num].length ;
		group[grp_num].size := tmp_grp[priority_num].size ;
		group[grp_num].weight := tmp_grp[priority_num].weight ;
		group[grp_num].blk_zero_msk := tmp_grp[priority_num].blk_zero_msk ;
		group[grp_num].blk_ones_msk := tmp_grp[priority_num].blk_ones_msk ;

				(* FOR EACH ENTRY IN GROUP[N] ; RE-ASSIGN MCR[N].GROUP TO NEW PRIORITIZED GROUP# *)

		FOR N := 1 TO group[grp_num].length DO
		   BEGIN
		       group[grp_num].entry[n].e_type := tmp_grp[priority_num].entry[n].e_type ;
		       IF group[grp_num].entry[n].e_type = adr_t THEN
		         BEGIN
			     group[grp_num].entry[n].m_adr := tmp_grp[priority_num].entry[n].m_adr ;
			     mcr_num := group[grp_num].entry[n].m_adr ;
			     mcr[mcr_num].group := grp_num ;
		         END
		       ELSE
		         BEGIN
			      group[grp_num].entry[n].setn := tmp_grp[priority_num].entry[n].setn ;
			      set_num := group[grp_num].entry[n].setn ;
			      set_len := setn[set_num].length ;
			      FOR set_entry := 1 TO set_len DO
			         BEGIN
				     mcr_num := setn[set_num].entry[set_entry] ;
				     mcr[mcr_num].group := grp_num ;
			         END ; (* FOR SET_ENTRY *)
		         END; (* ELSE *)
		   END; (* FOR N *)

	    END; (* FOR GRP_NUM *)

      END; (* IF NOT ERROR *)
END; (* PROCEDURE SORT GROUPS *)



PROCEDURE check_pat( check_zero_msk, check_ones_msk : UNSIGNED; grp_num : INTEGER; VAR match_count: INTEGER; VAR fail:BOOLEAN) ;
VAR
	care_count, bit_one, n, entry_num, grp_len, set_len, set_num, mcr_num : INTEGER;
	tmp_zero_msk, tmp_ones_msk : UNSIGNED;
BEGIN
{ writeln('check mask ',MASK(check_zero_msk,CHECK_ones_MSK));} 
	fail := FALSE;
	match_count := 0;
	grp_len := group[grp_num].length;
	FOR entry_num := 1 TO grp_len DO
		CASE group[grp_num].entry[entry_num].e_type OF
		adr_t :	BEGIN (* address type *)
			   mcr_num := group[grp_num].entry[entry_num].m_adr;
			   IF mcr[mcr_num].a_con.line > 0 THEN 
				BEGIN
				   tmp_zero_msk := mcr[mcr_num].a_con.zero_msk;
				   tmp_ones_msk := mcr[mcr_num].a_con.ones_msk;
{writeln('       target ',mask(tmp_zero_msk,tmp_ones_msk));}
				   IF (UAND(tmp_zero_msk,check_zero_msk) = check_zero_msk) AND
				    (UAND(tmp_ones_msk,check_ones_msk) = check_ones_msk) THEN match_count := match_count +  1 ;
				END
			END;  (* address type *)
		set_t : BEGIN  (* set type *)
			   set_num := group[grp_num].entry[entry_num].setn;
			   set_len := setn[set_num].length;
			   FOR n := 1 TO set_len DO
				BEGIN  (* each set entry *)
			   	   mcr_num := setn[set_num].entry[n];
				   IF mcr[mcr_num].a_con.line > 0 THEN 
					BEGIN
					   tmp_zero_msk := mcr[mcr_num].a_con.zero_msk;
					   tmp_ones_msk := mcr[mcr_num].a_con.ones_msk;
{ writeln('       target ',mask(tmp_zero_msk,tmp_ones_msk));}
					   IF (UAND(tmp_zero_msk,check_zero_msk) = check_zero_msk) AND
					    (UAND(tmp_ones_msk,check_ones_msk) = check_ones_msk) THEN match_count := match_count +  1 ;
					END
				END  (* each set entry *)
			END  (*set type *)
		END; (* case *)
{  writeln('            number of hit ',match_count); }
	bit_one := 1;
	care_count := 0;
	FOR n := 1 TO 7 DO
	   BEGIN
		IF UAND( UOR(check_zero_msk,check_ones_msk),bit_one) <> 0 THEN care_count := care_count + 1;
		bit_one := bit_one * 2;
	   END;

	IF (care_count <= 0) OR (match_count <=0) THEN writeln('DRY ROT (CHECK_PAT) - CHECK PATTERN IS ',MASK(check_zero_msk,
				check_ones_msk),' CARE COUNT IS ',care_count:4)
	 ELSE  IF match_count > (2**(7-care_count)) THEN 
	   BEGIN
		fail := TRUE;
{ writeln(' check fail'); }
	   END
	END ; (* procedure analyze *)


PROCEDURE analyze( grp_num : INTEGER) ;
VAR
	count, n, entry_num, grp_len, set_len, set_num, mcr_num : INTEGER;
	zero_msk, ones_msk : UNSIGNED;
	fail : BOOLEAN;
BEGIN
	grp_len := group[grp_num].length;
	FOR entry_num := 1 TO grp_len DO
		CASE group[grp_num].entry[entry_num].e_type OF
		adr_t :	BEGIN (* address type *)
			   mcr_num := group[grp_num].entry[entry_num].m_adr;
			   IF mcr[mcr_num].a_con.line > 0 THEN 
				BEGIN  (* have a_con *)
				  zero_msk := UAND(mcr[mcr_num].a_con.zero_msk,%B'00001111111');
				  ones_msk := UAND(mcr[mcr_num].a_con.ones_msk,%B'00001111111');
				  IF (zero_msk <> 0) OR (ones_msk <> 0) THEN 
				     BEGIN (* got non-zero msk *)
					check_pat(zero_msk, ones_msk, grp_num, count, fail);
					IF fail THEN
					 BEGIN  (* fail *)
					   WRITELN;
					   WRITELN('      ******ALLOCATE ERROR - TOO MANY ADDRESS CONSTRAINTS IN GROUP');
					   WRITELN('  MASK ',mask(zero_msk,ones_msk),' OCCURED ',count:3,' TIMES IN GROUP ',grp_num:3);
					 END (* fail *)
				     END (* got non-zero msk *)
				END  (* have a_con *)
			END;  (* address type *)
		set_t : BEGIN  (* set type *)
			   set_num := group[grp_num].entry[entry_num].setn;
			   set_len := setn[set_num].length;
			   FOR n := 1 TO set_len DO
				BEGIN  (* each set entry *)
			   	   mcr_num := setn[set_num].entry[n];
				   IF mcr[mcr_num].a_con.line > 0 THEN 
					BEGIN  (* have a_con *)
					  zero_msk := UAND(mcr[mcr_num].a_con.zero_msk,%B'00001111111');
					  ones_msk := UAND(mcr[mcr_num].a_con.ones_msk,%B'00001111111');
					  IF (zero_msk <> 0) OR (ones_msk <> 0) THEN 
					     BEGIN (* got non-zero msk *)
						check_pat(zero_msk, ones_msk, grp_num, count, fail);
						IF fail THEN
						 BEGIN  (* fail *)
						   WRITELN;
						   WRITELN('      ******ALLOCATE ERROR - TOO MANY ADDRESS CONSTRAINTS IN GROUP');
						   WRITELN('  MASK ',mask(zero_msk,ones_msk),' OCCURED ',count:3,' TIMES IN GROUP ',grp_num:3);
						 END (* fail *)
					     END (* han-zero mask *)
					END (* have a_con *)
				END  (* each set entry *)
			END  (*set type *)
		END ; (* case *)
	END ; (* procedure analyze *)


		(* ALLOCATE ATEMPTS TO STORE ALL MCRS. IT CALLS "FIT". "FIT" CALLS "STORE". "STORE" CALLS ITSELF AND DEALLOCATE. *)

PROCEDURE allocate ( filename : VARYING[R] OF CHAR );
CONST
	dot_out = '.out' ;
	null_adrs = 0 ;
TYPE
	entity_type = (mcr_ty,set_ty,grp_ty);
VAR
	n, addres, mcr_num,set_num,adrs : INTEGER ;
	block_num,dummy_adrs : UNSIGNED ;
	first_file,second_file : VARYING[132] OF CHAR ;
	done,store_fail,fit_fail : BOOLEAN ;


		(* DEALLOCATE CAN ERASE AN MCR,A SET,OR A GROUP FROM THE PHYSICAL ARRAY. *)

PROCEDURE deallocate ( val_type : entity_type ; value_num : INTEGER ; VAR addres : UNSIGNED );
CONST
	adrs_mask = %b'00001111111' ;
VAR
	mcr_num,ref_mcr,set_num,len,n,m,num_of_entries : INTEGER ;
	adrs,dummy_adrs : UNSIGNED ;

BEGIN
    CASE val_type OF
	mcr_ty : BEGIN
(*		     WRITELN ('DEALLOCATING MCR#',value_num);  *)	 (* FOR TEST PURPOSES *)
		     addres := UAND ( adrs_mask, mcr[value_num].p_adr) + 1 ;
		     adrs := mcr[value_num].p_adr ;
		     IF (adrs < 2048) AND NOT (mcr[value_num].d_con.abs1 OR mcr[value_num].d_con.abs2) THEN
		       BEGIN
			   p_adr[adrs::INTEGER] := -1 ;
			   mcr[value_num].p_adr := 2048 ;
		       END;
		 END; (* CASE MCR_TY *)

	set_ty : BEGIN
(*		     WRITELN ('DEALLOCATING SET#',value_num);  *) 	(* FOR TEST PURPOSES *)
		     ref_mcr := setn[value_num].entry[1] ;
		     addres := UAND ( adrs_mask,mcr[ref_mcr].p_adr) + 1 ;
		     len := setn[value_num].length ;
		     FOR n := 1 TO len DO
			BEGIN
			    mcr_num := setn[value_num].entry[n] ;
			    adrs := mcr[mcr_num].p_adr ;
		            IF (adrs < 2048) AND NOT (mcr[mcr_num].d_con.abs1 OR mcr[mcr_num].d_con.abs2) THEN
			    IF adrs < 2048 THEN
			      BEGIN
				   mcr[mcr_num].p_adr := 2048 ;
				   p_adr[adrs::INTEGER] := -1 ;
			      END;
			END; (* FOR N *)
		 END; (* CASE SET_TY *)

	grp_ty : BEGIN
(*		     WRITELN ('DEALLOCATING GROUP#',value_num);  *)	 (* FOR TEST PURPOSES *)
		     num_of_entries := group[value_num].length ;
		     FOR m := 1 TO num_of_entries DO
			BEGIN
			    IF group[value_num].entry[m].e_type = adr_t THEN
			      BEGIN
				  mcr_num := group[value_num].entry[m].m_adr ;
				  deallocate (mcr_ty,mcr_num,dummy_adrs);
			      END
			    ELSE
			      BEGIN
				  set_num := group[value_num].entry[m].setn ;
				  if not setn[set_num].abs then deallocate (set_ty,set_num,dummy_adrs);
			      END;
			END; (* FOR M *)
		 END; (* CASE GRP_TY *)
    END; (* CASE VAL_TYPE *)

END; (* PROCEDURE DEALLOCATE *)


		(* STORE ATTEMPTS TO A ALLOCATE AN MCR OR A SET . WHEN ALLOCATING A SET, IT CALLS ITSELF TO STORE THE
			FIRST ITEM IN THE SET. IF AN ITEM IN A SET WON'T FIT THEN STORE CALLS DEALLOCATE THEN CALLS
			ITSELF AGAIN . ( RECURSIVE UNTIL THE SET FITS OR THE ADDRESS BECOMES 128 )    *)


PROCEDURE store  ( entry_type : entity_type; entry_num : INTEGER ; block,adrs_val : UNSIGNED; VAR fail : BOOLEAN );
	
VAR
	mcr_num,mcr_val,ref_mcr,set_num,set_entry,set_len,n : INTEGER ;
	adrs,ref_adrs,block_adrs,zero,ones,mcr_delta,start_adrs,set_adrs : UNSIGNED ;
	done,set_store_fail : BOOLEAN ;

BEGIN
    block_adrs := block * 128 ;
    CASE entry_type OF
     mcr_ty : BEGIN
(*		  WRITELN ('STORING MCR#',entry_num);  *)	 (* FOR TEST PURPOSES *)
		  mcr_val := entry_num ;
		  IF (mcr[mcr_val].p_adr < 2048 ) AND NOT (mcr[mcr_val].d_con.abs1 OR mcr[mcr_val].d_con.abs2) THEN
		    BEGIN
			error := true ;
			WRITELN ('MCR# ',mcr_val,' HAS ALREADY BEEN PLACED');
		    END
		  ELSE
		    BEGIN
			done := false ;
			n := 0 ;
			IF  adrs_val > 0   THEN
			  IF adrs_val < 128 THEN
			        n := adrs_val::INTEGER
			  ELSE
			        fail := true ;
			IF mcr[mcr_val].a_con.line > 0 THEN
			  BEGIN
			       ones := mcr[mcr_val].a_con.ones_msk ;
			       zero := mcr[mcr_val].a_con.zero_msk ;
			       WHILE (n < 128 ) AND (not done ) DO
			         BEGIN
				     adrs := block_adrs + n ;
				     IF (UAND( adrs,ones) = ones) AND
					(UAND(UNOT(adrs),zero) = zero) AND
			(mcr[mcr_val].d_con.abs1 OR mcr[mcr_val].d_con.abs2 OR (p_adr[adrs::INTEGER] = -1 ) ) AND
					NOT ( mcr[mcr_val].d_con.abs1 AND (mcr[mcr_val].p_adr <> adrs) ) AND
					NOT ( mcr[mcr_val].d_con.abs2 AND (mcr[mcr_val].p_adr <> adrs) ) THEN
				       BEGIN
					   p_adr[adrs::INTEGER] := mcr_val ;
					   mcr[mcr_val].p_adr := adrs ;
					   done := true ;
				       END; (* IF UAND.. *)
				     n := n + 1 ;
			         END; (* WHILE *)
			       IF not done THEN
				     fail := true ;
			  END
			ELSE
			  BEGIN
			      WHILE (not done) AND (n < 128 ) DO
		 	        BEGIN
			          adrs := block_adrs + n ;
				  IF (mcr[mcr_val].d_con.abs1 OR mcr[mcr_val].d_con.abs2 OR (p_adr[adrs::INTEGER] = -1 ) ) AND
				     NOT ( mcr[mcr_val].d_con.abs1 AND (mcr[mcr_val].p_adr <> adrs) ) AND
				     NOT ( mcr[mcr_val].d_con.abs2 AND (mcr[mcr_val].p_adr <> adrs) ) THEN
				    BEGIN
				       p_adr[adrs::INTEGER] := mcr_val ;
				       mcr[mcr_val].p_adr := adrs ;
				       done := true ;
				    END; (* IF P_ADR.. *)
				     n := n + 1 ;
			        END; (* WHILE *)
			      IF not done THEN
			        BEGIN
			           fail := true ;
			        END;

			  END; (* IF MCR HAS A_CON *)
		    END; (* IF MCR ALREADY PLACED *)
	      END; (* CASE MCR_TY *)


     set_ty : BEGIN
(*		  WRITELN ('STORING SET#',entry_num);  *) 	(* FOR TEST PURPOSES *)
		  done := false ;
		  set_store_fail := false ;
		  start_adrs := 0 ;
		  IF adrs_val > 0 THEN
		    IF adrs_val < 128 THEN
		      BEGIN
		          start_adrs := adrs_val ;
		      END
		    ELSE
		      BEGIN	(* BLOCK BOUNDS CROSSED *)
			  fail := true ;
		      END;
		set_num := entry_num ;
		set_len := setn[set_num].length ;
		ref_mcr := setn[set_num].entry[1] ;
		set_entry := 1 ;
		WHILE (set_entry <= set_len) AND ( not fail ) AND ( not done ) DO
		   BEGIN
			IF set_entry = 1 THEN
			  BEGIN
				store (mcr_ty,ref_mcr,block,start_adrs,set_store_fail );
				ref_adrs := mcr[ref_mcr].p_adr ;
				IF set_store_fail THEN
				  BEGIN
					fail := true ;
				  END;
			  END
			ELSE
			  BEGIN
			      mcr_num := setn[set_num].entry[set_entry] ;
			      mcr_delta := setn[set_num].delta[set_entry] ;
			      adrs := ref_adrs + mcr_delta ;
			      IF adrs < (( block + 1 ) * 128 ) THEN     (* CHECK TO SEE IF ADRS HAS CROSSED BLOCK BOUNDS *)
				BEGIN
				  IF (p_adr[adrs::INTEGER] = -1) OR mcr[mcr_num].d_con.abs1 OR mcr[mcr_num].d_con.abs2 THEN
			 	    BEGIN  (* possible address *)
					IF mcr[mcr_num].a_con.line > 0 THEN
					  BEGIN  (* address contraint *)
					      ones := mcr[mcr_num].a_con.ones_msk ;
					      zero := mcr[mcr_num].a_con.zero_msk ;
				     	      IF (UAND( adrs,ones) = ones) AND
					         (UAND(UNOT(adrs),zero) = zero) AND
					         NOT ( mcr[mcr_num].d_con.abs1 AND (mcr[mcr_num].p_adr <> adrs) ) AND
					         NOT ( mcr[mcr_num].d_con.abs2 AND (mcr[mcr_num].p_adr <> adrs) )  THEN
					        BEGIN  (* assign location *)
						     p_adr[adrs::INTEGER] := mcr_num ;
						     mcr[mcr_num].p_adr := adrs ;
					        END (* assign location *)
					      ELSE
						BEGIN
						    deallocate (set_ty,set_num,set_adrs);
(*		WRITELN ('ACON ** SET ADDRESS =',set_adrs,'   BLOCK# =', block );		*)
						    IF NOT setn[set_num].abs THEN 
							store (set_ty,set_num,block,set_adrs,set_store_fail);
						    IF set_store_fail THEN
							  fail := true
						    ELSE
							  done := true ;
						END;
					  END (* address contraint *)
					ELSE
					    BEGIN (* no address contraint *)
						IF NOT ( mcr[mcr_num].d_con.abs1 AND (mcr[mcr_num].p_adr <> adrs) ) AND
						   NOT ( mcr[mcr_num].d_con.abs2 AND (mcr[mcr_num].p_adr <> adrs) )  THEN
						     BEGIN
							p_adr[adrs::INTEGER] := mcr_num ;
							mcr[mcr_num].p_adr := adrs ;
						     END
						ELSE
						     fail := TRUE
					    END  (* no address contraint *)
			 	    END (* possible address *)
			          ELSE
				    BEGIN
				    	deallocate (set_ty,set_num,set_adrs);
(*		WRITELN ('******** SET ADDRESS =',set_adrs,'   BLOCK# =', block );	*)
				    	store (set_ty,set_num,block,set_adrs,set_store_fail);
				    	IF set_store_fail THEN
				    	  BEGIN
						fail := true ;
					  END
					ELSE
					  BEGIN
					      done := true ;
					  END;
				    END;
				END (* IF ADRS .. *)
			      ELSE
				BEGIN
				    fail := true ;
				END;
			  END ; (* ELSE *)
			set_entry := set_entry + 1 ;
		   END; (* WHILE SET_ENTRY *)
	      END ; (* CASE SET_TY *)
    END; (* CASE ENTRY_TYPE *)
END ; (* PROCEDURE STORE *)


		(* FIT ATTEMPTS TO ALLOCATE ALL GROUPS. IT CALLS STORE FOR EACH ITEM IN A GROUP. IF ANY ITEM IN A GROUP
			WON'T ALLOCATE THEN FIT CALLS DEALLOCATE AND INCREMENTS THE BLOCK NUMBER SO IT CAN TRY AGAIN. *)


PROCEDURE fit  ( grp_val : INTEGER ; VAR grp_fit_fail : BOOLEAN );
CONST
	null_adrs = 0 ;
VAR
	n,mcr_num,set_num,entry,num_of_entries : INTEGER ;
	block_num, dummy_address, base_adr : UNSIGNED ;
	backup_done, done,group_fail,store_fail,dummy_fail : BOOLEAN ;
BEGIN
    IF grp_val > 1 THEN
      BEGIN
	  n := grp_val - 1 ;
	  fit (n,dummy_fail)
      END;

    done := false ;
    block_num := group[grp_val].blk_ones_msk DIV 128 ;
    num_of_entries := group[grp_val].length ;
    WHILE  (not done ) AND (block_num < 16 ) DO
      BEGIN  (* try each block *)
	  group_fail := false ;
	  store_fail := false ;
	  entry := 1 ;
	  base_adr := block_num * 128 ;

	  IF (UAND(base_adr,group[grp_val].blk_ones_msk) = group[grp_val].blk_ones_msk) AND 
	  (UAND( UNOT(base_adr),group[grp_val].blk_zero_msk) = group[grp_val].blk_zero_msk ) THEN
	   WHILE (entry <= num_of_entries) AND (not group_fail) DO
	    BEGIN   (* store each entry *)
		IF group[grp_val].entry[entry].e_type = adr_t THEN
	          BEGIN
		     mcr_num := group[grp_val].entry[entry].m_adr ;
		     store (mcr_ty,mcr_num,block_num,null_adrs,store_fail);
		  END
		ELSE
		  BEGIN
		     set_num := group[grp_val].entry[entry].setn ;
		     IF NOT setn[set_num].abs THEN store (set_ty,set_num,block_num,null_adrs,store_fail);
		  END;

		IF store_fail THEN
		  BEGIN  (* store fail *)
			deallocate( grp_ty, grp_val, dummy_address);
			group_fail := true ;
		  END  (* store fail *)

		ELSE entry := entry + 1 ;

	    END  (* store each entry *)
	  ELSE 
	    BEGIN
		group_fail := TRUE;
	    END;

	  IF entry > num_of_entries 
	  THEN BEGIN
		done := true ;
		end;
	  IF group_fail THEN block_num := block_num + 1 ;

      END; (* try each block *)

    IF ( block_num > 15 ) AND ( group_fail ) THEN
      BEGIN
	  WRITELN ('ALLOCATE ERROR*** CANNOT FIT GROUP#',grp_val);
	  dump_block(fil_nam, grp_val, entry);
	  analyze(grp_val);
	  grp_fit_fail := true ;
      END;
END; (* PROCEDURE FIT *)




BEGIN 		(* BODY OF ALLOCATE *)
  IF not error THEN
    BEGIN  (* groups made *)


	fit_fail := false ;

					(* ALLOCATE ALL GROUPS.  *)

	fit (last_group,fit_fail) ;


					(* ALLOCATE ALL MCRS THAT ARE NOT IN A GROUP *)

	    addres := -1;
	    FOR mcr_num := 0 TO last_mcr_adr DO
		IF ( mcr[mcr_num].p_adr = 2048 ) AND ( mcr[mcr_num].group = 0 )  THEN
		  BEGIN  (* found floating mcr *)
		    done := FALSE;
		    float_count := float_count + 1 ;
		    REPEAT
			BEGIN (* look for free adr *)
			   addres := addres + 1;
			   IF p_adr[addres] = -1 THEN done := TRUE;
			END (* look for free adr *)
		    UNTIL done OR (addres > max_adr);

		    IF NOT done THEN WRITELN ('ALLOCATE ERROR*** MCR#',mcr_num,'CANNOT BE STORED')
		     ELSE 
			BEGIN  (* found free adr *)
			   p_adr[addres] := mcr_num;
			   mcr[mcr_num].p_adr := addres
			END (* found free adr *)

		  END  (* found floating mcr *)

    END (* groups made *)

END;		(* BODY OF ALLOCATE *)


			(* VERIFY WILL RE-READ THE ".CON" FILE AND COMPARE THE PHYSICAL PLACEMENT OF THE MCRS WITH THEIR
				PARTICULAR CONSTRAINTS. IT ALSO CHECKS FOR DUPLICATE ADDRESSING .  *)


PROCEDURE verify ( filename : VARYING[S] OF CHAR );
CONST
	blk_msk = %b'11110000000' ;
	dot_con = '.con' ;

VAR
	adrs_array : ARRAY[0..max_adr] OF UNSIGNED ;
	mcr_array : ARRAY[0..max_adr] OF INTEGER ;
	n,mcr_num,addres,line_num,col3,col4,comp_mcr : INTEGER ;

	zero_msk,ones_msk,phys_adrs,mcr_blk,comp_blk,
	abs_adrs,mcr_adrs,comp_adrs,mcr_delta,rad3_adrs,col5 : UNSIGNED ;

	con_fil_nam,time_date : VARYING[132] OF CHAR ;
	con_field : CHAR ;

BEGIN
    IF NOT error THEN
      BEGIN
	    FOR n := 0 TO max_adr DO
	      BEGIN
		  adrs_array[n] := -1 ;
		  mcr_array[n] := 2048 ;
	      END;


				(* FIND ALL DUPLICATE MCRS ( MCRS THAT OCCUPY TWO ADDRESSES )  *)

	    FOR addres := 0 TO max_adr DO
	      BEGIN
		  mcr_num := p_adr[addres] ;
	 	  IF ( mcr_num > -1 ) AND ( mcr_num < 2048 ) THEN
		    IF adrs_array[mcr_num] > -1 THEN
		      BEGIN
			  WRITELN ;
			  WRITELN ('DUPLICATE MCR IN P_ADR ');
			  WRITELN ('  MCR ',mcr_num,'(',HEX(mcr_num,3),') IS USED AT ADDRESS',addres,'(',HEX(addres,3),') and',
				adrs_array[mcr_num],'(',HEX(adrs_array[mcr_num],3),')' );
		      END
		    ELSE
		      BEGIN
			  adrs_array[mcr_num] := addres :: UNSIGNED ;
		      END;
	      END; (* FOR N *)



				(* FIND ALL DUPLICATE ADDRESSES ( ADDRESS WITH TWO MCRS POINTING TO IT )  *)

	    FOR mcr_num := 0 TO last_mcr_adr DO
	      BEGIN
		  addres := mcr[mcr_num].p_adr :: INTEGER ;
		  IF addres < 2048 THEN
		    IF mcr_array[addres] < 2048  THEN
		      BEGIN
			  WRITELN ;
			  WRITELN ('DUPLICATE ADDRESS ');
			  WRITELN ('  ADDRESS ',addres,'(',HEX(addres,3),') IS USED IN MCR',mcr_num,'(',HEX(mcr_num,3),
				') AND',mcr_array[addres],'(',HEX(mcr_array[addres],3),')' );
		      END
		    ELSE
		      BEGIN
			  mcr_array[addres] := mcr_num ;
		      END
		  ELSE
		     BEGIN
			 WRITELN ;
			 WRITELN ('UNASSIGNED MCR ');
			 WRITELN (' MCR',mcr_num,'(',HEX(mcr_num,3),') HAS NOT BEEN ALLOCATED!!');
		     END;
	      END; (* FOR N *)

						(* READ CONSTRAINT FILE AND COMPARE PHYSICAL PLACEMENT OF MCR(S) *)
	    con_fil_nam := filename + dot_con ;			(*    WITH CONSTRAINTS IN CONSTRAINT FILE *)
	    OPEN ( con_file,con_fil_nam,HISTORY:=READONLY );
	    RESET ( con_file );
	    READLN ( con_file,time_date ) ;
	    WHILE NOT EOF( con_file )  DO
		BEGIN
		    READLN ( con_file,con_field,line_num,col3,col4,col5 );
		    CASE con_field OF
		      'A' : BEGIN
				mcr_num := col4 ;
				rad3_adrs := col5 ;
				rad3_to_bin ( rad3_adrs ,zero_msk,ones_msk );
				phys_adrs := mcr[mcr_num].p_adr ;
				IF (UAND( phys_adrs, ones_msk ) <> ones_msk ) OR
				   (UAND( UNOT( phys_adrs ),zero_msk ) <> zero_msk ) THEN
				  BEGIN
				      WRITELN ;
				      WRITELN ('VERIFY ERROR ');
				      WRITELN (' PLACEMENT OF MCR ',mcr_num,'(',HEX(mcr_num,3),') DOES NOT MATCH CONSTRAINT IN CONSTRAINT FILE ');
				      WRITELN (con_field,'  ',line_num,'  ',col3,'  ',col4,'  ',col5 );
				  END;
			    END;
	
		      'B' : BEGIN
				mcr_num := col3 ;
				comp_mcr := col4 ;
				mcr_blk := UAND ( blk_msk , mcr[mcr_num].p_adr );
				comp_blk := UAND ( blk_msk , mcr[comp_mcr].p_adr );
				IF mcr_blk <> comp_blk THEN
				  BEGIN
				      WRITELN ;
				      WRITELN ('VERIFY ERROR ');
				      WRITELN (' PLACEMENT OF MCR ',mcr_num,'(',HEX(mcr_num,3),') DOES NOT MATCH CONSTRAINT IN CONSTRAINT FILE ');
				      WRITELN (con_field,'  ',line_num,'  ',col3,'  ',col4,'  ',col5 );
				  END;
			    END;

		      'D' : BEGIN
				IF col3 = -1 THEN
				  BEGIN
				      mcr_num := col4 ;
				      abs_adrs := col5 ;
				      phys_adrs := mcr[mcr_num].p_adr ;
				      IF abs_adrs <> phys_adrs THEN
					BEGIN
					    WRITELN ;
					    WRITELN ('VERIFY ERROR ');
					    WRITELN (' PLACEMENT OF MCR ',mcr_num,'(',HEX(mcr_num,3),') DOES NOT MATCH CONSTRAINT IN CONSTRAINT FILE ');
					    WRITELN (con_field,'  ',line_num,'  ',col3,'  ',col4,'  ',col5 );
					END;
				  END
				ELSE
				  BEGIN
				      mcr_num := col4 ;
				      comp_mcr := col3 ;
				      mcr_delta := col5 ;
				      mcr_adrs := mcr[mcr_num].p_adr ;
				      comp_adrs := mcr[comp_mcr].p_adr ;
				      mcr_blk := UAND ( blk_msk , mcr[mcr_num].p_adr );
				      comp_blk := UAND ( blk_msk , mcr[comp_mcr].p_adr );
				      IF (( comp_adrs + mcr_delta ) <> mcr_adrs ) OR ( mcr_blk <> comp_blk ) THEN
					BEGIN
					    WRITELN ;
					    WRITELN ('VERIFY ERROR ');
					    WRITELN (' PLACEMENT OF MCR ',mcr_num,'(',HEX(mcr_num,3),') DOES NOT MATCH CONSTRAINT IN CONSTRAINT FILE ');
					    WRITELN (con_field,'  ',line_num,'  ',col3,'  ',col4,'  ',col5 );
					END;
				  END; (* ELSE *)
			    END;

		    OTHERWISE
			    BEGIN
				WRITELN ;
				WRITELN ('VERIFY ERROR ' );
				WRITELN (' CONSTRAINT FIELD IN CONSTRAINT FILE IS NOT  A,B,OR D ');
				WRITELN (con_field,'  ',line_num,'  ',col3,'  ',col4,'  ',col5 );
			    END;
		    END; (* CASE *)
		END; (* WHILE NOT EOF *)
	    CLOSE ( con_file );
      END; (* IF NOT ERROR *)
END; (* PROCEDURE VERIFY *)


		(* ALLOC_OUTPUT WRITES THE FINAL OUTPUT FILE (.BDR) TO BE USED BY ALLOC3 *)


PROCEDURE alloc_output ( filename : VARYING[o] OF CHAR );
CONST
	dot_bdr = '.BDR' ;
VAR
	mcr_num,line_num,page_num : INTEGER ;
	adrs : UNSIGNED ;
	out_fil_nam : VARYING[132] OF CHAR ;

BEGIN
    IF not error THEN
      BEGIN
	  out_fil_nam := filename + dot_bdr ;
	  OPEN (alloc_file,out_fil_nam,HISTORY := NEW );
	  REWRITE (alloc_file );
	  WRITELN (alloc_file,adr_stamp );
	  FOR mcr_num := 0 TO last_mcr_adr DO
	    BEGIN
		line_num := mcr[mcr_num].line ;
		page_num := mcr[mcr_num].page ;
		adrs := mcr[mcr_num].p_adr ;
		WRITELN (alloc_file,'  ',mcr_num:4,' ',line_num:5,'   ',page_num:3,'   ',adrs:4 );
	    END; (* FOR MCR_NUM *)
	  CLOSE(alloc_file);
      END; (* IF NOT ERROR *)
END; (* PROCEDURE ALLOC_OUTPUT *)


		(* WRITES OUT THE COMPLETE DATA STRUCTURE SO THAT ERRORS CAN BE TRACED *)


PROCEDURE dump ( filename : VARYING[T] OF CHAR );
CONST
	dot_dmp = '.dmp' ;


VAR
	last_p_adr, final, n, mcr_num,set_num,set_entry,grp_num,grp_entry :INTEGER ;
	dmp_fil_nam : VARYING[132] OF CHAR ;


BEGIN
	last_p_adr:= max_adr + 1;
	REPEAT
		last_p_adr := last_p_adr-1
	UNTIL (last_p_adr <= 0) OR (p_adr[last_p_adr] <> -1);

	dmp_fil_nam := filename + dot_dmp ;
	OPEN (alloc_file ,dmp_fil_nam,HISTORY:= NEW );
	REWRITE (alloc_file );
	WRITELN;
	WRITELN (alloc_file,'                      LAST MCR =',last_mcr_adr:4,'(',HEX(last_mcr_adr,3),')' );
	WRITELN ('     LAST MCR ADDRESS   =',last_mcr_adr:4,'(',HEX(last_mcr_adr,3),')' );
	IF ERROR THEN WRITELN(alloc_file,'NO ADR ALLOCATED') ELSE WRITELN(alloc_file,'             LAST ADR ASSIGNED =',
		last_p_adr:4,'(',HEX(last_p_adr,3),')');
	IF ERROR THEN WRITELN('     NO ADR ALLOCATED') ELSE WRITELN('     LAST ADR ALLOCATED =',
		last_p_adr:4,'(',HEX(last_p_adr,3),')');
	WRITELN (alloc_file,'                NUMBER OF SETS =',last_set:4 );
	WRITELN (alloc_file,'              NUMBER OF GROUPS =',last_group:4 );
	WRITELN (alloc_file,'  NUMBER OF ADDRESS CONSTRAINTS = ',a_con_count:4);
	WRITELN (alloc_file,'   NUMBER OF BLOCK CONSTRAINTS  = ',b_con_count:4);
	WRITELN (alloc_file,'   NUMBER OF DELTA CONSTRAINTS  = ',d_con_count:4);
	WRITELN (alloc_file,'NUMBER OF ABSOLUTE ASSIGNMENTS = ',abs_count:4);
	WRITELN (alloc_file,'  NUMBER OF UNCONSTRAINTED MCRS = ',float_count:4);
	FOR mcr_num := 0 TO last_mcr_adr DO
	    BEGIN
			WRITELN (alloc_file,' ') ;
			WRITE(alloc_file,'MCR ',mcr_num:4,'(',HEX(MCR_NUM,3),')   LINE  ',mcr[mcr_num].line:4,'/',mcr[mcr_num].page:5,
				'   WT ',mcr[mcr_num].weight:4,'   ADR ');
			IF mcr[mcr_num].p_adr = 2048 THEN WRITE(alloc_file,'unallocated')
				else WRITE(alloc_file,mcr[mcr_num].p_adr:4,'(',HEX(mcr[mcr_num].p_adr,3),')');
			IF mcr[mcr_num].group > 0 THEN WRITE (alloc_file,'   Group ',mcr[mcr_num].group:4);
			IF mcr[mcr_num].setn > 0 THEN WRITE(alloc_file,'   SET ',mcr[mcr_num].setn:4);
			WRITELN (alloc_file,' ') ;
			IF mcr[mcr_num].a_con.line > 0 THEN
				WRITELN(alloc_file,'       A_CON  LINE  ',mcr[mcr_num].a_con.line:4,
				  '   MASK   ',mask(mcr[mcr_num].a_con.zero_msk,mcr[mcr_num].a_con.ones_msk));
			IF mcr[mcr_num].b_con.line > 0 THEN
				WRITELN (alloc_file,'       B_CON  LINE  ',mcr[mcr_num].b_con.line:4,
				  '    M_ADR   ',mcr[mcr_num].b_con.m_adr:4,'(',HEX(mcr[mcr_num].b_con.m_adr,3),')' );
			IF mcr[mcr_num].d_con.line1 > 0 THEN
			   BEGIN
				WRITE (alloc_file,'       D_CON1   LINE  ',mcr[mcr_num].d_con.line1:4);
				IF mcr[mcr_num].d_con.abs1 THEN
					WRITELN(alloc_file,'    absolute address @ ',mcr[mcr_num].d_con.m_adr1:4,
					   '(',HEX(mcr[mcr_num].d_con.m_adr1,3),')')
				ELSE
					WRITELN (alloc_file,'    base address  ',mcr[mcr_num].d_con.m_adr1:4,'(',
					  HEX(mcr[mcr_num].d_con.m_adr1,3),')  delta ',mcr[mcr_num].d_con.delta1:4)
			   END;				   
			IF mcr[mcr_num].d_con.line2 > 0 THEN
			   BEGIN
				WRITE(alloc_file,'       D_CON2   LINE  ',mcr[mcr_num].d_con.line2:4);
				IF mcr[mcr_num].d_con.abs2 THEN
					WRITELN (alloc_file,'   absolute address @ ',mcr[mcr_num].d_con.m_adr2:4,
					   '(',HEX(mcr[mcr_num].d_con.m_adr2,3),')')
				ELSE
					WRITELN (alloc_file,'    base address  ',mcr[mcr_num].d_con.m_adr2:4,'(',
					  HEX(mcr[mcr_num].d_con.m_adr2,3),')  delta ',mcr[mcr_num].d_con.delta2:4)
			   END
	    END;
	PAGE(alloc_file);
	FOR set_num := 1 TO last_set DO
	   BEGIN
		WRITELN (alloc_file,' ');
		WRITE (alloc_file,'SET ',set_num:2,'  LENGTH ',setn[set_num].length:2,'  WEIGHT ',setn[set_num].weight:4);
		IF setn[set_num].abs THEN WRITELN(alloc_file, '   absolute assignment ')
		ELSE WRITELN(alloc_file, ' ');
		WRITELN (alloc_file,'             MCR            DELTA       ADR');
		FOR set_entry := 1 TO setn[set_num].length DO
		   BEGIN
			WRITE (alloc_file,'            ',setn[set_num].entry[set_entry]:4,
			   '(',HEX(setn[set_num].entry[set_entry],3),')       ',setn[set_num].delta[set_entry]:4);
			IF mcr[setn[set_num].entry[set_entry]].p_adr < 2048 THEN
				WRITELN(alloc_file,'        ',mcr[setn[set_num].entry[set_entry]].p_adr:4,'(',
				HEX(mcr[setn[set_num].entry[set_entry]].p_adr,3),')')
			ELSE
				WRITELN(alloc_file,'        unallocated')
		   END
	   END;
	PAGE(alloc_file);
	FOR grp_num := 1 TO last_group DO
	   BEGIN (* each group *)
		WRITELN (alloc_file,' ');
		WRITELN (alloc_file,'GROUP ',grp_num:1,'  LENGTH ',group[grp_num].length:3,'  SIZE ',group[grp_num].size:3,
		  '  WEIGHT ',group[grp_num].weight:5,'  mask ',
		  mask(group[grp_num].blk_zero_msk, group[grp_num].blk_ones_msk));
	        WRITELN (alloc_file,'             TYPE    ENTRY       WEIGHT      ADR');
		FOR grp_entry := 1 TO group[grp_num].length DO
		   BEGIN  (* each group entry *)
		     IF group[grp_num].entry[grp_entry].e_type = adr_t THEN
			BEGIN  (* mcr type *)
			  WRITE (alloc_file,'            mcr    ',group[grp_num].entry[grp_entry].m_adr:4,
			    '(',HEX(group[grp_num].entry[grp_entry].m_adr,3),')     ',
			    mcr[group[grp_num].entry[grp_entry].m_adr].weight:4,'    ');
			  IF  mcr[group[grp_num].entry[grp_entry].m_adr].p_adr = 2048 THEN WRITELN(alloc_file,'unassigned')
				ELSE  WRITELN(alloc_file, mcr[group[grp_num].entry[grp_entry].m_adr].p_adr:4,'(',
					  HEX(mcr[group[grp_num].entry[grp_entry].m_adr].p_adr,3),')');
			END  (* mcr type *)
		     ELSE
			BEGIN  (* set type *)
			   WRITE (alloc_file,'            set         ',group[grp_num].entry[grp_entry].setn:4,
			      '     ',setn[group[grp_num].entry[grp_entry].setn].weight:4,'    ');
			   IF mcr[setn[group[grp_num].entry[grp_entry].setn].entry[1]].p_adr = 2048 THEN WRITELN(alloc_file,'unassigned')
				ELSE  WRITELN(alloc_file,mcr[setn[group[grp_num].entry[grp_entry].setn].entry[1]].p_adr:4,'(',
					HEX(mcr[setn[group[grp_num].entry[grp_entry].setn].entry[1]].p_adr,3),')');
			END  (* set type *)
		   END  (* each group entry *)
	   END; (* each group *)

	PAGE( alloc_file);
	IF last_p_adr < last_mcr_adr THEN final := last_mcr_adr ELSE final := last_p_adr;
	WRITELN(alloc_file,'      MCR    TO    ADR                  ADR    TO    MCR');
	FOR n := 0 TO final DO
	   BEGIN  (* main loop *)
		IF n <= last_mcr_adr THEN 
		   BEGIN
			WRITE(alloc_file,'    ',n:4,'(',HEX(n,3),')    ');
			IF mcr[n].p_adr = 2048 THEN WRITE(alloc_file,'unallocated          ')
			 ELSE WRITE(alloc_file,mcr[n].p_adr:4,'(',HEX(mcr[n].p_adr,3),')            ')
		   END
		 ELSE  WRITE(alloc_file,'                                      ');
		IF n <= last_p_adr THEN
		   BEGIN
			WRITE(alloc_file,n:4,'(',HEX(n,3),')    ');
			IF p_adr[n] = -1 THEN WRITELN(alloc_file,'unassigned')
			 ELSE WRITELN(alloc_file,p_adr[n]:4,'(',HEX(p_adr[n],3),')')
		   END
		 ELSE WRITELN(alloc_file,' ');
	   END; (* main loop *)
			
	WRITELN (alloc_file,' ');
	WRITELN (alloc_file,'END OF FILE ');
	CLOSE (alloc_file);
(*      END; 	*)	(* IF ERROR *)
END;  (* PROCEDURE DUMP *)


PROCEDURE FIND ;
VAR
	N : INTEGER ;

BEGIN
    FOR N := 0 TO LAST_MCR_ADR DO
	BEGIN
	    IF ( MCR[N].SETN > 0 ) AND (MCR[N].GROUP = 0 ) THEN
	      BEGIN
		  WRITELN ('SET # ',MCR[N].SETN,'  IS NOT IN A GROUP' );
	      END; (* IF *)
	END; (* FOR N *)
END; (* PROC *)

		(* BODY OF ALLOC2 *)
BEGIN
	error := false ;
	init;
	writeln;
	writeln('CVAX Pass 2 Allocator  V1.06  26-Sep-86');
	get_filename_and_debug ( fil_nam );
	WRITELN;
	WRITELN('***Loading contraints');
	load_data( fil_nam );
	WRITELN;
	WRITELN('***Collecting sets');
	collect_sets ;
	WRITELN;
	WRITELN('***Collecting groups');
	collect_groups ;
	WRITELN;
	WRITELN('***Sorting Groups');
	sort_groups ;
	WRITELN;
	WRITELN('***Allocating');
	allocate ( fil_nam );
	WRITELN;
	WRITELN('***Verifying');
	verify ( fil_nam ) ;
	alloc_output ( fil_nam );
	WRITELN;
	WRITELN('***Writing .DMP file');
	dump ( fil_nam );
END.


