attach_mpc_.pl1                 10/08/84  1321.6rew 10/08/84  1229.8      133515



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   * Copyright (c) 1972 by Massachusetts Institute of        *
   * Technology and Honeywell Information Systems, Inc.      *
   *                                                         *
   *********************************************************** */


/* ATTACH_MPC_ - Subroutine interface for attaching an MPC. */
/* Written January 1980 by Larry Johnson */
/* Modified October 1982 by C. Hornig for new PRPH TAP card. */
/* Modified June 1984 by Paul Farley to correct attaching by channel
   when it is required to be on a primary channel. Also now use
   hcs_$get_user_effmode to check access to rcp_priv_.
*/

/* format: style4,indattr,insnl,delnl */

attach_mpc_:
     proc (arg_attach_mpc_datap, arg_code);

/* Parameters */

dcl  arg_attach_mpc_datap   ptr;
dcl  arg_code	        fixed bin (35);

/* Automatic */

dcl  mpc_type	        char (3);
dcl  (i, j)	        fixed bin;
dcl  rs_mode	        fixed bin (5);
dcl  execute	        bit (5) init ("00100"b);
dcl  code		        fixed bin (35);
dcl  n_tried	        fixed bin;
dcl  dev_tried	        (4) char (32);
dcl  rcp_info_ptr	        ptr;
dcl  1 auto_printer_info    like printer_info aligned automatic;
dcl  1 auto_device_info     like device_info aligned automatic;

/* External */

dcl  com_err_	        entry options (variable);
dcl  config_$find_2	        entry (char (4) aligned, char (4) aligned, ptr);
dcl  find_config_card_$mpc_for_channel
		        entry (fixed bin (3), fixed bin (6), ptr);
dcl  find_config_card_$prph_for_channel
		        entry (fixed bin (3), fixed bin (6), ptr);
dcl  ioa_$rsnnl	        entry options (variable);
dcl  ipc_$create_ev_chn     entry (fixed bin (71), fixed bin (35));
dcl  convert_ipc_code_      entry (fixed bin (35));
dcl  rcp_priv_$attach       entry (char (*), ptr, fixed bin (71), char (*), bit (36) aligned, fixed bin (35));
dcl  rcp_$check_attach      entry (bit (36) aligned, ptr, char (*), fixed bin, fixed bin (19), fixed bin (71), fixed bin,
		        fixed bin (35));
dcl  rcp_$detach	        entry (bit (36) aligned, bit (*), fixed bin, char (*), fixed bin (35));
dcl  ipc_$delete_ev_chn     entry (fixed bin (71), fixed bin (35));
dcl  ioi_$set_channel_required
		        entry (fixed bin, fixed bin (3), fixed bin (6), fixed bin (35));
dcl  hcs_$get_user_effmode  entry (char (*), char (*), char (*), fixed bin, fixed bin (5), fixed bin (35));

dcl  error_table_$unimplemented_version
		        fixed bin (35) ext static;
dcl  error_table_$invalid_device
		        fixed bin (35) ext static;
dcl  error_table_$bad_channel
		        fixed bin (35) ext static;
dcl  error_table_$no_connection
		        fixed bin (35) ext static;
dcl  error_table_$device_busy
		        fixed bin (35) ext static;

dcl  disk_status_table_$disk_status_table_
		        ext;

dcl  (addr, bit, hbound, null, rtrim, substr)
		        builtin;
%page;
/* Attach entry */

	attach_mpc_datap = arg_attach_mpc_datap;
	if attach_mpc_data.version ^= attach_mpc_data_version_1 then do;
	     code = error_table_$unimplemented_version;
	     if attach_mpc_data.report
	     then call com_err_ (code, attach_mpc_data.caller_name);
	     go to error_return;
	end;
	attach_mpc_data.ioi_index = 0;
	attach_mpc_data.ioi_channel = 0;
	attach_mpc_data.rcp_id = "0"b;
	attach_mpc_data.max_workspace_size = 0;
	attach_mpc_data.max_time_limit = 0;
	attach_mpc_data.mpc_cardp = null ();
	attach_mpc_data.prph_cardp = null ();
	attach_mpc_data.device_name = "";
	attach_mpc_data.status_tablep = addr (disk_status_table_$disk_status_table_);
						/* Any table should work ok */

/* Check for no mpc name given.  If so, attach mpc on channel specified */

	if attach_mpc_data.mpc_name = "" then do;
	     if ^attach_mpc_data.channel_required then do;
no_mpc_for_chan:
		code = error_table_$bad_channel;
		if attach_mpc_data.report
		then call com_err_ (code, attach_mpc_data.caller_name, "No MPC found for channel specified.");
		go to error_return;
	     end;
	     call find_config_card_$mpc_for_channel (attach_mpc_data.iom, (attach_mpc_data.channel), mpc_cardp);
	     attach_mpc_data.mpc_name = mpc_card.name;	/* This is what to attach */
	end;

/* Check mpc name */

	mpc_type = substr (attach_mpc_data.mpc_name, 1, 3);
	if ^(mpc_type = "msp" | mpc_type = "mtp" | mpc_type = "urp") then do;
	     code = error_table_$invalid_device;
	     if attach_mpc_data.report
	     then call com_err_ (code, attach_mpc_data.caller_name, "^a", attach_mpc_data.mpc_name);
	     go to error_return;
	end;

/* Locate mpc card for this mpc */

	call config_$find_2 ("mpc", substr (attach_mpc_data.mpc_name, 1, 4), mpc_cardp);
	if mpc_cardp = null () then do;
	     code = error_table_$invalid_device;
	     if attach_mpc_data.report
	     then call com_err_ (code, attach_mpc_data.caller_name, "MPC ^a not configured.", attach_mpc_data.mpc_name);
	     go to error_return;
	end;
	attach_mpc_data.mpc_cardp = mpc_cardp;
	attach_mpc_data.model = mpc_card.model;
	attach_mpc_data.type = mpc_type;

/* Be sure channel requested consistent with this mpc */

	if attach_mpc_data.channel_required then do;
	     if ^attach_mpc_data.bootload_channel then do;
		if channel_on_mpc ()
		then go to channel_ok;
		code = error_table_$bad_channel;
		if attach_mpc_data.report
		then call com_err_ (code, attach_mpc_data.caller_name, "Requested channel not on mpc ^a.",
			attach_mpc_data.mpc_name);
		go to error_return;
	     end;
	     else do;
		if attach_mpc_data.channel = 0 then do; /* none specified */
		     attach_mpc_data.iom = mpc_card.iom (1);
						/* Use lowest channel */
		     attach_mpc_data.channel = mpc_card.chan (1);
		     goto channel_ok;
		end;
		do i = 1 to hbound (mpc_card.port, 1) while (mpc_card.iom (i) ^= -1);
		     if attach_mpc_data.iom = mpc_card.iom (i) &
						/* primary channel? */
			attach_mpc_data.channel = mpc_card.chan (i)
		     then goto channel_ok;
		end;
		code = error_table_$bad_channel;
		if attach_mpc_data.report
		then call com_err_ (code, attach_mpc_data.caller_name,
			"Requested channel, not valid primary on mpc ^a.", attach_mpc_data.mpc_name);
		go to error_return;
	     end;
	end;
channel_ok:
	if mpc_type = "urp"
	then go to unit_record_attach;
%page;
/* Attach disk or tape mpc */

	if attach_mpc_data.channel_required then do;
	     call find_prph (attach_mpc_data.iom, attach_mpc_data.channel);
	     if attach_mpc_data.prph_cardp = null () then do;
		code = error_table_$no_connection;
		if attach_mpc_data.report
		then call com_err_ (code, attach_mpc_data.caller_name, "Unable to get to mpc ^a thru ^a.",
			attach_mpc_data.mpc_name, edit_channel ());
		go to error_return;
	     end;
	     call attach_special;
	     if code = 0
	     then go to attach_complete;
	     else do;
		if attach_mpc_data.report
		then call com_err_ (code, attach_mpc_data.caller_name, "Unable to attach ^a to get to mpc ^a.",
			attach_mpc_data.device_name, attach_mpc_data.mpc_name);
		go to error_return;
	     end;
	end;
	else do;
	     n_tried = 0;
	     do i = 1 to hbound (mpc_card.port, 1);	/* Try all ports */
		call find_prph ((mpc_card.iom (i)), (mpc_card.chan (i)));
		if attach_mpc_data.prph_cardp ^= null () then do;
		     do j = 1 to n_tried;		/* Dont try same device twice */
			if dev_tried (j) = attach_mpc_data.device_name
			then go to next_port;
		     end;
		     n_tried = n_tried + 1;
		     dev_tried (n_tried) = attach_mpc_data.device_name;
		     call attach_special;
		     if code = 0 then do;
			attach_mpc_data.iom = mpc_card.iom (i);
			attach_mpc_data.channel = mpc_card.chan (i);
			go to attach_complete;
		     end;
		end;
next_port:
	     end;
	end;
report_failure:
	if n_tried = 0 then do;
	     code = error_table_$no_connection;
	     if attach_mpc_data.report
	     then call com_err_ (code, attach_mpc_data.caller_name, "Unable to find path to ^a.",
		     attach_mpc_data.mpc_name);
	     go to error_return;
	end;
	else do;
	     code = error_table_$device_busy;
	     if attach_mpc_data.report
	     then call com_err_ (code, attach_mpc_data.caller_name, "Unable to attach ^a.", attach_mpc_data.mpc_name);
	end;
	go to error_return;
%page;
/* Attach unit record mpc */

unit_record_attach:
	if attach_mpc_data.channel_required then do;
	     call find_prph (attach_mpc_data.iom, attach_mpc_data.channel);
	     if attach_mpc_data.prph_cardp = null () then do;
		code = error_table_$no_connection;
		if attach_mpc_data.report
		then call com_err_ (code, attach_mpc_data.caller_name, "Unable to get to mpc ^a thru channel ^a.",
			attach_mpc_data.mpc_name, edit_channel ());
		go to error_return;
	     end;
	     call attach_unit_record;
	     if code = 0
	     then go to attach_complete;
	     else do;
		if attach_mpc_data.report
		then call com_err_ (code, attach_mpc_data.caller_name, "Unable to attach ^a to get to mpc ^a.",
			attach_mpc_data.device_name, attach_mpc_data.mpc_name);
		go to error_return;
	     end;
	end;

	n_tried = 0;
	do i = 1 to mpc_card.nchan (1);
	     call find_prph ((mpc_card.iom (1)), mpc_card.chan (1) + i - 1);
	     if attach_mpc_data.prph_cardp ^= null () then do;
		n_tried = n_tried + 1;
		call attach_unit_record;
		if code = 0 then do;
		     attach_mpc_data.iom = mpc_card.iom (1);
		     attach_mpc_data.channel = mpc_card.chan (1) + i - 1;
		     go to attach_complete;
		end;
	     end;
	end;
	go to report_failure;

attach_complete:
	call ioi_$set_channel_required (attach_mpc_data.ioi_index, attach_mpc_data.iom, attach_mpc_data.channel, code);
	if code ^= 0 then do;
	     if attach_mpc_data.report
	     then call com_err_ (code, attach_mpc_data.caller_name, "Unable to force use of ^a for ^a.",
		     edit_channel (), attach_mpc_data.mpc_name);
	     go to error_return;
	end;

	arg_code = 0;
	return;

error_return:
	call detach_mpc_ (attach_mpc_datap, (0));
	arg_code = code;
	return;
%page;
/* Entry to detach an mpc */

detach_mpc_:
     entry (arg_attach_mpc_datap, arg_code);

	attach_mpc_datap = arg_attach_mpc_datap;

	if attach_mpc_data.rcp_id ^= "0"b
	then call rcp_$detach (attach_mpc_data.rcp_id, "0"b, 0, "", code);
	attach_mpc_data.rcp_id = "0"b;
	if attach_mpc_data.ioi_channel ^= 0
	then call ipc_$delete_ev_chn (attach_mpc_data.ioi_channel, code);
	attach_mpc_data.ioi_channel = 0;
	arg_code = 0;
	return;
%page;
/* Attach a special device to get to a tape or disk mpc */

attach_special:
     proc;

	call fill_device_info;
	call attach ("special");

	return;

     end attach_special;

attach_unit_record:
     proc;

dcl  dev_type	        char (32);

	if substr (attach_mpc_data.device_name, 1, 3) = "prt" then do;
	     dev_type = "printer";
	     rcp_info_ptr, printer_info_ptr = addr (auto_printer_info);
	     printer_info.version_num = 1;
	     printer_info.usage_time = 0;
	     printer_info.wait_time = 0;
	     printer_info.system_flag = "0"b;
	     printer_info.device_name = substr (attach_mpc_data.device_name, 1, 8);
	     printer_info.model = 0;
	     printer_info.print_train = 0;
	     printer_info.line_length = -1;
	end;
	else do;
	     call fill_device_info;
	     if substr (attach_mpc_data.device_name, 1, 3) = "rdr"
	     then dev_type = "reader";
	     else if substr (attach_mpc_data.device_name, 1, 3) = "pun"
	     then dev_type = "punch";
	     else dev_type = "special";		/* Probably wrong, but what else is there? */
	end;
	call attach (dev_type);

	return;

     end attach_unit_record;

fill_device_info:
     proc;

	rcp_info_ptr, device_info_ptr = addr (auto_device_info);
	device_info.version_num = 1;
	device_info.usage_time = 0;
	device_info.wait_time = 0;
	device_info.system_flag = "0"b;
	device_info.device_name = substr (attach_mpc_data.device_name, 1, 8);
	device_info.model = 0;
	device_info.qualifiers (*) = 0;
	return;

     end fill_device_info;
%page;
attach:
     proc (dev_type);

dcl  dev_type	        char (*);
dcl  state	        fixed bin;
dcl  rcp_comment	        char (100);

	if attach_mpc_data.ioi_channel = 0 then do;
	     call ipc_$create_ev_chn (attach_mpc_data.ioi_channel, code);
	     if code ^= 0 then do;
		call convert_ipc_code_ (code);
		if attach_mpc_data.report
		then call com_err_ (code, attach_mpc_data.caller_name, "Unable to create event channel.");
		go to error_return;
	     end;
	end;

/* Check callers access to rcp_priv_ */

	call hcs_$get_user_effmode (">system_library_1", "rcp_priv_", "", -1, rs_mode, code);

	if code ^= 0 then do;
	     call com_err_ (code, attach_mpc_data.caller_name, "Cannot get effective access to >sl1>rcp_priv_.");
	     return;
	end;

	if bit (rs_mode) & execute
	then ;
	else do;
	     call com_err_ (code, attach_mpc_data.caller_name, "Improper access to gate >sl1>rcp_priv_.");
	     return;
	end;


	call rcp_priv_$attach (dev_type, rcp_info_ptr, attach_mpc_data.ioi_channel, "", attach_mpc_data.rcp_id, code);
	if code ^= 0
	then return;

	call rcp_$check_attach (attach_mpc_data.rcp_id, rcp_info_ptr, rcp_comment, attach_mpc_data.ioi_index,
	     attach_mpc_data.max_workspace_size, attach_mpc_data.max_time_limit, state, code);
	if state ^= 0
	then if code = 0
	     then code = state;

	return;

     end attach;

edit_channel:
     proc returns (char (32) var);

dcl  temp		        char (32) var;

	call ioa_$rsnnl ("IOM ^[a^;b^;c^;d^;e^;f^;g^;h^], channel ^d", temp, (0), attach_mpc_data.iom,
	     attach_mpc_data.channel);
	return (temp);

     end edit_channel;

channel_on_mpc:
     proc returns (bit (1));

dcl  i		        fixed bin;

	do i = 1 to hbound (mpc_card.port, 1) while (mpc_card.iom (i) ^= -1);
	     if mpc_card.iom (i) = attach_mpc_data.iom & mpc_card.chan (i) <= attach_mpc_data.channel
		& mpc_card.chan (i) + mpc_card.nchan (i) > attach_mpc_data.channel
	     then return ("1"b);
	end;
	return ("0"b);

     end channel_on_mpc;
%page;
/* Procedure, that given an iom and channel, will find device necessary to attach to that channel */

find_prph:
     proc (iom, chan);

dcl  iom		        fixed bin (3);
dcl  chan		        fixed bin (6);

	call find_config_card_$prph_for_channel (iom, (chan), prph_cardp);
	if prph_cardp = null () then do;
	     attach_mpc_data.prph_cardp = null ();
	     attach_mpc_data.device_name = "";
	     return;
	end;

	attach_mpc_data.prph_cardp = prph_cardp;
	attach_mpc_data.device_name = prph_card.name;
	if substr (attach_mpc_data.device_name, 1, 3) = "dsk" | substr (attach_mpc_data.device_name, 1, 3) = "tap"
	then attach_mpc_data.device_name = rtrim (attach_mpc_data.device_name) || "_00";
	return;

     end find_prph;
%page;
%include attach_mpc_data;
%include config_mpc_card;
%include config_prph_card;
%include rcp_device_info;
%include rcp_printer_info;

     end attach_mpc_;




		    char_mpc_.pl1                   04/05/85  1059.7rew 04/05/85  1056.9       92196



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   * Copyright (c) 1972 by Massachusetts Institute of        *
   * Technology and Honeywell Information Systems, Inc.      *
   *                                                         *
   *********************************************************** */


/*
   *  CHAR_MPC_ - Procedure for locating important data in the mpc dump
   *
   *  Written origionally by Jim Bush
   *  Modified March 1977 by Larry Johnson
   *  Modified October 1980 by Rich Coppola to add mpc error counters/register
   *   addresses to mpc_data.
   *  Modified Aug 1981 by Rich Coppola to add recognition of MTP611
   *  Modified Aug 1981 by Rich Coppola to add recognition of EURC
   *  Modified Jan 1983 by Rich Coppola to correct offset for MTC501 psi error
   *   ctr.
   *  Modified Jan 1984 by Art Beattie to add boot device numbers and expand
   *   firmware revision handling in disk_char structure.
   *  Modified June 1984 by Paul Farley for DAU support and to use a pointer
   *   parameter to reference the MPC memory image.
   *  Modified March 1985 by Paul Farley to correct a problem with the calculation
   *   of the tape fw revision (fw was in error and this will allow for it).
*/

/* format: style4,delnl,insnl,ifthenstmt,indnoniterend */

char_mpc_:
     proc (image_ptr, mpc_datap);

dcl  image_ptr ptr parameter;
dcl  image (0:4095) bit (16) unal based (image_ptr);	/* MPC memory image */

dcl  (bin, fixed, addr, substr, hbound, mod) builtin;
dcl  i fixed bin;
dcl  eurc_sw bit (1) init ("0"b);
dcl  revision char (2);
dcl  hex char (16) int static options (constant) init ("0123456789ABCDEF");

dcl  (
     mtc500_char init (0000000011100000b),		/* Mtc500 characteristics table at 00E0 (hex) */
     mtc601_char init (0000001000010000b),		/* Mtc601 characteristics table at 0210 (hex) */
     mtc610_char init (0000000101010000b),		/* MTP610/611 characteristics table at 0150 (hex) */
     dsc191_char init (0000010011110000b)
     )						/* Dsc191,190 & 181 characteristics table at 04F0 (hex) */
	fixed bin (16) int static options (constant);

dcl  char_ptr ptr;

dcl  1 tape_char based (char_ptr) unaligned,
       2 mem_sze bit (16),				/* Read/write memory size */
       2 config_sw bit (16),				/* Configuration switch settings */
       2 trace_tab_p bit (16),			/* Trace table begin ptr */
       2 trace_tab_size bit (16),			/* Trace table size */
       2 trace_tab_cur bit (16),			/* Trace table current entry ptr */
       2 mpc_stat bit (16),				/* Mpc statistics table pointer */
       2 dev_stat bit (16),				/* Device statistics table pointer */
       2 rev_l_tab bit (16),				/* Revision level table? */
       2 fw_id bit (16),				/* Firmware identifacation */
       2 fw_rev,					/* Firmware revision */
         3 pad1 bit (4),
         3 lrev (2) bit (4),				/* Letter revision */
         3 srev bit (4),				/* Sub revision */
       2 as_date,					/* Assembly date */
         3 month bit (8),
         3 day bit (8),
       2 pad2 (5) bit (16);

dcl  1 disk_char based (char_ptr) unaligned,
       2 mem_sze bit (16),				/* Read/write memory size */
       2 config_sw bit (16),				/* Configuration switch settings */
       2 trace_tab_p bit (16),			/* Trace table begin ptr */
       2 trace_tab_size bit (16),			/* Trace table size */
       2 trace_tab_cur bit (16),			/* Trace table current entry ptr */
       2 mpc_stat bit (16),				/* Mpc statistics table pointer */
       2 dev_stat bit (16),				/* Device statistics table pointer */
       2 rev_l_tab bit (16),				/* Revision level table? */
       2 fw_rev_old,				/* Firmware revision */
         3 com_fw_id bit (8),				/* Common firmware identifier */
         3 srev bit (4),				/* Sub revision */
         3 lrev bit (4),				/* Letter revision */
       2 as_date,					/* Assembly date */
         3 month bit (8),
         3 day bit (8),
       2 fw_rev,					/* Firmware revision */
         3 pad1 bit (4),
         3 lrev (2) bit (4),				/* Letter revision */
         3 srev bit (4),				/* Sub revision */
       2 pad2 (3) bit (16),
       2 boot_device,				/* Boot device numbers for */
         3 la0_psi0 bit (8),				/*  each MPC channel. */
         3 la0_psi1 bit (8),
         3 la1_psi0 bit (8),
         3 la1_psi1 bit (8);

dcl  1 dau_char based (image_ptr) unaligned,		/* Config data */
       2 type bit (8),				/* = 12 HEX */
       2 hw_rev bit (8) unal,				/* DAU rev */
       2 fw_maj_rev bit (8) unal,			/* firmware rev letter */
       2 fw_sub_rev bit (8) unal;			/* firmware rev number */

%page;
	mpc_data.fw_rev = "";
	mpc_data.trace_start = 0;
	mpc_data.trace_size = 0;
	mpc_data.trace_cur = 0;
	mpc_data.dev_stat_addr = 0;
	mpc_data.config_sw = "0"b;
	mpc_data.mpc_stat_addr = 0;
	mpc_data.mpc_err_int_ctr_addr = 0;
	mpc_data.mpc_err_data_reg_addr = 0;
	mpc_data.dau_rev = "0"b;


	if mpc_data.type = "mtp" then do;
	     if mpc_data.model = 500 | mpc_data.model = 501 | mpc_data.model = 502 | mpc_data.model = 600
	     then char_ptr = addr (image (mtc500_char));
	     else if mpc_data.model = 601 | mpc_data.model = 602 then char_ptr = addr (image (mtc601_char));
	     else if mpc_data.model = 610 | mpc_data.model = 611 then char_ptr = addr (image (mtc610_char));
	     else return;				/* Don't know this one */
						/* Convert hex to dec */
	     substr (revision, 1, 1) = tape_rev_letter (tape_char.lrev (1), tape_char.lrev (2));
						/* This is the tape major revision */
	     substr (revision, 2, 1) = substr (hex, fixed (tape_char.srev, 4) + 1, 1);
						/* And sub revision */
	     mpc_data.fw_rev = revision;
	     mpc_data.trace_start = bin (tape_char.trace_tab_p);
	     mpc_data.trace_size = bin (tape_char.trace_tab_size);
	     mpc_data.trace_cur = bin (tape_char.trace_tab_cur);
	     mpc_data.dev_stat_addr = bin (tape_char.dev_stat);
	     mpc_data.config_sw = tape_char.config_sw;
	     mpc_data.mpc_stat_addr = bin (tape_char.mpc_stat);

	     if mpc_data.model = 500 | mpc_data.model = 501 | mpc_data.model = 502 | mpc_data.model = 600 then do;
		mpc_data.mpc_err_int_ctr_addr = 253;	/* 00FD */
		mpc_data.mpc_err_data_reg_addr = 254;	/* 00FE */
		end;

	     else if mpc_data.model = 601 then do;
		mpc_data.mpc_err_int_ctr_addr = 381;	/* 017D */
		mpc_data.mpc_err_data_reg_addr = 382;	/* 017E */
		end;

	     else if mpc_data.model = 610 | mpc_data.model = 611 then do;
		mpc_data.mpc_err_int_ctr_addr = 439;	/* 01B7 */
		mpc_data.mpc_err_data_reg_addr = 440;	/* 01B8 */
		end;
	     end;
	else if mpc_data.type = "msp" then do;		/* All MSPs */
	     if mpc_data.model = 800 then do;		/* DAU? */
		unspec (mpc_data.fw_rev) = "0"b || dau_char.fw_maj_rev || "0"b || dau_char.fw_sub_rev;
		mpc_data.dau_rev = dau_char.hw_rev;
		return;
		end;
	     char_ptr = addr (image (dsc191_char));

	     if disk_char.fw_rev_old.srev = "f"b4 & disk_char.fw_rev_old.lrev = "f"b4 then do;
						/* New format for disk firmware revision */
		substr (revision, 1, 1) = revision_letter (disk_char.fw_rev.lrev (1), disk_char.fw_rev.lrev (2));
		substr (revision, 2, 1) = substr (hex, fixed (disk_char.fw_rev.srev, 4) + 1, 1);
		end;
	     else do;				/* Old format for disk firmware revision */
		substr (revision, 1, 1) = revision_letter ("0"b4, disk_char.fw_rev_old.lrev);
		substr (revision, 2, 1) = substr (hex, fixed (disk_char.fw_rev_old.srev, 4) + 1, 1);
		end;

	     mpc_data.fw_rev = revision;
	     mpc_data.trace_start = bin (disk_char.trace_tab_p);
	     mpc_data.trace_size = bin (disk_char.trace_tab_size);
	     mpc_data.trace_cur = bin (disk_char.trace_tab_cur);
	     mpc_data.dev_stat_addr = bin (disk_char.dev_stat);
	     mpc_data.config_sw = disk_char.config_sw;
	     mpc_data.mpc_stat_addr = bin (disk_char.mpc_stat);
	     mpc_data.mpc_err_int_ctr_addr = 252;	/* 00FC */
	     mpc_data.mpc_err_data_reg_addr = 253;	/* 00FD */
	     end;


	else if mpc_data.type = "urp" then do;
	     eurc_sw = "0"b;
	     do i = 1 to hbound (eurc_model_numbers, 1) while (eurc_sw = "0"b);
		if mpc_data.model = eurc_model_numbers (i) then eurc_sw = "1"b;
	     end;
	     if eurc_sw = "1"b then do;
		mpc_data.fw_rev = "";		/* he doesn't have any */
		mpc_data.trace_start = 0;
		mpc_data.trace_size = 0;
		mpc_data.trace_cur = 0;
		mpc_data.dev_stat_addr = 0;
		mpc_data.config_sw = "0"b;
		mpc_data.mpc_stat_addr = 0;
		mpc_data.mpc_err_int_ctr_addr = 0;
		mpc_data.mpc_err_data_reg_addr = 0;
		end;

	     else if mpc_data.model = 2 | mpc_data.model = 600 then do;
		mpc_data.fw_rev = "";
		mpc_data.trace_start = bin ("0f00"b4);
		mpc_data.trace_size = bin ("0100"b4);
		mpc_data.trace_cur = bin (image (bin ("00af"b4)));
						/* Contents of af */
		mpc_data.dev_stat_addr = 0;
		mpc_data.config_sw = "0"b;
		mpc_data.mpc_stat_addr = 0;		/* he doesn't have any */
		mpc_data.mpc_err_int_ctr_addr = 167;	/* 00A7 */
		mpc_data.mpc_err_data_reg_addr = 168;	/* 0A8 */
		end;
	     end;
	return;

revision_letter:
     proc (msb, lsb) returns (char (1));

dcl  (msb, lsb) bit (4) unaligned;
dcl  rev_letters char (26) int static options (constant) init ("ZABCDEFGHIJKLMNOPQRSTUVWXY");

	return (substr (rev_letters, mod (fixed (msb, 4) * 16 + fixed (lsb, 4), 26) + 1, 1));
     end revision_letter;

/* The above is the proper method of getting the revision. The following is
   a kludge to get the proper tape revision. */

tape_rev_letter:
     proc (msb, lsb) returns (char (1));

dcl  (msb, lsb) bit (4) unaligned;
dcl  mtc500_rev_letters char (38) int static options (constant) init
     ("ZABCDEFGHJ??????KLM?N?P?RS??????TUVWXY");
dcl  rev_letters char (24) int static options (constant) init
     ("ZABCDEFGH?JKLMNPRSTUVWXY");

	if mpc_data.model = 500 | mpc_data.model = 501 | mpc_data.model = 502 | mpc_data.model = 600
	     then return (substr (mtc500_rev_letters, mod (fixed (msb, 4) * 16 + fixed (lsb, 4), 24) + 1, 1));
	else return (substr (rev_letters, mod (fixed (msb, 4) * 16 + fixed (lsb, 4), 24) + 1, 1));
     end tape_rev_letter;
%page;
%include dump_mpc_data;
%page;
%include eurc_model_numbers;

     end char_mpc_;




		    decode_mpc_stats_.pl1           04/02/85  1110.7rew 04/02/85  1037.3       67905



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   * Copyright (c) 1972 by Massachusetts Institute of        *
   * Technology and Honeywell Information Systems, Inc.      *
   *                                                         *
   *********************************************************** */


/* format: style4,delnl,insnl,ifthenstmt,indnoniterend */

/* DECODE_MPC_STATS_ - Decode MPC counters and registers.
   coded December 1980 by Rich Coppola	*/
/* Modified June 1984 by Paul Farley for DAU (MSP800) support */

decode_mpc_stats_:
     proc;


/* Arguments */

dcl  a_poll_mpc_datap ptr;				/* pointer to mpc data structure */
dcl  a_mpc_data_summaryp ptr;				/* pointer to mpc data summary structure */


/* AUTOMATIC */

dcl  (i, j) fixed bin;
dcl  my_mpc_stat_analp ptr;
dcl  error_reg bit (16);

/* STATIC */


dcl  mpc_stat_name (12) char (18) static options (constant)
	init ("LA0-PSI0 Parities", "LA0-PSI0 OPI Drops", "LA0-PSI1 Parities", "LA0-PSI1 OPI Drops", "LA1-PSI0 Parities",
	"LA1-PSI0 OPI Drops", "LA1-PSI1 Parities", "LA1-PSI1 OPI Drops", " ", "LA0 Alert Counter", " ",
	"LA1 Alert Counter");

dcl  dau_stat_name (20) char (18) static options (constant)
	init ("PSI0 OPI Drops", "PSI1 OPI Drops", "PSI2 OPI Drops", "PSI3 OPI Drops", "PSI0 OPO Drops",
	"PSI1 OPO Drops", "PSI2 OPO Drops", "PSI3 OPO Drops", "PSI0 Time-outs", "PSI1 Time-outs", "PSI2 Time-outs",
	"PSI3 Time-outs", "PSI0 IIW Faults", "PSI1 IIW Faults", "PSI2 IIW Faults", "PSI3 IIW Faults",
	"PSI0 Parity Errors", "PSI1 Parity Errors", "PSI2 Parity Errors", "PSI3 Parity Errors");

dcl  err_reg_name (16) char (43) static options (constant)
	init ("POWER WARNING (Bit 0)", "X/Y OPERAND PARITY (Bit 1)", "FUNCTIONAL NETWORK (Bit 2)", "",
	"INTERVAL TIMER PARITY (Bit 4)", "INTERVAL TIMER EXHAUST (Bit 5)", "EXTERNAL PARITY (Bit 6)",
	"BRANCH TEST REGISTER PARITY (Bit 7)", "ERROR TIMEOUT (Bit 8)", "MAIN MEMORY (Bit 9)",
	"DAI NON-OPERATIONAL PORT (Bit 10)", "ROSAR PARITY (Bit 11)", "ROR PARITY (Bit 12)", "ROS NOT PRESENT (Bit 13)",
	"SIM ERROR INTERRUPT (bit 14)", "ERROR TIMEOUT WHILE INHIBITING EN1 (Bit 15)");

dcl  err_reg_hint (16) char (21) static options (constant)
	init ("", "FN WWB.", "FN WWB.", "", "IM WWB.", "", "MOS or RA WWBs.", "FN WWB or CA problem.", "LA WWB.",
	"MOS WWB.", "", "RA WWB.", "Control Store WWB(s).", "", "", "");

/* BUILTINS */

dcl  (addr, substr) builtin;

	return;					/* do not enter here */
%page;
stat_ctrs_:
     entry (a_poll_mpc_datap, my_mpc_stat_analp);

	mpc_stat_analp = my_mpc_stat_analp;
	poll_mpc_datap = a_poll_mpc_datap;
	poll_mpc_specp = addr (poll_mpc_data.specific);
	j = 0;

	do i = 1 to 12;				/* cycle thru all counters */
	     if poll_mtp_data.polled_stat_counters (i) ^= 0 then do;
		j = j + 1;
		mpc_stat_anal.interp_stat_ctrs (j) = mpc_stat_name (i);
		mpc_stat_anal.stat_cntr_cnt (j) = poll_mtp_data.polled_stat_counters (i);
		end;
	end;

	mpc_stat_anal.num_ctr_interps = j;

	return;
%page;
dau_stat_ctrs_:
     entry (a_poll_mpc_datap, my_mpc_stat_analp);

	mpc_stat_analp = my_mpc_stat_analp;
	poll_mpc_datap = a_poll_mpc_datap;
	poll_mpc_specp = addr (poll_mpc_data.specific);
	j = 0;

	do i = 1 to 20;				/* cycle thru all counters */
	     if poll_dau_data.psi_cntr (i) ^= 0 then do;
		j = j + 1;
		mpc_stat_anal.interp_stat_ctrs (j) = dau_stat_name (i);
		mpc_stat_anal.stat_cntr_cnt (j) = poll_dau_data.psi_cntr (i);
		end;
	end;

	if poll_dau_data.err_interrupts ^= 0 then do;
	     j = j + 1;
	     mpc_stat_anal.interp_stat_ctrs (j) = "Error Interrupts";
	     mpc_stat_anal.stat_cntr_cnt (j) = poll_dau_data.err_interrupts;
	     end;

	mpc_stat_anal.num_ctr_interps = j;

	return;
%page;
/* **********************************************************
   *   This entry is used to receive a decode of the error   *
   *   data register only				   *
   ********************************************************** */

err_data_:
     entry (a_poll_mpc_datap, my_mpc_stat_analp);

	mpc_stat_analp = my_mpc_stat_analp;
	poll_mpc_datap = a_poll_mpc_datap;
	poll_mpc_specp = addr (poll_mpc_data.specific);
	j = 0;

	if substr (poll_mpc_data.name, 1, 3) = "urp" then do;
						/* old URP controller */
	     error_reg = poll_urp_data.register;
	     mpc_stat_anal.auxar = "0"b;
	     mpc_stat_anal.intar = poll_urp_data.INTAR;
	     mpc_stat_anal.err_ctr = poll_urp_data.interrupt_counter;
	     end;
	else do;					/* old disk or tape controller */
	     error_reg = poll_mtp_data.register;
	     mpc_stat_anal.auxar = poll_mtp_data.AUXAR;
	     mpc_stat_anal.intar = poll_mtp_data.INTAR;
	     mpc_stat_anal.err_ctr = poll_mtp_data.interrupt_counter;
	     end;

	do i = 1 to 16;
	     if substr (error_reg, i, 1) = "1"b then do;
		j = j + 1;
		mpc_stat_anal.message (j) = err_reg_name (i);
		mpc_stat_anal.HINT (j) = err_reg_hint (i);
		end;
	end;

	mpc_stat_anal.num_interps = j;
	return;

%page;
stat_ctrs_for_summary_:
     entry (a_mpc_data_summaryp, my_mpc_stat_analp);

	mpc_stat_analp = my_mpc_stat_analp;
	mpc_data_summaryp = a_mpc_data_summaryp;
	j = 0;

	do i = 1 to 12;				/* cycle thru all counters */
	     if mpc_data_summary.polled_stat_counters (i) ^= 0 then do;
		j = j + 1;
		mpc_stat_anal.interp_stat_ctrs (j) = mpc_stat_name (i);
		mpc_stat_anal.stat_cntr_cnt (j) = mpc_data_summary.polled_stat_counters (i);
		end;
	end;

	mpc_stat_anal.num_ctr_interps = j;

	return;
%page;
dau_stat_ctrs_for_summary_:
     entry (a_mpc_data_summaryp, my_mpc_stat_analp);

	mpc_stat_analp = my_mpc_stat_analp;
	mpc_data_summaryp = a_mpc_data_summaryp;
	j = 0;

	do i = 1 to 20;				/* cycle thru all counters */
	     if mpc_data_summary.psi_cntr (i) ^= 0 then do;
		j = j + 1;
		mpc_stat_anal.interp_stat_ctrs (j) = dau_stat_name (i);
		mpc_stat_anal.stat_cntr_cnt (j) = mpc_data_summary.psi_cntr (i);
		end;
	end;

	if mpc_data_summary.err_interrupts ^= 0 then do;
	     j = j + 1;
	     mpc_stat_anal.interp_stat_ctrs (j) = "Error Interrupts";
	     mpc_stat_anal.stat_cntr_cnt (j) = mpc_data_summary.err_interrupts;
	     end;

	mpc_stat_anal.num_ctr_interps = j;

	return;
%page;
/* **********************************************************
   *   This entry is used to receive a decode of the error   *
   *   data register only				   *
   ********************************************************** */

err_data_for_summary_:
     entry (a_mpc_data_summaryp, my_mpc_stat_analp);

	mpc_stat_analp = my_mpc_stat_analp;
	mpc_data_summaryp = a_mpc_data_summaryp;
	j = 0;

	if substr (mpc_data_summary.name, 1, 3) = "urp" then do;
						/* old URP controller */
	     error_reg = mpc_data_summary.register;
	     mpc_stat_anal.auxar = "0"b;
	     mpc_stat_anal.intar = mpc_data_summary.INTAR;
	     mpc_stat_anal.err_ctr = mpc_data_summary.interrupt_counter;
	     end;
	else do;					/* old disk or tape controller */
	     error_reg = mpc_data_summary.register;
	     mpc_stat_anal.auxar = mpc_data_summary.AUXAR;
	     mpc_stat_anal.intar = mpc_data_summary.INTAR;
	     mpc_stat_anal.err_ctr = mpc_data_summary.interrupt_counter;
	     end;

	do i = 1 to 16;
	     if substr (error_reg, i, 1) = "1"b then do;
		j = j + 1;
		mpc_stat_anal.message (j) = err_reg_name (i);
		mpc_stat_anal.HINT (j) = err_reg_hint (i);
		end;
	end;

	mpc_stat_anal.num_interps = j;
	return;

%page;
%include poll_mpc_data;
%page;
%include dump_mpc_data;

     end decode_mpc_stats_;




		    display_mpc_data_.pl1           04/02/85  1110.7rew 04/02/85  1037.3      138537



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   * Copyright (c) 1972 by Massachusetts Institute of        *
   * Technology and Honeywell Information Systems, Inc.      *
   *                                                         *
   *********************************************************** */


/* DISPLAY_MPC_DATA_ - Print MPC and Device Statistics for MPC.
   coded December 1980 by Rich Coppola	*/
/* Modified May 1982 by Rich Coppola to add EURC support */
/* Modified June 1984 by Paul Farley for DAU (MSP800) support and
   to change "MTC Read Count" to "MTC Read Retry Count" */

/* format: style4,delnl,insnl,ifthenstmt,indnoniterend */

display_mpc_data_:
     proc (a_poll_mpc_datap, a_sw, short_sw);


/* Arguments */

dcl  a_poll_mpc_datap ptr;				/* Pointer to mpc data structure */
dcl  a_sw ptr;					/* Pointer to ioa_switch */
dcl  short_sw bit (1);				/* Set to fit display on 80 char terminal */


/* Automatic */

dcl  sw ptr;					/* Pointer to ioa_switch */

dcl  (i, j, k, l, index) fixed bin,			/* Iteration variables */
     dt char (24);					/* Current date and time */
dcl  pic6 picture "zzzzz9";
dcl  pic99 picture "99";
dcl  ndev fixed bin;
dcl  num_to_print fixed bin;
dcl  nprint fixed bin;
dcl  nblabel fixed bin;
dcl  blabelp ptr;
dcl  hint bit (1);
dcl  tape_sw bit (1);
dcl  mpc_only bit (1) init ("0"b);
dcl  print_mpc_line bit (1);
dcl  have_stats bit (1) init ("0"b);
dcl  (urp_sw, eurc_sw) bit (1) init ("0"b);
dcl  dau_sw bit (1) init ("0"b);
dcl  (nonzero_error_reg, nonzero_cntrs) bit (1);
dcl  header_line char (136);
dcl  retl fixed bin (21);
dcl  (my_n_devices, my_n_stats) fixed bin;
dcl  (my_dev_ptr, my_stat_ptr) ptr;
dcl  SUBSYSTEM char (3);
dcl  field_count fixed bin (35);
dcl  lines_printed fixed bin;
dcl  lines_needed fixed bin;

dcl  1 line unal,
       2 title char (28),
       2 field (16) char (6);

dcl  1 dev_statistic (64),
       2 counter (16) fixed bin;


/* Constants */

dcl  eurlabel (15) char (28) static options (constant)
	init ("PDSI Receiver Errors", "PDSI Transmission Errors", "Cards Punched", "Cards Read", "PDSI Frames Received",
	"PDSI Frames Transmitted", "Connect PCW's", "Total PCW's", "IOM Transactions (L)", "IOM Transactions (U)",
	"IOM Word Transmissions (L)", "IOM Word Transmissions (U)", "Lines Printed", "PDSI Re-Transmissions",
	"Pages printed");


dcl  tlabel (8) char (28) static options (constant)
	init ("Records Read", "Records Written", "Records with Write Error", "Records with Read Error",
	"Transfer Timing Errors", "Marginal Records", "Single Track Corrections", "MTC Read Retry Count");

dcl  dlabel (16) char (28) int static options (constant)
	init ("Movement Seeks", "Data Sectors Written", "Data Sectors Read", "Data Transfer Commands",
	"Seek Incompletes", "Header Verification Errors", "Transfer Timing Errors", "Data Check Character Alerts",
	"Count Check Character Alerts", "Parity Errors", "Alternate Tracks Processed", "EDAC Correctable Errors",
	"EDAC Uncorrectable Errors", "Positioner Offsets", "Data Correction Init", "Search Alerts");

dcl  daulabel (16) char (28) int static options (constant)
	init ("Movement Seeks", "Data Sectors Written", "Data Sectors Read", "Data Transfer Commands",
	"Seek Incompletes", "Header Verification Errors", "Transfer Timing Errors", "Data Check Character Alerts",
	"Count Check Character Alerts", "Interface Errors", "Alternate Tracks Processed", "EDAC Correctable Errors",
	"EDAC Uncorrectable Errors", "Latencies", "Record Retry", "Sync Failures");


/* Based */

dcl  blabel (nblabel) char (28) based (blabelp);
dcl  1 my_dev_info (my_n_devices) like dev_info based (my_dev_ptr);
dcl  1 my_stat_info (my_n_stats) like stat_info based (my_stat_ptr);

/* External Entries */

dcl  (
     ioa_$ioa_switch,
     ioa_$ioa_switch_nnl,
     ioa_$rs
     ) entry options (variable);
dcl  date_time_ entry (fixed bin (52), char (*));
dcl  decode_mpc_stats_$stat_ctrs_ entry (ptr, ptr);
dcl  decode_mpc_stats_$dau_stat_ctrs_ entry (ptr, ptr);
dcl  decode_mpc_stats_$err_data_ entry (ptr, ptr);
dcl  (addr, clock, hbound, min, null, rtrim, string, substr) builtin;
dcl  cv_dec_ entry (char (*)) returns (fixed bin (35));
%page;
start:
	poll_mpc_datap = a_poll_mpc_datap;
	poll_mpc_specp = addr (poll_mpc_data.specific);
	my_dev_ptr, my_stat_ptr = null;
	my_n_devices, my_n_stats = 0;
	sw = a_sw;

	call date_time_ (clock (), dt);		/* Get current date and time. */

	if short_sw
	then num_to_print = 8;
	else num_to_print = 16;
	lines_printed = 0;
	nonzero_error_reg = "0"b;

	if substr (poll_mpc_data.name, 1, 3) = "urp" then do;
	     call ioa_$rs ("^5xStatistics for ^a controller.^3x^a", header_line, retl, poll_mpc_data.name, dt);
	     ndev = 0;
	     urp_sw = "1"b;
	     eurc_sw = "0"b;
	     do i = 1 to hbound (eurc_model_numbers, 1) while (eurc_sw = "0"b);
		if poll_mpc_data.model = eurc_model_numbers (i) then eurc_sw = "1"b;
	     end;
	     if eurc_sw = "1"b then do;		/* If EURC controller ... */
		my_n_devices, ndev = poll_eurc_data.n_devices;
		my_dev_ptr = addr (poll_eurc_data.dev_info);
		my_n_stats = poll_eurc_data.n_stats;
		my_stat_ptr = addr (poll_eurc_data.stat_info);
		nblabel = hbound (eurlabel, 1);
		blabelp = addr (eurlabel);
		lines_needed = 16;
		go to display_eurc;
		end;
	     if poll_urp_data.register ^= "0"b then nonzero_error_reg = "1"b;
	     end;


	else if substr (poll_mpc_data.name, 1, 3) = "mtp" then do;
						/* If tape controller ... */
	     call ioa_$rs ("^5xStatistics for ^a controller. FW Rev. ^a^3x^a", header_line, retl, poll_mpc_data.name,
		poll_mtp_data.firmware_rev, dt);
	     my_n_devices, ndev = poll_mtp_data.n_devices;
	     my_dev_ptr = addr (poll_mtp_data.dev_info);
	     my_n_stats = poll_mtp_data.n_stats;
	     my_stat_ptr = addr (poll_mtp_data.stat_info);
	     nblabel = hbound (tlabel, 1);
	     blabelp = addr (tlabel);
	     tape_sw = "1"b;
	     SUBSYSTEM = "tap";
	     lines_needed = 8;
	     if poll_mtp_data.register ^= "0"b then nonzero_error_reg = "1"b;
	     end;

	else if substr (poll_mpc_data.name, 1, 3) = "msp" then do;
						/* If disk controller ... */
	     if poll_mpc_data.model = 800 then do;	/* DAU? */
		call ioa_$rs ("^5xStatistics for ^a DAU. FW Rev. ^a, HW Rev. ^2.4b(hex)^3x^a", header_line, retl,
		     poll_mpc_data.name, poll_dau_data.fw_rev, poll_dau_data.hw_rev, dt);
		my_n_devices, ndev = poll_dau_data.n_devices;
		my_dev_ptr = addr (poll_dau_data.dev_info);
		my_n_stats = poll_dau_data.n_stats;
		my_stat_ptr = addr (poll_dau_data.stat_info);
		nblabel = hbound (daulabel, 1);
		blabelp = addr (daulabel);
		dau_sw = "1"b;
		end;
	     else do;
		call ioa_$rs ("^5xStatistics for ^a controller. FW Rev. ^a^3x^a", header_line, retl,
		     poll_mpc_data.name, poll_msp_data.firmware_rev, dt);
		my_n_devices, ndev = poll_msp_data.n_devices;
		my_dev_ptr = addr (poll_msp_data.dev_info);
		my_n_stats = poll_msp_data.n_stats;
		my_stat_ptr = addr (poll_msp_data.stat_info);
		nblabel = hbound (dlabel, 1);
		blabelp = addr (dlabel);
		if poll_msp_data.register ^= "0"b then nonzero_error_reg = "1"b;
		end;
	     tape_sw = "0"b;
	     SUBSYSTEM = "dsk";
	     lines_needed = 16;
	     end;

	call ioa_$ioa_switch (sw, "^|^a^/", substr (header_line, 1, retl));

	allocate mpc_stat_anal;
	print_mpc_line = "0"b;


	if ^urp_sw & ^dau_sw then do;			/* old disk & tape */
	     nonzero_cntrs = "0"b;
	     do i = 1 to 12 while (^nonzero_cntrs);
		if poll_mtp_data.polled_stat_counters (i) ^= 0 then nonzero_cntrs = "1"b;
	     end;

	     if nonzero_cntrs then do;
		call decode_mpc_stats_$stat_ctrs_ (poll_mpc_datap, mpc_stat_analp);

		call ioa_$ioa_switch (sw, "^/The LA-PSI ERROR COUNTERS contain the following information:");

		do i = 1 to mpc_stat_anal.num_ctr_interps;
		     call ioa_$ioa_switch (sw, "^a = ^d", rtrim (mpc_stat_anal.interp_stat_ctrs (i)),
			mpc_stat_anal.stat_cntr_cnt (i));
		     lines_printed = lines_printed + 1;
		end;
		print_mpc_line = "1"b;		/* remember */
		call ioa_$ioa_switch (sw, "^/");
		end;

	     end;


	else if dau_sw then do;			/* DAU? */
	     call ioa_$ioa_switch (sw, "^/Channel Interface Configuration:");
	     call ioa_$ioa_switch_nnl (sw, "^xCI-0 ^[on^;off^]line, CI-1 ^[on^;off^]line, ", poll_dau_data.ci_0_online,
		poll_dau_data.ci_1_online);
	     call ioa_$ioa_switch_nnl (sw, "^xPSI-0 ^[2^;4^]trip, PSI-1 ^[2^;4^]trip, ", poll_dau_data.psi0_2trip,
		poll_dau_data.psi1_2trip);
	     call ioa_$ioa_switch (sw, "^xPSI-2 ^[2^;4^]trip, PSI-3 ^[2^;4^]trip^/", poll_dau_data.psi2_2trip,
		poll_dau_data.psi3_2trip);
	     lines_printed = lines_printed + 6;

	     nonzero_cntrs = "0"b;
	     do i = 1 to 20 while (^nonzero_cntrs);
		if poll_dau_data.psi_cntr (i) ^= 0 then nonzero_cntrs = "1"b;
	     end;

	     if nonzero_cntrs | poll_dau_data.err_interrupts ^= 0 then do;
		call decode_mpc_stats_$dau_stat_ctrs_ (poll_mpc_datap, mpc_stat_analp);

		call ioa_$ioa_switch (sw, "^/The DAU/PSI ERROR COUNTERS contain the following information:");
		lines_printed = lines_printed + 2;

		do i = 1 to mpc_stat_anal.num_ctr_interps;
		     call ioa_$ioa_switch (sw, "^x^a = ^d", rtrim (mpc_stat_anal.interp_stat_ctrs (i)),
			mpc_stat_anal.stat_cntr_cnt (i));
		     lines_printed = lines_printed + 1;
		end;

		if poll_dau_data.ext_size ^= 0 then do;
		     call ioa_$ioa_switch (sw, "^/DAU Extended Error Info (72 Bytes):^3(^/^24( ^2.4b^)^)",
			poll_dau_data.err_info);
		     lines_printed = lines_printed + 5;
		     end;
		print_mpc_line = "1"b;		/* remember */
		call ioa_$ioa_switch (sw, "^/");
		end;

	     end;


	if nonzero_error_reg then do;
	     call decode_mpc_stats_$err_data_ (poll_mpc_datap, mpc_stat_analp);

	     if mpc_stat_anal.num_interps ^= 0 then print_mpc_line = "1"b;
						/* remember */
	     call ioa_$ioa_switch (sw, "^/The MPC ERROR DATA REGISTER contains the following information:");

	     do i = 1 to mpc_stat_anal.num_interps;
		if mpc_stat_anal.HINT (i) ^= ""
		then hint = "1"b;
		else hint = "0"b;
		call ioa_$ioa_switch (sw, "^a^[ Suspect: ^a^]", rtrim (mpc_stat_anal.message (i)), hint,
		     rtrim (mpc_stat_anal.HINT (i)));
		lines_printed = lines_printed + 1;
	     end;

	     call ioa_$ioa_switch (sw, "The last INTAR address is:^2x^4.4b", mpc_stat_anal.intar);

	     if SUBSYSTEM = "dsk"
	     then					/* AUXAR only valid for disk MPCs */
		call ioa_$ioa_switch (sw, "The last AUXAR address is:^2x^4.4b", mpc_stat_anal.auxar);
	     call ioa_$ioa_switch (sw, "ERROR INTERRUPT COUNTER = ^6d^/", mpc_stat_anal.err_ctr);
	     lines_printed = lines_printed + 5;
	     end;


	if urp_sw & ^print_mpc_line
	then call ioa_$ioa_switch (sw, "^2/No error indications encountered for MPC ^a.^2/", poll_mpc_data.name);

	if (urp_sw | mpc_only) then return;

display_eurc:
	dev_statistic (*) = 0;

	if eurc_sw then do;				/* do eurc specifics */
	     call ioa_$ioa_switch (sw, "PROM	  CORE  IOM  SPECIAL-CONTROLLER  LINK/EDIT  PDSI  SELF-TEST  DAI");
	     call ioa_$ioa_switch (sw, "REVISION^15t^2.4b^20t^2.4b^40t^2.4b^51t^2.4b^57t^2.4b^68t^2.4b^73t^2.4b",
		poll_eurc_data.core, poll_eurc_data.iom, poll_eurc_data.special_controller, poll_eurc_data.link_edit,
		poll_eurc_data.pdsi_application, poll_eurc_data.self_test, poll_eurc_data.dai_application);
	     call ioa_$ioa_switch (sw, "^/Uptime Clock-seconds ^12d^/", poll_eurc_data.uptime_clock);
	     end;

	have_stats = "0"b;

	do l = 1 to my_n_stats;
	     dev_statistic (my_stat_info (l).dev_index).counter (my_stat_info (l).stat_index) = my_stat_info (l).value;
	     if my_stat_info (l).value ^= 0 then have_stats = "1"b;
	end;

/* If no stats available, then quit */

	if ^have_stats then do;
	     call ioa_$ioa_switch (sw, "Statistics block for ^[DAU^;MPC^] ^a is empty.^/", dau_sw, poll_mpc_data.name);
	     return;
	     end;

	do i = 1 to ndev by num_to_print;
	     nprint = min (num_to_print, ndev + 1 - i);

	     if i >= nprint
	     then l = ndev;
	     else l = nprint;
	     have_stats = "0"b;
	     do j = i to l while (have_stats = "0"b);
		do k = 1 to hbound (blabel, 1);
		     if dev_statistic (j).counter (k) ^= 0 then have_stats = "1"b;
		end;
	     end;

	     if ^have_stats then go to try_next_set;

	     if (lines_printed + lines_needed) > 56 then do;
		lines_printed = 0;
		call ioa_$ioa_switch (sw, "^|^a^/", substr (header_line, 1, retl));
		end;

	     string (line) = "";
	     if eurc_sw
	     then line.title = "Device Name";

	     else line.title = "Subsystem";
	     lines_printed = lines_printed + 8;

	     if ^eurc_sw
	     then do j = 1 to nprint;
		substr (line.field (j), 3) = SUBSYSTEM || my_dev_info.subsystem (i + j - 1);
	     end;

	     else do j = 1 to nprint;
		line.field (j) = "  " || rtrim (my_dev_info.dev_name (i + j - 1));
	     end;

	     call ioa_$ioa_switch (sw, "^a", string (line));

	     string (line) = "";
	     if ^eurc_sw
	     then line.title = "Drive";

	     else line.title = "Logical Channel";

	     do j = 1 to nprint;
		pic6 = my_dev_info.driveno (i + j - 1);
		line.field (j) = pic6;
	     end;
	     call ioa_$ioa_switch (sw, "^a", string (line));

	     string (line) = "";
	     line.title = "Model";
	     do j = 1 to nprint;
		if ^eurc_sw
		then line.field (j) = my_dev_info.dev_model (i + j - 1);
		else do;
		     pic6 = cv_dec_ (my_dev_info.dev_model (i + j - 1));
		     line.field (j) = pic6;
		     end;
	     end;

	     call ioa_$ioa_switch (sw, "^a", string (line));

	     string (line) = "";

	     if eurc_sw then go to display_stats;
	     if tape_sw then do;
		if poll_mpc_data.model < 610
		then line.title = "Port";
		else line.title = "TM/Port";
		end;

	     else if dau_sw then line.title = "Port";

	     else line.title = "CA/Port";

	     do j = 1 to nprint;
		index = (i + j - 1);
		line.field (j) = "";
		if (^tape_sw | poll_mpc_data.model > 602) & ^dau_sw then do;
		     line.field (j) = "   /  ";
		     pic6 = my_dev_info.ca (index);
		     substr (line.field (j), 3, 1) = substr (pic6, 6, 1);
		     pic99 = my_dev_info.port (index);
		     substr (line.field (j), 5, 2) = pic99;
		     end;

		else do;
		     pic6 = my_dev_info.port (index);
		     line.field (j) = pic6;
		     end;
	     end;

	     call ioa_$ioa_switch (sw, "^a", string (line));

	     line.title = "OPI";
	     do j = 1 to nprint;
		line.field (j) = "";
		if my_dev_info.opi (i + j - 1)
		then line.field (j) = "    ON";
		else line.field (j) = "   OFF";
	     end;

	     call ioa_$ioa_switch (sw, "^a^/", string (line));

display_stats:
	     do k = 1 to hbound (blabel, 1);
		string (line) = "";
		line.title = blabel (k);
		field_count = 0;

		do j = 1 to nprint;
		     index = (i + j - 1);
		     field_count = dev_statistic (index).counter (k) + field_count;
		     pic6 = dev_statistic (index).counter (k);
		     line.field (j) = pic6;
		end;
		if field_count > 0 then do;
		     call ioa_$ioa_switch (sw, "^a", string (line));
		     lines_printed = lines_printed + 1;
		     end;
	     end;

	     call ioa_$ioa_switch (sw, "^/");

try_next_set:
	end;

	return;
%page;
display_mpc_:
     entry (a_poll_mpc_datap, a_sw);

	mpc_only = "1"b;
	go to start;


%page;
%include poll_mpc_data;
%page;
%include dump_mpc_data;
%page;
%include eurc_model_numbers;

     end display_mpc_data_;




		    dump_mpc.pl1                    04/02/85  1110.7rew 04/02/85  1035.4      261846



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   * Copyright (c) 1972 by Massachusetts Institute of        *
   * Technology and Honeywell Information Systems, Inc.      *
   *                                                         *
   *********************************************************** */


/* format: style4,delnl,insnl,ifthenstmt,indnoniterend */

/* DUMP_MPC: Command to perform dump of MPC read/write memory */
/* Written July 1975 by Larry Johnson */
/* Updated January 1977 for disk mpcs and to add -iom and -channel args */
/* Modified 10/09/79 for new MPC card format by Michael R. Jordan */
/* Modified January 1980 by Larry Johnson to dump MPC's by their name */
/* Modified December 1980 by Rich Coppola to default output to user_io */
/* Modified January 1981 by Rich Coppola to add -mpc arg to display only mpc stats */
/* Modified Apr 1 1982 by Rich Coppola to dump MPCs in ASCII. This is required for
   the EURC and most likely Dipper "MPCs". */
/* Modified August 1982 by Rich Coppola to correct the output_file ctl_arg
   recognition. It was missing the "-".
   Modified June 1984 by Paul Farley to add MSP800(DAU) support.
   Modified March 1985 by Paul Farley to double DAU config area, for 64 devices (PBF).
*/

dump_mpc:
     proc;

dcl  code fixed bin (35);				/* Standard system status code */
dcl  name char (8) init ("dump_mpc");
dcl  io_code fixed bin;
dcl  workp ptr;					/* Pointer to IOI buffer segment */
dcl  ws_size_needed fixed bin (18);			/* IOI workspace size */
dcl  (i, j) fixed bin;
dcl  dev_name char (32) var;				/* Name of device to assign */
dcl  n_args fixed bin;				/* Number of command arguments */
dcl  arg_ptr ptr;					/* Pointer to a command argument */
dcl  arg_len fixed bin;				/* Length of a command argument */
dcl  arg char (arg_len) based (arg_ptr);		/* Command argument described by arg_ptr,arg_len */
dcl  path_ptr ptr;					/* Pointer to path name of listing */
dcl  path_len fixed bin;				/* Length of pathname of listing */
dcl  path char (path_len) based (path_ptr);		/* Hence, this is the pathname */
dcl  default_path char (32);				/* A default listing segment will be built here */
dcl  line_length fixed bin (17);			/* value returned by get_line_length */
dcl  mpc_list_ptr ptr;				/* Pointer to IOCB of mpc_list */
dcl  list_attach bit (1) init ("0"b);			/* Set if list switch has been attached */
dcl  list_open bit (1) init ("0"b);			/* Set when list switch has been opened */
dcl  of_sw bit (1) init ("0"b);			/* Set if an output file is specified */
dcl  mpc_only_sw bit (1) init ("0"b);			/* Set if only MPC data is wanted (-mpc) */
dcl  stat_sw bit (1) init ("0"b);			/* Set if -stat used */
dcl  trace_sw bit (1) init ("0"b);			/* Set if -trace used */
dcl  dump_sw bit (1) init ("0"b);			/* Set if -dump used */
dcl  extend_sw bit (1) init ("0"b);			/* To extend old listing segment */
dcl  short_sw bit (1) init ("0"b);			/* To set display to 80 char line */
dcl  eurc_sw bit (1) init ("0"b);			/* We have an EURC */
dcl  dau_sw bit (1) init ("0"b);			/* MSP800 (DAU) */
dcl  attach_desc char (256) var;
dcl  mpc_memory_size fixed bin;			/* size of MPC memory */
dcl  dau_data_bytes fixed bin;
dcl  error_message char (256) var;

dcl  1 my_mpc_data aligned like mpc_data automatic;
dcl  1 my_attach_data aligned like attach_mpc_data automatic;
dcl  1 my_event_wait_info aligned like event_wait_info;

dcl  1 wait_list aligned,				/* Wait list for ipc_$block */
       2 nchan fixed bin init (1),			/* Always 1 channel */
       2 ev_chan fixed bin (71);			/* Which is this */

dcl  1 buf aligned based (workp),			/* The IOI buffer segment */
       2 idcw1 bit (36),				/* Will be read controller main memory */
       2 dcw1 bit (36),				/* Addr=buf.control, tally=1 */
       2 idcw2 bit (36),				/* Will be initiate read data transfer */
       2 dcw2 bit (36),				/* Address=buf.mem, tally=rest of segment */
       2 control,					/* Describes where data is in mpc */
         3 addr bit (16) unal,			/* Addr in mpc memory */
         3 tally bit (16) unal,			/* Count in mpc words */
         3 fill bit (4) unal,
       2 mem (0:mpc_memory_size - 1) bit (18) unal;	/* This is the mpc memory in ASCII */

dcl  1 stat_buf aligned based (workp),			/* The IOI buffer segment */
       2 idcw1 bit (36),				/* Will be read controller main memory */
       2 dcw1 bit (36),				/* Addr=stat_buf.control, tally=1 */
       2 idcw2 bit (36),				/* Will be initiate read data transfer */
       2 dcw2 bit (36),				/* Address=stat_buf.mem, tally=rest of segment */
       2 control,					/* Describes where data is in mpc */
         3 addr bit (16) unal,			/* Addr in mpc memory */
         3 tally bit (16) unal,			/* Count in mpc words */
         3 fill bit (4) unal,
       2 stats (0:83) bit (18) unal;			/* EURC statistics in ASCII */

dcl  1 trace_buf aligned based (workp),			/* The IOI buffer segment */
       2 idcw1 bit (36),				/* Will be read controller main memory */
       2 dcw1 bit (36),				/* Addr=trace_buf.control, tally=1 */
       2 idcw2 bit (36),				/* Will be initiate read data transfer */
       2 dcw2 bit (36),				/* Address=trace_buf.mem, tally=rest of segment */
       2 control,					/* Describes where data is in mpc */
         3 addr bit (16) unal,			/* Addr in mpc memory */
         3 tally bit (16) unal,			/* Count in mpc words */
         3 fill bit (4) unal,
       2 trace (0:255) bit (9) unal;			/* EURC trace in ASCII */

dcl  1 eurc_dump_buf aligned based (workp),		/* The IOI buffer segment */
       2 idcw1 bit (36),				/* Will be read controller main memory */
       2 dcw1 bit (36),				/* Addr=dump_buf.control, tally=1 */
       2 idcw2 bit (36),				/* Will be initiate read data transfer */
       2 dcw2 bit (36),				/* Address=dump_buf.mem, tally=rest of segment */
       2 control,					/* Describes where data is in mpc */
         3 addr bit (18) unal,			/* Addr in mpc memory */
         3 tally bit (18) unal,			/* Count in mpc words */
       2 eurc_dump (0:3071) bit (18) unal;		/* EURC dump in ASCII */

dcl  1 dau_buf aligned based (workp),			/* The IOI buffer segment */
       2 list (20),					/* DCW List */
         3 idcw bit (36),
         3 dcw bit (36),
       2 control (8),				/* Read memory info */
         3 addr bit (16) unal,
         3 tally bit (16) unal,
         3 fill bit (4) unal,
       2 data (0:dau_data_bytes - 1) bit (18) unal;	/* data from DAU in ASCII format */

dcl  dau_config_idx fixed bin,			/* offsets in dau_buf.data */
     dau_stat_idx fixed bin,				/* statistic offset */
     dau_trace_idx fixed bin,				/* trace offset */
     dau_dump_idx fixed bin;				/* dump offset */

dcl  eurc_mem_bin (0:3071) bit (16) unal;		/* eurc mem converted to bin */
dcl  mpc_mem_bin (0:4095) bit (16) unal;		/* mpc mem converted to binary */
dcl  eurc_trace (0:255) bit (8) unal;			/* eurc trace data converted to bin */
dcl  eurc_stats (0:83) bit (16) unal;			/* eurc stats converted to bin */
dcl  dau_datap ptr init (null);
dcl  dau_data (0:dau_data_bytes - 1) bit (16) unal based (dau_datap);

%page;
/* Entry variables */

dcl  get_temp_segment_ entry (char (*), ptr, fixed bin (35));
dcl  release_temp_segment_ entry (char (*), ptr, fixed bin (35));
dcl  ioi_$workspace entry (fixed bin, ptr, fixed bin (18), fixed bin (35));
dcl  ioi_$connect entry (fixed bin, fixed bin (18), fixed bin (35));
dcl  ipc_$block entry (ptr, ptr, fixed bin (35));
dcl  convert_ipc_code_ entry (fixed bin (35));
dcl  com_err_ entry options (variable);
dcl  ioa_ entry options (variable);
dcl  char_mpc_ entry (ptr, ptr);
dcl  dump_mpc_ entry (ptr, ptr, ptr, bit (1));
dcl  dump_mpc_$dau entry (ptr, ptr, ptr, bit (1));
dcl  dump_mpc_$eurc entry (ptr, ptr, ptr, bit (1));
dcl  stat_mpc_ entry (ptr, ptr, ptr, bit (1));
dcl  stat_mpc_$dau entry (ptr, ptr, ptr, bit (1));
dcl  stat_mpc_$eurc entry (ptr, ptr, ptr, bit (1));
dcl  stat_mpc_$mpc_stats_ entry (ptr, ptr, ptr, bit (1));
dcl  stat_mpc_$dau_stats_ entry (ptr, ptr, ptr, bit (1));
dcl  trace_mpc_ entry (ptr, ptr, ptr);
dcl  trace_mpc_$dau entry (ptr, ptr, ptr);
dcl  trace_mpc_$eurc entry (ptr, ptr, ptr);
dcl  cu_$arg_count entry (fixed bin);
dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl  get_line_length_$switch entry (ptr, fixed bin (35)) returns (fixed bin);
dcl  iox_$user_output ptr ext;
dcl  iox_$attach_ioname entry (char (*), ptr, char (*), fixed bin (35));
dcl  iox_$open entry (ptr, fixed bin, bit (1) aligned, fixed bin (35));
dcl  iox_$close entry (ptr, fixed bin (35));
dcl  iox_$detach_iocb entry (ptr, fixed bin (35));
dcl  attach_mpc_ entry (ptr, fixed bin (35));
dcl  detach_mpc_ entry (ptr, fixed bin (35));
dcl  parse_io_channel_name_ entry (char (*), fixed bin (3), fixed bin (6), fixed bin (35));
dcl  analyze_device_stat_$rsnnl entry (char (*) var, ptr, bit (72), bit (18));

dcl  error_table_$noarg ext fixed bin (35);
dcl  error_table_$request_not_recognized ext fixed bin (35);
dcl  error_table_$badopt ext fixed bin (35);

dcl  (length, substr, null, bit, rel, bin, size, addr, rtrim, unspec, hbound, multiply) builtin;

dcl  (cleanup, sus_) condition;
%page;
/* Scan command arguments */

	code = 0;
	arg_ptr = null;

	call cu_$arg_count (n_args);			/* First, find out how many */
	if n_args = 0 then do;			/* None is illegal */
no_dev:
	     call com_err_ (error_table_$noarg, name, "MPC name");
	     go to usage;
	     end;

	attach_mpc_datap = addr (my_attach_data);
	unspec (attach_mpc_data) = "0"b;
	attach_mpc_data.version = attach_mpc_data_version_1;
	attach_mpc_data.mpc_name = "";
	event_wait_info_ptr = addr (my_event_wait_info);

	path_ptr = null;				/* Listing segment path pointer not known */
	mpc_list_ptr = iox_$user_output;		/* Set default output */

	line_length = get_line_length_$switch (null (), code);
	if line_length < 132 then short_sw = "1"b;
	if code ^= 0 then short_sw = "0"b;


	do i = 1 to n_args;				/* Scan all args */
	     call cu_$arg_ptr (i, arg_ptr, arg_len, code);/* Get argument */
	     if code ^= 0 then go to err;		/* This should not happen */
	     if substr (arg, 1, 1) = "-" then do;	/* If a control argument */
		if arg = "-dump" then dump_sw = "1"b;
		else if arg = "-stat" then stat_sw = "1"b;
		else if arg = "-trace" then trace_sw = "1"b;
		else if arg = "-mpc" then mpc_only_sw = "1"b;
		else if arg = "-extend" then extend_sw = "1"b;
		else if arg = "-short" then short_sw = "1"b;
		else if arg = "-long" then short_sw = "0"b;

		else if arg = "-of" | arg = "-output_file" then do;
		     of_sw = "1"b;
		     short_sw = "0"b;		/* use long line for fo */

		     j = i + 1;
		     call cu_$arg_ptr (j, arg_ptr, arg_len, code);
						/* Get pathname */

		     if code ^= 0 then path_ptr = null; /* Set for default file name */

		     else if substr (arg, 1, 1) = "-" then path_ptr = null;
						/* Set for default file name */

		     else do;
			path_ptr = arg_ptr;
			path_len = arg_len;
			i = i + 1;
			end;
		     end;


		else if arg = "-channel" | arg = "-ch" | arg = "-chn" then do;
		     i = i + 1;
		     call cu_$arg_ptr (i, arg_ptr, arg_len, code);
		     if code ^= 0 then do;
			call com_err_ (code, name, "After -channel");
			go to done;
			end;
		     call parse_io_channel_name_ (arg, attach_mpc_data.iom, attach_mpc_data.channel, code);
		     if code ^= 0 then do;
			call com_err_ (code, name, "^a", arg);
			go to done;
			end;
		     attach_mpc_data.channel_required = "1"b;
		     end;
		else do;
		     code = error_table_$badopt;
		     go to arg_err;
		     end;
		end;
	     else if attach_mpc_data.mpc_name = "" then attach_mpc_data.mpc_name = arg;
						/* If no device found yet, this is it */


	     else do;				/* Bad command argument */
		code = error_table_$request_not_recognized;
		go to arg_err;
		end;
	end;

/* Now perform some basic checks on the arguments found */

	if attach_mpc_data.mpc_name = "" & ^attach_mpc_data.channel_required then go to no_dev;
						/* Device name should have been specified */

	if ^(dump_sw | stat_sw | trace_sw | mpc_only_sw) then stat_sw = "1"b;
						/* If no control args given, assume statistics */
%page;
/* Attach the mpc */

	on cleanup call clean_up;
	on sus_ call clean_up;

	attach_mpc_data.report = "1"b;		/* Let it print errors */
	attach_mpc_data.caller_name = name;		/* Me */
	call attach_mpc_ (attach_mpc_datap, code);
	if code ^= 0 then return;

/* When an entry is created in ioi_ to check the state of the suspend
   devices flag for an MPC, the following should be added to skip the
   MPC if the IO is suspended. This way dump_mpc will not hang!

   *	call ioi_$check_suspend_state (or whatever)
   *	     (attach_mpc_data.ioi_index, io_suspended, code);
   *	if io_suspended then do;
   *	     call clean_up;
   *	     return;
   *	end;
*/

	mpc_datap = addr (my_mpc_data);
	mpc_data.name = attach_mpc_data.mpc_name;
	mpc_data.model = attach_mpc_data.model;
	mpc_data.type = attach_mpc_data.type;
	wait_list.ev_chan = attach_mpc_data.ioi_channel;

	eurc_sw = "0"b;
	if (substr (mpc_data.name, 1, 3) = "urp")
	then do i = 1 to hbound (eurc_model_numbers, 1) while (eurc_sw = "0"b);

	     if mpc_data.model = eurc_model_numbers (i) then eurc_sw = "1"b;
	end;

	else if (substr (mpc_data.name, 1, 3) = "msp") & mpc_data.model = 800 then dau_sw = "1"b;

/* Create IOI workspace segment */

	if dau_sw then do;
	     call get_temp_segment_ ("dump_mpc", dau_datap, code);
	     if code ^= 0 then do;
		call com_err_ (code, name, "getting a temporary segment.");
		goto done;
		end;
	     dau_data_bytes = 130;			/* config data */
	     if (stat_sw | mpc_only_sw) then dau_data_bytes = dau_data_bytes + 630;
	     if trace_sw then dau_data_bytes = dau_data_bytes + 128;
	     if dump_sw
	     then					/* 32K of memory */
						/* 16K (16-bit) bytes */
		dau_data_bytes = dau_data_bytes + 16384;
	     ws_size_needed = size (dau_buf);
	     end;
	else do;
	     mpc_memory_size = 4096;
	     ws_size_needed = size (buf);
	     end;
	if ws_size_needed > attach_mpc_data.max_workspace_size then do;
						/* Can't create big enough work space */
	     call com_err_ (0, name, "Required work space of ^d words exceeds maximum of ^d.", ws_size_needed,
		attach_mpc_data.max_workspace_size);
	     go to done;
	     end;
	call ioi_$workspace (attach_mpc_data.ioi_index, workp, ws_size_needed, code);
	if code ^= 0 then go to work_err;

	if eurc_sw then do;				/* special case the EURC */

	     if mpc_only_sw then do;
		call ioa_ ("^a: The -mpc ctl_arg is not applicable to the EURC.");
		go to done;
		end;

	     if dump_sw then do;
		call build_eurc_dump_dcw;
		call do_io (io_code);
		if io_code ^= 0 then go to do_io_err (io_code);

		do i = 0 to 3071;
		     substr (eurc_mem_bin (i), 1, 8) = substr (eurc_dump_buf.eurc_dump (i), 2, 8);
		     substr (eurc_mem_bin (i), 9, 8) = substr (eurc_dump_buf.eurc_dump (i), 11, 8);
		end;

		end;

	     if stat_sw then do;
		call build_stat_dcw;
		call do_io (io_code);
		if io_code ^= 0 then go to do_io_err (io_code);
		do i = 0 to 83;			/* convert it to binary */
		     substr (eurc_stats (i), 1, 8) = substr (stat_buf.stats (i), 2, 8);
		     substr (eurc_stats (i), 9, 8) = substr (stat_buf.stats (i), 11, 8);
		end;
		end;

	     if trace_sw then do;
		call build_trace_dcw;
		call do_io (io_code);
		if io_code ^= 0 then go to do_io_err (io_code);
		do i = 0 to 255;			/* convert it to binary */
		     substr (eurc_trace (i), 1, 8) = substr (trace_buf.trace (i), 2, 8);
		end;
		end;
	     end;


	else do;
	     if dau_sw
	     then call build_dau_dcw;			/* DAU */
	     else call build_dump_dcw;		/* Normal MPC */
	     call do_io (io_code);
	     if io_code ^= 0 then go to do_io_err (io_code);
	     end;
%page;

/* Prepare a listing segment */

	if of_sw then do;				/* User specified output file */
	     if path_ptr = null then do;		/* If path name not given in command */
		default_path = rtrim (attach_mpc_data.mpc_name) || ".list";
		path_ptr = addr (default_path);
		path_len = length (default_path);
		end;
	     attach_desc = "vfile_ " || rtrim (path);
	     if extend_sw then attach_desc = rtrim (attach_desc) || " -extend";
	     call iox_$attach_ioname ("mpc_list", mpc_list_ptr, (attach_desc), code);
	     if code ^= 0 then go to iox_err;
	     list_attach = "1"b;			/* Remember to detach it */
	     call iox_$open (mpc_list_ptr, 2, "0"b, code);/* Open for stream_output */
	     if code ^= 0 then go to iox_err;
	     list_open = "1"b;			/* Remember to close it */
	     end;


/* Now convert data to binary  */

	if dau_sw
	then					/* DAU? */
	     do i = 0 to dau_data_bytes - 1;
	     substr (dau_data (i), 1, 8) = substr (dau_buf.data (i), 2, 8);
	     substr (dau_data (i), 9, 8) = substr (dau_buf.data (i), 11, 8);
	end;

	else if ^eurc_sw
	then					/* if old style MPC or URC dump */
	     do i = 0 to mpc_memory_size - 1;
	     substr (mpc_mem_bin (i), 1, 8) = substr (buf.mem (i), 2, 8);
	     substr (mpc_mem_bin (i), 9, 8) = substr (buf.mem (i), 11, 8);
	end;



/* Don't need MPC any more so detach it */

	call detach_mpc_ (attach_mpc_datap, code);

/* Now print out the data */

/* Learn about mpc */
	if dau_sw
	then call char_mpc_ (addr (dau_data (dau_config_idx)), mpc_datap);
	else call char_mpc_ (addr (mpc_mem_bin), mpc_datap);

	if dump_sw then do;
	     if eurc_sw then call dump_mpc_$eurc (addr (eurc_mem_bin), mpc_list_ptr, mpc_datap, short_sw);
	     else if dau_sw then call dump_mpc_$dau (addr (dau_data (dau_dump_idx)), mpc_list_ptr, mpc_datap, short_sw);
	     else call dump_mpc_ (addr (mpc_mem_bin), mpc_list_ptr, mpc_datap, short_sw);
	     end;

	if trace_sw then do;
	     if eurc_sw then call trace_mpc_$eurc (addr (eurc_trace), mpc_list_ptr, mpc_datap);
	     else if dau_sw then call trace_mpc_$dau (addr (dau_data (dau_trace_idx)), mpc_list_ptr, mpc_datap);
	     else call trace_mpc_ (addr (mpc_mem_bin), mpc_list_ptr, mpc_datap);
	     end;

	if stat_sw then do;
	     if eurc_sw then call stat_mpc_$eurc (addr (eurc_stats), mpc_list_ptr, mpc_datap, short_sw);
	     else if dau_sw
	     then call stat_mpc_$dau (addr (dau_data (dau_config_idx)), mpc_list_ptr, mpc_datap, short_sw);
	     else call stat_mpc_ (addr (mpc_mem_bin), mpc_list_ptr, mpc_datap, short_sw);
	     end;

	if (mpc_only_sw & ^eurc_sw) then do;
	     if dau_sw
	     then call stat_mpc_$dau_stats_ (addr (dau_data (dau_config_idx)), mpc_list_ptr, mpc_datap, short_sw);
	     else call stat_mpc_$mpc_stats_ (addr (mpc_mem_bin), mpc_list_ptr, mpc_datap, short_sw);
	     end;

do_io_err (3):
done:
	call clean_up;
	return;
%page;
/* Error routines */
do_io_err (2):
ipc_err:
	call convert_ipc_code_ (code);
err:
	call com_err_ (code, name);
	go to done;

att_err:
	call com_err_ (code, name, "Attaching ^a.", dev_name);
	go to done;

work_err:
	call com_err_ (code, name, "Creating buffer of ^d words.", ws_size_needed);
	go to done;

do_io_err (1):
io_err:
	call com_err_ (code, name, "Issuing connect.");
	go to done;

arg_err:
	call com_err_ (code, name, "^a", arg);
usage:
	call ioa_ ("^a: Usage is ""dump_mpc MPC_NAME {-control_args}""", name);
	call ioa_ ("Valid control_args are:^/^25t-dump^/^25t-trace^/^25t-stat");
	call ioa_ ("^25t-mpc^/^25t-channel IOM_TAG_CC, -ch IOM_TAG_CC^/^25t-output_file PATH, -of PATH");
	call ioa_ ("^25t-extend^/^25t-long^/^25t-short ");
	return;

iox_err:
	call com_err_ (code, name, "I/O switch mpc_list.");
	go to done;

/* Cleanup handler */

clean_up:
     proc;


	call detach_mpc_ (attach_mpc_datap, code);

	if list_open then do;
	     list_open = "0"b;
	     call iox_$close (mpc_list_ptr, code);
	     end;
	if list_attach then do;
	     list_attach = "0"b;
	     call iox_$detach_iocb (mpc_list_ptr, code);
	     end;
	if dau_datap ^= null then call release_temp_segment_ ("dump_mpc", dau_datap, code);

	return;

     end clean_up;
%page;
do_io:
     proc (err_code);
dcl  err_code fixed bin;


/* Do the io operation */

	call ioi_$connect (attach_mpc_data.ioi_index, 0, code);
	if code ^= 0 then do;
	     err_code = 1;				/* io_err */
	     return;
	     end;


	call ipc_$block (addr (wait_list), event_wait_info_ptr, code);
						/* Wait for completion */
	if code ^= 0 then do;			/* ipc_err */
	     err_code = 2;
	     return;
	     end;


	imp = addr (event_wait_info.message);		/* Status is here */
	if imess.er then do;			/* Error */
	     if imess.time_out
	     then error_message = "Timeout.";
	     else call analyze_device_stat_$rsnnl (error_message, attach_mpc_data.status_tablep, (imess.status), ("0"b))
		     ;
	     call com_err_ (0, name, "I/O error occured: ^a", error_message);
	     err_code = 3;
	     return;
	     end;

	err_code = 0;
	return;
     end do_io;
%page;

build_dump_dcw:
     proc;


/* Build dcw list to dump R/W memory */

	idcwp = addr (buf.idcw1);			/* First IDCW */
	buf.idcw1 = "0"b;
	idcw.command = "02"b3;			/* Command is read controller main memory (ASCII) */
	idcw.code = "111"b;				/* This makes it an IDCW */
	idcw.control = "10"b;			/* Set continue bit */
	idcw.chan_cmd = "40"b3;			/* Indicate special controller command */

	dcwp = addr (buf.dcw1);
	buf.dcw1 = "0"b;
	dcw.address = rel (addr (buf.control));		/* Get offset to control word */
	dcw.tally = "000000000001"b;

	idcwp = addr (buf.idcw2);			/* Second IDCW */
	buf.idcw2 = "0"b;
	idcw.command = "06"b3;			/* Command is initiate read data transfer */
	idcw.code = "111"b;				/* Code is 111 to make it an idcw */
	idcw.chan_cmd = "40"b3;			/* Special controller command */

	dcwp = addr (buf.dcw2);
	buf.dcw2 = "0"b;
	dcw.address = rel (addr (buf.mem));		/* Offset to core image */
	dcw.tally = bit (bin (size (buf) - bin (rel (addr (buf.mem)), 18), 12));
						/* Rest of seg */


	buf.addr = "0"b;				/* Mpc address to start is 0 */
	buf.tally = bit (bin (mpc_memory_size, 16), 16);
	buf.fill = "0"b;
	return;
     end build_dump_dcw;
%page;

build_eurc_dump_dcw:
     proc;

/* Build dcw list to get RW mem dump  from EURC MPC */

	idcwp = addr (eurc_dump_buf.idcw1);		/* First IDCW */
	eurc_dump_buf.idcw1 = "0"b;
	idcw.command = "02"b3;			/* Command is readmemory ASCII */
	idcw.code = "111"b;				/* This makes it an IDCW */
	idcw.control = "10"b;			/* Set continue bit */
	idcw.chan_cmd = "40"b3;			/* Indicate special controller command */

	dcwp = addr (eurc_dump_buf.dcw1);
	eurc_dump_buf.dcw1 = "0"b;
	dcw.address = rel (addr (eurc_dump_buf.control)); /* Get offset to control word */
	dcw.tally = "000000000001"b;

	idcwp = addr (eurc_dump_buf.idcw2);		/* Second IDCW */
	eurc_dump_buf.idcw2 = "0"b;
	idcw.command = "06"b3;			/* Command is initiate read data transfer */
	idcw.code = "111"b;				/* Code is 111 to make it an idcw */
	idcw.chan_cmd = "40"b3;			/* Special controller command */

	dcwp = addr (eurc_dump_buf.dcw2);
	eurc_dump_buf.dcw2 = "0"b;
	dcw.address = rel (addr (eurc_dump_buf.eurc_dump));
						/* Offset to core image */
	dcw.tally = bit (bin (size (eurc_dump_buf) - bin (rel (addr (eurc_dump_buf.eurc_dump)), 18), 12));
						/* Rest of seg */

	eurc_dump_buf.addr = "200000"b3;		/* Mpc address to start is 8000 hex */
	eurc_dump_buf.tally = "1800"b4;		/* Count is 1800 ascii (9-bit) bytes */
	return;
     end build_eurc_dump_dcw;
%page;

build_stat_dcw:
     proc;


/* Build dcw list to get statistics from EURC MPC */

	idcwp = addr (stat_buf.idcw1);		/* First IDCW */
	stat_buf.idcw1 = "0"b;
	idcw.command = "31"b3;			/* Command is read Statistics */
	idcw.code = "111"b;				/* This makes it an IDCW */
	idcw.control = "10"b;			/* Set continue bit */
	idcw.chan_cmd = "41"b3;			/* Indicate special controller command */
	idcw.count = "15"b3;

	dcwp = addr (stat_buf.dcw1);
	stat_buf.dcw1 = "0"b;
	dcw.address = rel (addr (stat_buf.control));	/* Get offset to control word */
	dcw.tally = "000000000010"b;

	idcwp = addr (stat_buf.idcw2);		/* Second IDCW */
	stat_buf.idcw2 = "0"b;
	idcw.command = "06"b3;			/* Command is initiate read data transfer */
	idcw.code = "111"b;				/* Code is 111 to make it an idcw */
	idcw.chan_cmd = "40"b3;			/* Special controller command */

	dcwp = addr (stat_buf.dcw2);
	stat_buf.dcw2 = "0"b;
	dcw.address = rel (addr (stat_buf.stats));	/* Offset to core image */
	dcw.tally = "0052"b3;			/* It returns 42 words */
	return;
     end build_stat_dcw;
%page;

build_trace_dcw:
     proc;


/* Build dcw list to get trace dump from EURC MPC */

	idcwp = addr (trace_buf.idcw1);		/* First IDCW */
	trace_buf.idcw1 = "0"b;
	idcw.command = "31"b3;			/* Command is Diagnostic Mode */
	idcw.code = "111"b;				/* This makes it an IDCW */
	idcw.control = "10"b;			/* Set continue bit */
	idcw.chan_cmd = "41"b3;			/* Indicate special controller command */
	idcw.count = "10"b3;
	dcwp = addr (trace_buf.dcw1);
	trace_buf.dcw1 = "0"b;
	dcw.address = rel (addr (trace_buf.control));	/* Get offset to control word */
	dcw.tally = "000000000010"b;

	idcwp = addr (trace_buf.idcw2);		/* Second IDCW */
	trace_buf.idcw2 = "0"b;
	idcw.command = "06"b3;			/* Command is initiate read data transfer */
	idcw.code = "111"b;				/* Code is 111 to make it an idcw */
	idcw.chan_cmd = "40"b3;			/* Special controller command */

	dcwp = addr (trace_buf.dcw2);
	trace_buf.dcw2 = "0"b;
	dcw.address = rel (addr (trace_buf.trace));	/* Offset to core image */
	dcw.tally = "0100"b3;			/* It returns 64 words */
	return;
     end build_trace_dcw;


%page;

build_dau_dcw:
     proc;

/* Build dcw list to get all needed data from DAU. */

dcl  (list_idx, next_idx) fixed bin;

	list_idx = 1;
	idcwp = addr (dau_buf.list (list_idx).idcw);	/* First IDCW */
	dau_buf.list (list_idx).idcw = "0"b;
	idcw.command = "24"b3;			/* Read Config */
	idcw.code = "111"b;				/* IDCW */
	idcw.chan_cmd = "30"b3;			/* Want list in dev# order */
	dcwp = addr (dau_buf.list (list_idx).dcw);
	dau_buf.list (list_idx).dcw = "0"b;
	dcw.address = rel (addr (dau_buf.data (0)));
	dcw.tally = "0101"b3;			/* 65 words */
	dau_config_idx = 0;
	next_idx = 130;

	if stat_sw | mpc_only_sw then do;
	     idcw.control = "10"b;			/* set continue bit for prev IDCW */
	     dau_stat_idx = next_idx;
	     list_idx = list_idx + 1;
	     idcwp = addr (dau_buf.list (list_idx).idcw);
	     dau_buf.list (list_idx).idcw = "0"b;
	     idcw.command = "26"b3;			/* Read Statistics */
	     idcw.code = "111"b;			/* IDCW */
	     dcwp = addr (dau_buf.list (list_idx).dcw);
	     dau_buf.list (list_idx).dcw = "0"b;
	     dcw.address = rel (addr (dau_buf.data (next_idx)));
	     dcw.tally = "0473"b3;			/* 315 words */
	     next_idx = next_idx + 630;
	     end;

	if trace_sw then do;
	     idcw.control = "10"b;			/* set continue bit for prev IDCW */
	     dau_trace_idx = next_idx;
	     list_idx = list_idx + 1;
	     idcwp = addr (dau_buf.list (list_idx).idcw);
	     dau_buf.list (list_idx).idcw = "0"b;
	     idcw.command = "03"b3;			/* Read Trace table */
	     idcw.code = "111"b;			/* IDCW */
	     idcw.chan_cmd = "40"b3;			/* Controller cmd */
	     dcwp = addr (dau_buf.list (list_idx).dcw);
	     dau_buf.list (list_idx).dcw = "0"b;
	     dcw.address = rel (addr (dau_buf.data (next_idx)));
	     dcw.tally = "0100"b3;			/* 64 words */
	     next_idx = next_idx + 128;
	     end;

	if dump_sw then do;
	     idcw.control = "10"b;			/* set continue bit for prev IDCW */
	     dau_dump_idx = next_idx;			/* remember index */
						/* DAU memory size is 32K bytes. It will require eight sets */
						/* of IDCW/DCW/IDCW/DCW pairs to extract the data, */
						/* because we are limited to 4K bytes per I/O. */

	     do i = 1 to 8;
		list_idx = list_idx + 1;
		idcwp = addr (dau_buf.list (list_idx).idcw);
		dau_buf.list (list_idx).idcw = "0"b;
		idcw.command = "02"b3;		/* Read Memory */
		idcw.code = "111"b;			/* IDCW */
		idcw.control = "10"b;		/* set continue bit */
		idcw.chan_cmd = "40"b3;		/* Controller cmd */
		dcwp = addr (dau_buf.list (list_idx).dcw);
		dau_buf.list (list_idx).dcw = "0"b;
		dcw.address = rel (addr (dau_buf.control (i)));
		dcw.tally = "000000000001"b;
		dau_buf.control (i).addr = bit (multiply ((i - 1), 4096, 16), 16);
		dau_buf.control (i).tally = "1000"b4;	/* 4K bytes */
		dau_buf.control (i).fill = "0"b;
		list_idx = list_idx + 1;
		idcwp = addr (dau_buf.list (list_idx).idcw);
		dau_buf.list (list_idx).idcw = "0"b;
		idcw.command = "06"b3;		/* Do the read! */
		idcw.code = "111"b;			/* IDCW */
		idcw.control = "10"b;		/* set continue bit */
		idcw.chan_cmd = "40"b3;		/* Controller cmd */
		dcwp = addr (dau_buf.list (list_idx).dcw);
		dau_buf.list (list_idx).dcw = "0"b;
		dcw.address = rel (addr (dau_buf.data (next_idx)));
		dcw.tally = "2000"b3;		/* 1024 words */
		next_idx = next_idx + 2048;		/* 2K double-bytes */
	     end;
	     idcw.control = "00"b;			/* Reset continue bit on last IDCW */
	     end;
	return;
     end build_dau_dcw;


%page;
%include iom_pcw;
%page;
%include iom_dcw;
%page;
%include ioi_stat;
%page;
%include event_wait_info;
%page;
%include dump_mpc_data;
%page;
%include attach_mpc_data;
%page;
%include eurc_model_numbers;
     end dump_mpc;




		    dump_mpc_.pl1                   10/08/84  1321.6rew 10/08/84  1229.8       63036



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */
/* DUMP_MPC_ - Print Memory Image for MPC.
   coded 7/8/75 by Noel I. Morris       */
/*
   Modified June 1984 by Paul Farley for DAU support, use a pointer
   parameter to reference the MPC memory image and implement duplicate
   output line supression (i.e. "===='s").
*/

/* format: style4,delnl,insnl,ifthenstmt,indnoniterend */

/* ******************************************************
   *                                                    *
   *                                                    *
   * Copyright (c) 1972 by Massachusetts Institute of   *
   * Technology and Honeywell Information Systems, Inc. *
   *                                                    *
   *                                                    *
   ****************************************************** */


dump_mpc_:
     proc (image_ptr, sw, mpc_datap, short_sw);

dcl  image_ptr ptr parameter;
dcl  image (0:4095) bit (16) unal based (image_ptr);	/* MPC memory image */
dcl  sw ptr,					/* IOX_ switch for output */
     short_sw bit (1);				/* Switch for short line */

dcl  loc fixed bin (16),				/* current location in trace */
     dt char (24);					/* current date and time */

dcl  sub_image_ptr ptr;				/* pointer to data printed of current line */
dcl  sub_image (16) bit (16) unal based (sub_image_ptr);	/* Portion of data that fits on 1 line */
dcl  eurc_sub_image (32) bit (8) unal based (sub_image_ptr);/* ditto for EURC */
dcl  match_image bit (256) unal based (match_image_ptr);
dcl  check_image bit (256) unal based (check_image_ptr);
dcl  (match_image_ptr, check_image_ptr) ptr;
dcl  (duplicate, displayed_equal) bit (1);
dcl  (line_count, page_count) fixed bin;
dcl  ioa_$ioa_switch entry options (variable);
dcl  date_time_ entry (fixed bin (52), char (*));
dcl  urp_sw bit (1) init ("0"b);
dcl  eurc_addr fixed bin (16) uns;
dcl  dau_addr fixed bin (16) uns;
dcl  (addr, bit, clock, hbound, substr) builtin;

%page;


	call date_time_ (clock (), dt);		/* Get current date and time. */

	if substr (mpc_data.type, 1, 3) = "urp" then urp_sw = "1"b;
	line_count = 56;
	page_count = 0;
	duplicate, displayed_equal = "0"b;
	do loc = 0 to hbound (image, 1) by 16;		/* Iterate through the memory image. */
	     if line_count = 56 then do;		/* Every 56 lines, start a new page. */
		page_count = page_count + 1;
		call ioa_$ioa_switch (sw, "^|^5xDump of ^a controller. ^[FW Rev. ^a^;^s^]^3x^a^2xPage: ^d^/",
		     mpc_data.name, ^urp_sw, mpc_data.fw_rev, dt, page_count);
		line_count = 0;
		end;

/* get pointer to data for current line */
	     sub_image_ptr, check_image_ptr = addr (image (loc));
	     if ^duplicate & loc ^= 0 then match_image_ptr = addr (image (loc - 16));
	     duplicate = "0"b;
	     if loc ^= 0 & loc + 16 < hbound (image, 1)
	     then if match_image = check_image then duplicate = "1"b;
	     if duplicate
	     then if ^displayed_equal
		then if (line_count > 0 & line_count < 55) then do;
			call ioa_$ioa_switch (sw, "====");
			line_count = line_count + 1;
			displayed_equal = "1"b;
			end;
		     else goto display_line;
		else ;
	     else do;
display_line:
		if short_sw
		then call ioa_$ioa_switch (sw, "^4.4b ^8( ^2(^4.4b^)^)", bit (loc, 16), sub_image);
		else call ioa_$ioa_switch (sw, "^4.4b ^2(  ^4( ^2( ^4.4b^)^)^)", bit (loc, 16), sub_image);
		line_count = line_count + 1;
		duplicate, displayed_equal = "0"b;
		end;
	end;
	return;
%page;
dump_mpc_$eurc:
     entry (image_ptr, sw, mpc_datap, short_sw);
dcl  eurc_image (0:3071) bit (16) unal based (image_ptr);


	call date_time_ (clock (), dt);		/* Get current date and time. */

	eurc_addr = 32768;				/* thats 8000Hex */
	line_count = 56;
	page_count = 0;
	duplicate, displayed_equal = "0"b;
	do loc = 0 to hbound (eurc_image, 1) by 16;	/* Iterate through the memory image. */
	     if line_count = 56 then do;		/* Every 56 lines, start a new page. */
		page_count = page_count + 1;
		call ioa_$ioa_switch (sw, "^|^5xDump of ^a controller.^3x^a^2xPage: ^d^/", mpc_data.name, dt,
		     page_count);
		line_count = 0;
		end;

/* get pointer to data for current line */
	     sub_image_ptr, check_image_ptr = addr (eurc_image (loc));
	     if ^duplicate & loc ^= 0 then match_image_ptr = addr (eurc_image (loc - 16));
	     duplicate = "0"b;
	     if loc ^= 0 & loc + 16 < hbound (eurc_image, 1)
	     then if match_image = check_image then duplicate = "1"b;
	     if duplicate
	     then if ^displayed_equal
		then if (line_count > 0 & line_count < 55) then do;
			call ioa_$ioa_switch (sw, "====");
			line_count = line_count + 1;
			displayed_equal = "1"b;
			end;
		     else goto eurc_display;
		else ;
	     else do;
eurc_display:
		if short_sw
		then call ioa_$ioa_switch (sw, "^4.4b ^8( ^4(^2.4b^)^)", bit (eurc_addr, 16), eurc_sub_image);
		else call ioa_$ioa_switch (sw, "^4.4b ^2(  ^8( ^2(^2.4b^)^)^)", bit (eurc_addr, 16), eurc_sub_image);
		line_count = line_count + 1;
		duplicate, displayed_equal = "0"b;
		end;
	     eurc_addr = eurc_addr + 32;
	end;
	return;

%page;
dump_mpc_$dau:
     entry (image_ptr, sw, mpc_datap, short_sw);
dcl  dau_image (0:16383) bit (16) unal based (image_ptr);


	call date_time_ (clock (), dt);		/* Get current date and time. */
	line_count = 56;
	page_count = 0;
	dau_addr = 0;
	duplicate, displayed_equal = "0"b;
	do loc = 0 to hbound (dau_image, 1) by 16;	/* Iterate through the memory image. */
	     if line_count = 56 then do;		/* Every 56 lines, start a new page. */
		page_count = page_count + 1;
		call ioa_$ioa_switch (sw, "^|^5xDump of DAU ^a. FW Rev. ^a, HW Rev. ^2.4b(hex)^3x^a^2xPage: ^d^/",
		     mpc_data.name, mpc_data.fw_rev, mpc_data.dau_rev, dt, page_count);
		line_count = 0;
		end;

/* get pointer to data for current line */
	     sub_image_ptr, check_image_ptr = addr (dau_image (loc));
	     if ^duplicate & loc ^= 0 then match_image_ptr = addr (dau_image (loc - 16));
	     duplicate = "0"b;
	     if loc ^= 0 & loc + 16 < hbound (dau_image, 1)
	     then if match_image = check_image then duplicate = "1"b;
	     if duplicate
	     then if ^displayed_equal
		then if (line_count > 0 & line_count < 55) then do;
			call ioa_$ioa_switch (sw, "====");
			line_count = line_count + 1;
			displayed_equal = "1"b;
			end;
		     else goto dau_display;
		else ;
	     else do;
dau_display:
		if short_sw
		then call ioa_$ioa_switch (sw, "^4.4b ^8( ^2(^4.4b^)^)", bit (dau_addr, 16), sub_image);
		else call ioa_$ioa_switch (sw, "^4.4b ^2(  ^4( ^2( ^4.4b^)^)^)", bit (dau_addr, 16), sub_image);
		line_count = line_count + 1;
		duplicate, displayed_equal = "0"b;
		end;
	     if loc < hbound (dau_image, 1) - 16 then dau_addr = dau_addr + 32;
	end;
	return;

%page;
%include dump_mpc_data;

     end dump_mpc_;




		    gload_.pl1                      12/01/86  1259.9rew 12/01/86  1258.0      358272



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        * Copyright (c) 1972 by Massachusetts Institute of        *
        * Technology and Honeywell Information Systems, Inc.      *
        *                                                         *
        *********************************************************** */


/* Initially coded March 1978 by J. A. Bush
   Modified July 1978 by J. A. Bush to add checksum capability
   Modified March 1979 by J. A. Bush to process octal and hex patch cards
   Modified August 1981 by J. A. Bush to load object decks produced by 355map
   Modified June 1983 by G. C. Dixon to add $allow_zero_checksums entrypoint. */


/****^  HISTORY COMMENTS:
  1) change(86-10-13,Fakoury), approve(86-10-29,MCR7565),
     audit(86-11-24,Parisek), install(86-12-01,MR12.0-1229):
     Modified to correct errors in patch code.
                                                   END HISTORY COMMENTS */



/* format: style4,ifthenstmt,ifthen,ind3,ll125,lineconind1 */
gload_: proc (deck_ptr, a_load_ptr, a_ld_offset, info_ptr, code);

dcl  caller char (*);				/* naming of calling program used in warnings. */
dcl  dir char (*);					/* dir/ent of firmware file being loaded. */
dcl  ent char (*);
dcl  deck_ptr ptr;					/* pointer to gcos ssf object deck */
dcl  a_load_ptr ptr;				/* pointer to segment in which to load core image */
dcl  a_ld_offset fixed bin (18);			/* relocation offset */
dcl  info_ptr ptr;					/* ptr to load_data structure */
dcl  code fixed bin (35);				/* standard status code */

dcl  core_ptr ptr;					/* pointer to core image during loading */
dcl  (ldp, load_ptr) ptr;
dcl  accum bit (36);				/* checksum accumulator */
dcl  allow_zero_checksums bit (1);			/* "1"b => zero checksums are allowed in decks. */
						/* The 0 is replaced by computed checksum. */
dcl  fnp_sw bit (1);				/* "1"b => the fnp entry was called */
dcl  (load_len, ld_offset, dlen) fixed bin (18);		/* words loaded by loader */
dcl  (preface, obj_flag, eof, first_reloc, first_abs, tmr, two_wd) bit (1); /* flags */
dcl  (i, j, k, l, m, n) fixed bin;			/* do loop counters */
dcl  blk_len fixed bin;				/* physical block length counter */
dcl  cbsn fixed bin;				/* current block serial number */
dcl  lst_ld_entry fixed bin;				/* last entry in load table */
dcl  lx fixed bin;					/* load_table index */
dcl  vcb fixed bin;					/* v count bit index */
dcl  last_seq fixed bin;				/* last sequence number */
dcl  last_assigned fixed bin (18);			/* last assigned address in relocatable deck */
dcl  final fixed bin (18);				/* final address for relocation */
dcl  symref_vec fixed bin (18);			/* symref vector location */
dcl  blank_common fixed bin (18);			/* address of blank common, if present */
dcl  blank_common_len fixed bin (18);			/* length of blank common */
dcl  lcwp ptr;					/* pointer to loader control word */
dcl  cptr ptr;					/* pointer to card image */
dcl  idbp ptr;					/* pointer to mpc deck id block */
dcl  p_ptr ptr;					/* patch card ptr */
dcl  obj_buf char (80);				/* char buffer for $ object card */
dcl  card_buf char (80);				/* char buffer for patch card */
dcl  mpc_checksum bit (16);
dcl  dk_rev char (6);
dcl  (pa, tp, mpcp (2)) bit (36);
dcl  (fw_low, fw_high, ovl, a_cnt) fixed bin;
dcl  mem_name char (14);
dcl  data_move char (l) unaligned based;		/* to move data as a character string */
dcl  fnp_seg (0:262143) bit (18) unaligned based (load_ptr);
dcl  ld_wd bit (36) based (core_ptr);
dcl  halfs (2) fixed bin (18) unsigned unaligned based (ldp);
dcl  p_word (2) fixed bin (18) unsigned unaligned based (p_ptr);
dcl  error_table_$fatal_error fixed bin (35) ext;
dcl  (addr, addrel, bin, bit, char, currentsize, fixed, index, length,
     ltrim, mod, ptr, rel, rtrim, search, substr, unspec) builtin;

dcl  1 spec_halfs (2) unaligned based (ldp),
       2 sign bit (1),				/* relocation sign bit */
       2 rindex bit (vcb),				/* relocation index in load table */
       2 addend bit (17 - vcb);			/* relative addend */

dcl  1 ld_table aligned,				/* load table */
         (2 ld_entry (256),				/* array of entries */
         3 ld_offset fixed bin (18),			/* program offset */
         3 pad1 bit (13),
         3 ld_type fixed bin (3)) unaligned;		/* symbol type */

dcl  bcd_to_ascii_ entry (bit (*), char (*));
dcl  ioa_ entry () options (variable);
dcl  ioa_$rsnnl entry options (variable);
dcl  gload_cksum_ entry (ptr, fixed bin (18), bit (36));

dcl  1 preface_card based (cptr) aligned,		/* relocatable preface card format */
         (2 cw like lcw,				/* close enough to use */
       2 checksum bit (36),				/* checksum of columns 1-3 and 7-72 */
       2 blk_cmn_len fixed bin (18) unsigned,		/* length of blank common */
       2 mb8 bit (1),				/* if on, program should be loaded mod 8 */
       2 cob_68 bit (1),				/* if on, program is a cobol 68 deck */
       2 reserved bit (1),				/* reserved for future use */
       2 sym_x2 bit (15),				/* 2 times the number of symbols */
       2 sym_pair (10),				/* symbol definitions */
         3 bcd_sym bit (36),				/* 6 char bcd symbol name */
         3 sym_pos fixed bin (18) unsigned,		/* relative position of sym within sub pgm */
         3 mod8 bit (1),				/* if set, blk comn is set to next mod8 loc */
         3 sym_ref_ptr bit (14),			/* ptr to card  and block for symref */
         3 sym_type fixed bin (3) unsigned) unaligned;	/* symbol type */

dcl  1 reloc_card based (cptr) aligned,			/* relocatable binary card format */
       2 cw like lcw unaligned,			/* loader control word goes here */
       2 checksum bit (36),				/* checksum of columns 1-3 and 7-72 */
       2 reloc_data (3) unaligned,			/* relocation data */
         3 rloc (7),				/* relocation identifiers */
	 4 reserved bit (1),
	 4 hwds (2) fixed bin (2) unsigned,		/* relocation for each half word */
         3 mbz bit (1),
       2 data (0:18) bit (36);			/* data words */

dcl  1 abs_card based (cptr) aligned,			/* absolute binary card format */
       2 cw like lcw unaligned,			/* loader control word goes here */
       2 checksum bit (36),				/* checksum of columns 1-3 and 7-72 */
       2 data (0:22) bit (36);			/* data words */

dcl  1 bin_card based (cptr) aligned,			/* any binary card */
       (2 data (rcw.rsize - 3) bit (36),		/* all words but seq number */
       2 edit_name (4) bit (12),			/* bcd data read in binary mode */
       2 sn (4),					/* 4 sequence numbers */
         3 pad1 bit (2),
         3 seq_num bit (10),				/* bcd seq number  read in bin mode */
       2 pad2 bit (12)) unaligned;

dcl  1 fnp_card based (cptr) unaligned,			/* FNP binary card format */
       2 cw like lcw,				/* loader control word goes here */
       2 checksum bit (36),				/* checksum of columns 1-3 and 7-72 */
       2 data (0:44) bit (18);			/* data words */

dcl  1 lcw unaligned based (lcwp),			/* template for loader control word */
       (2 type fixed bin (3),				/* 1 = abs, 2 = reloc, 0 = xfer, 4 = preface */
       2 rel_sym fixed bin (6),			/* if reloc, symbol to which card to be loaded */
       2 mb5 fixed bin (3),				/* must be 5 for binary card */
       2 count fixed bin (6),				/* count of data words on this card */
       2 l_addr fixed bin (18)) unsigned;		/* load address */

dcl  1 o_card based (addr (obj_buf)) aligned,		/* template for an object card */
       (2 pad1 char (15),
       2 library char (6),				/* col 16 - either "hmpcj1" or "htnd  " */
       2 ld_type char (1),				/* col 22, module type */
       2 ss_type char (1),				/* col 23, subsystem type */
       2 pad2 char (3),
       2 m_applic char (1),				/* Multics applicability, non blank means not applicable */
       2 pad3 char (15),
       2 model char (6),				/* for hmpcj1 decks, controller model # */
       2 version char (6),				/* for hmpcj1 decks, model version # */
       2 pad4 char (5),
       2 assem char (1),				/* "m" for mpc assembler, "g" for gmap */
       2 call_name char (6),				/* module call name, or gecall name */
       2 ttl_date char (6),				/* date module assembled */
       2 edit_name char (4)) unaligned;			/* module edit name */

dcl  1 o_patch based (addr (card_buf)) aligned,		/* template for octal patch card */
       (2 add char (6),				/* patch address */
       2 blk1 char (1),
       2 octal char (5),				/* either "octal" or "mask " */
       2 blk2 char (3),
       2 p_fld char (57),				/* variable filed (patch data) */
       2 lbl char (4)) unaligned;			/* edit name */


dcl  1 h_patch based (addr (card_buf)) aligned,		/* template for hex patch card */
       (2 h_add char (6),				/* (c1) hex patch address */
       2 cr char (1),				/* (c7) = "c" for cs, "r" for r/w mem */
       2 hex char (3),				/* (c8) = "hex" for hex patch */
       2 pad1 char (5),
       2 inst (2) char (4),				/* (c16) 2 - 4 hex digit instructions */
       2 pad2 char (23),
       2 rev char (6),				/* (c48) should equal word 2 of deck id block */
       2 pad3 char (20),
       2 lbl char (4)) unaligned;			/* (c75) = deck edit name */

dcl  1 id_blk based (idbp) aligned,			/* template for ident block */
       (2 ident bit (36),				/* module identification */
       2 revision,
         3 rev_dot bit (24),				/* char string "rev." */
         3 rev bit (12),				/* alpa-numeric revision */
       2 type_code bit (18),				/* module type (itr, mdr or firmware) */
       2 pad1 bit (18),
       2 dk_purpose bit (24),
       2 pad2 bit (12),
       2 rw_start fixed bin (18) unsigned,		/* offset of read/write overlay */
       2 pad3 bit (18),
       2 hx_cs_st fixed bin (18) unsigned,		/* rel. start of control store in hex words */
       2 hx_rw_st fixed bin (18) unsigned,		/* rel. start of read/write overlay in hex words */
       2 pad4 bit (108),
       2 mpcbot bit (36)) unaligned;			/* = "MPCBOT" */

dcl  1 p_array aligned,				/* storage for parsed patch cards */
       2 patches (20),				/* 20 patches possible */
         (3 rloc (2) bit (1),				/* relocation for both halfs */
         3 ppad bit (34),
         3 ul (2) bit (18)) unaligned;			/* upper and lower half */

dcl  1 fw based (load_ptr),				/* A memory overlay */
       2 fw_word (fw_low:fw_high) unal,
         3 fill1 bit (1) unal,
         3 byte1 bit (8) unal,
         3 fill2 bit (1) unal,
         3 byte2 bit (8) unal;

dcl  btp (2) bit (18) unaligned based (addr (tp));
dcl  1 load_data based (info_ptr) like gload_data aligned;	/* pertinent info  generated from loader */

dcl  bcd_obj bit (78) int static options (constant) init
      ("53202020202020462241252363"b3);			/* "$      object" in bcd */
dcl  bcd_dkend bit (72) int static options (constant) init
      ("532020202020202442254524"b3);			/* "$      dkend" in bcd */
dcl  (max_abs_wds init (22),
     max_reloc_wds init (19),
     max_fnp_wds init (44)) fixed bin int static options (constant);
%page;
      allow_zero_checksums = "0"b;
      go to COMMON;

allow_zero_checksums:
   entry (caller, dir, ent, deck_ptr, a_load_ptr, a_ld_offset, info_ptr, code);

      allow_zero_checksums = "1"b;

COMMON: ld_offset = a_ld_offset;			/* copy load offset */
      load_ptr = a_load_ptr;				/* copy load ptr */
      preface, obj_flag, eof, first_reloc, first_abs = "0"b;/* initialize some things */
      load_data.deck_name, load_data.diagnostic = "";
      load_data.sym_cnt = 0;
      load_data.deck_type, load_data.text_len = "0"b;
      code, load_len, symref_vec, last_seq = 0;
      prptr = deck_ptr;				/* set first block pointer */
      cbsn = bcw.bsn;				/* load block serial number counter */

      do while (^eof);				/* iterate through entire deck */
         lrptr = addr (gc_phy_rec.gc_phy_rec_data (1));	/* get pointer to first logical record */
         blk_len = 0;				/* initialize block length counter */
         do while (blk_len < bcw.blk_size);
	  if rcw.media_code = 2 then do;		/* bcd card image */
	     if substr (gc_log_rec_bits, 1, 78) = bcd_obj then do; /* object card */
	        call bcd_to_ascii_ (gc_log_rec_bits, obj_buf); /* convert to ascii */
	        obj_flag = "1"b;
	        load_data.deck_name = o_card.edit_name;	/* set name for user */
	        call CK_TD_LOAD;			/* go add in relocation (if required) */
	     end;
	     else if substr (gc_log_rec_bits, 1, 72) = bcd_dkend then /* dkend card */
	        eof = "1"b;				/* set flag to get out */
	     else do;				/* must be patch card or bad bcd card */
	        call CK_PATCH;			/* go check if valid patch */
	        if code ^= 0 then return;		/* not valid patch, quit now */
	     end;
	  end;
	  else if rcw.media_code = 1 then do;		/* bin card image */
	     cptr = addr (gc_log_rec.gc_log_rec_data);	/* set card pointer */
	     if ^obj_flag then do;			/* we must have object card first */
	        code = error_table_$fatal_error;	/* cards out of sequence */
	        call ioa_$rsnnl ("Binary card at ^p, appears before $ object card",
	         load_data.diagnostic, i, cptr);
	        return;
	     end;
	     if reloc_card.mb5 ^= 5 then do;		/* not column binary card */
	        code = error_table_$fatal_error;
	        call ioa_$rsnnl ("Card type - ^12.3b at ^p, is not a column binary card",
	         load_data.diagnostic, i, cptr -> ld_wd, cptr);
	        return;
	     end;
	     if reloc_card.type > 4 then do;		/* illegal card type */
	        code = error_table_$fatal_error;
	        call ioa_$rsnnl ("Card type - ^12.3b at ^p, is not a loadable binary card",
	         load_data.diagnostic, i, cptr -> ld_wd, cptr);
	        return;
	     end;
	     j = 0;
	     do i = 1 to 4;				/* 4 digits of seq number */
	        j = j * 10 + (index (bin_card.seq_num (i), "1"b) - 1);
	     end;
	     if j ^= last_seq + 1 then do;		/* seq num error */
	        code = error_table_$fatal_error;
	        call ioa_$rsnnl ("Binary card sequence error at ^p. Sequence number is ^d; S/B ^d",
	         load_data.diagnostic, i, cptr, j, last_seq + 1);
	        return;
	     end;
	     last_seq = j;
	     if abs_card.type ^= 0 then		/* if not absolute xfer card */
	        if CKSUM_CARD () then return;		/* if checksum error return with error */
	     if fnp_sw then
	        call DO_FNP;			/* go load fnp deck */
	     else if preface_card.type = 4 then		/* preface card */
	        call DO_PREFACE;
	     else if abs_card.type < 2 then		/* absolute card */
	        call DO_ABS;
	     else if reloc_card.type < 4 then		/* relocatable card */
	        call DO_RELOC;

	     else do;
	        code = error_table_$fatal_error;	/* unrecognizeable card type */
	        call ioa_$rsnnl ("Card type - ^12.3b at ^p, is not recognizable by loader",
	         load_data.diagnostic, i, cptr -> ld_wd, cptr);
	     end;
	     if code ^= 0 then return;		/* must have had error */
	  end;
	  else if rcw.media_code = 0 & rcw.file_mark = 15 then eof = "1"b; /* if eof */
	  else do;				/* card type we do not process */
	     code = error_table_$fatal_error;		/* illegal type */
	     call ioa_$rsnnl ("Logical record media code - ^o at ^p, is not processed by loader",
	      load_data.diagnostic, i, rcw.media_code, lrptr);
	     return;
	  end;
	  blk_len = blk_len + rcw.rsize + 1;		/* increment running block length */
	  lrptr = addrel (lrptr, currentsize (gc_log_rec)); /* set next logical record */
         end;
         if ^eof then do;				/* if we haven't reached last block */
	  prptr = addrel (prptr, bcw.blk_size + 1);	/* set phy rcd ptr to nxt word */
	  if bcw.bsn = 0 then			/* if nxt blk not appended... */
	     prptr = ptr (prptr, bin (rel (prptr)) + (320 - mod (bin (rel (prptr)), 320)));
	  if bcw.bsn ^= cbsn + 1 then do;		/* block serial number error */
	     code = error_table_$fatal_error;
	     call ioa_$rsnnl ("Block serial number error at ^p. Block serial number is ^o; S/B ^o",
	      load_data.diagnostic, i, prptr, bcw.bsn, cbsn + 1);
	     return;
	  end;
	  cbsn = cbsn + 1;				/* increment current block serial number */
         end;
      end;
      dlen = load_len;				/* save loaded length */
      if preface then				/* if relocatable */
         load_len = last_assigned;			/* offset already added in */
      else load_len = load_len + ld_offset;
      load_data.text_len = bit (load_len);		/* set length for user */
      accum = "0"b;					/* initialize checksum accumulator */
      call gload_cksum_ (load_ptr, dlen, accum);		/* calculate deck checksum */
      load_data.checksum = accum;			/* and save for user */

%page;

/* DO_RELOC - internal procedure to process relocatable binary cards */

DO_RELOC: proc;

      if ^first_reloc then do;
         first_reloc = "1"b;
         if ^preface then do;				/* must have preface card first */
	  code = error_table_$fatal_error;		/* no preface card */
	  call ioa_$rsnnl ("Relocatable text card at ^p, appears before preface card",
	   load_data.diagnostic, i, cptr);
	  return;
         end;
         if blank_common_len ^= 0 then do;		/* we have blank common to assign */
	  blank_common = last_assigned;		/* set address of blank common */
	  last_assigned = last_assigned + blank_common_len; /* set last address */
         end;
         lst_ld_entry = lx;				/* set last load table entry */
      end;
      lcwp = addr (reloc_card.cw);			/* set initial control word ptr */
      a_cnt = lcw.count;				/* load control word count */
      l, m, n = 0;					/* start at first data word */
      tmr, two_wd = "0"b;				/* reset flags */
      if lcw.rel_sym ^= 0 | lcw.type = 3 then do;		/* do we have an addend? */
         call ADD_COMMON;				/* yes */
         if code ^= 0 then return;			/* return if some problem */
      end;
      else core_ptr = addrel (load_ptr, lcw.l_addr);
      ldp = addr (reloc_card.data (m));			/* set address of first data word */
      do i = 1 to 3 while (^tmr);			/* relocate each word */
         do j = 1 to 7 while (^tmr);
	  if unspec (reloc_data (i).rloc (j)) = "0"b then /* if no relocation this word */
	     ld_wd = ldp -> ld_wd;			/* move the whole thing as is */
	  else do k = 1 to 2;			/* relocate each half */
	     go to reloc (reloc_data (i).rloc (j).hwds (k));
reloc (0):					/* absolute, copy as is */
	     core_ptr -> halfs (k) = halfs (k);
	     go to reloc_end;
reloc (1):					/* relocate relative to load address */
	     core_ptr -> halfs (k) = halfs (k) + ld_offset;
	     go to reloc_end;
reloc (2):					/* relocate relative to beginning of blank common */
	     core_ptr -> halfs (k) = halfs (k) + blank_common;
	     go to reloc_end;
reloc (3):					/* special relocation */
	     lx = fixed (rindex (k), 7);		/* form load table index */
	     if ld_entry (lx).ld_type ^= 5 then do;	/* if not symref */
	        if fixed (addend (k), 12) ^= -1 then	/* if we do not have to use next word */
		 if ^sign (k) then			/* and not minus */
		    final = ld_entry (lx).ld_offset + fixed (addend (k), 12);
		 else final = ld_entry (lx).ld_offset - fixed (addend (k), 12);
	        else do;				/* Must use the nxt word */
		 two_wd = "1"b;
		 if ^sign (k) then			/* if positive number */
		    final = ld_entry (lx).ld_offset + addrel (ldp, 1) -> halfs (k);
		 else final = ld_entry (lx).ld_offset - addrel (ldp, 1) -> halfs (k);
	        end;
	        core_ptr -> halfs (k) = final;		/* set in load area */
	     end;
	     else do;				/* sym ref, set up mme gebort */
	        if symref_vec = 0 then do;		/* if we havn't set up vector yet */
		 symref_vec = last_assigned;		/* set it now */
		 last_assigned = last_assigned + 2;	/* add vector to total length */
		 ptr (load_ptr, symref_vec) -> ld_wd =	/* set first word in vector */
		  "004301236007"b3;			/* to ldq =hol1,dl */
		 ptr (load_ptr, symref_vec + 1) -> ld_wd = /* set up second word */
		  "000010001000"b3;			/* to mme gebort */
	        end;
	        if k = 1 then do;			/* if upper half reloc */
		 core_ptr -> halfs (1) = symref_vec;	/* set up a tsx7 to */
		 core_ptr -> halfs (2) = bin ("707000"b3, 18); /* symref_vector */
		 k = 2;				/* set k so we don't come back */
	        end;
	        else core_ptr -> halfs (k) = symref_vec;	/* if lower set address of vector */
	        if fixed (addend (k), 12) = -1 then	/* if two word entry */
		 two_wd = "1"b;			/* skip second word */
	     end;
reloc_end:
	  end;
	  core_ptr = addrel (core_ptr, 1);
	  ldp = addrel (ldp, 1);			/* increment deck ptr */
	  m = m + 1;
	  if two_wd then do;			/* if two word addend */
	     two_wd = "0"b;				/* reset flag */
	     ldp = addrel (ldp, 1);			/* skip next word */
	     m = m + 1;
	  end;
	  if m = a_cnt then do;			/* control word exhausted? */
	     l = l + lcw.count + n;			/* increment total load count */
	     if l = max_reloc_wds then tmr = "1"b;	/* if max length card */
	     else if (l < max_reloc_wds & reloc_card.data (l) = "0"b) then
	        tmr = "1"b;				/* if no more control words */
	     else do;				/* more control words + data */
	        lcwp = addr (reloc_card.data (l));	/* set control word ptr */
	        a_cnt = lcw.count;			/* load control word count */
	        m = 0;				/* reset load index */
	        n = 1;				/* set control word skip */
	        if lcw.rel_sym ^= 0 | lcw.type = 3 then do; /* do we have an addend? */
		 call ADD_COMMON;			/* yes */
		 if code ^= 0 then return;		/* return if some problem */
	        end;
	        else core_ptr = addrel (load_ptr, lcw.l_addr);
	        ldp = addrel (ldp, 1);		/* increment load ptr past control word */
	     end;
	  end;

         end;
      end;

   end DO_RELOC;

%page;

/* DO_PREFACE - internal procedure to process binary preface cards */

DO_PREFACE: proc;

      if ^preface then do;				/* if we haven't been here already */
         vcb = preface_card.rel_sym;			/* set vcb index */
         if preface_card.mb8 then			/* if pgm to be loaded mod 8 */
	  if mod (ld_offset, 8) ^= 0 then		/* and if not already mod 8 */
	     ld_offset = ld_offset + (8 - mod (ld_offset, 8));
         load_len = preface_card.l_addr;
         last_assigned = load_len + ld_offset;		/* set initial value */
         lx = 0;					/* initialize load table index */
         blank_common_len = preface_card.blk_cmn_len;	/* save blank common length */
         load_data.deck_type = "1"b;			/* relocatable deck */
         preface = "1"b;
      end;
      do i = 1 to (preface_card.count - 1) / 2 while (bcd_sym (i) ^= "0"b);
         call bcd_to_ascii_ (bcd_sym (i), load_data.definition (i + load_data.sym_cnt).symbol);
         j, load_data.definition (i + load_data.sym_cnt).sym_type = sym_pair (i).sym_type; /* set symbol type */
         if j = 0 | j = 1 then do;			/* symdefs */
	  final = sym_pair (i).sym_pos + ld_offset;	/* add in offset */
	  load_data.definition (i + load_data.sym_cnt).offset = bit (final);
         end;
         else if j = 3 then
	  load_data.definition (i + load_data.sym_cnt).offset = bit (sym_pair (i).sym_pos, 18);
         else if j ^= 2 then do;			/* Must be common or symref, if not cobol seg  */
	  lx = lx + 1;				/* increment load table index */
	  ld_entry (lx).ld_type = j;			/* set symbol type in load table */
	  if j ^= 5 then do;			/* if not symref */
	     if sym_pair (i).mod8 then		/* if mod 8 required */
	        if mod (last_assigned, 8) ^= 0 then	/* set it mod 8 if necessary */
		 last_assigned = last_assigned + (8 - mod (last_assigned, 8));
	     ld_entry (lx).ld_offset = last_assigned;	/* set address in load table */
	     load_data.definition (i + load_data.sym_cnt).offset = bit (ld_entry (lx).ld_offset);
	     last_assigned = last_assigned + sym_pair (i).sym_pos;
	  end;
	  else load_data.definition (i + load_data.sym_cnt).offset = "0"b;
         end;
      end;
      load_data.sym_cnt = load_data.sym_cnt + (i - 1);	/* set new load_data.sym_cnt */

   end DO_PREFACE;

%page;

/* DO_ABS - internal procedure to process absolute binary cards */

DO_ABS: proc;

      lcwp = addr (abs_card.cw);			/* set initial control word ptr */
      go to absc (lcw.type);				/* process proper card type */

absc (0):						/* absolute binary xfer card */

      load_data.definition (1).symbol = "xfer  ";		/* set symbol and xfer */
      load_data.definition (1).offset = bit (lcw.l_addr, 18); /* address for user */
      load_data.sym_cnt = 1;				/* set symbol count for user */
      return;

absc (1):						/* absolute binary text card */
      if ^first_abs then do;				/* if first time through */
         first_abs = "1"b;
         ld_offset = lcw.l_addr;			/* set offset from zero */
      end;
      m = 0;					/* start with first data word */
      tmr = "0"b;
      do while (^tmr);				/* do while there is more data */
         ldp = addr (abs_card.data (m));		/* set load address */
         core_ptr = addrel (load_ptr, lcw.l_addr);	/* set core address */
         l = lcw.count * 4;				/* generate character count */
         core_ptr -> data_move = ldp -> data_move;	/* move the data */
         load_len = load_len + lcw.count;		/* increment loaded length */
         m = m + lcw.count;				/* increment total count, this card */
         if m = max_abs_wds then tmr = "1"b;		/* if max length card */
         else if (m < max_abs_wds & abs_card.data (m) = "0"b) then
	  tmr = "1"b;				/* if no more control wds */
         else do;					/* more control wds + data */
	  lcwp = addr (abs_card.data (m));		/* set control word ptr */
	  m = m + 1;				/* increment data word index */
         end;
      end;
      return;

   end DO_ABS;
%page;

/* DO_FNP - internal subroutine to load object decks generated by the 355map assembler */

DO_FNP: proc;

      lcwp = addr (fnp_card.cw);			/* set initial control word ptr */
      go to fnpc (lcw.type);				/* process proper card type */

fnpc (0):						/* absolute binary xfer card */
      load_data.definition (1).symbol = "xfer  ";		/* set symbol and xfer */
      load_data.definition (1).offset = bit (lcw.l_addr, 18); /* address for user */
      load_data.sym_cnt = 1;				/* set symbol count for user */
      return;

fnpc (1):						/* absolute binary text card */
      m = 0;					/* set word index */
      core_ptr = addr (fnp_seg (lcw.l_addr));		/* set ptr to move */
      if ^first_abs | fnp_seg (lcw.l_addr) = "000000"b3 then do;
         l = 4;
         if ^first_abs then
	  core_ptr -> data_move = o_card.edit_name;	/* move the data */
         first_abs = "1"b;
      end;
      core_ptr = addrel (core_ptr, 1);			/* set ptr to move */
      go to fnp_com;				/* and go to common code */

fnpc (2):						/* relocatable binary text card */
      m = 5;					/* set word index to ignore relocation */
      core_ptr = addr (fnp_seg (lcw.l_addr + ld_offset));	/* set ptr to move */

fnp_com:						/* common to type 1 and 2 text cards */
      tmr = "0"b;
      do while (^tmr);				/* do while there is more data */
         ldp = addr (fnp_card.data (m));		/* move ptr to nxt data field */
         l = lcw.count * 2;				/* generate character count */
         load_len = load_len + lcw.count;		/* increment loaded length */
         core_ptr -> data_move = ldp -> data_move;	/* move the data */
         m = m + lcw.count;				/* increment total count, this card */
         if m = max_fnp_wds then tmr = "1"b;		/* if max length card */
         else if (m < max_fnp_wds & fnp_card.data (m) = "0"b) then
	  tmr = "1"b;				/* if no more control wds */
         else do;
	  lcwp = addr (fnp_card.data (m));		/* set new control word ptr */
	  m = m + 2;				/* adjust index for control word */
         end;
      end;
      return;


fnpc (4):						/*  preface card */
      preface, load_data.deck_type = "1"b;		/* relocatable deck */
      last_assigned = preface_card.l_addr + ld_offset;	/* set length */
      return;					/* thats all for now */

   end DO_FNP;
%page;

/* ADD_COMMON - internal subroutine to add in common symbol reference from preface card */

ADD_COMMON: proc;

      lx = lcw.rel_sym;
      if lcw.type = 3 then				/* if we must */
         lx = lx + 64;
      if lx > lst_ld_entry then do;			/* OH OH */
         code = error_table_$fatal_error;		/* more symbols than we have */
         call ioa_$rsnnl ("Card type ^12.3b at ^p refs. symbol # ^d, but only ^d symbols are defined",
	load_data.diagnostic, i, lcwp -> ld_wd, lcwp, lx, lst_ld_entry);
      end;
      else core_ptr = addrel (load_ptr, ld_entry (lx).ld_offset + lcw.l_addr); /* set core ptr */

   end ADD_COMMON;

/* CKSUM_CARD - internal procedure to compute and check checksum on a binary card */

CKSUM_CARD: proc returns (bit (1));

      accum = bin_card.data (1);			/* add in first word */
      call gload_cksum_ (addrel (cptr, 2), 22, accum);	/* add in rest of card - cksum word and last word */
      if accum ^= reloc_card.checksum then do;
         if allow_zero_checksums & reloc_card.checksum = "0"b then do;
	  call ioa_ ("^a: ZERO checksum at ^p; Checksum S/B ^12.3b.
Loading ^a>^a.  Checksum will be adjusted.",
	   caller, cptr, accum, dir, ent);
	  reloc_card.checksum = accum;
	  return ("0"b);
         end;
         else do;
	  code = error_table_$fatal_error;		/* if checksum error */
	  call ioa_$rsnnl ("Checksum error at ^p. Checksum is ^12.3b; S/B ^12.3b.",
	   load_data.diagnostic, i, cptr, reloc_card.checksum, accum);
	  return ("1"b);				/* return error */
         end;
      end;
      else return ("0"b);				/* checksum ok */

   end CKSUM_CARD;

%page;

/* CK_TD_LOAD - internal procedure to special case "hmpcj1" and "htnd" library decks */

CK_TD_LOAD: proc;

      if o_card.assem = " " then do;			/* if this is true, it is a 355map deck */
         fnp_sw = "1"b;				/* set indicator switch */
         return;					/* thats all we need here */
      end;
      else fnp_sw = "0"b;
      if o_card.library = "hmpcj1" | o_card.library = "htnd  " then do;
         if o_card.ld_type = "d" then			/* if data deck */
	  ld_offset = 0;				/* no relocation, load in place */
         else if o_card.ld_type = "p" then do;		/* if program deck */
	  ld_offset = 72;				/* offset 110 oct */
	  load_ptr = addrel (load_ptr, 72);		/* load at offset 110 */
         end;
         else if o_card.ld_type = "r" then do;		/* if relocatable deck */
	  load_ptr = addrel (load_ptr, 72);		/* add 110 offset */
	  ld_offset = fixed (rel (load_ptr), 18) - ld_offset; /* and subtract base */
         end;
      end;
      else load_ptr = addrel (load_ptr, ld_offset);	/* if not special case, addin  ld offset */

   end CK_TD_LOAD;


/* CK_PATCH - internal procedure to check a bcd card image for a ligit patch card */

CK_PATCH: proc;

      call bcd_to_ascii_ (gc_log_rec_bits, card_buf);	/* convert to ascii */
      if o_patch.octal = "octal" | o_patch.octal = "mask " then /* if octal patch card */
         call O_PATCH;				/* go process it */
      else if h_patch.hex = "hex" then			/* if hex patch card */
         call H_PATCH;				/* go process it */
      else do;					/* unrecognized bcd card image */
         code = error_table_$fatal_error;		/* Illegal bcd card */
         call ioa_$rsnnl ("Bcd card at ^p, is not $ object, $ dkend, or valid patch - ""^a""",
	load_data.diagnostic, i, addrel (lrptr, 1), card_buf);
      end;

   end CK_PATCH;

%page;

/* O_PATCH - internal procedure to process octal and mask octal patch cards */

O_PATCH: proc;

      if o_patch.lbl ^= o_card.edit_name then		/* edit names don't agree */
         call PATCH_ERR ("octal", "edit name does not agree with edit name from $ object card");
      else if ^CV_AB (8, o_patch.add, pa) then		/* if error in address */
         call PATCH_ERR ("octal", "error converting octal address");
      if code ^= 0 then return;			/* if error already */
      p_ptr = addrel (load_ptr, bin (pa, 18));		/* set patch address */
      l = 1;					/* set scan position to 1 */
      tmr = "0"b;					/* reset terminate condition */
      do i = 1 to 20 while (^tmr);			/* get patches into patch array */
         patches (i).rloc (1), patches (i).rloc (2) = "0"b;
         if substr (o_patch.p_fld, l, 1) = "r" then do;	/* if left half relocation */
	  patches (i).rloc (1) = "1"b;		/* set relocation indicator */
	  l = l + 1;				/* update field position */
         end;
         else if index ("01234567", substr (o_patch.p_fld, l, 1)) = 0 then do;
	  call PATCH_ERR ("octal", "illegal relocation indicator in octal patch " || char (i));
	  return;
         end;
         j = search (substr (o_patch.p_fld, l), ", ");	/* search for comma or blank */
         k = j - 1;					/* set  to field length */
         if substr (o_patch.p_fld, l + k, 1) = " " | l + j >= length (o_patch.p_fld) then
	  tmr = "1"b;				/* if at end of patch field */
         if substr (o_patch.p_fld, l + k - 1, 1) = "r" then do; /* if right half relocation */
	  patches (i).rloc (2) = "1"b;		/* set relocation indicator */
	  k = k - 1;				/* subtract 1 from fild length */
         end;
         else if index ("01234567", substr (o_patch.p_fld, l + k - 1, 1)) = 0 then do;
	  call PATCH_ERR ("octal", "illegal relocation indicator in octal patch " || char (i));
	  return;
         end;
         if ^CV_AB (8, substr (o_patch.p_fld, l, k), tp) then do;
	  call PATCH_ERR ("octal", "error converting octal patch " || char (i));
	  return;
         end;
         patches (i).ul (*) = btp;			/* copy patch data */
         l = l + k + 1;				/* update string start */
      end;
      do j = 1 to i - 1;				/* now do the patching */
         do k = 1 to 2;				/* apply patch to each half word */
	  if patches (j).rloc (k) then		/* if relocation this half... */
	     p_word (k) = bin (patches (j).ul (k), 18) + ld_offset; /* add in relocation */
	  else p_word (k) = bin (patches (j).ul (k), 18); /* otherwise just use value as is */
         end;
         p_ptr = addrel (p_ptr, 1);			/* increment to next word */
      end;

   end O_PATCH;

%page;

/* H_PATCH - internal procedure to process hexadecimal patch cards for mpc decks */

H_PATCH: proc;

      idbp = ptr (load_ptr, last_assigned - 10);		/* set ptr to id blk */
      call bcd_to_ascii_ (bit (id_blk.revision.rev), dk_rev); /* convert rev to ascii */

/* do some consistancy checks on the hex patch card */

      if h_patch.cr ^= "c" & h_patch.cr ^= "r" then	/* if not for control store of r/w mem */
         call PATCH_ERR ("hex", "collum 7 must be ""c"" or ""r""");
      else if o_card.assem ^= "m" then			/* if not assembled by mpc assembler */
         call PATCH_ERR ("hex", "object deck to be patched not produced with mpc assembler");
      else if h_patch.lbl ^= o_card.edit_name then	/* edit names don't agree */
         call PATCH_ERR ("hex", "edit name does not agree with edit name from $ object card");
      else if h_patch.rev ^= dk_rev then		/* revisions don't agree */
         call PATCH_ERR ("hex", "revision does not agree with revision from ident block");
      else if h_patch.cr = "r" & id_blk.rw_start = 0 then	/* no r/w memory overlay */
         call PATCH_ERR ("hex", "r/w memory overlay non existant");
      else if ^CV_AB (16, h_patch.h_add, pa) then		/* error converting address */
         call PATCH_ERR ("hex", "error converting hex address");
      else if substr (unspec (pa), 36, 1) & h_patch.inst (2) ^= "" then /* odd add and 2 patches */
         call PATCH_ERR ("hex", "only one patch allowed for odd address");
      else if ^CV_AB (16, h_patch.inst (1), mpcp (1)) then
         call PATCH_ERR ("hex", "error converting first hex patch");
      else if h_patch.inst (2) ^= "" then		/* if 2nd inst exists */
         if ^CV_AB (16, h_patch.inst (2), mpcp (2)) then	/* error converting 2nd inst */
	  call PATCH_ERR ("hex", "error converting second hex patch");
      if code ^= 0 then return;			/* if error already return */
      if h_patch.cr = "r" then do;			/* if patching r/w memory */
         fw_low = id_blk.hx_rw_st;			/* set diminsion limits */
         ovl = last_assigned - id_blk.rw_start - 10;
         mem_name = "read/write";
      end;
      else do;					/* patching control store */
         fw_low = id_blk.hx_cs_st;			/* set diminsion limits */
         if id_blk.rw_start = 0 then			/* if no r/w mem overlay */
	  ovl = last_assigned - 10;
         else ovl = id_blk.rw_start;
         mem_name = "control store";
      end;
      fw_high = fw_low + 2 * ovl - 1;			/* compute high range in 16 bit words */
      if bin (pa, 18) < fw_low | bin (pa, 18) > fw_high - 2 | /* check patch card range */
       (h_patch.inst (2) ^= "" & bin (pa, 18) + 1 > fw_high - 2) then do;
         code = error_table_$fatal_error;		/* set error code */
         call ioa_$rsnnl ("Hex patch address(s) not within ^a memory range of ^.4b to ^.4b^/""^a""",
	load_data.diagnostic, i, mem_name, bit (bin (fw_low, 16), 16),
	bit (bin (fw_high - 2, 16), 16), card_buf);
         return;
      end;
      call MPC_CHECKSUM;				/* compute initial checksum */
      if GET_WORD (fw_high - 1) ^= mpc_checksum then do;	/* error in initial mpc_checksum */
         code = error_table_$fatal_error;
         call ioa_$rsnnl ("Checksum error detected in ^a memory before hex patch at ^p applied",
	load_data.diagnostic, i, mem_name, addrel (lrptr, 1));
         return;
      end;

/* now apply the patches */

      do i = 1 to 2 while (h_patch.inst (i) ^= "");
         j = bin (pa, 18) - 1 + i;
         call PUT_WORD (j, bit (bin (mpcp (i), 16), 16));
      end;
      call MPC_CHECKSUM;				/* compute new mpc_checksum */
      call PUT_WORD (fw_high - 1, mpc_checksum);		/* and store */

   end H_PATCH;

%page;

/* PATCH_ERR - subroutine to set diagnostic for patch card error */

PATCH_ERR: proc (type, mess);

dcl  (type, mess) char (*);

      code = error_table_$fatal_error;			/* set error code */
      call ioa_$rsnnl ("Error in ^a patch card at ^p: ^a.^/""^a""", load_data.diagnostic, i,
       type, addrel (lrptr, 1), mess, card_buf);

   end PATCH_ERR;

/* CV_AB - function to convert ascii characters to binary */

CV_AB: proc (base, ain, cv) returns (bit (1));

dcl  ain char (*);
dcl  cv bit (36);
dcl  v fixed bin (36);
dcl  (base, i, j) fixed bin;
dcl  aw char (32);

      v = 0;					/* initialize bin number */
      aw = "";					/* initialize working storage */
      aw = ltrim (ain);				/* strip off leading white space */
      do i = 1 to length (rtrim (aw));
         j = index (substr ("0123456789abcdef", 1, base), substr (aw, i, 1)); /* convert char to bin */
         if j = 0 then return ("0"b);			/* return error */
         v = base * v + j - 1;			/* add in current value */
         if base = 16 then				/* if converting hex */
	  if v > 1111111111111111b then		/* if number not in range 0-FFFF */
	     return ("0"b);
      end;
      cv = bit (v, 36);				/* return converted number */
      return ("1"b);				/* return good */

   end CV_AB;

%page;

/* Procedure that can reconstruct a firmware word */

GET_WORD: proc (i) returns (bit (16));


dcl  i fixed bin;

      return (fw.byte1 (i) || fw.byte2 (i));

   end GET_WORD;

/* Procedure which can store a firmware word */

PUT_WORD: proc (i, new_word);

dcl  i fixed bin;
dcl  new_word bit (16);

      fw.byte1 (i) = substr (new_word, 1, 8);
      fw.byte2 (i) = substr (new_word, 9, 8);
      return;

   end PUT_WORD;

/* Procedure that can compute a mpc_checksum from a mpc memory image */

MPC_CHECKSUM: proc;

dcl  sum fixed bin (35);
dcl  i fixed bin;

      sum = 0;
      do i = fw_low to fw_high - 2;
         sum = sum + bin (GET_WORD (i), 16);
         do while (sum > 1111111111111111b);
	  sum = sum - 10000000000000000b;
	  sum = sum + 1;
         end;
      end;
      sum = -sum;
      mpc_checksum = substr (unspec (sum), 21);		/* Get last 16 bits */
      return;

   end MPC_CHECKSUM;
%page;
%include gload_data;
%include gcos_ssf_records;

   end gload_;




		    gload_cksum_.alm                11/10/82  1716.3rew 11/10/82  1147.7       15264



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1982 *
" *                                                         *
" * Copyright (c) 1972 by Massachusetts Institute of        *
" * Technology and Honeywell Information Systems, Inc.      *
" *                                                         *
" ***********************************************************


" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
" Program to compute a GCOS stye checksum word, adding with carry except
" the last word. The calling sequence is:
"
"	dcl gload_cksum_ entry (ptr, fixed bin (18), bit (36));
"        call gload_cksum_ (start_ptr, length, cksum_word);
"
"	where: start_ptr
"	          is a ptr to the first word to be added to the inputed 
"	          checksum word. (INPUT)
"	       length
"	          is the number of words to be added to form the completed
"	          checksum word. (INPUT)  
"	       cksum_word
"	          is the resultant checksum word. (INPUT/OUTPUT)
"
"	Written by J. A. Bush 8/31/81
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
	name	gload_cksum_
	entry	gload_cksum_

gload_cksum_:
	eppbp	ap|2,*		get array ptr
	eppbp	bp|0,*
	lxl5	ap|4,*		load length
	eax4	0		start at 0
	lda	ap|6,*		load the starting addend
	ldi	4000,dl		set overflow mask
cks_loop:	awca	bp|0,4		add next array element
	eax4	1,4		increment index
	eax5	-1,5		decrement count
	tpnz	cks_loop		transfer if more to do
	sta	ap|6,*		return checksum word
	ldi	0,dl		reset overflow mask
	short_return		" and return
	end




		    load_mpc.pl1                    03/08/88  0941.7r w 03/08/88  0930.0      297171



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        * Copyright (c) 1972 by Massachusetts Institute of        *
        * Technology and Honeywell Information Systems, Inc.      *
        *                                                         *
        *********************************************************** */

/* format: style4,indattr */

load_mpc: proc;

/* LOAD_MPC - A command to load firmware into an MPC */

/* Written in 1975 by Larry Johnson */
/* Installed as a tool in February 1980 */
/* Modified May 1982 by Rich Coppola to add support of the EURC */
/* Modified Sept 1982 by Rich Coppola to dc reset the EURC before running
   self-test. */
/* Modified June 1984 by Paul Farley to add calls to phcs_$ring_0_message
   for informing the operator(and syserr log) that a MPC's state is changing.
   This will include Suspending IO, Running tests, Loading firmware(and what
   revision) and Resuming IO(or leaving IO suspended if error occurred).
   This means the user will now be required to also have phcs_ access.
   Changed the "special" code in run_dcw to allow for multiple specials,
   where the ones after the first will be discarded and to allow for the
   special to be before the terminate or visa-versa...
   Also added code to allow for a 10 second retry period for power off faults.
   Modified June 1985 by Paul Farley to extend POF retry to 20 seconds.
*/

/****^  HISTORY COMMENTS:
  1) change(85-09-09,Farley), approve(85-09-09,MCR6979),
     audit(86-02-11,Coppola), install(86-03-21,MR12.0-1033):
     Support IMU.
  2) change(86-01-23,Farley), approve(86-03-03,MCR7360),
     audit(86-07-11,Coppola), install(86-08-18,MR12.0-1096):
     Changed to check DAU after firmware load to see if really operational. DAU
     continues to do initialization after good FW load terminate, so OPI may
     not be up yet.
  3) change(86-08-14,Farley), approve(86-10-24,MCR7529),
     audit(86-10-28,Fawcett), install(86-10-28,MR12.0-1200):
     Extended post firmware load status test to ALL DISK MPCs, as it has been
     found that they all have the timing window, but very small.
     
     Added one second pause time between ITR test pages, to give the IMU and
     MPC time to bring OPI back up.
  4) change(86-10-24,Farley), approve(86-10-24,MCR7545),
     audit(86-10-28,Fawcett), install(86-10-28,MR12.0-1200):
     Add a call to dc_reset after sucessfully running ITRs. The ITRs now leave
     the MPC in a state where firmware does not operate properly after being
     loaded unless the dc_reset is done.
                                                   END HISTORY COMMENTS */

/* Automatic storage */

dcl  code		        fixed bin (35);		/* Standard system status code */
dcl  arg_cnt	        fixed bin;			/* Count of command arguments */
dcl  i		        fixed bin;			/* Indexes for loops */
dcl  phcs_access	        fixed bin (5);		/* current access to phcs_ */
dcl  execute	        bit (5) init ("00100"b);	/* mask for checking for execute permission */
dcl  arg_ptr	        ptr;			/* Pointer to a command argument */
dcl  arg_len	        fixed bin;			/* Length of that argument */
dcl  arg		        char (arg_len) based (arg_ptr); /* The argument */
dcl  firm_sw	        bit (1) init ("1"b);		/* "1"b if firmware is to be reloaded */
dcl  itr_sw	        bit (1) init ("1"b);		/* "1"b if itrs are to be run */
dcl  eurc_data_error        bit (1) init ("0"b);		/* "1"b if an error is detected in self-test data xfer */
dcl  pcw_words	        bit (72) aligned;		/* This is a pcw */
dcl  err_msg	        char (20) var init ("terminate"); /* For building error messages */
dcl  msg_sw	        bit (1) init ("1"b);		/* This is reset if -brief is used */
dcl  timer_sw	        bit (1) init ("0"b);		/* This is set if -time is requested */
dcl  eurc_sw	        bit (1) init ("0"b);		/* MPC is an EURC */
dcl  (start_time, end_time) fixed bin (52);		/* For measuring elapsed time */
dcl  elapsed_time	        fixed bin (35);		/* End_time-start_time */
dcl  stopped_io	        bit (1) init ("0"b);		/* This is set if I have suspended io */
dcl  mpc_dead	        bit (1) init ("0"b);		/* Set while mpc has no firmware loaded */
dcl  io_begun	        bit (1) init ("0"b);		/* Set when i/o started on mpc */
dcl  buf_ptr	        ptr;			/* Pointer to workspace */
dcl  fw_revision	        char (2);			/* Firmware revision */
dcl  timer_channel	        fixed bin (71) init (-1);	/* Channel for timing operations */
dcl  eurc_test	        char (14) init ("EURC Self-test");
dcl  TEST_NAME	        char (32) var init ("");
dcl  1 wait_list,					/* List of events to wait for */
       2 nchan	        fixed bin,			/* 1 to wait for i/o event, 2 to wait for i/o or timer */
       2 channel_id	        (2) fixed bin (71);		/* This is the list */
dcl  special_status_flag    bit (1) aligned;		/* "1"b syas special status valid */
dcl  special_status_word    bit (36) aligned;		/* a place to put special status */
dcl  ioi_io_tm	        fixed bin (71);		/* time of IOI connect */
dcl  RETRY_IO_LABEL	        label variable;		/* used to restart the I/O */
dcl  seconds_from_last_io   fixed bin;


dcl  1 auto_attach_mpc_data like attach_mpc_data aligned automatic;
dcl  1 auto_event_wait_info aligned like event_wait_info automatic;

/* Based */

dcl  1 buf	        aligned based (buf_ptr),	/* The ioi workspace */
       2 idcw	        bit (36),
       2 dcw	        (2) bit (36),
       2 port_mask	        bit (36),			/* Urmpc port mask for device firmware */
       2 data	        (8192) bit (36);		/* Most that can be loaded with 2 DCW's */

dcl  1 eurc_buf	        aligned based (buf_ptr),	/* The IOI buffer segment */
       2 idcw1	        bit (36),			/* will be execute self-test */
       2 dcw1	        bit (36),			/* Addr = control.dummy_data */
       2 idcw2	        bit (36),			/* initiate data xfer idcw */
       2 dcw2	        bit (36),			/* Addr = control.eurc_self_test_data */
       2 control,
         3 dummy_data       (2) bit (36),
         3 eurc_self_test_data (40) bit (36);		/* Only need twenty words, but leave some room for a crazy EURC */

dcl  eurc_test_data	        (6) bit (36) based (eurc_test_datap) aligned;
dcl  eurc_test_datap        ptr;


/* Static data */

dcl  MAX_TIMEOUT	        fixed bin internal static options (constant) init (20);
						/* Maximum length of time in seconds to wait for IO completion */
dcl  ONE_SECOND	        fixed bin (71) internal static options (constant) init (1);
dcl  TWO_SECOND	        fixed bin (71) internal static options (constant) init (2);
dcl  eurc_check_data        (6) bit (36) internal static options (constant) init
		        ("252525252525"b3,
		        "525252525252"b3,
		        "252525252525"b3,
		        "525252525252"b3,
		        "525252525252"b3,
		        "252525252525"b3);
dcl  name		        char (8) internal static options (constant) init ("load_mpc"); /* Name of this program */

/* Entry constants and externals */

dcl  attach_mpc_	        entry (ptr, fixed bin (35));
dcl  cu_$arg_ptr	        entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl  cu_$arg_count	        entry (fixed bin);
dcl  com_err_	        entry options (variable);
dcl  convert_ipc_code_      entry (fixed bin (35));
dcl  detach_mpc_	        entry (ptr, fixed bin (35));
dcl  hcs_$get_user_effmode  entry (char (*), char (*), char (*), fixed bin, fixed bin (5), fixed bin (35));
dcl  ioa_		        entry options (variable);
dcl  ioi_$connect	        entry (fixed bin, fixed bin, fixed bin (35));
dcl  ioi_$connect_pcw       entry (fixed bin, fixed bin, bit (36) aligned, fixed bin (35));
dcl  ioi_$workspace	        entry (fixed bin, ptr, fixed bin (18), fixed bin (35));
dcl  ioi_$release_devices   entry (fixed bin, fixed bin (35));
dcl  ioi_$suspend_devices   entry (fixed bin, fixed bin (35));
dcl  ioi_$get_special_status entry (fixed bin, bit (1) aligned, bit (36) aligned, fixed bin (35));
dcl  ipc_$block	        entry (ptr, ptr, fixed bin (35));
dcl  ipc_$create_ev_chn     entry (fixed bin (71), fixed bin (35));
dcl  ipc_$delete_ev_chn     entry (fixed bin (71), fixed bin (35));
dcl  ipc_$drain_chn	        entry (fixed bin (71), fixed bin (35));
dcl  load_mpc_fw_info_      entry (ptr, char (*), bit (1), bit (1), ptr, fixed bin (35));
dcl  parse_io_channel_name_ entry (char (*), fixed bin (3), fixed bin (6), fixed bin (35));
dcl  release_temp_segment_  entry (char (*), pointer, fixed bin (35));
dcl  timer_manager_$alarm_wakeup entry (fixed bin (71), bit (2), fixed bin (71));
dcl  timer_manager_$reset_alarm_wakeup entry (fixed bin (71));

dcl  error_table_$noarg     fixed bin (35) ext static;
dcl  error_table_$request_not_recognized fixed bin (35) ext static;
dcl  error_table_$badopt    fixed bin (35) ext static;
dcl  error_table_$noentry   fixed bin (35) ext static;

dcl  (addr, addrel, bin, bit, clock, float, hbound, min, null, rel, rtrim, size, string, substr, unspec, divide) builtin;

dcl  cleanup	        condition;
%page;
/* Some initialization first */

	call cu_$arg_count (arg_cnt);			/* This is a useful number */
	if arg_cnt = 0 then do;
	     call com_err_ (0, name, "Usage: ^a mpc_name {-chn -itr -firm -bf -time}", name);
	     return;
	end;

	attach_mpc_datap = addr (auto_attach_mpc_data);
	unspec (attach_mpc_data) = "0"b;
	attach_mpc_data.version = attach_mpc_data_version_1;
	attach_mpc_data.mpc_name = "";
	attach_mpc_data.caller_name = name;
	attach_mpc_data.bootload_channel = "1"b;	/* We always need a bootable channel! */
	fw_revision = "";

	event_wait_info_ptr = addr (auto_event_wait_info);
	imp = addr (event_wait_info.message);
	statp = addr (imess.status);
	io_special_status_ptr = addr (special_status_word);
	fwlistp = null ();

	on cleanup call clean_up;			/* Setup cleanup handler */

/* Scan arguments */

	do i = 1 to arg_cnt;			/* Scan remaining arguments */
	     call cu_$arg_ptr (i, arg_ptr, arg_len, code);
	     if code ^= 0 then go to err_1;		/* This can't happen */
	     if substr (arg, 1, 1) ^= "-" then do;	/* If not a control argument */
		if attach_mpc_data.mpc_name = "" then attach_mpc_data.mpc_name = arg;
		else do;
req_err:		     call com_err_ (error_table_$request_not_recognized, name, "^a", arg);
		     go to exit;
		end;
	     end;
	     else if arg = "-channel" | arg = "-chn" then do;
		i = i + 1;
		call cu_$arg_ptr (i, arg_ptr, arg_len, code);
		if code ^= 0 then do;
		     call com_err_ (code, name, "After -channel");
		     go to exit;
		end;
		call parse_io_channel_name_ (arg, attach_mpc_data.iom, attach_mpc_data.channel, code);
		if code ^= 0 then do;
		     call com_err_ (code, name, "^a", arg);
		     go to exit;
		end;
		attach_mpc_data.channel_required = "1"b;
	     end;
	     else if arg = "-itr" then firm_sw = "0"b;	/* -itr means don't load firmware */
	     else if arg = "-firm" then itr_sw = "0"b;	/* -firm means don't run itrs */
	     else if arg = "-brief" | arg = "-bf" then msg_sw = "0"b; /* Quiet mode */
	     else if arg = "-time" then timer_sw = "1"b;
	     else if arg = "-revision" | arg = "-rv" | arg = "-rev" then do; /* Firmware revision */
		i = i + 1;
		call cu_$arg_ptr (i, arg_ptr, arg_len, code);
		if code ^= 0 then do;
		     call com_err_ (code, name, "After -revision");
		     go to exit;
		end;
		fw_revision = arg;
	     end;
	     else do;				/* Ran out of cases  */
		call com_err_ (error_table_$badopt, name, "^a", arg);
		go to exit;
	     end;
	end;

	if attach_mpc_data.mpc_name = "" & ^attach_mpc_data.channel_required then do;
	     call com_err_ (error_table_$noarg, name, "MPC name or channel ");
	     go to exit;
	end;

	if ^(itr_sw | firm_sw) then itr_sw, firm_sw = "1"b; /* If -firm and -itr specified */
%page;
/* Check callers access to phcs_ for sending messages to the console
   and syserr log. */

	call hcs_$get_user_effmode (">system_library_1", "phcs_", "", -1, phcs_access, code);

	if code ^= 0 then do;
	     call com_err_ (code, name, "Cannot get effective access to >sl1>phcs_.");
	     goto exit;
	end;

	if bit (phcs_access) & execute
	then ;
	else do;
	     call com_err_ (code, name, "Improper access to >sl1>phcs_ gate.");
	     goto exit;
	end;

/* Initialize event channels */

	call ipc_$create_ev_chn (timer_channel, code);	/* Get timer channel */
	if code ^= 0 then go to err_3;
	wait_list.channel_id (2) = timer_channel;

	attach_mpc_data.report = "1"b;
	attach_mpc_data.channel_required = "1"b;	/* If not previously set, do it NOW! */

	call attach_mpc_ (attach_mpc_datap, code);
	if code ^= 0 then go to exit;
	wait_list.channel_id (1) = attach_mpc_data.ioi_channel;

	eurc_sw = "0"b;
	if attach_mpc_data.type = "urp" then
	     do i = 1 to hbound (eurc_model_numbers, 1) while (eurc_sw = "0"b);

	     if attach_mpc_data.model = eurc_model_numbers (i) then
		eurc_sw = "1"b;
	end;

	if eurc_sw then do;				/* perform basic option checks for EURC */
	     if (firm_sw & ^itr_sw) then do;
		call com_err_ (error_table_$badopt, name, "Cannot load FW in EURC.");
		go to exit;
	     end;
	end;

/* Figure out firmware requirements for this mpc */
	if ^eurc_sw then do;
	     call load_mpc_fw_info_ (attach_mpc_data.mpc_cardp, fw_revision, itr_sw, firm_sw, fwlistp, code);
	     if code ^= 0 then go to exit;
	end;

/* Perform workspace initialization */

	call ioi_$workspace (attach_mpc_data.ioi_index, buf_ptr, size (buf), code); /* Assign work area */
	if code ^= 0 then do;
	     call com_err_ (code, name, "Unable to set workspace size to ^d words.", size (buf));
	     go to exit;
	end;
%page;
/* First, suspend all io and do a do a dc reset of the mpc */

	call ioi_$suspend_devices (attach_mpc_data.ioi_index, code); /* This waits for all i/o to finish */
	if code ^= 0 then do;
	     call com_err_ (code, name, "Unable to suspend I/O on ^a.", attach_mpc_data.mpc_name);
	     go to exit;
	end;

	stopped_io = "1"b;				/* Remember that I did this */

	call opr_notify ("Suspended I/O");		/* notify/log */

	call dc_reset;				/* Using this routine */

	if eurc_sw then do;
	     firm_sw = "0"b;
	     TEST_NAME = eurc_test;
	     call make_eurc_dcw;
	     if msg_sw then call ioa_ ("^a: Executing EURC self-test.", name);
	     call opr_notify ("Executing EURC self-test");/* notify/log */
	     call run_dcw ("0"b);
						/* If we come back here all went well */
						/* Now verify the self-test data */
	     eurc_data_error = "0"b;
	     eurc_test_datap = addr (eurc_self_test_data (15));
	     if unspec (eurc_test_data) ^= unspec (eurc_check_data) then
		do i = 1 to 6;
		if eurc_test_data (i) ^= eurc_check_data (i) then do;
		     call com_err_ (0, name, "Data from EURC is incorrect:,^/data was:^-^w^/should be:^-^w",
			eurc_test_data (i), eurc_check_data (i));
		     eurc_data_error = "1"b;
		end;
	     end;
	     if ^eurc_data_error then mpc_dead = "0"b;
	     go to exit;
	end;

	if itr_sw then do;
	     call run_itrs;				/* Run itr's */
	     call dc_reset;				/* itr's ran, reset mpc */
	end;

	if firm_sw then call load_firmware;		/* Load firmware */

	if substr (attach_mpc_data.mpc_name, 1, 3) = "msp" & ^mpc_dead then do;
						/* See if DISK MPC really ready */
	     mpc_dead = "1"b;			/* mark as dead until IO is complete */
	     call make_dcw ("00"b3, "02"b3, 0);		/* request-status */
	     call run_dcw ("0"b);			/* execute */
	     mpc_dead = "0"b;			/* MPC is OK */
	end;

exit:	call clean_up;


	if io_begun & ^mpc_dead & ^msg_sw then		/* Print msg if brief mode and all worked ok */
	     call ioa_ ("^a: Completed run of ^a.", name, attach_mpc_data.mpc_name);

	return;					/* Command is done */
%page;
/* Run all its's */

run_itrs: proc;

dcl  i		        fixed bin;
dcl  opr_not_notified       bit (1) init ("1"b);

	do i = 1 to fwlist.n;
	     fwep = addr (fwlist.entry (i));
	     if fwe.type = FWE_TYPE_ITR then do;
		unspec (buf.data) = unspec (control_store_overlay);
		call make_dcw ("10"b3, "00"b3, fwe.cs_len); /* Build dcw list */
		if msg_sw then call ioa_ ("^a: Running ^a.", name, fwe.name);
		if opr_not_notified then do;
		     call opr_notify ("Executing ITRs");/* notify/log */
		     opr_not_notified = "0"b;
		end;
		TEST_NAME = fwe.name;
		call run_dcw ("1"b);		/* Run it */
		call pause (ONE_SECOND);
	     end;
	end;

	return;

     end run_itrs;
%page;
/* Procedure to restore the standard firmware to an mpc */

load_firmware: proc;

dcl  (cs_ok, rw_ok, df_ok)  bit (1) init ("0"b);		/* These bits are set as firmware components restored */
dcl  fwx		        fixed bin;

	do fwx = 1 to fwlist.n;
	     fwep = addr (fwlist.entry (fwx));
	     if fwe.type = FWE_TYPE_FW then go to got_firmware;
	end;
	call com_err_ (error_table_$noentry, name, "Firmware for ^a got lost somewhere.", attach_mpc_data.mpc_name);
	go to exit;				/* Sorry */

got_firmware:
	call opr_notify ("Loading firmware, revision " || fw_revision); /* notify/log */
	unspec (buf.data) = unspec (control_store_overlay);
	call make_dcw ("10"b3, "00"b3, fwe.cs_len);	/* Build dcw list */
	if msg_sw then call ioa_ ("^a: Loading ^a control store.", name, fwe.name);
	TEST_NAME = fwe.name;
	call run_dcw ("0"b);			/* Run it */
	cs_ok = "1"b;				/* Control store overlay restored */

	unspec (buf.data) = unspec (read_write_overlay);
	call make_dcw ("11"b3, "00"b3, fwe.rw_len);	/* Build dcw list */
	if msg_sw then call ioa_ ("^a: Loading ^a read/write.", name, fwe.name);
	TEST_NAME = fwe.name;
	call run_dcw ("0"b);			/* Run it */
	rw_ok = "1"b;				/* Read write overlay restored */
	if attach_mpc_data.type = "urp" then call dev_firm (df_ok); /* Reload device firmware */
	else df_ok = "1"b;				/* If none, just set the flag */

	mpc_dead = ^(rw_ok & cs_ok & df_ok);		/* If all restored, mpc not dead any more */

	return;

     end load_firmware;
%page;
/* Procedure to load special device firmware for urmpc */

dev_firm: proc (load_ok);

dcl  load_ok	        bit (1);			/* This is "1"b if this routine suceeds */

dcl  i		        fixed bin;

	load_ok = "1"b;				/* Assume this routine will work */

	do i = 1 to fwlist.n;
	     fwep = addr (fwlist.entry (i));
	     if fwe.type = FWE_TYPE_DEV & fwe.port_mask ^= "0"b then do;
		unspec (buf.data) = unspec (control_store_overlay);
		buf.port_mask = "0"b;
		substr (buf.port_mask, 2, 8) = fwe.port_mask;
		call make_mask_dcw ("36"b3, "00"b3, fwe.cs_len);
		idcwp = addr (buf.idcw);		/* Point at idcw */
		idcw.device = "01"b3;		/* This is addressed to device 1 */
		idcw.chan_cmd = "40"b3;
		if msg_sw then call ioa_ ("^a: Loading ^a; ports: ^b", name,
			fwe.name, fwe.port_mask);
		TEST_NAME = fwe.name;
		call run_dcw ("0"b);		/* Run it */
	     end;
	end;

	return;

     end dev_firm;
%page;
/* Procedure to build pcw and dcw list to load firmware */

make_dcw: proc (op_code, channel_cmd, data_len);

dcl  op_code	        bit (6);			/* The device command to use */
dcl  channel_cmd	        bit (6);			/* The channel cmd to use */
dcl  data_len	        fixed bin;			/* The length of the data */
dcl  tally_len	        fixed bin;			/* The length of the data in the current DCW */
dcl  data_loc	        fixed bin (18) uns;		/* Location of data */
dcl  len		        fixed bin;

	len = data_len;
	data_loc = bin (rel (addr (buf.data)));

join:	idcwp = addr (buf.idcw);			/* IDCW is built in first word of buffer */
	string (idcw) = "0"b;			/* Reset it */
	idcw.command = op_code;			/* Copy in opcode */
	idcw.chan_cmd = channel_cmd;
	idcw.code = "111"b;				/* This must be set to make an IDCW */

	dcwp = addr (buf.dcw);			/* An IOTD will be built here */
	string (dcw) = "0"b;
	do while (len > 0);
	     string (dcw) = "0"b;			/* Reset it first */
	     dcw.address = bit (data_loc, 18);
	     tally_len = min (len, 4096);
	     len = len - tally_len;
	     data_loc = data_loc + tally_len;
	     if tally_len = 4096 then tally_len = 0;
	     dcw.tally = bit (bin (tally_len, 12), 12);
	     dcw.type = "01"b;
	     if len > 0 then dcwp = addrel (dcwp, 1);
	end;
	dcw.type = "00"b;

	return;
%page;
make_eurc_dcw: entry;

/* Build dcw list to initiate EURC self-test */

	idcwp = addr (eurc_buf.idcw1);		/* First IDCW */
	eurc_buf.idcw1 = "0"b;
	idcw.command = "31"b3;			/* Command is Set Diagnostic Mode */
	idcw.code = "111"b;				/* This makes it an IDCW */
	idcw.control = "10"b;			/* Set continue bit */
	idcw.chan_cmd = "40"b3;			/* Indicate special controller command */
	idcw.count = "22"b3;			/* Run self-test */
	dcwp = addr (eurc_buf.dcw1);
	eurc_buf.dcw1 = "0"b;
	dcw.address = rel (addr (eurc_buf.control));	/* Get offset to control word */
	dcw.tally = "000000000010"b;
	idcwp = addr (eurc_buf.idcw2);		/* Set up Second IDCW */
	eurc_buf.idcw2 = "0"b;
	idcw.command = "06"b3;			/* Initiate read data xfer */
	idcw.code = "111"b;				/* This makes it an IDCW */
	idcw.chan_cmd = "40"b3;			/* Special controller command */
	dcwp = addr (eurc_buf.dcw2);
	eurc_buf.dcw2 = "0"b;
	dcw.address = rel (addr (eurc_buf.eurc_self_test_data));
	dcw.tally = "0024"b3;			/* need 20 words */

/* Now fill in the data for the EURC */

	unspec (eurc_buf.control) = "0"b;
						/* zero it out first */
						/* This is the TO EURC data, checked by the EURC */

	eurc_buf.eurc_self_test_data (2) = "777777777777"b3;
	eurc_buf.eurc_self_test_data (3) = "525252525252"b3;
	eurc_buf.eurc_self_test_data (4) = "252525252525"b3;
	eurc_buf.eurc_self_test_data (5) = "252525252525"b3;
	eurc_buf.eurc_self_test_data (6) = "525252525252"b3;
	eurc_buf.eurc_self_test_data (7) = "525252525252"b3;
	eurc_buf.eurc_self_test_data (8) = "252525252525"b3;
	eurc_buf.eurc_self_test_data (9) = "400400400400"b3;
	eurc_buf.eurc_self_test_data (10) = "377377377377"b3;
	eurc_buf.eurc_self_test_data (11) = "125125125125"b3;
	eurc_buf.eurc_self_test_data (12) = "252252252252"b3;
	eurc_buf.eurc_self_test_data (13) = "017017017017"b3;
	eurc_buf.eurc_self_test_data (14) = "360360360360"b3;

/* The next 6 words in the buffer will contain data FROM the EURC, they are already zeroed out */

	return;

%page;
make_mask_dcw: entry (op_code, channel_cmd, data_len);	/* Include port mask */

	len = data_len + 1;
	data_loc = bin (rel (addr (buf.port_mask)));
	go to join;

     end make_dcw;
%page;
/* Procedure to run a dcw list and check status */

run_dcw: proc (spec_sw);

dcl  spec_sw	        bit (1);			/* Set if a special interrupt is expected */

	RETRY_IO_LABEL = start_io;			/* used to retry POFs */
	ioi_io_tm = clock ();			/* setup new time for POF retry */
start_io: call ipc_$drain_chn (attach_mpc_data.ioi_channel, code); /* Be sure no events  */
	if code ^= 0 then go to err_3;
	call ioi_$connect (attach_mpc_data.ioi_index, 0, code); /* Attempt the connect */
	if code ^= 0 then go to err_1;		/* If it failed, give up */
	if timer_sw then start_time = clock ();		/* Record start time */
	wait_list.nchan = 1;			/* Only waiting on 1 channel, for i/o */
run_block: call ipc_$block (addr (wait_list), event_wait_info_ptr, code); /* Now wait for something to happen */
	if code ^= 0 then go to err_3;
	if timer_sw then end_time = clock ();


/* See what did happen and act accoridingly */

	if imess.time_out then do;			/* If termination because of time out */
time_err:	     call com_err_ (0, name, "Timeout running ^a while waiting for ^a",
		TEST_NAME, err_msg);
	     go to exit;
	end;

/* If special status expected when running ITRs, we get a terminate and then a special */
/* ** BUT ** we could get several of the same specials(over different channels)
   and the order of special/terminate may be different... */

	if spec_sw then do;
	     if imess.level = "3"b3 then do;		/* this must be from the command */
		err_msg = "terminate";
		call check_status;			/* verify good status */

		err_msg = "special";		/* Special interupt expected now */
		call timer_manager_$reset_alarm_wakeup (timer_channel); /* Remove outstanding alarm */
		call ipc_$drain_chn (timer_channel, code); /* Reset timer channel */
		if code ^= 0 then go to err_3;
		call timer_manager_$alarm_wakeup (60, "11"b, timer_channel); /* Set 60 second timer */
		wait_list.nchan = 2;		/* Waiting for i/o or timer event now */
		call ipc_$block (addr (wait_list), event_wait_info_ptr, code); /* Wait for something to happen */
		if code ^= 0 then go to err_3;
		if timer_sw then end_time = clock ();	/* Record end time */
		if event_wait_info.channel_id = timer_channel then go to time_err; /* If time out */
		if imess.level ^= "7"b3 then go to wrong_stat;
						/* check status */
		call ioi_$get_special_status (attach_mpc_data.ioi_index,
		     special_status_flag, special_status_word, code);
		if code ^= 0 then do;
		     call com_err_ (code, name, "Atempting to get special status word.");
		     go to exit;
		end;
		if ^(special_status_flag | io_special_status.t) then do;
		     call com_err_ (0, name, "No special status recieved.");
		     go to exit;
		end;
		if substr (special_status_word, 25, 1) = "0"b then do;
						/* ITR had an error */
		     call ioa_ ("^a: ^a Failed.", name, fwe.name);
		     go to exit;
		end;
		return;

	     end;
	     else if imess.level = "7"b3 then do;	/* ITR complete */
		err_msg = "special";
						/* check status */
		call ioi_$get_special_status (attach_mpc_data.ioi_index,
		     special_status_flag, special_status_word, code);
		if code ^= 0 then do;
		     call com_err_ (code, name, "Atempting to get special status word.");
		     go to exit;
		end;
		if ^(special_status_flag | io_special_status.t) then do;
		     call com_err_ (0, name, "No special status recieved.");
		     go to exit;
		end;
		if substr (special_status_word, 25, 1) = "0"b then do;
						/* ITR had an error */
		     call ioa_ ("^a: ^a Failed.", name, fwe.name);
		     go to exit;
		end;
		err_msg = "terminate";
wait_for_term:
		call timer_manager_$reset_alarm_wakeup (timer_channel); /* Remove outstanding alarm */
		call ipc_$drain_chn (timer_channel, code); /* Reset timer channel */
		if code ^= 0 then go to err_3;
		call timer_manager_$alarm_wakeup (60, "11"b, timer_channel); /* Set 60 second timer */
		wait_list.nchan = 2;		/* Waiting for i/o or timer event now */
		call ipc_$block (addr (wait_list), event_wait_info_ptr, code); /* Wait for something to happen */
		if code ^= 0 then go to err_3;
		if timer_sw then end_time = clock ();	/* Record end time */
		if event_wait_info.channel_id = timer_channel then go to time_err; /* If time out */
		if imess.level = "7"b3 then go to wait_for_term; /* discard special */
		call check_status;			/* verify good status */
		return;

	     end;
	end;

	err_msg = "termination";			/* Looking for termination now */

	if imess.level ^= "3"b3 then do;		/* If not termination */
wrong_stat:    call com_err_ (0, name, "Unexpected level ^.3b status when ^a expected running ^a",
		imess.level, err_msg, TEST_NAME);
	     go to exit;
	end;

	call check_status;
						/* check for good status */

	if timer_sw then do;			/* If time requested */
	     elapsed_time = end_time - start_time;
	     if elapsed_time < 1000 then call com_err_ (0, name, "time = ^d usec", elapsed_time);
	     else if elapsed_time < 1000000 then call com_err_ (0, name, "time = ^.1f msec",
		     float (elapsed_time) / 1000.);
	     else call com_err_ (0, name, "time = ^.1f sec", float (elapsed_time) / 1.0e6);
	end;

	return;

     end run_dcw;
%page;

/* Routine to  check IOM status for any error indications */
check_status: proc;


	if ^status.t then do;			/* If no status.. */
	     call send_err ("IOM did not set status bit running ^a.",
		(TEST_NAME));
	     go to exit;
	end;

	if status.power then do;			/* If power off */
	     seconds_from_last_io = divide (clock () - ioi_io_tm, 1000000, 17, 0);
	     if seconds_from_last_io < MAX_TIMEOUT then do; /* try IO again? */
		call pause (ONE_SECOND);		/* take small breather */
		goto RETRY_IO_LABEL;		/* Try it again, Sam! */
	     end;
	     call send_err ("Power off error running ^a.", (TEST_NAME));
	     go to exit;
	end;

	if status.major | status.sub | status.channel_stat | status.central_stat then do; /* If any other error */
	     call com_err_ (0, name, "Bad status returned running ^a: major=^b sub=^b",
		TEST_NAME, status.major, status.sub);
	     if eurc_sw then if status.major = "12"b3 then
		     call com_err_ (0, name, "^a failed. Fault Vector = ^2o",
			eurc_test, status.sub);

	     if status.channel_stat then call com_err_ (0, name, "IOM channel status=^b",
		     status.channel_stat);
	     if status.central_stat then call com_err_ (0, name, "IOM central status=^b",
		     status.central_stat);
	     go to exit;
	end;
	return;
     end check_status;


%page;
/* Procedure to dc reset of an mpc by isuing a reset pcw */

dc_reset: proc;

	mpc_dead = "1"b;				/* This routine will almost certainly kill it */
	io_begun = "1"b;				/* Real stuff is starting */

	pcwp = addr (pcw_words);			/* Get PCW pointer */
	string (pcw) = "0"b;			/* Reset it */
	pcw.code = "111"b;				/* Set PCW code */
	pcw.mask = "1"b;				/* Make it a reset PCW */
	pcw.control = "11"b;

	idcwp = addr (buf.idcw);
	string (idcw) = "0"b;
	idcw.code = "111"b;
	idcw.chan_cmd = "000010"b;

	ioi_io_tm = clock ();			/* remember time */
	call ioi_$connect_pcw (attach_mpc_data.ioi_index, 0, substr (pcw_words, 1, 36), code); /* Do connect */
	if code ^= 0 then go to err_1;
	wait_list.nchan = 1;			/* Only waiting for io channel */
	call ipc_$block (addr (wait_list), event_wait_info_ptr, code);
	if code ^= 0 then go to err_3;
	if imess.level ^= "3"b3 | ^imess.time_out then do;/* Ioi should set time out flag */
	     call send_err ("Abnormal status resetting channel", "");
	     go to exit;
	end;

/* Since time out was only simulated by ioi, a real delay must be done to allow the mpc to reset */

	call timer_manager_$reset_alarm_wakeup (timer_channel); /* Be sure no alarm already set */
	call ipc_$drain_chn (timer_channel, code);	/* In case event occured */
	if code ^= 0 then go to err_3;
	call timer_manager_$alarm_wakeup (1, "11"b, timer_channel); /* Set 1 second timer */
	wait_list.channel_id (1) = timer_channel;	/* Must wait on timer channel */
	call ipc_$block (addr (wait_list), event_wait_info_ptr, code); /* Wait for a second */
	if code ^= 0 then go to err_3;
	wait_list.channel_id (1) = attach_mpc_data.ioi_channel; /* Restore wait list */

	return;

     end dc_reset;
%page;
/* Various error messages */

err_1:	call send_err ("", "");
	go to exit;

err_2:	call send_err ("^a", arg);
	go to exit;

err_3:	call convert_ipc_code_ (code);
	go to err_1;



/* Routine to send an error message */

send_err: proc (arg1, arg2);

dcl  (arg1, arg2)	        char (*);

	call com_err_ (code, name, arg1, arg2);
	return;

     end send_err;

/* Routine to notify system Operator of changes to the state of a MPC.. */

opr_notify: proc (opr_mess);

dcl  opr_mess	        char (*) parameter;
dcl  phcs_$ring_0_message   entry (char (*));

	call phcs_$ring_0_message (opr_mess || " for " ||
	     rtrim (attach_mpc_data.mpc_name) || ".");
	return;
     end opr_notify;

/* Routine to pause for N seconds */

pause: proc (pause_time);
dcl  pause_time	        fixed bin (71) parm;

	call timer_manager_$reset_alarm_wakeup (timer_channel); /* Be sure no alarm already set */
	call ipc_$drain_chn (timer_channel, code);	/* In case event occured */
	call timer_manager_$alarm_wakeup (pause_time, "11"b, timer_channel); /* Set timer */
	wait_list.channel_id (1) = timer_channel;	/* Must wait on timer channel */
	wait_list.nchan = 1;
	call ipc_$block (addr (wait_list), event_wait_info_ptr, code); /* Wait for a second */
	wait_list.channel_id (1) = attach_mpc_data.ioi_channel; /* Restore wait list */
	return;
     end pause;
%page;
/* Cleanup handler */

clean_up: proc;

	if stopped_io then do;			/* If I suspended io on the mpc */
	     if mpc_dead then do;
		call opr_notify ("I/O not released, firmware not restored"); /* notify/log */
		call com_err_ (0, name,
		     "I/O not released on ^a controller because firmware not restored.", attach_mpc_data.mpc_name);
	     end;
	     else do;
		call pause (TWO_SECOND);		/* short pause */
		call ioi_$release_devices (attach_mpc_data.ioi_index, code);
		stopped_io = "0"b;
		call opr_notify ("I/O resumed");	/* notify/log */
	     end;
	end;
	call detach_mpc_ (attach_mpc_datap, code);
	if timer_channel ^= -1 then do;
	     call timer_manager_$reset_alarm_wakeup (timer_channel);
	     call ipc_$delete_ev_chn (timer_channel, code);
	     timer_channel = -1;
	end;

	if fwlistp ^= null () then do;
	     do i = 1 to fwlist.n;
		fwep = addr (fwlist.entry (i));
		if fwe.segp ^= null () then call release_temp_segment_ (name, fwe.segp, code);
	     end;
	     free fwlist;
	end;

	return;

     end clean_up;
%page;
%include iom_pcw;
%page;
%include iom_dcw;
%page;
%include ioi_stat;
%page;
%include iom_stat;
%page;
%include event_wait_info;
%page;
%include attach_mpc_data;
%page;
%include load_mpc_info;
%page;
%include eurc_model_numbers;
%page;
%include io_special_status;


     end load_mpc;




		    load_mpc_fw_info_.pl1           12/10/84  1524.0rew 12/10/84  1006.2      131751



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   * Copyright (c) 1972 by Massachusetts Institute of        *
   * Technology and Honeywell Information Systems, Inc.      *
   *                                                         *
   *********************************************************** */


/* LOAD_MPC_FW_INFO_ - Subroutine used by the load_mpc command to locate firmware for an MPC. */
/* Given an MPC type, a model, and an optional firmware revisions, this module will locate the
   proper firmware in the T & D deckfile. */
/* Written February 1980 by Larry Johnson */
/* Modified October 1982 by C. Hornig for new config tools.
   /* Modified November 1982 by Rich Coppola to correct disk MPC model recognition
   which somehow got removed. */
/* Modified June 1984 by Paul Farley to add DAU (MSP800) support. */
/* Modified Nov. 1984 by Paul Farley to allow for a CCU (read/punch), see phx18465. */

/* format: style4,indattr,insnl,delnl */

load_mpc_fw_info_:
     proc (arg_mpcp, arg_fw_revision, arg_itr_needed, arg_fw_needed, arg_fwlistp, arg_code);

/* Parameters */

dcl  arg_mpcp	        ptr;
dcl  arg_fw_revision        char (*);
dcl  arg_code	        fixed bin (35);
dcl  arg_fwlistp	        ptr;
dcl  arg_itr_needed	        bit (1);
dcl  arg_fw_needed	        bit (1);

/* Automatic */

dcl  mpc_type	        char (3);
dcl  model	        fixed bin;
dcl  fw_mpc_name	        char (6);
dcl  cata_key	        char (32);
dcl  fw_revision	        char (2);
dcl  code		        fixed bin (35);
dcl  (i, j, k)	        fixed bin;
dcl  temp_string	        char (64) var;
dcl  answer	        char (32) var;
dcl  rv		        char (2);
dcl  module_listp	        ptr;
dcl  found_itr	        bit (1);
dcl  found_fw	        bit (1);
dcl  found_dev	        bit (1);
dcl  deck_ptr	        ptr;
dcl  fwsegp	        ptr;
dcl  fwsegl	        fixed bin;
dcl  rw_index	        fixed bin;
dcl  deck_iocbp	        ptr;
dcl  needed	        bit (1);
dcl  chan		        fixed bin (6);
dcl  dev_fw_err	        bit (1);
dcl  dev_fw_fnd	        bit (1);

dcl  1 cata_list	        aligned,
       2 n	        fixed bin,
       2 keys	        (10) char (24) unal;

dcl  1 module_list	        aligned based (module_listp),
       2 n	        fixed bin,
       2 name	        (0 refer (module_list.n)) char (24) unal;

dcl  fwseg	        (fwsegl) bit (36) aligned based (fwsegp);

/* Constants */

dcl  name		        char (8) int static options (constant) init ("load_mpc");
						/* I am really part of this guy */
dcl  MPCBOT	        bit (36) int static options (constant) init ("444723224663"b3);
						/* BCD for "MPCBOT" */

/* External */

dcl  tolts_util_$cata_sel   entry (ptr, char (32), ptr, fixed bin (35));
dcl  tolts_util_$search     entry (ptr, char (32), ptr, fixed bin, fixed bin (35));
dcl  command_query_	        entry options (variable);
dcl  com_err_	        entry options (variable);
dcl  get_temp_segment_      entry (char (*), pointer, fixed bin (35));
dcl  release_temp_segment_  entry (char (*), pointer, fixed bin (35));
dcl  gload_	        entry (ptr, ptr, fixed bin (18), ptr, fixed bin (35));
dcl  iox_$close	        entry (ptr, fixed bin (35));
dcl  iox_$detach_iocb       entry (ptr, fixed bin (35));
dcl  find_config_card_$prph_for_channel
		        entry (fixed bin (3), fixed bin (6), ptr);

dcl  error_table_$bad_arg   ext fixed bin (35);
dcl  error_table_$noentry   ext fixed bin (35);

dcl  cleanup	        condition;

dcl  (addr, bin, hbound, null, substr, unspec)
		        builtin;
%page;
	mpc_cardp = arg_mpcp;
	mpc_type = substr (mpc_card.name, 1, 3);
	model = mpc_card.model;
	fw_revision = arg_fw_revision;
	fwlistp = null ();
	deck_iocbp = null ();

	on cleanup call clean_up;

/* Tranlate the mpc name and model as Multics knows it to the name T&D knows it by. */

	if mpc_type = "urp"
	then fw_mpc_name = "urcmpc";
	else if mpc_type = "mtp" then do;
	     if model = 500 | model = 501 | model = 502 | model = 600
	     then fw_mpc_name = "mtc500";
	     else if model = 601 | model = 602
	     then fw_mpc_name = "mtp601";
	     else if model = 610 | model = 611
	     then fw_mpc_name = "mtp610";
	     else go to unknown_model;
	end;
	else if mpc_type = "msp" then do;
	     if model = 181
	     then fw_mpc_name = "dsc181";
	     else if model = 190
	     then fw_mpc_name = "dsc190";
	     else if model = 191 | model = 400 | model = 450 | model = 451 | model = 601 | model = 603
	     then fw_mpc_name = "dsc191";
	     else if model = 607 | model = 609 | model = 611 | model = 612 | model = 500
	     then fw_mpc_name = "dsc500";
	     else if model = 800
	     then fw_mpc_name = "msp800";		/* DAU */
	     else go to unknown_model;
	end;
	else do;
unknown_model:
	     call com_err_ (0, name, "Firmware type for ^a model ^d not known.", mpc_type, model);
	     code = error_table_$bad_arg;
	     go to error_return;
	end;

/* Locate firmware in the T&D deckfile */

	cata_key = "cata.itr." || fw_mpc_name;

	call tolts_util_$cata_sel (deck_iocbp, cata_key, addr (cata_list), code);
	if code ^= 0 then do;
	     call com_err_ (code, name, "Unable to find catalog for ^a firmware for ^a model ^d.", fw_mpc_name,
		mpc_type, model);
	     go to error_return;
	end;

/* Check requested revision against whats in file */

	temp_string = "";
	do i = 1 to cata_list.n;
	     if i > 1
	     then temp_string = temp_string || ", ";
	     rv = extract_rev (cata_list.keys (i));
	     if fw_revision ^= ""
	     then if fw_revision = rv then do;
		     cata_key = cata_list.keys (i);
		     go to got_key;
		end;
	     temp_string = temp_string || rv;
	end;
	if fw_revision ^= "" then do;
	     call com_err_ (0, name,
		"^a firmware revison ^a for ^a model ^d not found. Revision^[s^] available ^[is^;are^]: ^a.",
		fw_mpc_name, fw_revision, mpc_type, model, (cata_list.n ^= 1), (cata_list.n = 1), temp_string);
	     code = error_table_$noentry;
	     go to error_return;
	end;
	if cata_list.n = 1 then do;			/* If only 1, use it */
	     cata_key = cata_list.keys (1);
	     fw_revision = extract_rev (cata_list.keys (1));
	     go to got_key;
	end;

/* Multiple revision exists, and user didn't specify. So ask. */

	temp_string = temp_string || ", or no.";

repeat:
	query_info.version = query_info_version_4;
	call command_query_ (addr (query_info), answer, name,
	     "Multiple revisions of ^a firmware for ^a model ^d. Choose from ^a - ", fw_mpc_name, mpc_type, model,
	     temp_string);
	if answer = "no" | answer = "quit" | answer = "q" then do;
	     code = error_table_$noentry;
	     go to error_return;
	end;

	do i = 1 to cata_list.n;
	     if answer = extract_rev (cata_list.keys (i)) then do;
		cata_key = cata_list.keys (i);
		fw_revision = answer;
		go to got_key;
	     end;
	end;
	go to repeat;

/* Now that revision is decided, find catalog entry for it. */

got_key:
	call tolts_util_$search (deck_iocbp, cata_key, module_listp, (0), code);
	if code ^= 0 then do;
	     call com_err_ (code, name, "Unable to find catalog for ^a. Deckfile may be damaged.", cata_key);
	     go to error_return;
	end;

/* Now identify each of the programs */

	fwlist_n = module_list.n;
	allocate fwlist;

	found_itr, found_fw, found_dev = "0"b;

	do i = 1 to module_list.n;
	     fwep = addr (fwlist.entry (i));
	     fwe.name = module_list.name (i);
	     fwe.segp = null ();
	     fwe.device (*) = "";
	     fwe.cs_ptr, fwe.rw_ptr = null ();
	     fwe.cs_len, fwe.rw_len = 0;
	     fwe.port_mask = "0"b;
	     if substr (fwe.name, 1, 4) = "itr." then do;
		fwe.type = FWE_TYPE_ITR;
		found_itr = "1"b;
	     end;
	     else if ^found_fw then do;
		found_fw = "1"b;
		fwe.type = FWE_TYPE_FW;
	     end;
	     else if mpc_type = "urp" & found_fw then do;
		if substr (fwe.name, 1, 7) = "400ovl." then do;
		     fwe.type = FWE_TYPE_DEV;
		     fwe.device (1) = "prt";
		     found_dev = "1"b;
		end;
		else if substr (fwe.name, 1, 7) = "300ovl." then do;
		     fwe.type = FWE_TYPE_DEV;
		     fwe.device (1) = "rdr";
		     fwe.device (2) = "pun";
		     fwe.device (3) = "ccu";
		end;
		else go to cant_identify;
	     end;
	     else do;
cant_identify:
		code = error_table_$noentry;
		call com_err_ (0, name, "Can't identify firmware module ^a for ^a model ^d.", fwe.name, mpc_type,
		     model);
		go to error_return;
	     end;
	end;

/* For unit record device firmware, find out for which ports each module is needed */

	if mpc_type = "urp" then do;
	     dev_fw_fnd, dev_fw_err = "0"b;
	     do i = 1 to mpc_card.nchan (1);		/* Check each channel for device */
		chan = mpc_card.chan (1) + i - 1;
		call find_config_card_$prph_for_channel ((mpc_card.iom (1)), chan, prph_cardp);
		if prph_cardp = null ()
		then go to next_channel;
		do j = 1 to fwlist.n;		/* Find firmware for this device */
		     fwep = addr (fwlist.entry (j));
		     if fwe.type = FWE_TYPE_DEV then do;
			do k = 1 to hbound (fwe.device, 1);
			     if fwe.device (k) = substr (prph_card.name, 1, 3) then do;
						/* Got it */
				substr (fwe.port_mask, i, 1) = "1"b;
				dev_fw_fnd = "1"b;
				go to next_channel;
			     end;
			end;
		     end;
		end;
		call com_err_ (0, name, "No firmware for device ^a on mpc ^a", mpc_card.name, prph_card.name);
		dev_fw_err = "1"b;
next_channel:
	     end;

	     if ^dev_fw_fnd then do;
		call com_err_ (0, name, "No device firmware to load into mpc ^a.", mpc_card.name);
		dev_fw_err = "1"b;
	     end;
	     if dev_fw_err then do;
		code = error_table_$noentry;
		go to error_return;
	     end;
	end;

/* Now load each of the modules */

	if arg_itr_needed & ^found_itr then do;
	     code = error_table_$noentry;
	     call com_err_ (code, name, "No ITR's found for ^a model ^d.", mpc_type, model);
	     go to error_return;
	end;
	if arg_fw_needed & ^found_fw then do;
	     code = error_table_$noentry;
	     call com_err_ (code, name, "No firmware found for ^a model ^d.", mpc_type, model);
	     go to error_return;
	end;

	do i = 1 to fwlist.n;
	     fwep = addr (fwlist.entry (i));
	     needed = "0"b;
	     if fwe.type = FWE_TYPE_ITR
	     then needed = arg_itr_needed;
	     else if fwe.type = FWE_TYPE_FW
	     then needed = arg_fw_needed;
	     else if fwe.type = FWE_TYPE_DEV
	     then needed = arg_fw_needed & (fwe.port_mask ^= "0"b);
	     if needed then do;
		call get_temp_segment_ (name, fwe.segp, code);
		if code ^= 0 then do;
		     call com_err_ (code, name, "Can't get temp segment for ^a.", fwe.name);
		     go to error_return;
		end;
		call tolts_util_$search (deck_iocbp, (fwe.name), deck_ptr, (0), code);
		if code ^= 0 then do;
		     call com_err_ (code, name, "Unable to find ^a in deckfile.", fwe.name);
		     go to error_return;
		end;
		call gload_ (deck_ptr, fwe.segp, 0, addr (gload_data), code);
		if code ^= 0 then do;
		     call com_err_ (code, name, "^a. Loading ^a.", gload_data.diagnostic, fwe.name);
		     go to error_return;
		end;
		fwsegp = fwe.segp;
		fwsegl = bin (gload_data.text_len);
		if fwsegl <= 10 then do;
		     code = error_table_$noentry;
		     call com_err_ (0, name, "^a too short to be firmware module. length = ^d.", fwe.name, fwsegl);
		     go to error_return;
		end;
		if fwseg (fwsegl) ^= MPCBOT then do;
		     code = error_table_$noentry;
		     call com_err_ (0, name, "^a segment does not end with ""MPCBOT"".", fwe.name);
		     go to error_return;
		end;
		rw_index = bin (substr (fwseg (fwsegl - 5), 1, 18));
		fwe.cs_ptr = fwe.segp;
		if rw_index = 0
		then				/* No r/w overlay */
		     fwe.cs_len = fwsegl - 10;
		else do;
		     fwe.cs_len = rw_index;
		     fwe.rw_ptr = addr (fwseg (rw_index + 1));
		     fwe.rw_len = fwsegl - rw_index - 10;
		end;
		call check_checksum ("control store", control_store_overlay);
		if fwe.rw_ptr ^= null ()
		then call check_checksum ("read write", read_write_overlay);
		if fwe.type = FWE_TYPE_FW & fwe.rw_ptr = null () then do;
		     code = error_table_$noentry;
		     call com_err_ (0, name, "^a is missing a read/write overlay.", fwe.name);
		     go to error_return;
		end;
		if fwe.type ^= FWE_TYPE_FW & fwe.rw_ptr ^= null () then do;
		     code = error_table_$noentry;
		     call com_err_ (0, name, "^a has an unwanted read/write overlay.", fwe.name);
		     go to error_return;
		end;
	     end;
	end;

	call iox_$close (deck_iocbp, code);
	call iox_$detach_iocb (deck_iocbp, code);
	arg_fwlistp = fwlistp;
	if arg_fw_revision = ""
	then arg_fw_revision = fw_revision;
	arg_code = 0;
	return;

error_return:
	arg_fwlistp = null ();
	arg_code = code;
	call clean_up;
	return;
%page;
/* Compute a checksum */

check_checksum:
     proc (overlay_name, overlay);

dcl  overlay_name	        char (*);
dcl  overlay	        (*) bit (36) aligned;
dcl  check_sum	        fixed bin (35);
dcl  check_bit	        bit (36);
dcl  i		        fixed bin;
dcl  answer	        bit (18);

	check_sum = 0;
	do i = 1 to (hbound (overlay, 1) - 1);
	     call ch_add (substr (overlay (i), 1, 18));
	     call ch_add (substr (overlay (i), 19, 18));
	end;
	check_sum = -check_sum;
	check_bit = unspec (check_sum);
	answer = "0"b || substr (check_bit, 21, 8) || "0"b || substr (check_bit, 29, 8);
	if answer ^= substr (overlay (hbound (overlay, 1)), 1, 18) then do;
	     code = error_table_$noentry;
	     call com_err_ (0, name, "Checksum error in ^a overlay of ^a.", overlay_name, fwe.name);
	     go to error_return;
	end;
	return;

/* Do 16 bit addtion with end-around carry */

ch_add:
	proc (word);

dcl  word		        bit (18);
dcl  addval	        fixed bin (16);

	     addval = bin (substr (word, 2, 8) || substr (word, 11, 8));
	     check_sum = check_sum + addval;
	     do while (check_sum > 1111111111111111b);
		check_sum = check_sum - 10000000000000000b;
		check_sum = check_sum + 1;
	     end;

	end ch_add;

     end check_checksum;

extract_rev:
     proc (c) returns (char (2));

dcl  c		        char (*);

	return (substr (c, 17, 2));

     end extract_rev;

clean_up:
     proc;

	if deck_iocbp ^= null () then do;
	     call iox_$close (deck_iocbp, code);
	     call iox_$detach_iocb (deck_iocbp, code);
	end;
	if fwlistp ^= null () then do;
	     do i = 1 to fwlist.n;
		fwep = addr (fwlist.entry (i));
		if fwe.segp ^= null ()
		then call release_temp_segment_ (name, fwe.segp, code);
	     end;
	     fwlist_n = fwlist.n;
	     free fwlist;
	end;
	return;

     end clean_up;
%page;
%include query_info;
%include config_mpc_card;
%include config_prph_card;
%include gload_data;
%include load_mpc_info;

     end load_mpc_fw_info_;




		    mpc_data_summary.pl1            04/02/85  1110.7rew 04/02/85  1035.4      255870



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   * Copyright (c) 1972 by Massachusetts Institute of        *
   * Technology and Honeywell Information Systems, Inc.      *
   *                                                         *
   *********************************************************** */


/* MPC_DATA_SUMMARY: Command to summarize mpc data from the syserr log collected by poll_mpc */

/* Written MAY 1981 by Rich Fawcett  */
/* Most of this program was borrowed from the mos_edac_summary command. */
/* Modified May 1982 by Rich Coppola for EURC support */
/* Modified June 1983 by Paul Farley to fix EURC bugs. */
/* Modified Sept. 1983 to change "-mpc" arg to set mpc_only flag and to
   only update stats_data.polled_error_data if error_data reg is NON-ZERO.
   Modified Jan 1984 by Paul Farley to fix "-ext" function (phx16436).
   Modified June 1984 by Paul Farley to add DAU (MSP800) support.
   Modified March 1985 by Paul Farley to increase the size of psi_cntr (PBF).
*/

/* format: style4,delnl,insnl,ifthenstmt,indnoniterend */

mpc_data_summary:
     proc;

dcl  name char (17) int static options (constant) init ("mpc_data_summary");
						/* Name of procedure */
dcl  check_mpc fixed bin;
dcl  code fixed bin (35);				/* Standard system status code */
dcl  open_status bit (36) aligned;			/* Code from syserr_log_util_$open */
dcl  ptr_array (2) ptr;				/* An array of pointers as required by get_temp_segment_ */
dcl  tab_cnt fixed bin init (0);			/* Number of seperate status found */
dcl  mask bit (36) aligned init ("0"b);			/* Mask of significant bits in status word */
dcl  arg_ptr ptr;					/* Pointer to an argument */
dcl  arg_len fixed bin;				/* Length of an argument */
dcl  arg char (arg_len) based (arg_ptr);		/* A command argument */
dcl  arg_count fixed bin;				/* The number of arguments */
dcl  arg_list_ptr ptr;				/* Pointer to commands argument list */
dcl  for_ptr ptr;					/* Saved pointer to the -for argument */
dcl  for_len fixed bin;				/* Saved length of -for argument */
dcl  for_arg char (for_len) based (for_ptr);		/* This is the -for argument */
dcl  from_sw bit (1) init ("0"b);			/* Set if -from used */
dcl  to_sw bit (1) init ("0"b);			/* Set if -to used */
dcl  for_sw bit (1) init ("0"b);			/* Set if -for used */
dcl  more_args bit (1);				/* Set while there are more arguments to scan */
dcl  short_display_sw bit (1) init ("1"b);
dcl  short_arg bit (1) init ("0"b);
dcl  top_of_page_req bit (1) init ("0"b);
dcl  mpc_only bit (1) init ("0"b);
dcl  bf_sw bit (1) init ("0"b);
dcl  all_mpcs bit (1) init ("0"b);			/* all mpc's that we find will be summarized
						   if no mpc name are in put this will set set  */
dcl  (output_file, of_file_att, of_file_open) bit (1) init ("0"b);
						/* output file to be used and if it is attached and open */
dcl  ext_file bit (1) init ("0"b);			/* set if the output file is to be extended */
dcl  expand_sw bit (1) init ("0"b);			/* set if each entry found is the syserr_log is to also be printed */
dcl  segs_allocated bit (1) init ("0"b);		/* Set after work segments created */
dcl  (urp_sw, eurc_sw, dau_sw) bit (1) init ("0"b);
dcl  from_time fixed bin (71);			/* Time specified on -from */
dcl  to_time fixed bin (71);				/* Time specified on -to */
dcl  for_time fixed bin (71);				/* Time specified on -for */
dcl  count_limit fixed bin init (0);			/* Results for -limit arg */
dcl  day_limit fixed bin init (0);			/* Results for -day_limit arg */
dcl  workp ptr;					/* Pointer to work segment */
dcl  arg_no fixed bin init (1);			/* For scanning argument list */
dcl  msg_time fixed bin (71);				/* Time of syserrmessage */
dcl  msg_seq fixed bin (35);				/* Sequence number */
dcl  mpc_cnt fixed bin init (0);			/* Number of MPCs requested */
dcl  temp fixed bin;

dcl  output_iocbp ptr;				/* pointer to the output iocb */
dcl  of_path char (168);				/* path name used for output file */
dcl  attach_desc char (180);				/* variable used to build description used
						   for output file when attached */

dcl  1 work aligned based (workp),			/* Declaration of work segment */
       2 mpcreq (32) char (4),			/* Table of requested MPCs */
       2 stats_block (32, size (stats_data)) bit (36),	/* stats for each mpc */
       2 buffer (500) bit (36) aligned;			/* Syserr messages are read here */



dcl  1 stats_data aligned based (stats_block_ptr),
       2 version fixed bin,
       2 name char (4),				/* Name of MPC */
       2 model fixed bin,
       2 firmware_rev char (2),			/* Firmware revision */
						/* *old* MSP, MTP and URP specific data */
       2 config_sw bit (16),				/* Configuration switches */
       2 polled_stat_counters (12) fixed bin,		/* LA-PSI  error counters */
       2 interrupt_counter fixed bin (35),		/* the error interrupt counter */
       2 register bit (16),				/* the MPC's error data register */
       2 AUXAR bit (16),				/* the auxilliary mpc addr at time of last error */
       2 INTAR bit (16),				/* thar addr at which the error occurred */
						/* EURC Specific data */
       2 eurc_specifics,
         3 uptime_clock fixed bin (32) uns,
         3 prom_revision,
	 4 core bit (8),
	 4 iom bit (8),
	 4 special_controller bit (8),
	 4 link_edit bit (8),
	 4 pdsi_application bit (8),
	 4 self_test bit (8),
	 4 dai_application bit (8),			/* DAU specific data */
       2 hw_rev bit (8) unal,				/* DAU Revision */
       2 config unal,
         3 ci_0_online bit (1),
         3 ci_1_online bit (1),
         3 psi0_2trip bit (1),			/* 0= 4trip, 1= 2trip */
         3 psi1_2trip bit (1),
         3 psi2_2trip bit (1),
         3 psi3_2trip bit (1),
       2 err_interrupts fixed bin (35),
       2 err_info (72) bit (8) unal,
       2 psi_cntr (20) fixed bin (35),			/* Misc. data */
       2 the_mtp_sw bit (1),
       2 the_msp_sw bit (1),
       2 the_urp_sw bit (1),
       2 the_eurc_sw bit (1),
       2 the_dau_sw bit (1),
       2 type_other fixed bin,			/* = 0 device stats stored by device number,
						   = 1 device stats stored by ca number and port number
						   = 2 device stats stored by ca number, port number
						   and logical device */
       2 entries_found fixed bin,			/* number of syserr_log entries */
       2 first_time fixed bin (71) unaligned,		/* time fo the first syserr_log entry found fo this mpc */
       2 last_time fixed bin (71) unaligned,		/* time of the last syserr_log entry found for this mpc */
       2 dev_stat (0:3, 0:16, 0:1) like dev_stat,		/* array for disk with removable device number
						   indexed by ca and port */
       2 end_of_status_data fixed bin;


dcl  1 my_dev_info (my_n_devices) like dev_info based (my_dev_ptr);
dcl  1 my_stat_info (my_n_stats) like stat_info based (my_stat_ptr);

dcl  (my_n_devices, my_n_stats) fixed bin;
dcl  (my_dev_ptr, my_stat_ptr) ptr;
dcl  stats_block_ptr ptr;				/* pointers used to optmize arrays */
dcl  (F_TIME, L_TIME) char (24);

/* entrys for syserr_log */

dcl  syserr_log_util_$open entry (bit (36) aligned, fixed bin (35));
dcl  print_syserr_msg_$open_err entry (bit (36) aligned, char (*), fixed bin (35));
dcl  syserr_log_util_$read entry (ptr, fixed bin, fixed bin, fixed bin (35));
dcl  syserr_log_util_$close entry (fixed bin (35));
dcl  syserr_log_util_$search entry (fixed bin (71), fixed bin (71), fixed bin (35), fixed bin (35));

/* io type entrys */

dcl  ioa_$ioa_switch entry options (variable);
dcl  iox_$attach_ioname entry (char (*), ptr, char (*), fixed bin (35));
dcl  iox_$open entry (ptr, fixed bin, bit (1) aligned, fixed bin (35));
dcl  iox_$close entry (ptr, fixed bin (35));
dcl  iox_$detach_iocb entry (ptr, fixed bin (35));
dcl  iox_$user_output ext ptr;

/* misc entries */

dcl  com_err_ entry options (variable);
dcl  get_temp_segments_ entry (char (*), dim (*) ptr, fixed bin (35));
dcl  release_temp_segments_ entry (char (*), dim (*) ptr, fixed bin (35));
dcl  date_time_ entry (fixed bin (71), char (*));
dcl  cu_$arg_list_ptr entry (ptr);
dcl  cu_$arg_count entry (fixed bin);
dcl  cu_$arg_ptr_rel entry (fixed bin, ptr, fixed bin, fixed bin (35), ptr);
dcl  convert_date_to_binary_ entry (char (*), fixed bin (71), fixed bin (35));
dcl  convert_date_to_binary_$relative entry (char (*), fixed bin (71), fixed bin (71), fixed bin (35));
dcl  print_mpc_summary entry (ptr, ptr, bit (1), bit (1));
dcl  print_mpc_summary$display_mpc_ entry (ptr, ptr, bit (1), bit (1));
dcl  display_mpc_data_ entry (ptr, ptr, bit (1));
dcl  get_line_length_$switch entry (ptr, fixed bin (35)) returns (fixed bin);

/* error_table_ */

dcl  error_table_$end_of_info ext fixed bin (35);
dcl  error_table_$badopt ext fixed bin (35);

dcl  cleanup condition;

dcl  (addr, hbound, low, mod, null, rtrim, size, substr, unspec) builtin;

/* Initialization */

	on cleanup call clean_up;
	output_iocbp = iox_$user_output;
	call get_temp_segments_ (name, ptr_array, code);	/* Get a work segment */
	if code ^= 0 then do;
	     call com_err_ (code, name, "Can't get temp segment");
	     go to done;
	     end;
	segs_allocated = "1"b;			/* Remember that they are allocated */
	workp = ptr_array (1);			/* Copy pointer to my segment */

	stats_block (*, *) = ""b;			/* zero status area */

	call cu_$arg_list_ptr (arg_list_ptr);		/* Need pointer to argument list */
	call cu_$arg_count (arg_count);		/* And the length */
	more_args = (arg_count > 0);			/* Set if args to scan */
	call scan_args;				/* Scan the argument list */

	if mpc_cnt = 0 then all_mpcs = "1"b;


	if output_file then do;
	     if short_arg
	     then short_display_sw = "1"b;
	     else short_display_sw = "0"b;
	     attach_desc = "vfile_ " || rtrim (of_path);
	     if ext_file then attach_desc = rtrim (attach_desc) || " -extend";
	     call iox_$attach_ioname ("mpc_sum_sw", output_iocbp, attach_desc, code);
	     if code ^= 0 then do;
		call com_err_ (code, name, "attaching ^a", rtrim (of_path));
		goto done;
		end;
	     of_file_att = "1"b;
	     call iox_$open (output_iocbp, 2, "0"b, code);/* open for stream output */
	     if code ^= 0 then do;
		call com_err_ (code, name, "opening ^a", rtrim (of_path));
		goto done;
		end;
	     of_file_open = "1"b;
	     end;
	temp = get_line_length_$switch (output_iocbp, code);
	if ^short_arg then do;
	     if code ^= 0 | temp > 80
	     then short_display_sw = "0"b;
	     else short_display_sw = "1"b;
	     end;
	else short_display_sw = "1"b;
	if code ^= 0 | output_file
	then top_of_page_req = "1"b;
	else top_of_page_req = "0"b;


	call syserr_log_util_$open (open_status, code);	/* Open the syserr log */
	if code ^= 0 | substr (open_status, 1, 2) ^= "11"b then do;
						/* If error */
	     call print_syserr_msg_$open_err (open_status, name, code);
	     if code ^= 0 then go to done;		/* Not recoverable */
	     end;

	if ^from_sw then do;			/* No -from, so start at beginning */
	     call syserr_log_util_$search (0, msg_time, msg_seq, code);
	     if code ^= 0 then do;
		call com_err_ (code, name, "Can't find first message in log.");
		go to done;
		end;
	     from_time = msg_time;			/* Official starting time */
	     end;
	else do;					/* -from used, find rightmessage */
	     call syserr_log_util_$search (from_time, msg_time, msg_seq, code);
	     if code ^= 0 then do;
		call com_err_ (code, name, "Locating first message requested.");
		go to done;
		end;
	     end;

	if for_sw then do;				/* Now can compute -for limit */
	     call convert_date_to_binary_$relative (for_arg, to_time, from_time, code);
	     if code ^= 0 then do;
		call com_err_ (code, name, "-for ^a", for_arg);
		go to done;
		end;
	     to_sw = "1"b;				/* Now, just as if -to was specified */
	     end;
	if ^to_sw then to_time = from_time;		/* Initialize lastmessage time */

	syserr_msgp = addr (work.buffer);		/* Read here */

/* Loop thru the file */

loop:
	call syserr_log_util_$read (syserr_msgp, hbound (buffer, 1), (0), code);
	if code ^= 0 then do;
	     if code = error_table_$end_of_info then go to print;
	     call com_err_ (code, name, "Reading syserr log");
	     go to done;
	     end;

	if to_sw then do;				/* If time limit */
	     if syserr_msg.time > to_time then go to print;
	     end;
	else to_time = syserr_msg.time;		/* Save lastmessage time */

	if syserr_msg.data_code = SB_mpc_poll & syserr_msg.data_size > 0 then do;
	     poll_mpc_datap = addr (syserr_msg.data);
	     if look_for (poll_mpc_data.name, stats_block_ptr) then call count_it;
	     end;

	go to loop;

/* End of log reached */

print:
	call print_it;				/* Print results */

/* End of command */

done:
	call clean_up;
	return;




count_it:
     proc;

/* This proc will take the syserr entry in poll_mpc_data format and
   expand it to the stats_data so that the tracking by ca,port,logical */

dcl  (i, st, logical, ca_num, port_num, st_inx) fixed bin;

	if poll_mpc_data.version ^= poll_mpc_data_version_2 then do;
						/* wrong version? */
	     if ^bf_sw
	     then call com_err_ (0, name, "Syserr#^d contains a non-supported version of ^d, message skipped.",
		     syserr_msg.seq_num, poll_mpc_data.version);
	     return;
	     end;
	poll_mpc_specp = addr (poll_mpc_data.specific);
	if stats_data.first_time = 0 then do;
	     stats_data.version = poll_mpc_data.version;
	     stats_data.name = poll_mpc_data.name;
	     stats_data.model = poll_mpc_data.model;
	     stats_data.first_time = syserr_msg.time;

	     if substr (stats_data.name, 1, 3) = "urp" then do;
		stats_data.the_urp_sw = "1"b;
		stats_data.firmware_rev = "";
		do i = 1 to hbound (eurc_model_numbers, 1) while (stats_data.the_eurc_sw = "0"b);
		     if stats_data.model = eurc_model_numbers (i) then stats_data.the_eurc_sw = "1"b;
		end;
		end;
	     else if substr (stats_data.name, 1, 3) = "mtp" then do;
		stats_data.the_mtp_sw = "1"b;
		stats_data.firmware_rev = poll_mtp_data.firmware_rev;
		end;
	     else if substr (stats_data.name, 1, 3) = "msp" then do;
		stats_data.the_msp_sw = "1"b;
		if stats_data.model = 800 then do;
		     stats_data.the_dau_sw = "1"b;
		     stats_data.firmware_rev = poll_dau_data.fw_rev;
		     end;
		else stats_data.firmware_rev = poll_msp_data.firmware_rev;
		end;
	     end;
	stats_data.entries_found = stats_data.entries_found + 1;
	stats_data.last_time = syserr_msg.time;

	if expand_sw then call expand_syserr_entry;	/* user wants each entry expanded */

	urp_sw = stats_data.the_urp_sw;
	eurc_sw = stats_data.the_eurc_sw;
	dau_sw = stats_data.the_dau_sw;

	if ^urp_sw & ^dau_sw
	then					/* URC & EURC dont have any */
	     do i = 1 to 12;
	     stats_data.polled_stat_counters (i) =
		stats_data.polled_stat_counters (i) + poll_mtp_data.polled_stat_counters (i);
	end;

	else if dau_sw
	then do i = 1 to 20;
	     stats_data.psi_cntr (i) = stats_data.psi_cntr (i) + poll_dau_data.psi_cntr (i);
	end;

	if ^eurc_sw & ^dau_sw & poll_mtp_data.register ^= "0"b then do;
						/* any error bits on? */
	     if stats_data.the_mtp_sw then do;
		stats_data.interrupt_counter = stats_data.interrupt_counter + poll_mtp_data.interrupt_counter;
		stats_data.register = stats_data.register | poll_mtp_data.register;
		stats_data.AUXAR = poll_mtp_data.AUXAR;
		stats_data.INTAR = poll_mtp_data.INTAR;
		end;
	     else if stats_data.the_msp_sw then do;
		stats_data.interrupt_counter = stats_data.interrupt_counter + poll_msp_data.interrupt_counter;
		stats_data.register = stats_data.register | poll_msp_data.register;
		stats_data.AUXAR = poll_msp_data.AUXAR;
		stats_data.INTAR = poll_msp_data.INTAR;
		end;
	     else if stats_data.the_urp_sw then do;
		stats_data.interrupt_counter = stats_data.interrupt_counter + poll_urp_data.interrupt_counter;
		stats_data.register = stats_data.register | poll_urp_data.register;
		stats_data.INTAR = poll_urp_data.INTAR;
		end;
	     end;

	if eurc_sw then do;
	     stats_data.uptime_clock = poll_eurc_data.uptime_clock + stats_data.uptime_clock;
	     stats_data.core = poll_eurc_data.core;
	     stats_data.iom = poll_eurc_data.iom;
	     stats_data.special_controller = poll_eurc_data.special_controller;
	     stats_data.link_edit = poll_eurc_data.link_edit;
	     stats_data.pdsi_application = poll_eurc_data.pdsi_application;
	     stats_data.self_test = poll_eurc_data.self_test;
	     stats_data.dai_application = poll_eurc_data.dai_application;
	     end;

	else if dau_sw then do;
	     stats_data.hw_rev = poll_dau_data.hw_rev;
	     stats_data.config = poll_dau_data.config;
	     if poll_dau_data.ext_size ^= 0 then stats_data.err_info (*) = poll_dau_data.err_info;
	     stats_data.err_interrupts = stats_data.err_interrupts + poll_dau_data.err_interrupts;
	     end;

	if mpc_only | urp_sw then return;		/* all done? */

	if eurc_sw then do;
	     my_n_devices = poll_eurc_data.n_devices;
	     my_dev_ptr = addr (poll_eurc_data.dev_info);
	     my_n_stats = poll_eurc_data.n_stats;
	     my_stat_ptr = addr (poll_eurc_data.stat_info);
	     end;


	else if dau_sw then do;
	     my_n_devices = poll_dau_data.n_devices;
	     my_dev_ptr = addr (poll_dau_data.dev_info);
	     my_n_stats = poll_dau_data.n_stats;
	     my_stat_ptr = addr (poll_dau_data.stat_info);
	     end;

	else if stats_data.the_mtp_sw | stats_data.the_msp_sw then do;
	     my_n_devices = poll_mtp_data.n_devices;
	     my_dev_ptr = addr (poll_mtp_data.dev_info);
	     my_n_stats = poll_mtp_data.n_stats;
	     my_stat_ptr = addr (poll_mtp_data.stat_info);
	     end;

	do st = 1 to my_n_stats;
	     stat_info_ptr = addr (my_stat_info (st));
	     dev_info_ptr = addr (my_dev_info (stat_info.dev_index));

/* MPC can return a device number but not if opi is down, then data is invalid */

	     if ^dev_info.opi
	     then if ^eurc_sw then goto skip_dev_no_opi;
	     port_num = dev_info.driveno;		/* setup as if type_other = 0 */
	     ca_num = 0;
	     logical = 0;				/* now see what type is is */
	     if stats_data.the_msp_sw then do;
		if substr (dev_info.dev_model, 4, 1) = "5"
		then if substr (dev_info.dev_model, 6, 1) ^= "9" then do;
			logical = mod (dev_info.driveno, 2);
			type_other = 2;
			end;
		     else ;
		else ;
		ca_num = dev_info.ca;
		port_num = dev_info.port;
		if stats_data.type_other < 1 then stats_data.type_other = 1;
		end;
	     if stats_data.the_mtp_sw & stats_data.model >= 610 then do;
		ca_num = dev_info.ca;
		port_num = dev_info.port;
		if stats_data.type_other < 1 then stats_data.type_other = 1;
		end;
	     dev_stat_ptr = addr (stats_data.dev_stat (ca_num, port_num, logical));
	     dev_stat.subsystem = dev_info.subsystem;
	     if dev_stat.driveno ^= dev_info.driveno then dev_stat.prev_driveno = dev_stat.driveno;
	     dev_stat.driveno = dev_info.driveno;
	     dev_stat.opi = dev_info.opi;
	     dev_stat.ca = dev_info.ca;
	     dev_stat.port = dev_info.port;
	     dev_stat.dev_model = dev_info.dev_model;
	     dev_stat.dev_name = substr (dev_info.dev_name, 1, 6);
	     st_inx = stat_info.stat_index;
	     dev_stat.value (st_inx) = dev_stat.value (st_inx) + stat_info.value;
skip_dev_no_opi:
	end;

     end count_it;


look_for:
     proc (mpc_name, stat_ptr) returns (bit (1));

/* This proc will return a bit = "1"b then we want to count this data */

dcl  mpc_name char (4) aligned;
dcl  stat_ptr ptr;
dcl  i;
look:
	do i = 1 to mpc_cnt;
	     if mpc_name = work.mpcreq (i) then do;
		stat_ptr = addr (work.stats_block (i, 1));
		return ("1"b);
		end;
	end;
	if all_mpcs then do;			/* count all we find */
	     mpc_cnt = mpc_cnt + 1;
	     work.mpcreq (mpc_cnt) = mpc_name;
	     stat_ptr = addr (work.stats_block (mpc_cnt, 1));
	     return ("1"b);
	     end;
	stat_ptr = null ();
	return ("0"b);
     end look_for;


/* Procedure to print results */

print_it:
     proc;
dcl  idx fixed bin;

	do idx = 1 to mpc_cnt;
	     stats_block_ptr = addr (stats_block (idx, 1));
	     if stats_data.entries_found ^= 0 then do;
		stats_data.end_of_status_data = 1;
		mpc_data_summaryp = ptr_array (2);
		call pack;			/* set up format for printing */
		call date_time_ ((stats_data.first_time), F_TIME);
		call date_time_ ((stats_data.last_time), L_TIME);
		if top_of_page_req
		then call ioa_$ioa_switch (output_iocbp, "^|");
		else call ioa_$ioa_switch (output_iocbp, "^2/");
		if short_display_sw
		then call ioa_$ioa_switch (output_iocbp,
			"^23x^d syserr_log entries for ^a^/^23xfrom: ^a^/^23x^2xto: ^a", stats_data.entries_found,
			stats_data.name, F_TIME, L_TIME);

		else call ioa_$ioa_switch (output_iocbp,
			"^47x^d syserr_log entries for ^a^/^47xfrom: ^a^/^47x^2xto: ^a", stats_data.entries_found,
			stats_data.name, F_TIME, L_TIME);
		if mpc_only
		then call print_mpc_summary$display_mpc_ (mpc_data_summaryp, output_iocbp, short_display_sw, bf_sw);
		else call print_mpc_summary (mpc_data_summaryp, output_iocbp, short_display_sw, bf_sw);
		end;

	     else do;
		call date_time_ (from_time, F_TIME);
		call date_time_ (to_time, L_TIME);
		if top_of_page_req
		then call ioa_$ioa_switch (output_iocbp, "^|");
		else call ioa_$ioa_switch (output_iocbp, "^2/");
		call ioa_$ioa_switch (output_iocbp,
		     "^[^23x^;^47x^]No syserr_log entries found for ^a^/^[^23x^;^47x^]from: ^a^/^[^25x^;^49x^]to: ^a",
		     short_display_sw, work.mpcreq (idx), short_display_sw, F_TIME, short_display_sw, L_TIME);
		end;
	end;


     end print_it;


pack:
     proc;

dcl  (logical, ca_num, port_num, m, n) fixed bin;
dcl  from_data char (80) based (from_ptr);
dcl  to_data char (80) based (to_ptr);
dcl  1 next_stat like dev_stat based (next_ptr);
dcl  (next_ptr, to_ptr, from_ptr) ptr;


	unspec (mpc_data_summary) = ""b;		/* zero area */
	mpc_data_summary.version = mpc_data_summary_version_2;
	mpc_data_summary.name = stats_data.name;
	mpc_data_summary.model = stats_data.model;
	mpc_data_summary.firmware_rev = stats_data.firmware_rev;
	mpc_data_summary.config_sw = stats_data.config_sw;
	mpc_data_summary.polled_stat_counters (*) = stats_data.polled_stat_counters (*);
	mpc_data_summary.interrupt_counter = stats_data.interrupt_counter;
	mpc_data_summary.register = stats_data.register;
	mpc_data_summary.AUXAR = stats_data.AUXAR;
	mpc_data_summary.INTAR = stats_data.INTAR;
	mpc_data_summary.uptime_clock = stats_data.uptime_clock;
	mpc_data_summary.prom_revision = stats_data.prom_revision;
	mpc_data_summary.hw_rev = stats_data.hw_rev;
	mpc_data_summary.config = stats_data.config;
	mpc_data_summary.err_interrupts = stats_data.err_interrupts;
	mpc_data_summary.psi_cntr (*) = stats_data.psi_cntr (*);
	mpc_data_summary.n_devices = 0;
	if mpc_only then return;
	do logical = 0 to 1;
	     do ca_num = 0 to 3;
		do port_num = 0 to 16;
		     dev_stat_ptr = addr (stats_data.dev_stat (ca_num, port_num, logical));
		     if dev_stat.subsystem ^= low (1) then call add_dev;
		end;
		if stats_data.type_other = 0 then return;
	     end;
	     if stats_data.type_other = 1 then return;
	end;
	return;


add_dev:
	proc;

	     mpc_data_summary.n_devices = mpc_data_summary.n_devices + 1;
	     dev_sum_ptr = addr (mpc_data_summary.dev_stat (mpc_data_summary.n_devices));
	     do m = 1 to mpc_data_summary.n_devices - 1;
		next_ptr = addr (mpc_data_summary.dev_stat (m));
		if dev_stat.driveno < next_stat.driveno then do;
		     do n = mpc_data_summary.n_devices by -1 to m + 1;
			from_ptr = addr (mpc_data_summary.dev_stat (n - 1));
			to_ptr = addr (mpc_data_summary.dev_stat (n));
			to_data = from_data;
		     end;
		     next_ptr -> to_data = dev_stat_ptr -> from_data;
		     return;
		     end;
	     end;
	     dev_sum_ptr -> to_data = dev_stat_ptr -> from_data;

	end add_dev;

     end pack;

/* expand each entry */

expand_syserr_entry:
     proc;
	call date_time_ ((stats_data.last_time), F_TIME);
	call ioa_$ioa_switch (output_iocbp, "Entry number ^d at ^a", stats_data.entries_found, F_TIME);


	call display_mpc_data_ (poll_mpc_datap, output_iocbp, short_display_sw);
     end expand_syserr_entry;


/* Cleanup handler */

clean_up:
     proc;

	call syserr_log_util_$close (code);
	if output_file then do;
	     if of_file_open then call iox_$close (output_iocbp, code);
	     if of_file_att then call iox_$detach_iocb (output_iocbp, code);
	     end;


	if segs_allocated then do;
	     segs_allocated = "0"b;
	     call release_temp_segments_ (name, ptr_array, code);
	     end;
	return;

     end clean_up;

/* Procedure to scan the argument list */
scan_args:
     proc;

	do while (more_args);			/* Do while things to look at */
	     call get_arg;

	     if substr (arg, 1, 1) ^= "-" then do;	/* assume MPC name */
new_mpc:
		if substr (arg, 1, 3) ^= "msp"
		then if substr (arg, 1, 3) ^= "mtp"
		     then if substr (arg, 1, 3) ^= "urp" then do;
			     call com_err_ (0, name, "Invalid mpc specified ""^a""", arg);
			     go to done;
			     end;
			else ;
		     else ;
		else ;

		do check_mpc = 1 to mpc_cnt;
		     if arg = work.mpcreq (check_mpc) then goto skip_mpc;
		end;

		mpc_cnt = mpc_cnt + 1;		/* Count MPC found */
		all_mpcs = "0"b;
		work.mpcreq (mpc_cnt) = arg;		/* Save name */
skip_mpc:
		if more_args then do;		/* If more to scan */
		     call get_arg;
		     if substr (arg, 1, 1) ^= "-" then do;
						/* Found another MPC */
			if mpc_cnt < hbound (work.mpcreq, 1)
			then go to new_mpc;
			else do;			/* Too many */
			     call com_err_ (0, name, "There were more than ^d MPCs specified.",
				hbound (work.mpcreq, 1));
			     go to done;
			     end;
			end;
		     else call put_arg;		/* Went too far, back up 1 */
		     end;
		end;

	     else if arg = "-from" | arg = "-fm" then do; /* Start time */
		from_sw = "1"b;
		call time_arg (from_time);
		end;

	     else if arg = "-to" then do;		/* Ending time */
		to_sw = "1"b;
		call time_arg (to_time);
		end;

	     else if arg = "-for" then do;		/* Time limit */
		for_sw = "1"b;
		call time_arg (for_time);		/* For syntax checking only */
		for_len = arg_len;			/* Save pointer to this argument */
		for_ptr = arg_ptr;
		end;

	     else if arg = "-short" then short_arg = "1"b;

	     else if arg = "-long" | arg = "-lg" then bf_sw = "0"b;

	     else if arg = "-bf" | arg = "-brief" then bf_sw = "1"b;

	     else if arg = "-expand" then expand_sw = "1"b;

	     else if arg = "-all" | arg = "-a" then all_mpcs = "1"b;

	     else if arg = "-of" | arg = "output_file" then do;
		if more_args then do;
		     call get_arg;

		     if substr (arg, 1, 1) ^= "-"
		     then of_path = arg;
		     else do;
			of_path = rtrim (name) || ".output";
			call put_arg;
			end;
		     end;
		else of_path = rtrim (name) || ".output";
		short_display_sw = "0"b;
		output_file = "1"b;
		end;

	     else if arg = "-ext" | arg = "-extend" then ext_file = "1"b;

	     else if arg = "-mpc" then mpc_only = "1"b;

	     else do;				/* Bad arg */
		call com_err_ (error_table_$badopt, name, "^a", arg);
		go to done;
		end;
	end;

	if to_sw & for_sw then do;			/* Conflict */
	     call com_err_ (0, name, "Conflicting arguments: -to and -for");
	     go to done;
	     end;
	if ext_file & ^output_file then do;
	     call com_err_ (0, name, "Arg error extent argument but no output_file ");
	     go to done;
	     end;


	return;

     end scan_args;

/* Procedure to return the next argument from command line */

get_arg:
     proc;

	call cu_$arg_ptr_rel (arg_no, arg_ptr, arg_len, code, arg_list_ptr);
	if code ^= 0 then do;			/* Should never happen */
	     call com_err_ (code, name, "Arg ^d", arg_no);
	     go to done;
	     end;
	arg_no = arg_no + 1;			/* For next call */
	more_args = (arg_no <= arg_count);
	return;

put_arg:
     entry;					/* Entry to return argument after scanning too far */
	arg_no = arg_no - 1;
	more_args = (arg_no <= arg_count);
	return;

     end get_arg;

/* Procedure to convert a time argument */

time_arg:
     proc (t);

dcl  t fixed bin (71);				/* The time to ouput */
dcl  arg_copy char (10) var;				/* Save copy of arg here */

	arg_copy = arg;
	if ^more_args then do;			/* Must be more */
	     call com_err_ (0, name, "Argument required after ^a.", arg_copy);
	     go to done;
	     end;
	call get_arg;
	call convert_date_to_binary_ (arg, t, code);
	if code ^= 0 then do;
	     call com_err_ (code, name, "^a ^a", arg_copy, arg);
	     go to done;
	     end;

	return;

     end time_arg;


%page;
%include syserr_message;
%page;
%include poll_mpc_data;
%page;
%include eurc_model_numbers;
%page;
%include syserr_binary_def;

     end mpc_data_summary;




		    patch_firmware.pl1              04/02/85  1110.7rew 04/02/85  1035.3      177822



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   * Copyright (c) 1972 by Massachusetts Institute of        *
   * Technology and Honeywell Information Systems, Inc.      *
   *                                                         *
   *********************************************************** */

/* format: style4,delnl,insnl,^ifthendo */

/*
   PATCH_FIRMWARE: Implements the patch_firmware and dump_firmware commands.
   These commands patch and dump the contents of segments containing firmware
   modules.

   Written July 1976 by Larry Johnson.
   Modified 84June by Art Beattie to deal with DAU firmware.
   Modified March 1985 by Paul Farley to fix minor bug with DAU checking (PBF).
*/

patch_firmware:
     proc;

/* Start here for patch_firmware command */

	name = "patch_firmware";
	patch = "1"b;
	go to start;

/* Start here for dump_firmware command */

dump_firmware:
     entry;

	name = "dump_firmware";
	patch = "0"b;

/* Command starts here */

start:
	call cu_$arg_list_ptr (arg_list_ptr);
	call cu_$arg_count (nargs);
	if nargs = 0
	then do;
	     if patch
	     then call ioa_ ("Usage: ^a path cs/rw addr(hex) word1(hex) ... wordn(hex)", name);
	     else call ioa_ ("Usage: ^a path cs/rw/size addr(hex) count(hex)", name);
	     return;
	end;

	on cleanup call clean_up;

	call scan_args;

	call find_fw;

	if size_sw
	then call print_size;
	else if patch
	then call patch_fw;
	else call dump_fw;

done:
	call clean_up;
	if patch_worked
	then call ioa_ ("Patch complete.");
	return;

/* Procedure to scan argument list */

scan_args:
     proc;

	arg_name = "Pathname";			/* Need path first */
	call get_arg;
	call expand_path_ (arg_ptr, arg_len, addr (dir), addr (ename), code);
	if code ^= 0
	then do;
	     call com_err_ (code, name, "^a", arg);
	     go to done;
	end;

	arg_name = "Memory type";
	call get_arg;
	if arg = "cs"
	then cs_sw = "1"b;
	else if arg = "rw"
	then cs_sw = "0"b;
	else if ^patch & arg = "size"
	then do;
	     size_sw = "1"b;
	     return;
	end;
	else do;
	     if patch
	     then call com_err_ (0, name, "Second arg must be cs or rw, not ^a.", arg);
	     else call com_err_ (0, name, "Second arg must be cs, rw, or size, not ^a.", arg);
	     go to done;
	end;

	arg_name = "Address";
	address = get_hex_arg ();

	if ^patch
	then do;
	     arg_name = "Word count";
	     count = get_hex_arg ();
	     if count < 1
	     then do;
		call com_err_ (0, name, "Invalid word count: ^a", arg);
		go to done;
	     end;
	end;
	else do;
	     count = nargs - arg_no + 1;
	     if count = 0
	     then do;
		call com_err_ (error_table_$noarg, name, "Patch data.");
		go to done;
	     end;
	     if count > 16
	     then do;
		call com_err_ (error_table_$too_many_args, name, "Patch data.");
		go to done;
	     end;
	     do i = 1 to count;
		data (i) = get_hex_arg ();
	     end;
	end;

	return;
     end scan_args;

/* Get next argument */

get_arg:
     proc;

	call cu_$arg_ptr_rel (arg_no, arg_ptr, arg_len, code, arg_list_ptr);
	if code ^= 0
	then do;
	     call com_err_ (code, name, "^a", arg_name);
	     go to done;
	end;
	arg_no = arg_no + 1;
	return;

     end get_arg;

get_hex_arg:
     proc returns (fixed bin (35));			/* Get next argument in hex */

dcl  (i, j) fixed bin;
dcl  v fixed bin (35);

	call get_arg;
	v = 0;
	do i = 1 to length (arg);
	     j = index ("0123456789abcdef", substr (arg, i, 1));
	     if j = 0
	     then do;				/* Try caps */
		j = index ("ABCDEF", substr (arg, i, 1));
		if j = 0
		then do;				/* Still not found */
		     call com_err_ (0, name, "Invalid hexadecimal number: ^a", arg);
		     go to done;
		end;
		j = j + 10;
	     end;
	     v = 16 * v + j - 1;
	     if v > 1111111111111111b
	     then do;				/* Too big */
		call com_err_ (0, name, "Hexadecimal number not in range 0-FFFF: ^a", arg);
		go to done;
	     end;
	end;
	return (v);

     end get_hex_arg;

/* Procedure to initiate the firmware segment and decode it */

find_fw:
     proc;

	call hcs_$initiate_count (dir, ename, "", bit_count, 0, seg_ptr, code);
	if seg_ptr = null
	then do;
	     call com_err_ (code, name, "^a>^a", dir, ename);
	     go to done;
	end;

	word_count = divide (bit_count, 36, 17, 0);

	if word_count ^> 10
	then do;
	     call com_err_ (0, name, "Segment too small to be firmware segment.");
	     go to done;
	end;
	if seg (word_count) ^= mpcbot
	then do;					/* Check magic word */
	     call com_err_ (0, name, "Last word of segment does not contain ^12.3b, which is is BCD for 'MPCBOT'.",
		mpcbot);
	     go to done;
	end;

	call gcos_cv_gebcd_ascii_ (addr (seg (word_count - 7)), 6, addr (fw_type));
	call gcos_cv_gebcd_ascii_ (addr (seg (word_count - 9)), 6, addr (fw_ident));
	call gcos_cv_gebcd_ascii_ (addr (seg (word_count - 6)), 4, addr (fw_name));
	call gcos_cv_gebcd_ascii_ (addr (seg (word_count - 8)), 6, addr (fw_rev));

	if fw_ident = "msp800"
	then do;					/* DAU firmware has to be handled differently. */
	     dau_sw = "1"b;
	     dau_factor = 2;
	     word_length = 8;
	     words_per_line = 16;
	end;
	else do;					/* Normal stuff */
	     dau_sw = "0"b;
	     dau_factor = 1;
	     word_length = 16;
	     words_per_line = 8;
	end;

/* Even if DAU firmware, need to have the following. */

	cs_start = 1;				/* Control store starts in beginning */
	rw_start = bin (substr (seg (word_count - 5), 1, 18), 18);
						/* RW start is hidden here */
	if rw_start = 0
	then do;					/* No rw overlay, probably itr */
	     cs_length = word_count - 10;		/* Whole seg is control store */
	     rw_length = 0;				/* This says no read write overlay */
	end;
	else do;
	     cs_length = rw_start;			/* Control store is everything before read/write */
	     rw_length = word_count - rw_start - 10;
	     rw_start = rw_start + 1;			/* Because array starts at 1 */
	end;

	if ((rw_length > 0) | substr (fw_type, 4) = "itr") & fw_type ^= "msp800"
	then					/* If itr, or common firmware but not DAU */
	     cs_low = 512;				/* Adjust control store start */
	else cs_low = 0;
	cs_high = cs_low + 2 * cs_length * dau_factor - 1;
	rw_low = 0;
	if rw_length > 0
	then rw_high = rw_low + 2 * rw_length * dau_factor - 1;
	else rw_high = 0;

	if size_sw
	then return;				/* If just printing size, no more analysis needed */

/* Now that memory overlays are isolated, be sure request is consistent */

	if dau_sw
	then do;
	     fw_low = cs_low;
	     fw_high = cs_high + rw_high + 1;
	     mem_name = "dau";
	end;

	else if cs_sw
	then do;					/* Working with control store */
	     fwp = addr (seg (cs_start));
	     fw_low = cs_low;
	     fw_high = cs_high;
	     mem_name = "control store";		/* In case error printed */
	end;
	else do;
	     if rw_start = 0
	     then do;				/* R/W overlay non-existant */
		call com_err_ (0, name, "No read/write overlay in segment.");
		go to done;
	     end;
	     fwp = addr (seg (rw_start));
	     fw_low = rw_low;
	     fw_high = rw_high;
	     mem_name = "read/write";
	end;

	if ^patch
	then addr_limit = fw_high;			/* Allow dump of entire module */
	else addr_limit = fw_high - 2 * dau_factor;	/* But don't allow patch of checksum word  */

	if address < fw_low | address > addr_limit
	then do;					/* Bad addr */
	     call com_err_ (0, name, "Starting address not in ^a memory. Range is ^.4b:^.4b", mem_name,
		bit (bin (fw_low, 16), 16), bit (bin (addr_limit, 16), 16));
	     go to done;
	end;
	if address + count - 1 > addr_limit
	then do;
	     call com_err_ (0, name, "Ending address not in ^a memory. Range is ^.4b:^.4b", mem_name,
		bit (bin (fw_low, 16), 16), bit (bin (addr_limit, 16), 16));
	     go to done;
	end;

	if dau_sw
	then do;

	     rw_low = cs_high + 1;
	     rw_high = rw_low + rw_high;
	     daup = addr (seg (1));
	     dau_low = 0;
	     dau_high = rw_high;

	     if patch
	     then do i = cs_high - 3 to cs_high;
		if i >= address & i <= address + count - 1
		then do;
		     call com_err_ (0, name, "Cannot patch checksum for part one of the DAU firmware; ^.4b:^.4b",
			bit (bin (cs_high - 3, 16), 16), bit (bin (cs_high, 16), 16));
		     go to done;
		end;
	     end;					/* check for patching checksum for lower part */
						/* This has to be done on both parts of DAU firmware. */
	     fw_low = 0;
	     fw_high = 2 * cs_length - 1;		/* Checksum is done using MPC word length (16 bits) */
	     fwp = addr (seg (1));
	     call compute_checksum;

	     if get_word (fw_high - 1) ^= checksum
	     then do;
		call com_err_ (0, name, "Checksum for lower part of DAU firmware is not correct.");
		go to done;
	     end;

	     fwp = addr (seg (rw_start));
	     fw_high = 2 * rw_length - 1;
	     call compute_checksum;

	     if get_word (fw_high - 1) ^= checksum
	     then do;
		call com_err_ (0, name, "Checksum for upper part of DAU firmware is not correct.");
		go to done;
	     end;
	end;					/* dau firmware checksum check */

	else do;
	     call compute_checksum;			/* Be sure checksum starts correct */
	     if get_word (fw_high - 1) ^= checksum
	     then do;
		call com_err_ (0, name, "Checksum for ^a is not correct.", mem_name);
		go to done;
	     end;
	end;					/* normal firmware checksum check */

	return;

     end find_fw;

/* Procedure that can get a DAU firmware word */

get_dau_word:
     proc (get_address) returns (bit (16));

dcl  get_address fixed bin;

	return (dau.byte (get_address) || "00"b4);

     end get_dau_word;


/* Procedure that can reconstruct a firmware word */

get_mpc_word:
     proc (get_address) returns (bit (16));

dcl  get_address fixed bin;

	return (fw.byte1 (get_address) || fw.byte2 (get_address));

     end get_mpc_word;


/* Procedure which can store a DAU firmware word */

put_dau_word:
     proc (address, new_word);

dcl  (address) fixed bin;
dcl  new_word bit (16);

	dau.byte (address) = substr (new_word, 1, 8);

     end put_dau_word;


/* Procedure which can store a mpc firmware word */

put_mpc_word:
     proc (address, new_word);

dcl  address fixed bin;
dcl  new_word bit (16);

	fw.byte1 (address) = substr (new_word, 1, 8);
	fw.byte2 (address) = substr (new_word, 9, 8);

     end put_mpc_word;


/* Procedure that can compute a checksum from a mpc memory image */

compute_checksum:
     proc;

dcl  sum fixed bin (35);
dcl  i fixed bin;

	get_word = get_mpc_word;
	sum = 0;
	do i = 0 to fw_high - 2;
	     sum = sum + bin (get_word (i), 16);
	     do while (sum > 1111111111111111b);
		sum = sum - 10000000000000000b;
		sum = sum + 1;
	     end;
	end;
	sum = -sum;
	checksum = substr (unspec (sum), 21);		/* Get last 16 bits */
	return;

     end compute_checksum;

/* Procedure to copy a firmware overlay as a character string for efficiency */

copy_fw:
     proc (from_ptr, to_ptr);

dcl  (from_ptr, to_ptr) ptr;
dcl  char_len fixed bin;
dcl  char_overlay char (char_len) based;

	char_len = 2 * (fw_high - fw_low + 1);
	to_ptr -> char_overlay = from_ptr -> char_overlay;
	return;

     end copy_fw;

/* Procedure that can dump firmware words */

dump_fw:
     proc;

dcl  buffer (words_per_line) bit (word_length) aligned;
dcl  nwords fixed bin;
dcl  based_buffer (nwords) bit (word_length) aligned based (addr (buffer));
dcl  i fixed bin;
dcl  dump_fw_display char (64);

	if dau_sw
	then do;
	     get_word = get_dau_word;
	     dump_fw_display = "^4.4b   ^(^2.4b ^)";
	end;
	else do;
	     get_word = get_mpc_word;
	     dump_fw_display = "^4.4b   ^(^4.4b ^)";
	end;

	do while (count > 0);
	     nwords = min (words_per_line, count);	/* Words this line */
	     do i = 1 to nwords;
		buffer (i) = get_word (address + i - 1);
	     end;
	     call ioa_ (dump_fw_display, bit (bin (address, 16), 16), based_buffer);
	     count = count - nwords;
	     address = address + nwords;
	end;
	return;

     end dump_fw;

/* Procedure to patch firmware */

patch_fw:
     proc;

dcl  (real_fwp, temp_fwp) ptr;
dcl  (i, patch_address) fixed bin;
dcl  new_dat bit (16);
dcl  answer char (3) var;
dcl  patch_data_display char (64);
dcl  dau_base fixed bin;
dcl  patch_checksum_display char (64);
dcl  ctrl_checksum_display fixed bin;

dcl  1 query_info aligned,
       2 version fixed bin init (2),
       2 yes_or_no bit (1) unal init ("1"b),
       2 suppress_name bit (1) unal init ("0"b),
       2 status_code fixed bin (35) init (0),
       2 query_code fixed bin (35) init (0);

	if dau_sw
	then do;
	     patch_data_display = "^4.4b  ^2.4b to ^2.4b";
	     get_word = get_dau_word;
	     put_word = put_dau_word;
	     if address < rw_low			/* patching either lower or upper but not both */
	     then do;
		fwp = addr (seg (1));
		fw_high = 2 * cs_length - 1;
		ctrl_checksum_display = 2;
		dau_base = 0;
	     end;
	     else do;
		fwp = addr (seg (rw_start));
		fw_high = 2 * rw_length - 3;
		ctrl_checksum_display = 3;
		dau_base = rw_low;
		address = address - dau_base;
	     end;
	end;
	else do;
	     patch_data_display = "^4.4b  ^4.4b to ^4.4b";
	     get_word = get_mpc_word;
	     put_word = put_mpc_word;
	     ctrl_checksum_display = 1;
	end;

	call get_temp_segments_ (name, ptr_array, code);	/* Get seg for temp copy */
	if code ^= 0
	then do;
	     call com_err_ (code, name, "Unable to allocate temp segment.");
	     go to done;
	end;
	temp_fwp = ptr_array (1);
	call copy_fw (fwp, temp_fwp);			/* Copy only the section of */
						/* firmware that will be changed */
	real_fwp = fwp;				/* Save pointer to old data */
	fwp = temp_fwp;				/* The "fw" structure now defines temp copy */
	daup = temp_fwp;
	patch_checksum_display = "^4.4b  ^4.4b to ^4.4b (^[^;lower ^;upper ^]checksum)";

	do i = 1 to count;				/* Print changes */
	     patch_address = address + i - 1;
	     if dau_sw
	     then new_dat = bit (bin (data (i), 8), 16);
	     else new_dat = bit (bin (data (i), 16), 16);
	     call ioa_ (patch_data_display, bit (bin (patch_address + dau_base, 16), 16), get_word (patch_address),
		new_dat);
	     call put_word (patch_address, new_dat);	/* This makes the patch */
	end;

	check_addr = fw_high - 1;
	call compute_checksum;			/* Get checksum for patched module */
	call ioa_ (patch_checksum_display, bit (bin (check_addr * dau_factor + dau_base, 16), 16),
	     get_mpc_word (check_addr), checksum, ctrl_checksum_display);
	call put_mpc_word (check_addr, checksum);

	call command_query_ (addr (query_info), answer, name, "Type yes if patches are correct -- ");
	if answer ^= "yes"
	then return;				/* Bad patch */
	call copy_fw (temp_fwp, real_fwp);		/* Replace firmware */
	fwp = real_fwp;
	call compute_checksum;			/* Recalculate checksum, just to be sure */
	if get_word (check_addr) ^= checksum
	then do;					/* Logically, this can't fail, but... */
	     call com_err_ (0, name, "Firmware patched incorrectly. ^a now has a bad checksum.", ename);
	     go to done;
	end;
	patch_worked = "1"b;
	return;

     end patch_fw;

/* Procedure to print sizes of memory overlays */

print_size:
     proc;

	call ioa_ ("Firmware type: ^a,^a ^a (^a)", fw_type, fw_ident, fw_name, fw_rev);
	if dau_sw					/* There are four bytes that cannot be used in the middle */
	then call print_size_subr ("DAU", cs_start, cs_length + rw_length, cs_low, cs_high + rw_high + 1 - 4);
	else do;
	     call print_size_subr ("Control store", cs_start, cs_length, cs_low, cs_high - 2);
	     call print_size_subr ("Read/write", rw_start, rw_length, rw_low, rw_high - 2);
	end;
	return;

     end print_size;

print_size_subr:
     proc (mem_nm, start, len, low_adr, up_adr);

dcl  mem_nm char (*);
dcl  (start, len, low_adr, up_adr) fixed bin;

	if len = 0
	then do;
	     call ioa_ ("No ^a overlay.", mem_nm);
	     return;
	end;

	call ioa_ ("^a overlay at ^a|^o for ^d Multics words, ^.4b MPC(hex) words (addresses ^.4b:^.4b).", mem_nm,
	     ename, start - 1, len, bit (bin (up_adr - low_adr + 1, 16), 16), bit (bin (low_adr, 16), 16),
	     bit (bin (up_adr, 16), 16));
	return;

     end print_size_subr;



/* Cleanup handler */

clean_up:
     proc;

	if seg_ptr ^= null
	then call hcs_$terminate_noname (seg_ptr, code);
	if ptr_array (1) ^= null
	then call release_temp_segments_ (name, ptr_array, code);
	return;

     end clean_up;

%page;
dcl  get_word entry (fixed bin) returns (bit (16)) variable;
dcl  put_word entry (fixed bin, bit (16)) variable;
dcl  name char (16);				/* Name called by */
dcl  code fixed bin (35);
dcl  arg_ptr ptr;
dcl  arg_len fixed bin;
dcl  arg char (arg_len) based (arg_ptr);
dcl  arg_list_ptr ptr;
dcl  nargs fixed bin;
dcl  patch bit (1);					/* 1 for patch, 0 for dump */
dcl  arg_no fixed bin init (1);
dcl  arg_name char (16);
dcl  data (16) fixed bin;
dcl  dau_factor fixed bin;				/* DAU addresses twice that of normal firmware */
dcl  word_length fixed bin;
dcl  words_per_line fixed bin;			/* for displaying memory */
dcl  cs_sw bit (1);					/* 1 for control store, 0 for read/write */
dcl  dau_sw bit (1) init ("0"b);			/* 1 for DAU firmware, 0 for everthing else */
dcl  address fixed bin;
dcl  dir char (168);
dcl  ename char (32);
dcl  i fixed bin;
dcl  count fixed bin;
dcl  cs_start fixed bin;				/* offset of cs in fw module in Multics words */
dcl  cs_length fixed bin;				/* length of cs in Multics words */
dcl  rw_start fixed bin;				/* offset of rw in fw module in Multics words */
dcl  rw_length fixed bin;				/* length of rw in Multics words */
dcl  word_count fixed bin;
dcl  bit_count fixed bin (24);
dcl  mem_name char (16);
dcl  seg_ptr ptr init (null);
dcl  (cs_low, cs_high) fixed bin;			/* Range of valid control store addresses */
dcl  (rw_low, rw_high) fixed bin;			/* Range of valid read/write addresses */
dcl  (dau_low, dau_high) fixed bin;			/* Range for current overlay in DAU words */
dcl  (fw_low, fw_high) fixed bin;			/* Range for current overlay in MPC words */
dcl  fw_type char (6);				/* Type of firmware, decoded from bcd */
dcl  fw_ident char (6);				/* Firmware ident field, decoded from bcd */
dcl  fw_name char (4);
dcl  fw_rev char (6);
dcl  daup ptr;
dcl  fwp ptr;
dcl  checksum bit (16);
dcl  check_addr fixed bin;				/* Address of the checksum word */
dcl  ptr_array (1) ptr init (null);
dcl  patch_worked bit (1) init ("0"b);
dcl  size_sw bit (1) init ("0"b);
dcl  addr_limit fixed bin;

dcl  mpcbot bit (36) aligned int static options (constant) init ("100100100111010011010010100110110011"b);
						/* Bcd for MPCBOT */

dcl  seg (word_count) bit (36) aligned based (seg_ptr);	/* Entire segment */

dcl  1 dau based (daup),
       2 dau_word (dau_low:dau_high) unal,
         3 fill bit (1),
         3 byte bit (8);

dcl  1 fw based (fwp),				/* A memory overlay */
       2 fw_word (fw_low:fw_high) unal,
         3 fill1 bit (1) unal,
         3 byte1 bit (8) unal,
         3 fill2 bit (1) unal,
         3 byte2 bit (8) unal;

dcl  cu_$arg_list_ptr entry (ptr);
dcl  cu_$arg_count entry (fixed bin);
dcl  cu_$arg_ptr_rel entry (fixed bin, ptr, fixed bin, fixed bin (35), ptr);
dcl  ioa_ entry options (variable);
dcl  com_err_ entry options (variable);
dcl  expand_path_ entry (ptr, fixed bin, ptr, ptr, fixed bin (35));
dcl  hcs_$initiate_count entry (char (*), char (*), char (*), fixed bin (24), fixed bin (2), ptr, fixed bin (35));
dcl  hcs_$terminate_noname entry (ptr, fixed bin (35));
dcl  get_temp_segments_ entry (char (*), dim (*) ptr, fixed bin (35));
dcl  release_temp_segments_ entry (char (*), dim (*) ptr, fixed bin (35));
dcl  command_query_ entry options (variable);
dcl  gcos_cv_gebcd_ascii_ entry (ptr, fixed bin, ptr);

dcl  error_table_$noarg ext fixed bin (35);
dcl  error_table_$too_many_args ext fixed bin (35);

dcl  cleanup condition;

dcl  (addr, bin, bit, divide, index, length, min, null, substr, unspec) builtin;

     end patch_firmware;




		    poll_mpc.pl1                    03/08/88  0941.7r w 03/08/88  0930.0      508104



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   * Copyright (c) 1972 by Massachusetts Institute of        *
   * Technology and Honeywell Information Systems, Inc.      *
   *                                                         *
   *********************************************************** */


/* POLL_MPC - Command to periodically poll mpc's and log the statistics they contain */
/* Written March 1980 by Larry Johnson */
/* Modified December 1980 by Rich Coppola to clear statistics block, and add
   mpc registers to logged data */
/* Modified May 1982 by Rich Coppola to add support for EURC */
/* Modified October 1982 by C. Hornig for new PRPH TAP card. */
/* Modified Dec. 1983 by Paul Farley to fix a problem with suspend/release
   tape controller interrupt processing when more than one physical connection
   is configured.
   Modified June 1984 by Paul Farley to fix a problem with the command_cleanup
   proc not exiting properly. Call programs char_mpc_ and stat_mpc_ with a ptr
   to the MPC image. Add support for the new MSP800 (DAU).
   Modified March 1985 by Paul Farley to double DAU config area for 64 devices
   and correct a bug in the blocked_too_long entry (PBF).
*/

/* format: style4,delnl,insnl,ifthenstmt,indnoniterend */
poll_mpc:
     proc;

/* Parameters */

dcl  arg_event_call_info_ptr ptr;

/* Automatic */

dcl  code fixed bin (35);
dcl  argp ptr;
dcl  argl fixed bin;
dcl  argno fixed bin;
dcl  n_args fixed bin;
dcl  more_args bit (1);
dcl  arg_list_ptr ptr;
dcl  output_file char (201);
dcl  i fixed bin;
dcl  mpc_cnt fixed bin;
dcl  mpc_list (32) char (4);
dcl  char8 char (8) aligned;
dcl  1 auto_mpc_data aligned like mpc_data automatic;
dcl  event_message fixed bin (71);
dcl  mpc_mem_bin (0:4095) bit (16) unal;		/* mpc mem converted to binary */
dcl  eurc_stats (0:83) bit (16) unal;			/* eurc stats converted to bin */
dcl  dau_data (0:759) bit (16) unal;			/* DAU config and stats */
dcl  special_status_flag bit (1) aligned;		/* on if special status valid			*/
dcl  special_status_word bit (36) aligned;
dcl  my_event_wait_list_ptr ptr;
dcl  1 my_event_wait_list aligned,
       2 n_channels fixed binary init (1),		/* number of channels in wait list */
       2 pad bit (36),
       2 channel_id (2) fixed binary (71);

/* Constants */

dcl  d451_stat_size fixed bin int static options (constant) init (512);
dcl  d600_stat_size fixed bin int static options (constant) init (1024);
dcl  tape_stat_size fixed bin int static options (constant) init (128);
dcl  mpc_memory_size fixed bin int static options (constant) init (4096);
dcl  name char (8) int static options (constant) init ("poll_mpc");
dcl  OPERATION (9) char (20) var int static options (constant)
	init ("Attaching", "Read R/W memory", "Suspending IO (IOI)", "Suspend MPC", "Clear Dev Stats", "Release MPC",
	"Releasing IO (IOI)", "Detaching", "Reading DAU");

/* Static */

dcl  CMD_EXIT label int static;
dcl  static_log_mpc_datap ptr int static init (null);
dcl  time_int fixed bin int static init (0);
dcl  (tape_sw, disk_sw, urp_sw, eurc_sw, dau_sw) bit (1) int static init ("0"b);
dcl  mpc_attached bit (1) int static init ("0"b);
dcl  stopped_io bit (1) int static init ("0"b);		/* This is set if IOI suspended io */
dcl  mtp_suspended bit (1) int static init ("0"b);	/* Set if the mpc accepted the 'suspend' command */
dcl  log_mpc_datap ptr int static init (null);
dcl  log_mpc_entryp ptr int static;
dcl  log_mpc_data_n_mpcs fixed bin int static;
dcl  workp ptr int static;
dcl  error_message char (128) var int static;
dcl  (time_sw, output_file_sw, debug_sw, log_sw, off_sw, on_sw, finish_sw) bit (1) int static;
dcl  OP fixed bin int static init (0);
dcl  ATTACH_MPC fixed bin int static init (1);
dcl  READ_MPC_MEM fixed bin int static init (2);
dcl  IOI_SUS_MTP fixed bin int static init (3);
dcl  SUS_MTP fixed bin int static init (4);
dcl  WRITE_MPC_MEM fixed bin int static init (5);
dcl  REL_MTP fixed bin int static init (6);
dcl  IOI_REL_MTP fixed bin int static init (7);
dcl  DETACH_MPC fixed bin int static init (8);
dcl  READ_DAU fixed bin int static init (9);
dcl  ATT_ERR fixed bin int static init (1);		/* Couldn' attach */
dcl  IOI_WRKSP fixed bin int static init (2);		/* Couldn't get ioi workspace */
dcl  IO_ERR fixed bin int static init (3);		/* IO err of some sort */
dcl  STAT_ERR fixed bin int static init (4);		/* error getting mpc stats */
dcl  IPC_ERR fixed bin int static init (5);		/* ^turn io ch to event call ch */
dcl  CONN_ERR fixed bin int static init (6);		/* Error on the connect */
dcl  SUS_ERR fixed bin int static init (7);		/* The MTP needs more than */
						/* just a detach */
						/* Based */

dcl  arg char (argl) based (argp);

dcl  1 log_mpc_data aligned based (log_mpc_datap),
       2 n_mpcs fixed bin,				/* Number of mpcs configured */
       2 index fixed bin,				/* Index to the one currently being polled */
       2 overrun_count fixed bin,			/* Consequtive polling cycles missed because previous one slow */
       2 timer_event fixed bin (71),			/* Event channel for driving polling */
       2 prev_cycle_start fixed bin (71),		/* Start of last round */
       2 prev_mpc_start fixed bin (71),			/* Start of current mpc */
       2 prev_cycle_end fixed bin (71),			/* Type previous cycle completed last mpc */
       2 next_cycle_sched fixed bin (71),		/* Time of next scheduled run */
       2 interval fixed bin (71),			/* Time (in microseconds) between scheduled runs */
       2 iocbp ptr,
       2 workp ptr,
       2 flags unal,
         3 debug bit (1),
         3 log bit (1),
         3 output_file bit (1),
         3 finish bit (1),
         3 io_in_progress bit (1),
         3 pad bit (31),
       2 attach_desc char (256) var,
       2 attach_data like attach_mpc_data,		/* For attaching current mpc */
       2 mpc_entry (log_mpc_data_n_mpcs refer (log_mpc_data.n_mpcs)) like log_mpc_entry;

dcl  1 log_mpc_entry aligned based (log_mpc_entryp),
       2 mpc_name char (4),
       2 times_dumped fixed bin (35),
       2 times_failed fixed bin (35),
       2 fail_count fixed bin,			/* Count of consecutive failures */
       2 alarm bit (1),				/* Alarm sensed for this MPC */
       2 prev_err_reg bit (16),			/* Last copy of the err data reg */
       2 prev_err_ctr fixed bin,			/* last count of the err int ctr */
       2 prev_stat_ctr_cnt fixed bin,			/* last count of the */
       2 on bit (1);

dcl  1 buf aligned based (workp),			/* The IOI buffer segment */
       2 idcw1 bit (36),				/* Will be read controller main memory */
       2 dcw1 bit (36),				/* Addr=buf.control, tally=1 */
       2 idcw2 bit (36),				/* Will be initiate read data transfer */
       2 dcw2 bit (36),				/* Address=buf.mem, tally=rest of segment */
       2 control,					/* Describes where data is in mpc */
         3 addr bit (16) unal,			/* Addr in mpc memory */
         3 tally bit (16) unal,			/* Count in mpc words */
         3 fill bit (4) unal,
       2 mem (0:mpc_memory_size - 1) bit (18) unal;	/* This is the mpc memory */

dcl  1 buf1 aligned based (workp),
       2 idcw1 bit (36),
       2 dcw1 bit (36),
       2 control,
         3 addr bit (16) unal,
         3 tally bit (16) unal,
         3 fill bit (16) unal,
       2 release_data bit (36) unal;

dcl  1 stat_buf aligned based (workp),			/* The IOI buffer segment */
       2 idcw1 bit (36),				/* Will be read controller main memory */
       2 dcw1 bit (36),				/* Addr=stat_buf.control, tally=1 */
       2 idcw2 bit (36),				/* Will be initiate read data transfer */
       2 dcw2 bit (36),				/* Address=stat_buf.mem, tally=rest of segment */
       2 control,					/* Describes where data is in mpc */
         3 addr bit (16) unal,			/* Addr in mpc memory */
         3 tally bit (16) unal,			/* Count in mpc words */
         3 fill bit (4) unal,
       2 stats (0:83) bit (18) unal;			/* EURC statistics in ASCII */

dcl  1 dau_buf aligned based (workp),			/* The IOI buffer segment */
       2 cf_idcw bit (36),				/* Read Configuration (24o) */
       2 cf_dcw bit (36),				/* Addr=dau_buf.data(0), tally=65 */
       2 st_idcw bit (36),				/* Read/Clear Statistics (16o) */
       2 st_dcw bit (36),				/* Address=dau_buf.data(130), tally=315 */
       2 data (0:759) bit (18) unal;			/* Config & statistics area */


/* External */

dcl  analyze_device_stat_$rsnnl entry (char (*) var, ptr, bit (72), bit (18));
dcl  config_$find entry (char (4) aligned, ptr);
dcl  com_err_ entry options (variable);
dcl  cu_$arg_count entry (fixed bin);
dcl  absolute_pathname_ entry (char (*), char (*), fixed bin (35));
dcl  cu_$arg_list_ptr entry (ptr);
dcl  cu_$arg_ptr_rel entry (fixed bin, ptr, fixed bin, fixed bin (35), ptr);
dcl  hcs_$wakeup entry (bit (*), fixed bin (71), fixed bin (71), fixed bin (35));
dcl  get_process_id_ entry () returns (bit (36));
dcl  convert_ipc_code_ entry (fixed bin (35));
dcl  (
     ioa_,
     ioa_$nnl
     ) entry options (variable);
dcl  ipc_$create_ev_chn entry (fixed bin (71), fixed bin (35));
dcl  ipc_$decl_ev_call_chn entry (fixed bin (71), ptr, ptr, fixed bin, fixed bin (35));
dcl  ipc_$decl_ev_wait_chn entry (fixed bin (71), fixed bin (35));
dcl  timer_manager_$reset_alarm_wakeup entry (fixed bin (71));
dcl  ipc_$drain_chn entry (fixed bin (71), fixed bin (35));
dcl  timer_manager_$alarm_wakeup entry (fixed bin (71), bit (2), fixed bin (71));
dcl  timer_manager_$reset_alarm_call entry (entry);
dcl  timer_manager_$alarm_call entry (fixed bin (71), bit (2), entry);
dcl  ipc_$delete_ev_chn entry (fixed bin (71), fixed bin (35));
dcl  ipc_$set_wait_prior entry (fixed bin (35));
dcl  ipc_$block entry (ptr, ptr, fixed bin (35));
dcl  attach_mpc_ entry (ptr, fixed bin (35));
dcl  detach_mpc_ entry (ptr, fixed bin (35));
dcl  decode_mpc_stats_$err_data_ entry (ptr, ptr);
dcl  ioi_$get_special_status entry (fixed bin, bit (1) aligned, bit (36) aligned, fixed bin (35));
dcl  ioi_$suspend_devices entry (fixed bin, fixed bin (35));
dcl  ioi_$release_devices entry (fixed bin, fixed bin (35));
dcl  ioi_$workspace entry (fixed bin, ptr, fixed bin (18), fixed bin (35));
dcl  ioi_$connect entry (fixed bin, fixed bin (18), fixed bin (35));
dcl  char_mpc_ entry (ptr, ptr);
dcl  stat_mpc_ entry (ptr, ptr, ptr, bit (1));
dcl  stat_mpc_$return_dau_data entry (ptr, ptr, ptr, fixed bin (35));
dcl  stat_mpc_$return_mpc_data entry (ptr, ptr, ptr, bit (1), fixed bin (35));
dcl  stat_mpc_$eurc entry (ptr, ptr, ptr, bit (1));
dcl  stat_mpc_$dau entry (ptr, ptr, ptr, bit (1));
dcl  iox_$attach_name entry (char (*), ptr, char (*), ptr, fixed bin (35));
dcl  iox_$open entry (ptr, fixed bin, bit (1) aligned, fixed bin (35));
dcl  iox_$close entry (ptr, fixed bin (35));
dcl  iox_$detach_iocb entry (ptr, fixed bin (35));
dcl  rcp_$detach entry (bit (36) aligned, bit (*), fixed bin, char (*), fixed bin (35));
dcl  hphcs_$syserr_binary entry options (variable);
dcl  hphcs_$syserr entry options (variable);
dcl  analyze_ioi_imess_ entry (ptr, ptr, char (*) var);
dcl  get_temp_segment_ entry (char (*), ptr, fixed bin (35));
dcl  release_temp_segment_ entry (char (*), ptr, fixed bin (35));

dcl  error_table_$too_many_args ext fixed bin (35);
dcl  error_table_$noarg ext fixed bin (35);
dcl  error_table_$badopt ext fixed bin (35);
dcl  error_table_$inconsistent ext fixed bin (35);
dcl  error_table_$unable_to_do_io fixed bin (35) ext static;

dcl  (cleanup, conversion) condition;

dcl  (addr, bin, bit, clock, codeptr, currentsize, hbound, null, rel, rtrim, size, substr, unspec, sum) builtin;
%page;
/* Command entry to setup the command */

	call cu_$arg_count (n_args);
	call cu_$arg_list_ptr (arg_list_ptr);
	argno = 1;
	more_args = (argno <= n_args);
	time_sw = "0"b;
	output_file_sw = "0"b;
	debug_sw = "0"b;
	log_sw = "0"b;
	off_sw = "0"b;
	on_sw = "0"b;
	finish_sw = "0"b;
	mpc_cnt = 0;
	mpc_list (*) = "";
	CMD_EXIT = done;				/* Set command_cleanup's return label. */


	do while (more_args);
	     call get_arg;
	     if substr (arg, 1, 1) ^= "-" then do;	/* Must be mpc name */
		if mpc_cnt >= hbound (mpc_list, 1) then do;
		     call com_err_ (error_table_$too_many_args, name, "More than ^d MPC's listed.",
			hbound (mpc_list, 1));
		     go to error_return;
		     end;
		mpc_cnt = mpc_cnt + 1;
		mpc_list (mpc_cnt) = arg;
		end;
	     else if arg = "-time" | arg = "-tm" then do;
		if ^more_args then do;
missing:
		     call com_err_ (error_table_$noarg, name, "After ^a.", arg);
		     go to error_return;
		     end;
		call get_arg;
		on conversion go to bad_time;
		time_int = bin (arg);
		revert conversion;
		if time_int <= 0 then do;
bad_time:
		     call com_err_ (0, name, "Invalid time specified: ^a", arg);
		     go to error_return;
		     end;
		time_sw = "1"b;
		end;
	     else if arg = "-output_file" | arg = "-of" then do;
		if ^more_args then go to missing;
		call get_arg;
		call absolute_pathname_ (arg, output_file, code);
		if code ^= 0 then do;
		     call com_err_ (code, name, "^a", arg);
		     go to error_return;
		     end;
		output_file_sw = "1"b;
		end;
	     else if arg = "-log" then log_sw = "1"b;
	     else if arg = "-stop" | arg = "-sp" then do;
		off_sw = "1"b;
		on_sw = "0"b;
		end;
	     else if arg = "-start" | arg = "-sr" then do;
		on_sw = "1"b;
		off_sw = "0"b;
		end;
	     else if arg = "-finish" then finish_sw = "1"b;
	     else if arg = "-debug" | arg = "-db" then debug_sw = "1"b;
	     else do;
		call com_err_ (error_table_$badopt, name, "^a", arg);
		go to error_return;
		end;
	end;
%page;
/* This code handles modifications to running polling */

	if static_log_mpc_datap ^= null () then do;
	     log_mpc_datap = static_log_mpc_datap;
	     if log_mpc_data.finish then do;
		call com_err_ (0, name, "Finish operation in progress.  Requests not accepted until it completes.");
		go to error_return;
		end;
	     if n_args = 0 then do;			/* Some argument required to adjust polling */
		call com_err_ (error_table_$noarg, name, "Polling already in progress.");
		go to error_return;
		end;
	     if time_sw then log_mpc_data.interval = 60 * 1000000 * time_int;
	     if debug_sw then log_mpc_data.debug = "1"b;
	     if output_file_sw then do;
		log_mpc_data.attach_desc = "vfile_ " || rtrim (output_file) || " -extend";
		log_mpc_data.output_file = "1"b;
		end;
	     if log_sw then log_mpc_data.log = "1"b;
	     if on_sw | off_sw | (mpc_cnt > 0) then do;
		if mpc_cnt > 0 then call validate_mpc_list;
		if ^(on_sw | off_sw) then on_sw = "1"b;
		do i = 1 to log_mpc_data.n_mpcs;
		     log_mpc_entryp = addr (log_mpc_data.mpc_entry (i));
		     if listed_mpc () then do;
			log_mpc_entry.on = on_sw;
			if on_sw then log_mpc_entry.fail_count = 0;
			if log_mpc_data.debug
			then call ioa_ ("^a: Polling ^[enabled^;disabled^] for MPC ^a.", name, on_sw,
				log_mpc_entry.mpc_name);
			end;
		end;
		end;
	     if finish_sw then do;
		call timer_manager_$reset_alarm_wakeup (log_mpc_data.timer_event);
		call ipc_$drain_chn (log_mpc_data.timer_event, code);
		char8 = "finish";
		unspec (event_message) = unspec (char8);
		call hcs_$wakeup (get_process_id_ (), log_mpc_data.timer_event, event_message, code);
		if code ^= 0 then do;
		     call convert_ipc_code_ (code);
		     call com_err_ (code, name, "Unable to send finish wakeup.");
		     end;
		log_mpc_data.finish = "1"b;
		end;
	     go to done;
	     end;
%page;
/* This code handles starting polling for the first time */

	if on_sw | off_sw | finish_sw then do;
	     call com_err_ (error_table_$inconsistent, name,
		"^/^-Args -start, -stop, -finish not permitted before polling started.");
	     go to error_return;
	     end;
	if ^(log_sw | output_file_sw) then log_sw = "1"b;

	on cleanup call command_cleanup;

	call setup_static_data;

	log_mpc_data.iocbp = null ();
	log_mpc_data.debug = debug_sw;

	if mpc_cnt > 0 then call validate_mpc_list;

	do i = 1 to log_mpc_data.n_mpcs;
	     log_mpc_entryp = addr (log_mpc_data.mpc_entry (i));
	     if listed_mpc () then do;
		log_mpc_entry.on = "1"b;
		log_mpc_entry.prev_err_reg = "0"b;
		log_mpc_entry.prev_err_ctr = 0;
		log_mpc_entry.prev_stat_ctr_cnt = 0;
		end;
	end;

	log_mpc_data.log = log_sw;
	if output_file_sw then do;
	     log_mpc_data.attach_desc = "vfile_ " || rtrim (output_file) || " -extend";
	     log_mpc_data.output_file = "1"b;
	     end;

	if ^time_sw then time_int = 15;
	log_mpc_data.interval = time_int * 60 * 1000000;

	call ipc_$create_ev_chn (log_mpc_data.timer_event, code);
	if code ^= 0 then do;
	     call convert_ipc_code_ (code);
	     call com_err_ (code, name, "Unable to create event channel.");
	     go to error_return;
	     end;
	call ipc_$decl_ev_call_chn (log_mpc_data.timer_event, codeptr (timer_wakeup), log_mpc_datap, 30, code);
						/* Priority = 30 appropriate in Initializer */
	if code ^= 0 then do;
	     call convert_ipc_code_ (code);
	     call com_err_ (code, name, "Unable to setup event call channel.");
	     go to error_return;
	     end;

	char8 = "start";
	unspec (event_message) = unspec (char8);
	log_mpc_data.next_cycle_sched = clock ();
	call hcs_$wakeup (get_process_id_ (), log_mpc_data.timer_event, event_message, code);
	if code ^= 0 then do;
	     call convert_ipc_code_ (code);
	     call com_err_ (code, name, "Unable to send first wakeup.");
	     go to error_return;
	     end;
	static_log_mpc_datap = log_mpc_datap;

done:
	return;

error_return:
	call command_cleanup;
	return;
%page;
/* Timer wakeup to start polling operation */

timer_wakeup:
     entry (arg_event_call_info_ptr);

	CMD_EXIT = done;				/* Set command_cleanup's return label. */
	on cleanup call command_cleanup;
	event_call_info_ptr = arg_event_call_info_ptr;
	log_mpc_datap = event_call_info.data_ptr;

	if log_mpc_datap ^= static_log_mpc_datap then return;
						/* Spurious */
	if event_call_info.channel_id ^= log_mpc_data.timer_event then return;
						/* Likewise */

	unspec (char8) = unspec (event_call_info.message);
	if log_mpc_data.debug then do;
	     call ioa_$nnl ("Timer wakeup: ^a. Processing:", char8);
	     do i = 1 to log_mpc_data.n_mpcs;
		log_mpc_entryp = addr (log_mpc_data.mpc_entry (i));
		if log_mpc_entry.on then call ioa_$nnl (" ^a", log_mpc_entry.mpc_name);
	     end;
	     call ioa_ ("");
	     end;

	if log_mpc_data.index ^= 0 then do;		/* Previous operation still in progress */
	     log_mpc_entryp = addr (log_mpc_data.mpc_entry (log_mpc_data.index));
	     call com_err_ (0, name, "Polling overrun. Previous cycle still in progress, processing ^a.",
		log_mpc_entry.mpc_name);
	     log_mpc_data.overrun_count = log_mpc_data.overrun_count + 1;
	     if log_mpc_data.overrun_count >= 3 then do;
		log_mpc_data.finish = "1"b;
		call com_err_ (0, name, "Polling abandoned. Too many polling overruns occured.");
		end;
	     end;
	else log_mpc_data.overrun_count = 0;		/* Keeping up ok */

	if ^log_mpc_data.finish then do;
	     log_mpc_data.next_cycle_sched = log_mpc_data.next_cycle_sched + log_mpc_data.interval;
	     do while (log_mpc_data.next_cycle_sched <= clock ());
		log_mpc_data.next_cycle_sched = log_mpc_data.next_cycle_sched + log_mpc_data.interval;
	     end;
	     call timer_manager_$alarm_wakeup (log_mpc_data.next_cycle_sched, "00"b, log_mpc_data.timer_event);
	     end;

	if log_mpc_data.index ^= 0 then return;

/* Attach output file if specified */

	if log_mpc_data.output_file then do;
	     call iox_$attach_name ("poll_mpc", log_mpc_data.iocbp, (log_mpc_data.attach_desc), null (), code);
	     if code ^= 0 then do;
		call com_err_ (code, name, "Unable to attach output file.");
		log_mpc_data.iocbp = null ();
		go to process_next_mpc;
		end;
	     call iox_$open (log_mpc_data.iocbp, Stream_output, "0"b, code);
	     if code ^= 0 then do;
		call com_err_ (code, name, "Unable to open output file.");
		call iox_$detach_iocb (log_mpc_data.iocbp, code);
		log_mpc_data.iocbp = null ();
		end;
	     end;

/* Find the next mpc to run */

process_next_mpc:
	i = log_mpc_data.index + 1;
	if i > log_mpc_data.n_mpcs then do;		/* Cycle complete */
	     log_mpc_data.prev_cycle_end = clock ();
	     log_mpc_data.index = 0;
	     if log_mpc_data.iocbp ^= null () then do;
		call iox_$close (log_mpc_data.iocbp, code);
		call iox_$detach_iocb (log_mpc_data.iocbp, code);
		log_mpc_data.iocbp = null ();
		end;
	     if log_mpc_data.finish then do;		/* This is last cycle */
		call ioa_ ("^a: Finished.", name);
		call ipc_$delete_ev_chn (log_mpc_data.timer_event, code);
		call command_cleanup;
		end;
	     return;
	     end;

	log_mpc_data.index = i;
	log_mpc_entryp = addr (log_mpc_data.mpc_entry (i));
	if ^log_mpc_entry.on then go to process_next_mpc;

/* Attach next mpc */

	log_mpc_data.prev_mpc_start = clock ();
	log_mpc_entry.times_dumped = log_mpc_entry.times_dumped + 1;
	attach_mpc_datap = addr (log_mpc_data.attach_data);
	unspec (attach_mpc_data) = "0"b;
	attach_mpc_data.version = attach_mpc_data_version_1;
	attach_mpc_data.mpc_name = log_mpc_entry.mpc_name;
	attach_mpc_data.caller_name = name;
	attach_mpc_data.report = "1"b;
	OP = ATTACH_MPC;
	call attach_mpc_ (attach_mpc_datap, code);

	if code ^= 0 then do;
	     call detach_and_count (ATT_ERR);
	     go to process_next_mpc;
	     end;

	mpc_attached = "1"b;			/* remember */

	if log_mpc_data.debug
	then call ioa_ ("^a: ^a ^a (^a)", name, OPERATION (OP), attach_mpc_data.mpc_name, attach_mpc_data.device_name);

/* When an entry is created in ioi_ to check the state of the suspend
   devices flag for an MPC, the following should be added to skip the
   MPC if the IO is suspended. This way poll_mpc will not hang!

   *	call ioi_$check_suspend_state (or whatever)
   *	     (attach_mpc_data.ioi_index, io_suspended, code);
   *	if io_suspended then do;
   *	     call detach_and_count (SUSPENDED_ERR);
   *	     goto process_next_mpc;
   *	end;
*/

	if substr (attach_mpc_data.mpc_name, 1, 3) = "urp" then do;
	     tape_sw, disk_sw, dau_sw = "0"b;
	     urp_sw = "1"b;
	     eurc_sw = "0"b;
	     do i = 1 to hbound (eurc_model_numbers, 1) while (eurc_sw = "0"b);
		if attach_mpc_data.model = eurc_model_numbers (i) then eurc_sw = "1"b;
	     end;
	     end;

	else if substr (attach_mpc_data.mpc_name, 1, 3) = "msp" then do;
	     disk_sw = "1"b;
	     urp_sw, eurc_sw, tape_sw, dau_sw = "0"b;
	     if attach_mpc_data.model = 800 then dau_sw = "1"b;
	     end;

	else if substr (attach_mpc_data.mpc_name, 1, 3) = "mtp" then do;
	     tape_sw = "1"b;
	     urp_sw, disk_sw, dau_sw, eurc_sw = "0"b;
	     end;

	call ioi_$workspace (attach_mpc_data.ioi_index, workp, size (buf), code);
	if code ^= 0 then do;
	     call com_err_ (code, name, "Unable to set workspace for ^a.", attach_mpc_data.mpc_name);
	     call detach_and_count (IOI_WRKSP);
	     go to process_next_mpc;
	     end;

	log_mpc_data.workp = workp;


	if dau_sw
	then OP = READ_DAU;
	else OP = READ_MPC_MEM;
	if eurc_sw then call build_eurc_idcw;
	else if dau_sw then call build_dau_idcw;
	else call build_idcw;
	call do_io (code);
	if code ^= 0 then goto process_next_mpc;
	return;					/* Return, allowing I/O to complete */


%page;

/* Wakup handler for I/O completion events */

io_wakeup:
     entry (arg_event_call_info_ptr);

	CMD_EXIT = done;				/* Set command_cleanup's return label. */
	on cleanup call command_cleanup;
	event_call_info_ptr = arg_event_call_info_ptr;
	log_mpc_datap = event_call_info.data_ptr;
	if log_mpc_datap ^= static_log_mpc_datap then return;
						/* Spurious */
	if ^log_mpc_data.io_in_progress then return;
	if log_mpc_data.index = 0 then return;
	log_mpc_entryp = addr (log_mpc_data.mpc_entry (log_mpc_data.index));
	attach_mpc_datap = addr (log_mpc_data.attach_data);
	if attach_mpc_data.ioi_channel ^= event_call_info.channel_id then return;

	log_mpc_data.io_in_progress = "0"b;

	workp = log_mpc_data.workp;
	imp = addr (event_call_info.message);


	if imess.er | (imess.level ^= "3"b3) then do;
	     call analyze_ioi_imess_ (imp, attach_mpc_data.status_tablep, error_message);
	     call com_err_ (0, name, "I/O error on ^a: ^a", log_mpc_entry.mpc_name, error_message);
	     if log_mpc_data.log
	     then call hphcs_$syserr (3, "poll_mpc: I/O error on ^a: ^a", log_mpc_entry.mpc_name, error_message);

	     call detach_and_count (IO_ERR);
	     go to process_next_mpc;
	     end;

	if OP = READ_DAU then do;

	     mpc_datap = addr (auto_mpc_data);		/* Setup for memory checking rtn */
	     mpc_data.type = attach_mpc_data.type;
	     mpc_data.model = attach_mpc_data.model;
	     mpc_data.name = attach_mpc_data.mpc_name;

	     do i = 0 to 759;
		substr (dau_data (i), 1, 8) = substr (dau_buf.data (i), 2, 8);
		substr (dau_data (i), 9, 8) = substr (dau_buf.data (i), 11, 8);
	     end;
	     call char_mpc_ (addr (dau_data (0)), mpc_datap);
	     if log_mpc_data.debug
	     then call ioa_ ("^a: Firmware rev ^a (HW rev ^2.4b hex) for ^a.", name, mpc_data.fw_rev, mpc_data.dau_rev,
		     attach_mpc_data.mpc_name);

	     if log_mpc_data.iocbp ^= null ()
	     then call stat_mpc_$dau (addr (dau_data (0)), log_mpc_data.iocbp, mpc_datap, "0"b);

	     if log_mpc_data.log then do;
		call get_temp_segment_ ("poll_mpc", poll_mpc_datap, code);
		poll_mpc_specp = addr (poll_mpc_data.specific);
		call stat_mpc_$return_dau_data (addr (dau_data (0)), poll_mpc_datap, mpc_datap, code);

		if code ^= 0 then do;
		     call com_err_ (code, name, "Unable to process statistics for ^a", log_mpc_entry.mpc_name);
		     call detach_and_count (STAT_ERR);
		     go to process_next_mpc;
		     end;

		if poll_dau_data.err_interrupts ^= 0 then call dau_err_alarm;
		if sum (poll_dau_data.psi_cntr) ^= 0 then call dau_stat_alarm;
		call hphcs_$syserr_binary (5, poll_mpc_datap, SB_mpc_poll, currentsize (poll_mpc_data),
		     "poll_mpc: Polled ^a.", log_mpc_entry.mpc_name);

		poll_mpc_specp = null ();
		call release_temp_segment_ ("poll_mpc", poll_mpc_datap, code);
		end;
	     end;

	else if OP = READ_MPC_MEM then do;

	     mpc_datap = addr (auto_mpc_data);		/* Setup for memory checking rtn */
	     mpc_data.type = attach_mpc_data.type;
	     mpc_data.model = attach_mpc_data.model;
	     mpc_data.name = attach_mpc_data.mpc_name;

	     if eurc_sw = "0"b
	     then do i = 0 to mpc_memory_size - 1;
		substr (mpc_mem_bin (i), 1, 8) = substr (buf.mem (i), 2, 8);
		substr (mpc_mem_bin (i), 9, 8) = substr (buf.mem (i), 11, 8);
	     end;

	     else if eurc_sw = "1"b
	     then do i = 0 to 83;			/* convert it to binary */
		substr (eurc_stats (i), 1, 8) = substr (stat_buf.stats (i), 2, 8);
		substr (eurc_stats (i), 9, 8) = substr (stat_buf.stats (i), 11, 8);
	     end;

	     call char_mpc_ (addr (mpc_mem_bin), mpc_datap);
	     if log_mpc_data.debug
	     then call ioa_ ("^a: Firmware rev ^a for ^a.", name, mpc_data.fw_rev, attach_mpc_data.mpc_name);

	     if log_mpc_data.iocbp ^= null () then do;
		if eurc_sw
		then call stat_mpc_$eurc (addr (eurc_stats), log_mpc_data.iocbp, mpc_datap, "0"b);
		else call stat_mpc_ (addr (mpc_mem_bin), log_mpc_data.iocbp, mpc_datap, "0"b);
		end;

	     if log_mpc_data.log then do;
		call get_temp_segment_ ("poll_mpc", poll_mpc_datap, code);
		poll_mpc_specp = addr (poll_mpc_data.specific);
		if eurc_sw
		then call stat_mpc_$return_mpc_data (addr (eurc_stats), poll_mpc_datap, mpc_datap, eurc_sw, code);
		else call stat_mpc_$return_mpc_data (addr (mpc_mem_bin), poll_mpc_datap, mpc_datap, eurc_sw, code);

		if code ^= 0 then do;
		     call com_err_ (code, name, "Unable to process statistics for ^a", log_mpc_entry.mpc_name);
		     call detach_and_count (STAT_ERR);
		     go to process_next_mpc;
		     end;

		if ^eurc_sw then do;		/* DISK or TAPE MPC, use same format */
		     if poll_mtp_data.register ^= "0"b then call mpc_reg_alarm;

		     if sum (poll_mtp_data.polled_stat_counters) ^= 0 then call mpc_stat_alarm;
		     end;
		call hphcs_$syserr_binary (5, poll_mpc_datap, SB_mpc_poll, currentsize (poll_mpc_data),
		     "poll_mpc: Polled ^a.", log_mpc_entry.mpc_name);

		poll_mpc_specp = null ();
		call release_temp_segment_ ("poll_mpc", poll_mpc_datap, code);
		end;
	     end;

	if log_mpc_data.log = "0"b then go to wakeup_end; /* thats it then */

	if (disk_sw & ^dau_sw)
	then if OP = READ_MPC_MEM then do;		/* now clear the dev stat block */
		OP = WRITE_MPC_MEM;			/* if we just read the rw mem */
		call build_idcw;
		call do_io (code);
		if code ^= 0 then go to process_next_mpc;
		return;
		end;

	if tape_sw then do;				/* special case the MTP */
	     call suspend_mtp (code);
	     if code ^= 0 then go to process_next_mpc;
	     end;

wakeup_end:
	call DETACH_MPC_;

	log_mpc_entry.fail_count = 0;

	go to process_next_mpc;


%page;

/* routine to return the tape mpc to use if the mpc does not respond to a connect for io */

blocked_too_long:
     entry;

	log_mpc_datap = static_log_mpc_datap;
	if ^log_mpc_data.io_in_progress then return;
	if log_mpc_data.index < 1 then return;
	log_mpc_entryp = addr (log_mpc_data.mpc_entry (log_mpc_data.index));
	attach_mpc_datap = addr (log_mpc_data.attach_data);
	CMD_EXIT = done;				/* Set command_cleanup's return label. */
	call release_tape_mpc (-1, 0);		/* ensure mpc gets released */
	call detach_and_count (SUS_ERR);
	go to process_next_mpc;



%page;
build_eurc_idcw:
     proc;

/* Build dcw list to get statistics from EURC MPC */

	idcwp = addr (stat_buf.idcw1);		/* First IDCW */
	stat_buf.idcw1 = "0"b;
	idcw.command = "31"b3;			/* Command is read Statistics */
	idcw.code = "111"b;				/* This makes it an IDCW */
	idcw.control = "10"b;			/* Set continue bit */
	idcw.chan_cmd = "41"b3;			/* Indicate special controller command */
	idcw.count = "15"b3;

	dcwp = addr (stat_buf.dcw1);
	stat_buf.dcw1 = "0"b;
	dcw.address = rel (addr (stat_buf.control));	/* Get offset to control word */
	dcw.tally = "000000000010"b;

	idcwp = addr (stat_buf.idcw2);		/* Second IDCW */
	stat_buf.idcw2 = "0"b;
	idcw.command = "06"b3;			/* Command is initiate read data transfer */
	idcw.code = "111"b;				/* Code is 111 to make it an idcw */
	idcw.chan_cmd = "40"b3;			/* Special controller command */

	dcwp = addr (stat_buf.dcw2);
	stat_buf.dcw2 = "0"b;
	dcw.address = rel (addr (stat_buf.stats));	/* Offset to core image */
	dcw.tally = "0052"b3;			/* It returns 42 words */
	return;

     end build_eurc_idcw;
%page;
build_dau_idcw:
     proc;

/* Build dcw list to get configuration and statistics from DAU MSP */

	idcwp = addr (dau_buf.cf_idcw);		/* First IDCW */
	dau_buf.cf_idcw = "0"b;
	idcw.command = "24"b3;			/* Command is read Configuration */
	idcw.code = "111"b;				/* IDCW */
	idcw.control = "10"b;			/* Set continue bit */
	idcw.chan_cmd = "30"b3;			/* Want list in dev# order */

	dcwp = addr (dau_buf.cf_dcw);
	dau_buf.cf_dcw = "0"b;
	dcw.address = rel (addr (dau_buf.data (0)));	/* Get offset to config data area */
	dcw.tally = "0101"b3;			/* 65 words */

	idcwp = addr (dau_buf.st_idcw);		/* Second IDCW */
	dau_buf.st_idcw = "0"b;
	idcw.command = "16"b3;			/* Command is read/clear statistics */
	idcw.code = "111"b;				/* IDCW */

	dcwp = addr (dau_buf.st_dcw);
	dau_buf.st_dcw = "0"b;
	dcw.address = rel (addr (dau_buf.data (130)));	/* Offset to statistic data area */
	dcw.tally = "0473"b3;			/* 315 words */
	return;

     end build_dau_idcw;
%page;
build_idcw:
     proc;

/* Build read or write (dev stat block) main memory dcw list */

	idcwp = addr (buf.idcw1);			/* First IDCW */
	buf.idcw1 = "0"b;

	if OP = READ_MPC_MEM
	then idcw.command = "02"b3;			/* Command is read controller main memory (ASCII) */
	else idcw.command = "32"b3;			/* Command is write main memory (binary) */

	idcw.code = "111"b;				/* This makes it an IDCW */
	idcw.control = "10"b;			/* Set continue bit */
	idcw.chan_cmd = "40"b3;			/* Indicate special controller command */
	dcwp = addr (buf.dcw1);
	buf.dcw1 = "0"b;
	dcw.address = rel (addr (buf.control));		/* Get offset to control word */
	dcw.tally = "000000000001"b;
	idcwp = addr (buf.idcw2);			/* Second IDCW */
	buf.idcw2 = "0"b;
	idcw.code = "111"b;				/* Code is 111 to make it an idcw */
	idcw.chan_cmd = "40"b3;			/* Special controller command */
	dcwp = addr (buf.dcw2);
	buf.dcw2 = "0"b;
	dcw.address = rel (addr (buf.mem));		/* Offset to core image */
	dcw.tally = bit (bin (size (buf) - bin (rel (addr (buf.mem)), 18), 12));
						/* Rest of seg */

	if OP = READ_MPC_MEM then do;
	     idcw.command = "06"b3;			/* Command is initiate read data transfer */
	     buf.addr = "0"b;			/* Mpc address to start is 0 */
	     buf.tally = bit (bin (mpc_memory_size, 16), 16);
	     end;

	else do;					/* Command will be write */
	     buf.mem (*) = "0"b;
	     idcw.command = "16"b3;			/* Command is initiate write  data transfer */
	     buf.addr = bit (bin (mpc_data.dev_stat_addr, 16), 16);
						/* Mpc address to start */

	     if disk_sw then do;
		if mpc_data.model < 600
		then buf.tally = bit (bin (d451_stat_size, 16), 16);

		else buf.tally = bit (bin (d600_stat_size, 16), 16);
		end;

	     else if tape_sw then buf.tally = bit (bin (tape_stat_size, 16), 16);
	     end;

	buf.fill = "0"b;

	return;

     end build_idcw;
%page;
build_sus_rel_idcw:
     proc;


	idcwp = addr (buf1.idcw1);			/* First IDCW */
	buf1.idcw1 = "0"b;
	if OP = SUS_MTP
	then idcw.command = "00"b3;			/* Command is suspend controller */
	else idcw.command = "20"b3;			/* Command is release controller */
	idcw.code = "111"b;				/* This makes it an IDCW */
	idcw.chan_cmd = "40"b3;			/* Indicate special controller command */

	dcwp = addr (buf1.dcw1);
	buf1.dcw1 = "0"b;
	dcw.address = rel (addr (buf1.control));	/* Get offset to control word */
	dcw.tally = "000000000000"b;

	return;

     end build_sus_rel_idcw;

%page;

/* Cleanup handler for command interface */

command_cleanup:
     proc;


	call DETACH_MPC_;				/* detach if attached */
	if static_log_mpc_datap ^= null then do;
	     attach_mpc_datap = addr (log_mpc_data.attach_data);
	     if attach_mpc_data.rcp_id ^= "0"b then call rcp_$detach (attach_mpc_data.rcp_id, "0"b, 0, "", code);
	     attach_mpc_data.rcp_id = "0"b;
	     if attach_mpc_data.ioi_channel ^= 0 then call ipc_$delete_ev_chn (attach_mpc_data.ioi_channel, code);
	     attach_mpc_data.ioi_channel = 0;
	     if log_mpc_datap ^= null then call ipc_$delete_ev_chn (log_mpc_data.timer_event, code);
	     end;

	mpc_attached = "0"b;
	log_mpc_data_n_mpcs = 0;
	static_log_mpc_datap = null ();
	if static_log_mpc_datap = null () & log_mpc_datap ^= null () then free log_mpc_data;

	goto CMD_EXIT;				/* EXIT program */
     end command_cleanup;

%page;

DETACH_MPC_:
     proc;
dcl  code fixed bin (35);
dcl  detach_count fixed bin;

	if ^mpc_attached then return;

	OP = DETACH_MPC;
	detach_count = 1;
DETACH:
	call detach_mpc_ (attach_mpc_datap, code);

	if code ^= 0 then do;
	     detach_count = detach_count + 1;
	     if detach_count < 4
	     then go to DETACH;

	     else do;

		call com_err_ (code, name, "Cannot detach MPC ^a,", attach_mpc_data.mpc_name);
		call command_cleanup;
		end;
	     end;

	mpc_attached = "0"b;

	if log_mpc_data.debug
	then call ioa_ ("^a: ^a ^a (^a)", name, OPERATION (OP), attach_mpc_data.mpc_name, attach_mpc_data.device_name);

	disk_sw, tape_sw, urp_sw, eurc_sw, dau_sw = "0"b;

	return;

     end DETACH_MPC_;

%page;
detach_and_count:
     proc (err_code);

dcl  err_code;

	log_mpc_entry.times_failed = log_mpc_entry.times_failed + 1;
	log_mpc_entry.fail_count = log_mpc_entry.fail_count + 1;
	if log_mpc_entry.fail_count >= 3 then do;
	     if ^log_mpc_data.finish
	     then call com_err_ (0, name, "Polling of ^a turned off because of too many consequtive failures.",
		     log_mpc_entry.mpc_name);
	     log_mpc_entry.on = "0"b;
	     end;

	if err_code ^= SUS_ERR
	then					/* special case these errors */
	     call DETACH_MPC_;
	return;

     end detach_and_count;

%page;

do_io:
     proc (acode);

dcl  (icode, acode) fixed bin (35);


	call ipc_$decl_ev_call_chn (attach_mpc_data.ioi_channel, codeptr (io_wakeup), log_mpc_datap, 30, icode);

	if icode ^= 0 then do;
	     call convert_ipc_code_ (icode);
	     call com_err_ (icode, name, "Unable to turn ioi channel into event call channel.");
	     call detach_and_count (IPC_ERR);
	     acode = icode;
	     return;
	     end;

	if log_mpc_data.debug
	then call ioa_ ("^a: Issuing Connect to ^a  for ^a (^a)", name, OPERATION (OP), attach_mpc_data.mpc_name,
		attach_mpc_data.device_name);

	call ioi_$connect (attach_mpc_data.ioi_index, 0, icode);

	if icode ^= 0 then do;
	     call com_err_ (icode, name, "Unable to issue connect to dump memory.");
	     call detach_and_count (CONN_ERR);
	     acode = icode;
	     return;
	     end;

	log_mpc_data.io_in_progress = "1"b;
	acode = 0;

	return;
     end do_io;
%page;

do_tape_io:
     proc (spec_sw, acode);

dcl  (acode, CODE) fixed bin (35);
dcl  spec_sw bit (1);				/* if ON need a SPECIAL			*/
dcl  1 auto_event_wait_info like event_wait_info;

	acode, CODE = 0;
	my_event_wait_list_ptr = addr (my_event_wait_list);
	event_wait_info_ptr = addr (auto_event_wait_info);
	my_event_wait_list.channel_id (1) = attach_mpc_data.ioi_channel;
	call ipc_$create_ev_chn (my_event_wait_list.channel_id (2), CODE);
	if CODE ^= 0 then goto common_ret;

	if log_mpc_data.debug
	then call ioa_ ("^a: Issuing Connect to ^a  for ^a (^a)", name, OPERATION (OP), attach_mpc_data.mpc_name,
		attach_mpc_data.device_name);

/* Do the io operation */

	call ipc_$decl_ev_wait_chn (attach_mpc_data.ioi_channel, CODE);
	if CODE ^= 0 then go to common_ret;

	call ipc_$set_wait_prior (CODE);
	if CODE ^= 0 then go to common_ret;

	call ipc_$drain_chn (attach_mpc_data.ioi_channel, CODE);
	if CODE ^= 0 then goto common_ret;

	call ioi_$connect (attach_mpc_data.ioi_index, 0, CODE);
	if CODE ^= 0 then go to common_ret;

	call timer_manager_$alarm_call (60, "11"b, blocked_too_long);

	call ipc_$block (my_event_wait_list_ptr, event_wait_info_ptr, CODE);
	call timer_manager_$reset_alarm_call (blocked_too_long);
	if CODE ^= 0 then go to common_ret;


	attach_mpc_datap = addr (log_mpc_data.attach_data);
	log_mpc_data.io_in_progress = "0"b;
	workp = log_mpc_data.workp;

	imp = addr (event_wait_info.message);		/* Status is here */
	if imess.time_out then do;
time_err:
	     error_message = "Timeout.";
	     goto err_mess;
	     end;

	if imess.er then do;			/* Error */
	     call analyze_device_stat_$rsnnl (error_message, attach_mpc_data.status_tablep, (imess.status), ("0"b));
err_mess:
	     CODE = error_table_$unable_to_do_io;
	     call com_err_ (CODE, name, "I/O error occured: ^a", error_message);
	     go to common_ret;
	     end;
	error_message = "terminate";
	if spec_sw then do;
	     if imess.level = "3"b3 then do;
		call terminate (CODE);
		if CODE ^= 0 then do;
		     if CODE = -1 then goto err_mess;
		     else if CODE = -2 then goto wrong_stat;
		     goto common_ret;
		     end;
		call drain (CODE);
		if CODE ^= 0 then do;
		     if CODE = -1
		     then goto time_err;
		     else goto common_ret;
		     end;
		call special (CODE);
		if CODE ^= 0 then do;
		     if CODE = -1 then goto err_mess;
		     else if CODE = -2 then goto wrong_stat;
		     goto common_ret;
		     end;
		end;
	     else if imess.level = "7"b3 then do;
		call special (CODE);
		if CODE ^= 0 then do;
		     if CODE = -1 then goto err_mess;
		     else if CODE = -2 then goto wrong_stat;
		     goto common_ret;
		     end;

spec_drain:
		call drain (CODE);
		if CODE ^= 0 then do;
		     if CODE = -1 then goto time_err;
		     goto common_ret;
		     end;
		if imess.level = "7"b3 then goto spec_drain;
						/* Controller has multiple connections. */
						/* Will ignore all other specials from the other channels. */
		call terminate (CODE);
		if CODE ^= 0 then do;
		     if CODE = -1 then goto err_mess;
		     else if CODE = -2 then goto wrong_stat;
		     goto common_ret;
		     end;
		end;
	     call ipc_$drain_chn (attach_mpc_data.ioi_channel, CODE);
						/* forget any extra specials. */
	     if CODE ^= 0 then goto common_ret;

	     end;

	if ^(spec_sw) & (imess.level ^= "3"b3) then goto wrong_stat;
	acode = 0;				/* went ok */

	return;

common_ret:
	acode = CODE;
	return;

wrong_stat:
	CODE = error_table_$unable_to_do_io;
	call com_err_ (CODE, name, "Unexpected level ^.3b status when ^a expected.", imess.level, error_message);
	go to common_ret;

     end do_tape_io;
%page;
drain:
     proc (acode);
dcl  acode fixed bin (35);

	acode = 0;
	call timer_manager_$reset_alarm_wakeup (my_event_wait_list.channel_id (2));
						/* Remove outstanding alarm */
	call ipc_$drain_chn (my_event_wait_list.channel_id (2), acode);
						/* Reset timer channel */
	if acode ^= 0 then return;
	call timer_manager_$alarm_wakeup (60, "11"b, my_event_wait_list.channel_id (2));
						/* Set 60 second timer */
	my_event_wait_list.n_channels = 2;		/* Waiting for i/o or timer event now */
	call ipc_$block (addr (my_event_wait_list), event_wait_info_ptr, acode);
						/* Wait for something to happen */
	if acode ^= 0 then return;
	if event_wait_info.channel_id = my_event_wait_list.channel_id (2) then do;
						/* If time out */
	     acode = -1;				/* caller knows what to do			*/
	     return;
	     end;
     end drain;
%page;
get_arg:
     proc;

	call cu_$arg_ptr_rel (argno, argp, argl, code, arg_list_ptr);
	if code ^= 0 then do;
	     call com_err_ (code, name, "Can't happen.");
	     go to error_return;
	     end;
	argno = argno + 1;
	more_args = (argno <= n_args);
	return;

put_arg:
     entry;

	argno = argno - 1;
	more_args = (argno <= n_args);
	return;

     end get_arg;
%page;


/* Function to return 1 if mpc was listed in command line.  If none were listed, 1 is returned for all mpc's */

listed_mpc:
     proc returns (bit (1));

dcl  i fixed bin;

	if mpc_cnt = 0 then return ("1"b);
	do i = 1 to mpc_cnt;
	     if log_mpc_entry.mpc_name = mpc_list (i) then return ("1"b);
	end;
	return ("0"b);

     end listed_mpc;

%page;

mpc_reg_alarm:
     proc;

dcl  (i, j, k, l) fixed bin init (0);
dcl  (hint, plural_sw) bit (1) init ("0"b);


	if log_mpc_entry.alarm then do;		/* It's happened before */
	     if (log_mpc_entry.prev_err_ctr = poll_mtp_data.interrupt_counter)
		& (log_mpc_entry.prev_err_reg = poll_mtp_data.register)
	     then return;				/* Same one */
	     if log_mpc_entry.prev_err_reg ^= poll_mtp_data.register then go to update_count;
						/* Update and notify the OPR */
	     if log_mpc_entry.prev_err_ctr ^= poll_mtp_data.interrupt_counter then do;
update_count:
		if poll_mtp_data.interrupt_counter > log_mpc_entry.prev_err_ctr
		then k = poll_mtp_data.interrupt_counter - log_mpc_entry.prev_err_ctr;
		else if poll_mtp_data.interrupt_counter < log_mpc_entry.prev_err_ctr
		then k = poll_mtp_data.interrupt_counter;

		go to send_alarm;
		end;

	     return;

	     end;

send_alarm:
	allocate mpc_stat_anal;
	if k = 0 then k = poll_mtp_data.interrupt_counter;
	if k > 1 then plural_sw = "1"b;
	log_mpc_entry.alarm = "1"b;
	log_mpc_entry.prev_err_reg = poll_mtp_data.register;
	log_mpc_entry.prev_err_ctr = poll_mtp_data.interrupt_counter;


	call decode_mpc_stats_$err_data_ (poll_mpc_datap, mpc_stat_analp);
	do i = 1 to mpc_stat_anal.num_interps;
	     if substr (mpc_stat_anal.message (i), 1, 1) = "" then return;
						/* spurious */

	     if substr (mpc_stat_anal.HINT (i), 1, 1) = " "
	     then hint = "0"b;
	     else hint = "1"b;

	     call hphcs_$syserr (3,
		"poll_mpc: MPC ^a has had ^d ^a error^[s^] since the last poll.^/^[^2-Suspect the ^a^/^]^2-Please inform your CSD representative."
		, log_mpc_entry.mpc_name, k, rtrim (mpc_stat_anal.message (i)), plural_sw, hint,
		rtrim (mpc_stat_anal.HINT (i)));

	end;

	return;
     end mpc_reg_alarm;

%page;

mpc_stat_alarm:
     proc;
dcl  k fixed bin;
dcl  plural_sw bit (1) init ("0"b);


	if log_mpc_entry.prev_stat_ctr_cnt = sum (poll_mtp_data.polled_stat_counters) then return;
						/* no change */

	if sum (poll_mtp_data.polled_stat_counters) = 0 then return;
						/* MPC booted or no errors ever */

	if sum (poll_mtp_data.polled_stat_counters) > log_mpc_entry.prev_stat_ctr_cnt then do;
						/*  an error has occurred */

	     k = (sum (poll_mtp_data.polled_stat_counters) - log_mpc_entry.prev_stat_ctr_cnt);
	     log_mpc_entry.prev_stat_ctr_cnt = sum (poll_mtp_data.polled_stat_counters);

	     if k > 1
	     then plural_sw = "1"b;
	     else plural_sw = "0"b;

	     call hphcs_$syserr (3,
		"poll_mpc: MPC ^a has had ^d PSI-LA error^[s^] since the last poll.^/^2-Please inform your CSD Representative."
		, log_mpc_entry.mpc_name, k, plural_sw);
	     end;

	return;
     end mpc_stat_alarm;

%page;

dau_err_alarm:
     proc;

dcl  (i, j, k, l) fixed bin init (0);

	if log_mpc_entry.alarm then do;		/* It's happened before */
	     if log_mpc_entry.prev_err_ctr = poll_dau_data.err_interrupts then return;
						/* Same one */
						/* Update and notify the OPR */
	     if poll_dau_data.err_interrupts > log_mpc_entry.prev_err_ctr
	     then k = poll_dau_data.err_interrupts - log_mpc_entry.prev_err_ctr;
	     else if poll_dau_data.err_interrupts < log_mpc_entry.prev_err_ctr then k = poll_dau_data.err_interrupts;

	     end;

	if k = 0 then k = poll_dau_data.err_interrupts;
	log_mpc_entry.alarm = "1"b;
	log_mpc_entry.prev_err_reg = ""b;		/* DAU doesn't have one */
	log_mpc_entry.prev_err_ctr = poll_dau_data.err_interrupts;

	call hphcs_$syserr (3,
	     "poll_mpc: DAU ^a has had ^d error^[s^] since the last poll.^/^2-Please inform your CSD representative.",
	     log_mpc_entry.mpc_name, k, (k > 1));

	return;
     end dau_err_alarm;

%page;

dau_stat_alarm:
     proc;
dcl  (k, err_sum) fixed bin;

	err_sum = sum (poll_dau_data.psi_cntr) - poll_dau_data.psi_cntr (13)
						/* PSI-0 IIW faults */
	     - poll_dau_data.psi_cntr (14)		/* PSI-1 IIW faults */
	     - poll_dau_data.psi_cntr (15)		/* PSI-2 IIW faults */
	     - poll_dau_data.psi_cntr (16);		/* PSI-3 IIW faults */
	if err_sum = 0 then return;			/* only IIW errors */
	if log_mpc_entry.prev_stat_ctr_cnt = err_sum then return;
						/* no change */

	if err_sum > log_mpc_entry.prev_stat_ctr_cnt then do;
						/*  an error has occurred */

	     k = err_sum - log_mpc_entry.prev_stat_ctr_cnt;
	     log_mpc_entry.prev_stat_ctr_cnt = err_sum;

	     call hphcs_$syserr (3,
		"poll_mpc: DAU ^a has had ^d PSI error^[s^] since the last poll.^/^2-Please inform your CSD Representative."
		, log_mpc_entry.mpc_name, k, (k > 1));
	     end;

	return;
     end dau_stat_alarm;

%page;

release_tape_mpc:
     proc (err_code, acode);
dcl  (err_code, rel_count) fixed bin;
dcl  (acode, code) fixed bin (35);

	code = acode;
	rel_count = 1;

	if err_code ^= 0
	then					/* let someone know there was an error */
	     call com_err_ (code, name, "There was an error while MPC ^a was suspended, release will be attempted.",
		attach_mpc_data.mpc_name);

	if mtp_suspended = "1"b then do;		/* Get MPC going again */
	     OP = REL_MTP;

	     if log_mpc_data.debug
	     then call ioa_ ("^a: ^a ^a (^a)", name, OPERATION (OP), attach_mpc_data.mpc_name,
		     attach_mpc_data.device_name);

RETRY_REL:
	     call build_sus_rel_idcw;
	     call do_tape_io ("1"b, code);

	     if code ^= 0 then do;
		rel_count = rel_count + 1;
		if rel_count < 4
		then go to RETRY_REL;

		else do;				/* we are in trouble */
		     call com_err_ (code, name, "Cannot release MPC ^a. Suggest reloading firmware.",
			attach_mpc_data.mpc_name);

/* Make an attempt to get IOI to release */

		     call ioi_$release_devices (attach_mpc_data.ioi_index, code);

		     call command_cleanup;		/*  and QUIT */
		     end;
		end;
	     end;

	mtp_suspended = "0"b;			/* Made it, the MPC itself is now free for io */

%page;

/* Now get IOI to allow IO on the mtp again */


	if stopped_io = "1"b then do;			/* Get IOI to allow io again */
	     OP = IOI_REL_MTP;

	     if log_mpc_data.debug
	     then call ioa_ ("^a: ^a ^a (^a)", name, OPERATION (OP), attach_mpc_data.mpc_name,
		     attach_mpc_data.device_name);

	     call ioi_$release_devices (attach_mpc_data.ioi_index, code);

	     if code ^= 0 then do;
		call com_err_ (code, name, "Call to ioi_$release_devices failed.");

/* we are really in trouble */

		call com_err_ (code, name, "Cannot release MPC ^a.", attach_mpc_data.mpc_name);

		call command_cleanup;		/*  and QUIT */
		end;
	     end;

	stopped_io = "0"b;
	acode = 0;

	return;

     end release_tape_mpc;

%page;

/* Routine to setup static data-base */

setup_static_data:
     proc;

dcl  i fixed bin;

/* First, count mpc's */

	log_mpc_data_n_mpcs = 0;
	mpc_cardp = null ();
	call config_$find ("mpc", mpc_cardp);
	do while (mpc_cardp ^= null ());
	     if substr (mpc_card.name, 1, 3) = "msp" | substr (mpc_card.name, 1, 3) = "mtp"
		| substr (mpc_card.name, 1, 3) = "urp"
	     then log_mpc_data_n_mpcs = log_mpc_data_n_mpcs + 1;
	     call config_$find ("mpc", mpc_cardp);
	end;
	if log_mpc_data_n_mpcs = 0 then do;
	     call com_err_ (0, name, "No MPC's configured. Polling not initiated.");
	     go to error_return;
	     end;

	allocate log_mpc_data;
	unspec (log_mpc_data) = "0"b;
	log_mpc_data.n_mpcs = log_mpc_data_n_mpcs;

	mpc_cardp = null ();
	do i = 1 to log_mpc_data.n_mpcs;
skip_mpc:
	     call config_$find ("mpc", mpc_cardp);
	     if substr (mpc_card.name, 1, 3) ^= "msp" & substr (mpc_card.name, 1, 3) ^= "mtp"
		& substr (mpc_card.name, 1, 3) ^= "urp"
	     then go to skip_mpc;
	     log_mpc_entryp = addr (log_mpc_data.mpc_entry (i));
	     log_mpc_entry.mpc_name = mpc_card.name;
	end;
	return;

     end setup_static_data;

%page;

/* Internal proc to handle special interrupt from suspend and release operations
   to the tape MPC */

special:
     proc (acode);
dcl  acode fixed bin (35);

	acode = 0;
	error_message = "special";
	if imess.level ^= "7"b3 then do;
	     acode = -2;				/* maps to wrong status in caller		*/
	     return;
	     end;

	call ioi_$get_special_status (attach_mpc_data.ioi_index, special_status_flag, special_status_word, acode);
	if acode ^= 0 then do;
no_special:
	     call com_err_ (acode, name, "Attempting to get special status word.");
	     return;
	     end;
	io_special_status_ptr = addr (special_status_word);
	if ^(special_status_flag | io_special_status.t) then do;
	     acode = -1;				/* caller knows what to do			*/
	     return;
	     end;
	if OP = SUS_MTP then do;
	     if log_mpc_data.debug
	     then call ioa_ ("^a: Processing SUSPEND special status for ^a: Status = ^w", name,
		     attach_mpc_data.mpc_name, special_status_word);

	     if substr (special_status_word, 27, 1)
	     then mtp_suspended = "1"b;
	     else do;				/* suspend didn't work			*/
		acode = error_table_$unable_to_do_io;
		call com_err_ (acode, name, "MTP was not suspended.");
		return;
		end;
	     end;
	else if OP = REL_MTP then do;
	     if log_mpc_data.debug
	     then call ioa_ ("^a: Processing RELEASE special status for ^a: Status = ^w", name,
		     attach_mpc_data.mpc_name, special_status_word);

	     if substr (special_status_word, 26, 1)
	     then mtp_suspended = "0"b;
	     else do;				/* release didn't work			*/
		acode = error_table_$unable_to_do_io;
		call com_err_ (acode, name, "MTP was not released.");
		return;
		end;
	     end;
     end special;
%page;
terminate:
     proc (acode);

dcl  acode fixed bin (35);

	acode = 0;
	error_message = "terminate";			/* Special interupt expected now */

	if log_mpc_data.debug
	then call ioa_ ("^a: Processing Terminate status for ^a:^/Level = ^.3b, Status = ^w", name,
		attach_mpc_data.mpc_name, imess.level, imess.status);

	if imess.level ^= "3"b3 then do;		/* If not termination */
	     acode = -2;				/* caller knows what to do			*/
	     return;
	     end;

	if imess.er then do;			/* Error */
	     call analyze_device_stat_$rsnnl (error_message, attach_mpc_data.status_tablep, (imess.status), ("0"b));
	     acode = -1;				/* caller knows what to do			*/
	     return;
	     end;

     end terminate;
%page;
/*  Internal subroutine to control the suspending, clearing of dev stats, and
   releasing of the tape controller */

suspend_mtp:
     proc (CODE);

dcl  (CODE, scode) fixed bin (35);

	call suspend_tape_mpc (scode);

	if scode ^= 0 then do;
	     call DETACH_MPC_;
	     CODE = scode;
	     return;
	     end;

	OP = WRITE_MPC_MEM;
	call build_idcw;
	call do_tape_io ("0"b, scode);		/* special case the suspend */

	if scode ^= 0 then do;
	     call release_tape_mpc (IO_ERR, scode);
	     call detach_and_count (SUS_ERR);
	     CODE = scode;
	     return;
	     end;

	call release_tape_mpc (0, 0);			/* normal release */
	CODE = 0;
	return;

     end suspend_mtp;

%page;

suspend_tape_mpc:
     proc (acode);

dcl  (code, acode, saved_code) fixed bin (35);

	stopped_io, mtp_suspended = "0"b;
	OP = IOI_SUS_MTP;

	if log_mpc_data.debug
	then call ioa_ ("^a: ^a ^a (^a)", name, OPERATION (OP), attach_mpc_data.mpc_name, attach_mpc_data.device_name);

/* This waits for all i/o to finish */

	call ioi_$suspend_devices (attach_mpc_data.ioi_index, code);


	if code ^= 0 then go to IOI_SUS_ERR;

	stopped_io = "1"b;				/* MUST remember this */
	OP = SUS_MTP;
	call build_sus_rel_idcw;
	call do_tape_io ("1"b, code);			/* now clear stat block */


	if code = 0 then do;			/* PHEW */
	     acode = 0;
	     mtp_suspended = "1"b;			/* MUST remember this also */
	     return;
	     end;
	go to SUS_MTP_ERR;


IOI_SUS_ERR:
	saved_code = code;				/* release_tape can wipe it out */
	call detach_and_count (SUS_ERR);		/* keep track of failures */
	go to com_err_ret;


SUS_MTP_ERR:
	call detach_and_count (SUS_ERR);
	call release_tape_mpc (SUS_ERR, code);		/* let him clean up */
com_err_ret:
	acode = saved_code;
	return;

     end suspend_tape_mpc;

%page;

/* Be sure all mpc's given on comnmand line are configured. */

validate_mpc_list:
     proc;

dcl  (i, j) fixed bin;

	do i = 1 to mpc_cnt;
	     do j = 1 to log_mpc_data.n_mpcs;
		log_mpc_entryp = addr (log_mpc_data.mpc_entry (j));
		if mpc_list (i) = log_mpc_entry.mpc_name then go to mpc_ok;
	     end;
	     call com_err_ (0, name, "MPC ^a is not configured, or is not pollable.", mpc_list (i));
	     mpc_list (i) = "";
	     mpc_cnt = mpc_cnt - 1;
	     go to error_return;
mpc_ok:
	end;
	return;

     end validate_mpc_list;


%page;
/*   Begin Message Documentation
   *
   *    Message:
   *    poll_mpc: Polled MPC_NAME.
   *
   *    S:     $info
   *
   *    T:     $run
   *
   *    M:     Polled the MPC identified by MPC_NAME and placed the polled
   *           data in the syserr_log.
   *
   *    Message:
   *    poll_mpc: I/O error on MPC_NAME ERROR_MESSAGE.
   *
   *    S:     $info
   *
   *    T:     $run
   *
   *    M:     poll_mpc experienced an I/O error atempting to poll the mpc.
   *           Three consecutive errors for MPC_NAME will suspend polling of
   *           this mpc.
   *
   *    Message:
   *    poll_mpc: MPC MPC_NAME has had X ERROR_NAME error(s) since the last poll.
   *
   *              SUSPECT the YYY wwb. (If known).
   *
   *              Please inform your CSD representative.
   *
   *     S:     $beep
   *
   *     T:     $run
   *
   *     M:     An internal mpc error, error data register or LA-PSI error counter,
   *            was detected in the named MPC. The number of errors detected since
   *            the last poll is identified by X. The type of error identified by
   *            ERROR_NAME is an interpretation of the register or counter name,
   *            i.e., X/Y OPERAND PARITY ERROR. In some cases a board causing
   *            the error can be identified. if this is the case the SUSPECT board
   *            will be identified by YYY to aid the FE.
   *
   *     A:     Call CSD.
   *            If the subsystem serviced by this MPC is experiencing other
   *            errors or the errors encountered between polling cycles is
   *            increasing remove the MPC from service, if possible. This is
   *            important for disk subsystems as file system damage may
   *            occur.
   *
   *     END MESSAGE DOCUMENTATION */

%page;
%include attach_mpc_data;
%page;
%include config_mpc_card;
%page;
%include event_call_info;
%page;
%include iom_pcw;
%page;
%include iom_dcw;
%page;
%include ioi_stat;
%page;
%include dump_mpc_data;
%page;
%include iox_modes;
%page;
%include poll_mpc_data;
%page;
%include syserr_binary_def;
%page;
%include event_wait_info;
%page;
%include eurc_model_numbers;
%page;
%include io_special_status;

     end poll_mpc;




		    print_mpc_summary.pl1           04/02/85  1110.7rew 04/02/85  1037.3      141075



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   * Copyright (c) 1972 by Massachusetts Institute of        *
   * Technology and Honeywell Information Systems, Inc.      *
   *                                                         *
   *********************************************************** */


/* PRINT_MPC_SUMMARY - Print MPC and Device Statistics for MPC.
   coded December 1980 by Rich Coppola */
/* Modified May 1982 by Rich Coppola to add EURC support */
/* Modified June 1983 by Paul Farley to fix EURC bug. */
/* Modified June 1984 by Paul Farley for DAU (MSP800) support and
   to change "MTC Read Count" to "MTC Read Retry Count" */

/* format: style4,delnl,insnl,ifthenstmt,indnoniterend */

print_mpc_summary:
     proc (a_mpc_data_summaryp, a_sw, short_sw, a_bf_sw);

/* Arguments */

dcl  a_mpc_data_summaryp ptr;				/* Pointer to mpc data structure */
dcl  a_sw ptr;					/* Pointer to ioa_switch */
dcl  short_sw bit (1);				/* Set to fit display on 80 char terminal */
dcl  a_bf_sw bit (1);				/* set if only errordat to be printed */


/* Automatic */

dcl  sw ptr;					/* Pointer to ioa_switch */

dcl  (i, j, k) fixed bin;				/* Iteration variables */
dcl  pic8 picture "zzzzzzz9";
dcl  pic99 picture "99";
dcl  pic9 picture "9";
dcl  ndev fixed bin;
dcl  num_to_print fixed bin;
dcl  nprint fixed bin;
dcl  nblabel fixed bin;
dcl  blabelp ptr;
dcl  hint bit (1);
dcl  tape_sw bit (1);
dcl  mpc_only bit (1) init ("0"b);
dcl  bf_sw bit (1) init ("0"b);
dcl  print_mpc_line bit (1);
dcl  (urp_sw, eurc_sw) bit (1) init ("0"b);
dcl  dau_sw bit (1) init ("0"b);
dcl  (nonzero_cntrs) bit (1);
dcl  header_line char (136);
dcl  retl fixed bin (21);
dcl  SUBSYSTEM char (3);
dcl  temp_value float bin (21);
dcl  temp_con float bin (21);
dcl  temp fixed bin;
dcl  temp_float float (21);
dcl  indx fixed bin;
dcl  (ratio_need, stat_need) bit (1);
dcl  prev_drive_sw bit (1) init ("0"b);
dcl  ratio_wanted bit (1) init ("0"b);


dcl  1 line unal,
       2 title char (28),
       2 field (16) char (8);

dcl  1 liner unal,
       2 title char (28) init ("     Ratio"),
       2 field (16) char (8);


/* Constants */
dcl  eurlabel (15) char (28) static options (constant)
	init ("PDSI Receiver Errors", "PDSI Transmission Errors", "Cards Punched", "Cards Read", "PDSI Frames Received",
	"PDSI Frames Transmitted", "Connect PCW's", "Total PCW's", "IOM Transactions (L)", "IOM Transactions (U)",
	"IOM Word Transmissions (L)", "IOM Word Transmissions (U)", "Lines Printed", "PDSI Re-Transmissions",
	"Pages printed");

dcl  tlabel (8) char (28) static options (constant)
	init ("Records Read", "Records Written", "Records with Write Error", "Records with Read Error",
	"Transfer Timing Errors", "Marginal Records", "Single Track Corrections", "MTC Read Retry Count");

dcl  dlabel (16) char (28) int static options (constant)
	init ("Movement Seeks", "Data Sectors Written", "Data Sectors Read", "Data Transfer Commands",
	"Seek Incompletes", "Header Verification Errors", "Transfer Timing Errors", "Data Check Character Alerts",
	"Count Check Character Alerts", "Parity Errors", "Alternate Tracks Processed", "EDAC Correctable Errors",
	"EDAC Uncorrectable Errors", "Positioner Offsets", "Data Correction Init", "Search Alerts");

dcl  daulabel (16) char (28) int static options (constant)
	init ("Movement Seeks", "Data Sectors Written", "Data Sectors Read", "Data Transfer Commands",
	"Seek Incompletes", "Header Verification Errors", "Transfer Timing Errors", "Data Check Character Alerts",
	"Count Check Character Alerts", "Interface Errors", "Alternate Tracks Processed", "EDAC Correctable Errors",
	"EDAC Uncorrectable Errors", "Latencies", "Record Retry", "Sync Failures");


/* Based */


dcl  blabel (nblabel) char (28) based (blabelp);

/* External Entries */

dcl  ioa_$ioa_switch entry options (variable);
dcl  ioa_$ioa_switch_nnl entry options (variable);
dcl  ioa_$rsnnl entry () options (variable);
dcl  ioa_$rs entry () options (variable);
dcl  decode_mpc_stats_$stat_ctrs_for_summary_ entry (ptr, ptr);
dcl  decode_mpc_stats_$dau_stat_ctrs_for_summary_ entry (ptr, ptr);
dcl  decode_mpc_stats_$err_data_for_summary_ entry (ptr, ptr);
dcl  (addr, divide, hbound, length, min, rtrim, string, substr) builtin;
dcl  (size, zerodivide) condition;


summary:
     entry (a_mpc_data_summaryp, a_sw, short_sw, a_bf_sw);
start:
	mpc_data_summaryp = a_mpc_data_summaryp;
	sw = a_sw;
	bf_sw = a_bf_sw;

	if short_sw
	then num_to_print = 6;
	else num_to_print = 12;
	ndev = mpc_data_summary.n_devices;

	if substr (mpc_data_summary.name, 1, 3) = "urp" then do;
	     header_line = "";
	     retl = 0;
	     urp_sw = "1"b;
	     eurc_sw = "0"b;
	     do i = 1 to hbound (eurc_model_numbers, 1) while (eurc_sw = "0"b);
		if mpc_data_summary.model = eurc_model_numbers (i) then eurc_sw = "1"b;
	     end;
	     if eurc_sw = "1"b then do;		/* If EURC controller ... */
		nblabel = hbound (eurlabel, 1);
		blabelp = addr (eurlabel);
		go to display_eurc;
		end;
	     end;


	else if substr (mpc_data_summary.name, 1, 3) = "mtp" then do;
						/* If tape controller ... */
	     call ioa_$rs ("FW Rev. ^a", header_line, retl, mpc_data_summary.firmware_rev);
	     nblabel = hbound (tlabel, 1);
	     blabelp = addr (tlabel);
	     tape_sw = "1"b;
	     SUBSYSTEM = "tap";
	     end;

	else if substr (mpc_data_summary.name, 1, 3) = "msp" then do;
						/* If disk controller ... */
	     if mpc_data_summary.model = 800 then do;	/* DAU? */
		call ioa_$rs ("FW Rev. ^a, HW Rev. ^2.4b(hex)", header_line, retl, mpc_data_summary.firmware_rev,
		     mpc_data_summary.hw_rev);
		nblabel = hbound (daulabel, 1);
		blabelp = addr (daulabel);
		dau_sw = "1"b;
		end;
	     else do;
		call ioa_$rs ("FW Rev. ^a", header_line, retl, mpc_data_summary.firmware_rev);
		nblabel = hbound (dlabel, 1);
		blabelp = addr (dlabel);
		end;
	     tape_sw = "0"b;
	     SUBSYSTEM = "dsk";
	     end;

	call ioa_$ioa_switch (sw, "^/^[^23x^;^47x^]^a^/", short_sw, substr (header_line, 1, retl));

	allocate mpc_stat_anal;
	print_mpc_line = "0"b;


	if ^urp_sw & ^dau_sw then do;			/* old disk & tape */
	     nonzero_cntrs = "0"b;
	     do i = 1 to 12 while (^nonzero_cntrs);
		if mpc_data_summary.polled_stat_counters (i) ^= 0 then nonzero_cntrs = "1"b;
	     end;

	     if nonzero_cntrs then do;
		call decode_mpc_stats_$stat_ctrs_for_summary_ (mpc_data_summaryp, mpc_stat_analp);

		call ioa_$ioa_switch (sw, "^/The LA-PSI ERROR COUNTERS contain the following information:");

		do i = 1 to mpc_stat_anal.num_ctr_interps;
		     call ioa_$ioa_switch (sw, "^a = ^d", rtrim (mpc_stat_anal.interp_stat_ctrs (i)),
			mpc_stat_anal.stat_cntr_cnt (i));
		end;
		print_mpc_line = "1"b;		/* remember */
		call ioa_$ioa_switch (sw, "^/");
		end;

	     end;

	else if dau_sw then do;			/* DAU? */
	     call ioa_$ioa_switch (sw, "^/Latest Channel Interface Configuration:");
	     call ioa_$ioa_switch_nnl (sw, "^xCI-0 ^[on^;off^]line, CI-1 ^[on^;off^]line, ",
		mpc_data_summary.ci_0_online, mpc_data_summary.ci_1_online);
	     call ioa_$ioa_switch_nnl (sw, "^xPSI-0 ^[2^;4^]trip, PSI-1 ^[2^;4^]trip, ", mpc_data_summary.psi0_2trip,
		mpc_data_summary.psi1_2trip);
	     call ioa_$ioa_switch (sw, "^xPSI-2 ^[2^;4^]trip, PSI-3 ^[2^;4^]trip^/", mpc_data_summary.psi2_2trip,
		mpc_data_summary.psi3_2trip);

	     nonzero_cntrs = "0"b;
	     do i = 1 to 20 while (^nonzero_cntrs);
		if mpc_data_summary.psi_cntr (i) ^= 0 then nonzero_cntrs = "1"b;
	     end;

	     if nonzero_cntrs | mpc_data_summary.err_interrupts ^= 0 then do;
		call decode_mpc_stats_$dau_stat_ctrs_for_summary_ (mpc_data_summaryp, mpc_stat_analp);

		call ioa_$ioa_switch (sw, "^/The DAU/PSI ERROR COUNTERS contain the following information:");

		do i = 1 to mpc_stat_anal.num_ctr_interps;
		     call ioa_$ioa_switch (sw, "^a = ^d", rtrim (mpc_stat_anal.interp_stat_ctrs (i)),
			mpc_stat_anal.stat_cntr_cnt (i));
		end;

		if mpc_data_summary.err_interrupts ^= 0 then do;
		     call ioa_$ioa_switch (sw, "^/Last DAU Extended Error Info (72 Bytes):^3(^/^24( ^2.4b^)^)",
			mpc_data_summary.err_info);
		     end;
		print_mpc_line = "1"b;		/* remember */
		call ioa_$ioa_switch (sw, "^/");
		end;

	     end;


	if mpc_data_summary.register ^= "0"b then do;
	     call decode_mpc_stats_$err_data_for_summary_ (mpc_data_summaryp, mpc_stat_analp);

	     if mpc_stat_anal.num_interps ^= 0 then print_mpc_line = "1"b;
						/* remember */
	     call ioa_$ioa_switch (sw, "^/The MPC ERROR DATA REGISTER contains the following information:");

	     do i = 1 to mpc_stat_anal.num_interps;
		if mpc_stat_anal.HINT (i) ^= ""
		then hint = "1"b;
		else hint = "0"b;
		call ioa_$ioa_switch (sw, "^a^[ Suspect: ^a^]", rtrim (mpc_stat_anal.message (i)), hint,
		     rtrim (mpc_stat_anal.HINT (i)));
	     end;

	     call ioa_$ioa_switch (sw, "The last INTAR address is:^2x^4.4b", mpc_stat_anal.intar);

	     if SUBSYSTEM = "dsk"
	     then					/* AUXAR only valid for disk MPCs */
		call ioa_$ioa_switch (sw, "The last AUXAR address is:^2x^4.4b", mpc_stat_anal.auxar);
	     call ioa_$ioa_switch (sw, "The ERROR INTERRUPT COUNTER is: ^6d^/", mpc_stat_anal.err_ctr);

	     end;


	if print_mpc_line = "0"b & (mpc_only | urp_sw)
	then call ioa_$ioa_switch (sw, "^/^11tNo error indications encountered for MPC ^a.^2/", mpc_data_summary.name);

	if (urp_sw | mpc_only) then return;

display_eurc:
	if eurc_sw then do;				/* do eurc specifics */
	     call ioa_$ioa_switch (sw, "PROM	  CORE  IOM  SPECIAL-CONTROLLER  LINK/EDIT  PDSI  SELF-TEST  DAI");
	     call ioa_$ioa_switch (sw, "REVISION^15t^2.4b^20t^2.4b^40t^2.4b^51t^2.4b^57t^2.4b^68t^2.4b^73t^2.4b",
		mpc_data_summary.core, mpc_data_summary.iom, mpc_data_summary.special_controller,
		mpc_data_summary.link_edit, mpc_data_summary.pdsi_application, mpc_data_summary.self_test,
		mpc_data_summary.dai_application);
	     call ioa_$ioa_switch (sw, "^/Uptime Clock-seconds ^12d", mpc_data_summary.uptime_clock);
	     end;



	do i = 1 to ndev by num_to_print;
	     nprint = min (num_to_print, ndev + 1 - i);


/* start info about device  */

	     string (line) = "";
	     if eurc_sw
	     then line.title = "Device Name";
	     else line.title = "Subsystem";

	     if ^eurc_sw
	     then do j = 1 to nprint;
		substr (line.field (j), 5) = SUBSYSTEM || mpc_data_summary.subsystem (i + j - 1);
	     end;

	     else do j = 1 to nprint;
		substr (line.field (j), 9 - length (rtrim (mpc_data_summary.dev_name (i + j - 1)))) =
		     mpc_data_summary.dev_name (i + j - 1);
	     end;

	     call ioa_$ioa_switch (sw, "^a", string (line));

	     string (line) = "";
	     if ^eurc_sw
	     then line.title = "Drive";

	     else line.title = "Logical Channel";

	     do j = 1 to nprint;
		pic8 = mpc_data_summary.driveno (i + j - 1);
		line.field (j) = pic8;
	     end;
	     call ioa_$ioa_switch (sw, "^a", string (line));


	     if ^eurc_sw then do;
		string (line) = "";
		line.title = "Prev_drive";
		do j = 1 to nprint;
		     if mpc_data_summary.prev_driveno (i + j - 1) ^= 0 then do;
			pic8 = mpc_data_summary.prev_driveno (i + j - 1);
			line.field (j) = pic8;
			prev_drive_sw = "1"b;
			end;
		end;

		if prev_drive_sw then call ioa_$ioa_switch (sw, "^a", string (line));
		end;

	     string (line) = "";
	     line.title = "Model";
	     do j = 1 to nprint;
		substr (line.field (j), 9 - length (rtrim (mpc_data_summary.dev_model (i + j - 1)))) =
		     mpc_data_summary.dev_model (i + j - 1);
	     end;
	     call ioa_$ioa_switch (sw, "^a", string (line));

	     string (line) = "";

	     if eurc_sw then do;
display_eurc_stats:
		do k = 1 to hbound (blabel, 1);
		     string (line) = "";
		     string (liner) = "";
		     line.title = blabel (k);

		     do j = 1 to nprint;
			indx = (i + j - 1);
			pic8 = mpc_data_summary.dev_stat (indx).value (k);
			line.field (j) = pic8;
		     end;
		     call ioa_$ioa_switch (sw, "^a", string (line));
		end;

		call ioa_$ioa_switch (sw, "^2/");
		go to end_eurc_dev;
		end;


	     if tape_sw then do;
		if mpc_data_summary.model < 610
		then line.title = "Port";
		else line.title = "TM/Port";
		end;

	     else line.title = "CA/Port";

	     do j = 1 to nprint;
		line.field (j) = "";
		if (^tape_sw) | (mpc_data_summary.model > 602) then do;
		     pic9 = mpc_data_summary.ca (i + j - 1);
		     pic99 = mpc_data_summary.port (i + j - 1);
		     substr (line.field (j), 5) = pic9 || "/" || pic99;

		     end;

		else do;
		     pic8 = mpc_data_summary.port (i + j - 1);
		     line.field (j) = pic8;
		     end;
	     end;

	     call ioa_$ioa_switch (sw, "^a", string (line));

	     line.title = "OPI";
	     do j = 1 to nprint;
		line.field (j) = "";
		if mpc_data_summary.opi (i + j - 1)
		then line.field (j) = "      ON";
		else line.field (j) = "     OFF";
	     end;

	     call ioa_$ioa_switch (sw, "^a^/", string (line));


	     on zerodivide
		begin;
		liner.field (j) = "  ******";
		goto pr_stat;
	     end;

	     on size
		begin;
		line.field (j) = "  ******";
		goto recover_size;
	     end;


	     do k = 1 to hbound (blabel, 1);
		string (line) = "";
		string (liner) = "";
		if ^tape_sw
		then liner.title = "     Ratio * 100";
		else liner.title = "     Ratio";
		line.title = blabel (k);

		ratio_need, stat_need = "0"b;
		do j = 1 to nprint;

		     indx = (i + j - 1);

		     if mpc_data_summary.dev_stat (indx).value (k) ^= 0 then do;
			if bf_sw
			then			/* dont display anything but error counters */
			     if k <= 2 then goto skip_print;
			     else if ^tape_sw & k <= 4 then goto skip_print;
			stat_need = "1"b;
			pic8 = mpc_data_summary.dev_stat (indx).value (k);
			line.field (j) = pic8;
recover_size:
			if ^tape_sw
			then if k > 4 then do;
				ratio_need = "1"b;
				temp_value = mpc_data_summary.dev_stat (indx).value (k);
				goto msp_dev (k);
end_msp_dev:
				temp_float = divide (temp_value, temp_con, 21);
				call ioa_$rsnnl ("^8.3f", liner.field (j), temp, temp_float);
				end;
			     else ;
			else if k > 2 then do;
			     ratio_need = "1"b;
			     temp_value = mpc_data_summary.dev_stat (indx).value (k);
			     goto mtp_dev (k);
end_mtp_dev:
			     temp_float = divide (temp_value, temp_con, 21);

			     call ioa_$rsnnl ("^8.3f", liner.field (j), temp, temp_float);
			     end;
			end;
		end;
pr_stat:
		if stat_need then do;
		     call ioa_$ioa_switch (sw, "^a", string (line));
		     if ratio_need & ratio_wanted then call ioa_$ioa_switch (sw, "^a", string (liner));
		     end;
skip_print:
		ratio_need, stat_need = "0"b;
	     end;
end_eurc_dev:
	     call ioa_$ioa_switch (sw, "^2/");
	end;
	return;

msp_dev (5):
msp_dev (6):
msp_dev (7):
msp_dev (8):
msp_dev (9):
msp_dev (10):
msp_dev (12):
msp_dev (13):
msp_dev (15):
msp_dev (16):
	temp_con = mpc_data_summary.dev_stat (indx).value (4) * 100;
	goto end_msp_dev;

msp_dev (11):
msp_dev (14):
	temp_con = mpc_data_summary.dev_stat (indx).value (1) * 100;
	goto end_msp_dev;

mtp_dev (5):
mtp_dev (6):
	temp_con = mpc_data_summary.dev_stat (indx).value (1) + mpc_data_summary.dev_stat (indx).value (2);
	goto end_mtp_dev;

mtp_dev (3):
	temp_con = mpc_data_summary.dev_stat (indx).value (2);
	goto end_mtp_dev;

mtp_dev (4):
mtp_dev (7):
mtp_dev (8):
	temp_con = mpc_data_summary.dev_stat (indx).value (1);
	goto end_mtp_dev;

%page;
display_mpc_:
     entry (a_mpc_data_summaryp, a_sw, short_sw, a_bf_sw);

	mpc_only = "1"b;
	go to start;

%page;
%include poll_mpc_data;
%page;
%include dump_mpc_data;
%page;
%include eurc_model_numbers;
     end print_mpc_summary;





		    stat_mpc_.pl1                   04/02/85  1110.7rew 04/02/85  1035.4      279117



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   * Copyright (c) 1972 by Massachusetts Institute of        *
   * Technology and Honeywell Information Systems, Inc.      *
   *                                                         *
   *********************************************************** */


/* STAT_MPC_ - Gather MPC and Device Statistics for MPC's.
   coded 7/8/75 by Noel I. Morris	*/
/* Major rewrite March 1980 by Larry Johnson to print more detailed info. */
/* Modified 10/80 by Rich Coppola to fix bug in tape port determination
   develop tape   and disk drive model numbers from data retained in mpc mem.
   Also added code to capture and display statistics for the mpc itself. */
/* Modified 12/80 by Rich Coppola to remove the display routine and make
   it a subroutine so it could be used to display data from dump_mpc or
   mpc data placed in the syserr_log by poll_mpc. */
/* Modified Aug 1981 by Rich Coppola to add recognition of MTP611 and DSC611/612
   to the code. */
/* Modified May 1982 by Rich Coppola to add support for the EURC */
/* Modified October by C. Hornig for new PRPH TAP card format. */
/* Modified Oct 1982 by Rich Coppola to correct display of EURC up-time ctr */
/* Modified Apr 1983 by Paul Farley to correct a problem with the short_sw
   parm interacting with the arg_eurc_sw parm (TR phx15060). */
/* Modified June 1983 by Paul Farley to correct a problem with printing
   zero TAPE statistics.
   Modified June 1984 by Paul Farley for DAU support and to use a pointer
   parameter to reference the MPC memory image.
   Modified March 1985 by Paul Farley to double DAU config area, for 64 devices (PBF).
*/

/* format: style4,delnl,insnl,ifthenstmt,indnoniterend */
stat_mpc_:
     proc (image_ptr, sw, mpc_datap, arg_short_sw);

/* Arguments */

dcl  image_ptr ptr parameter;
dcl  image (0:4095) bit (16) unal based (image_ptr);	/* MPC memory image */
dcl  dau_data (0:759) bit (16) unal based (image_ptr);	/* DAU config and statistic data */
dcl  sw ptr,					/* IOX_ switch for output */
     arg_short_sw bit (1);				/* To display 80 char line */

dcl  arg_code fixed bin (35);
dcl  arg_poll_mpc_datap ptr;
dcl  arg_eurc_sw bit (1);

/* Automatic */

dcl  p ptr,					/* Pointer to trace word */
     (i, j, k) fixed bin;				/* Iteration variables */
dcl  eurc_image (1:168) bit (8) unal based (image_ptr);
dcl  ndev fixed bin;
dcl  code fixed bin (35);
dcl  (dau_dev_number, dau_port, pair_idx) fixed bin;
dcl  model_num char (4);
dcl  (dau_config_ptr, dau_stats_ptr) ptr;
dcl  disk_dev_tablep ptr;
dcl  cross_barred bit (1);
dcl  dual_personality bit (1);
dcl  device_namep ptr;
dcl  ca_port_tablep ptr;
dcl  device_modelp ptr;
dcl  device_drivenop ptr;
dcl  err_int_ptr ptr;
dcl  err_data_ptr ptr;
dcl  mpc_stat_addrp ptr;
dcl  return_info bit (1);
dcl  n_pad_words fixed bin;
dcl  tape_dev_tablep ptr;
dcl  mpc_only bit (1) init ("0"b);
dcl  tape_sw bit (1);
dcl  short_sw bit (1);
dcl  statx fixed bin;
dcl  found fixed bin;
dcl  (urp_sw, eurc_sw, dau_sw) bit (1) init ("0"b);
dcl  LC (0:3) char (4) init ((4) (""));
dcl  eurc_lc_model (0:3) fixed bin;
dcl  1 auto_mpc_stat_info like mpc_stat_info aligned automatic;

/* Constants */

dcl  tape_model (8) char (6) static options (constant)
	init ("   610", "", "   600", "   500", "   410", "   P30", "   630", "");

dcl  ddev_model (0:223) char (6) static options (constant)
	init ((84) (""), "  190A", (52) (""), "  190B", "   401", "  190B", (14) (""), "   451", (31) (""), "   402",
	(13) (""), "   500", "   501", "   500", "   501", "   500", "   501", "   500", "   501", (9) (""), "   509",
	"", "   509", "", "   509", "", "   509");


/* based */

dcl  1 tstat (16) based (p) unal,			/* Tape statistics */
       2 stat (8) fixed bin (16) uns unal;		/* Statistics for device */

dcl  1 dstat (64) based (p) unal,
       2 stat (16) fixed bin (16) uns;

dcl  eurc_stat (60) fixed bin (16) uns based (p) unal;	/* RAW Stats for EURC devs */

dcl  1 estat (4),					/* matricised properly */
       2 stat (15) fixed bin (16) uns;

dcl  1 d451_dev_table aligned based (disk_dev_tablep),
       2 per_dev (32) unal,
         3 opi bit (1) unal,
         3 pad1 bit (2) unal,
         3 ca fixed bin (1) uns unal,
         3 port fixed bin (4) uns unal,
         3 pad bit (24) unal;

dcl  1 d601_dev_table aligned based (disk_dev_tablep),
       2 per_dev (64) unal,
         3 opi bit (1) unal,
         3 pad1 bit (2) unal,
         3 ca fixed bin (1) uns unal,
         3 port fixed bin (4) uns unal,
         3 pad bit (8) unal;

dcl  1 dau_char based (dau_config_ptr) unaligned,		/* Config data */
       2 type bit (8),				/* = 12 HEX */
       2 hw_rev bit (8) unal,				/* DAU rev */
       2 fw_maj_rev bit (8) unal,			/* firmware rev letter */
       2 fw_sub_rev fixed bin (8) uns unal,		/* firmware rev number */
       2 dev (64),					/* seq'ed by dev# */
						/* all 4 bytes zero, if device NEVER configured */
         3 type fixed bin (8) uns unal,			/* device type */
         3 number fixed bin (8) uns unal,		/* device number, =FF if not configured */
         3 summary_status bit (8) unal,			/* device SS reg */
         3 port_number fixed bin (8) uns unal;		/* device DAU port */

dcl  1 dau_stats based (dau_stats_ptr) unaligned,		/* Status data */
       2 port_data (0:15, 2) unal,			/* posibly two logical devices per port */
         3 number fixed bin (8) uns unal,		/* device number */
         3 type fixed bin (8) uns unal,			/* device type */
         3 pad bit (16) unal,				/* MBZ */
         3 stat (16) fixed bin (16) uns unal,		/* device counters */
       2 dau_type fixed bin (8) uns unal,		/* HEX 12 */
       2 fw_maj_rev bit (8) unal,			/* firmware rev letter */
       2 fw_sub_rev bit (8) unal,			/* firmware rev number */
       2 dau_flags unal,
         3 ci_0_online bit (1) unal,			/* channel interface */
         3 ci_1_online bit (1) unal,
         3 mbz bit (2) unal,
         3 psi0_2trip bit (1) unal,			/* ci-0 port-0 */
         3 psi1_2trip bit (1) unal,			/* ci-0 port-1 */
         3 psi2_2trip bit (1) unal,			/* ci-1 port-0 */
         3 psi3_2trip bit (1) unal,			/* ci-1 port-1 */
       2 special_dau_cmds fixed bin (16) uns unal,	/* controller commands cntr */
       2 sus_rlse_cmds fixed bin (16) uns unal,		/* suspend/release commands cntr */
       2 write_spc fixed bin (16) uns unal,		/* write type special controller commands */
       2 read_spc fixed bin (16) uns unal,		/* read type special controller commands */
       2 psi_cntr (20) fixed bin (8) uns unal,		/* all PSI counters */
       2 err_interrupts fixed bin (16) uns unal,		/* dau error counter */
       2 pad bit (16) unal,				/* MBZ */
       2 ext_dau_info (72) bit (8) unal;		/* extended DAU info */

dcl  1 t600_dev_table aligned based (tape_dev_tablep),
       2 per_dev (16) unal,
         3 opi bit (1),
         3 pad bit (9),
         3 tm bit (4),
         3 port fixed bin (2) uns,
         3 pad1 bit (16),
         3 tape_models bit (8),
         3 pad2 bit (8),
         3 pad_words (5) bit (16);


dcl  1 t500_dev_table aligned based (tape_dev_tablep),
       2 per_dev (16) unal,
         3 opi bit (1),
         3 pad bit (11),
         3 port fixed bin (4) uns,
         3 pad_words (n_pad_words) bit (16);

dcl  1 ca_port_table (0:31) based (ca_port_tablep) unal,
       2 ddev_type fixed bin (8) uns,
       2 ddev_table_ptr bit (8);

dcl  device_name (64) char (4) based (device_namep);
dcl  device_model (64) fixed bin based (device_modelp);
dcl  device_driveno (64) fixed bin based (device_drivenop);

dcl  t500_err_int_ctr fixed bin (16) uns based (err_int_ptr);
dcl  1 t500_err_data based (err_data_ptr) unal,
       2 reg bit (16),
       2 intar bit (16),
       2 pad bit (16);


dcl  1 t600_err_data based (err_int_ptr) unal,
       2 pad bit (8),
       2 int_ctr fixed bin (8) uns,
       2 reg bit (16),
       2 intar bit (16),
       2 pad1 bit (16);

dcl  1 dsk_err_data based (err_int_ptr) unal,
       2 pad bit (8),
       2 int_ctr fixed bin (8) uns,
       2 reg bit (16),
       2 auxar bit (16),
       2 intar bit (16);


dcl  1 urp_err_data based (err_int_ptr) unal,
       2 pad bit (8),
       2 err_int_ctr fixed bin (8) uns,
       2 err_data_reg bit (16),
       2 err_data_intar bit (16),
       2 pad1 bit (16);

dcl  1 mpc_err_stat based (mpc_stat_addrp) unal,
       2 ctrs (12) fixed bin (8) uns;


/* Static */

dcl  nmpcs fixed bin int static init (0);
dcl  mpc_names (16) char (4) int static;
dcl  mpc_device_names (16) ptr int static;
dcl  mpc_device_models (16) ptr int static;
dcl  mpc_device_drivenos (16) ptr int static;


/* External */

dcl  ioa_$ioa_switch entry options (variable);
dcl  get_temp_segment_ entry (char (*), ptr, fixed bin (35));
dcl  release_temp_segment_ entry (char (*), ptr, fixed bin (35));
dcl  config_$find_2 entry (char (4) aligned, char (4) aligned, ptr);
dcl  find_config_card_$prph_for_channel entry (fixed bin (3), fixed bin (6), ptr);
dcl  display_mpc_data_ entry (ptr, ptr, bit (1));
dcl  display_mpc_data_$display_mpc_ entry (ptr, ptr, bit (1));
dcl  error_table_$incorrect_device_type ext fixed bin (35);

dcl  (addr, bin, char, hbound, ltrim, rtrim, mod, null, size, substr) builtin;
%page;
start:
	short_sw = arg_short_sw;			/* save switch */
	return_info = "0"b;

join:
	mpc_stat_infop = addr (auto_mpc_stat_info);
	err_int_ptr = addr (image (mpc_data.mpc_err_int_ctr_addr));
	err_data_ptr = addr (image (mpc_data.mpc_err_data_reg_addr));
	mpc_stat_addrp = addr (image (mpc_data.mpc_stat_addr));
	mpc_stat_info.mpc_name = substr (mpc_data.name, 1, 4);

	if mpc_data.type = "urp" then urp_sw = "1"b;

	if eurc_sw then do;				/* If it is an EURC */
	     call decode_eurc_config;
	     ndev, mpc_stat_info.ndev = 0;
	     mpc_stat_info.stat_counters (*) = 0;
	     mpc_stat_info.int_counter = 0;
	     mpc_stat_info.register = "0"b;
	     mpc_stat_info.auxar = "0"b;
	     mpc_stat_info.intar = "0"b;
	     p = image_ptr;				/* starts at 0 */
	     do i = 1 to 4;				/* fill the stat matrice from raw data */
		k = 0;
		do j = i to 60 by 4;
		     k = k + 1;
		     estat.stat (i, k) = eurc_stat (j);
		end;
	     end;

	     do i = 1 to 4;
		if LC (i - 1) ^= "" then go to use_eurc_dev;
		do j = 1 to 15;
		     if estat.stat (i, j) ^= 0 then go to use_eurc_dev;
		end;
		go to next_eurc_dev;
use_eurc_dev:
		ndev, mpc_stat_info.ndev = ndev + 1;
		found = 0;
		dev_stat_infop = addr (mpc_stat_info.dev_info (ndev));
		dev_stat_info.subsystem = LC (i - 1);
		dev_stat_info.driveno = i - 1;	/* equate to log chan */
		dev_stat_info.model = ltrim (rtrim (char (eurc_lc_model (i - 1))));
		dev_stat_info.opi = "0"b;
		dev_stat_info.port, dev_stat_info.ca = 0;
		do j = 1 to 15;
		     dev_stat_info.stat (j) = estat.stat (i, j);
		end;
		dev_stat_info.stat (16) = 0;
next_eurc_dev:
	     end;

	     mpc_stat_info.uptime_clock =
		bin (eurc_image (123) || eurc_image (124) || eurc_image (121) || eurc_image (122), 32);
	     mpc_stat_info.prom_revision.core = eurc_image (129);
	     mpc_stat_info.prom_revision.iom = eurc_image (130);
	     mpc_stat_info.prom_revision.special_controller = eurc_image (131);
	     mpc_stat_info.prom_revision.link_edit = eurc_image (132);
	     mpc_stat_info.prom_revision.pdsi_application = eurc_image (133);
	     mpc_stat_info.prom_revision.self_test = eurc_image (134);
	     mpc_stat_info.prom_revision.dai_application = eurc_image (135);

	     end;

	else if dau_sw then do;			/* If its a DAU */
	     dau_config_ptr = image_ptr;		/* config area */
	     dau_stats_ptr = addr (dau_data (130));	/* statistics area */
	     ndev, mpc_stat_info.ndev = 0;
	     if mpc_only then go to fill_poll_mpc;
	     dual_personality, cross_barred = "0"b;	/* not used on dau */
	     call decode_disk_config;
	     do i = 1 to 64;			/* process attached device list */
		if dau_char.dev (i).type = 0 then goto next_dau_dev;

		dau_port = dau_char.dev (i).port_number;
		if dau_char.dev (i).number = 255 then do;
						/* FF hex */
		     dau_dev_number = i;
		     model_num = ltrim (ddev_model (dau_char.dev (i).type));
		     if model_num = "500" | model_num = "501" | model_num = "509" then do;
			if mod (dau_dev_number, 2) ^= 0
			then pair_idx = 1;		/* device was ODD# */
			else pair_idx = 2;		/* Device was EVEN# */
			end;
		     else pair_idx = 1;		/* All others get first port slot */
		     do j = 1 to 16;
			if dau_stats.port_data (dau_port, pair_idx).stat (j) ^= 0 then go to use_the_data;
		     end;
		     goto next_dau_dev;
		     end;
		else do;
		     dau_dev_number = dau_char.dev (i).number;
		     if dau_dev_number = dau_stats.port_data (dau_port, 1).number then pair_idx = 1;
		     else if dau_dev_number = dau_stats.port_data (dau_port, 2).number then pair_idx = 2;
		     else goto next_dau_dev;
		     end;

		if device_name (dau_dev_number) ^= ""
		then do j = 1 to 16;
		     if dau_stats.port_data (dau_port, pair_idx).stat (j) ^= 0 then go to use_the_data;
		end;

		go to next_dau_dev;

use_the_data:
		ndev, mpc_stat_info.ndev = ndev + 1;
		dev_stat_infop = addr (mpc_stat_info.dev_info (ndev));
		dev_stat_info.driveno = device_driveno (dau_dev_number);
		dev_stat_info.subsystem = device_name (dau_dev_number);
		dev_stat_info.port = dau_port;
		dev_stat_info.ca = 0;		/* always zero */

		dev_stat_info.model = ddev_model (dau_char.dev (i).type);
		dev_stat_info.opi = (dau_char.dev (i).number ^= 255);
						/* FF hex */
		do j = 1 to 16;
		     dev_stat_info.stat (j) = dau_stats.port_data (dau_port, pair_idx).stat (j);
		end;
next_dau_dev:
	     end;

	     end;

	else if mpc_data.type = "mtp" then do;		/* If tape controller ... */
	     tape_sw = "1"b;
	     p = addr (image (mpc_data.dev_stat_addr));	/* Get pointer to statistics block. */

	     call decode_tape_config;
	     ndev, mpc_stat_info.ndev = 0;
	     tape_dev_tablep = addr (image (10000000b));
	     mpc_stat_info.stat_counters (*) = 0;
	     if (mpc_data.model > 502) & (mpc_data.model < 610)
	     then n_pad_words = 7;
	     else n_pad_words = 1;

	     do i = 1 to 8;				/* gather the mpc stat counters */
		mpc_stat_info.stat_counters (i) = mpc_err_stat.ctrs (i);
	     end;

	     if mpc_data.model < 601 then do;
		mpc_stat_info.error_data.int_counter = t500_err_int_ctr;
		mpc_stat_info.error_data.register = t500_err_data.reg;
		mpc_stat_info.error_data.auxar = "0"b;
		mpc_stat_info.error_data.intar = t500_err_data.intar;
		end;

	     else do;
		t600_err_data.pad = "0"b;
		mpc_stat_info.error_data = t600_err_data;
		mpc_stat_info.error_data.intar = mpc_stat_info.error_data.auxar;
		mpc_stat_info.error_data.auxar = "0"b;
		end;

	     if mpc_only then go to fill_poll_mpc;

	     do i = 1 to 16;
		if device_name (i) ^= ""
		then do j = 1 to 8;
		     if tstat.stat (i, j) ^= 0 then go to use_tape;
		end;
		go to next_tape;
use_tape:
		ndev, mpc_stat_info.ndev = ndev + 1;
		found = 0;
		dev_stat_infop = addr (mpc_stat_info.dev_info (ndev));
		dev_stat_info.driveno = device_driveno (i);
		dev_stat_info.subsystem = device_name (i);

		if mpc_data.model < 610 then do;
		     dev_stat_info.model = ltrim (char (mpc_data.model));
		     dev_stat_info.port = t500_dev_table.port (dev_stat_info.driveno);
		     dev_stat_info.opi = t500_dev_table.opi (dev_stat_info.driveno);
		     end;

		else if mpc_data.model = 610 | mpc_data.model = 611 then do;
		     dev_stat_info.port = t600_dev_table.port (dev_stat_info.driveno);
		     dev_stat_info.opi = t600_dev_table.opi (dev_stat_info.driveno);
		     if dev_stat_info.opi
		     then do j = 1 to 7 while (found = 0);
			if j = 2 then j = 3;	/* bypass the GCR bit */
			if substr (t600_dev_table.tape_models (dev_stat_info.driveno), j, 1) = "1"b then do;
			     dev_stat_info.model = tape_model (j);
			     found = 1;
			     end;
		     end;

		     else dev_stat_info.model = "";

		     found = 0;

		     do j = 1 to 4 while (found = 0);
			if substr (t600_dev_table.tm (dev_stat_info.driveno), j, 1) = "1"b then do;
			     dev_stat_info.ca = j - 1;
			     found = 1;
			     end;
		     end;
		     end;

		else go to bad_dev;

		do j = 1 to 8;
		     dev_stat_info.stat (j) = tstat.stat (i, j);
		end;
		do j = 9 to 16;
		     dev_stat_info.stat (j) = 0;
		end;
next_tape:
	     end;
	     end;

	else if mpc_data.type = "msp" & ^dau_sw then do;
	     tape_sw = "0"b;
	     p = addr (image (mpc_data.dev_stat_addr));
	     ndev, mpc_stat_info.ndev = 0;

	     mpc_stat_info.stat_counters = mpc_err_stat.ctrs;
						/* gather mpc stat counters */
	     mpc_stat_info.error_data = dsk_err_data;	/* and the error data reg */
	     if mpc_only then go to fill_poll_mpc;


	     if mpc_data.model < 600 then do;
		cross_barred = substr (mpc_data.config_sw, 11, 1);
		dual_personality = substr (mpc_data.config_sw, 9, 1);
		call decode_disk_config;
		ca_port_tablep = addr (image (100100000b));
		disk_dev_tablep = addr (image (10000000b));
		do i = 1 to 32;

		     if ^d451_dev_table.opi (i) then do;/* If not powered on, see if any stats */
			do j = 1 to 16;
			     if dstat.stat (i, j) ^= 0 then go to use_d451;
			end;
			end;

		     if device_name (i) ^= ""
		     then do j = 1 to 16;
			if dstat.stat (i, j) ^= 0 then go to use_d451;
		     end;

		     go to next_disk1;

use_d451:
		     ndev, mpc_stat_info.ndev = ndev + 1;
		     dev_stat_infop = addr (mpc_stat_info.dev_info (ndev));
		     dev_stat_info.driveno = device_driveno (i);
		     dev_stat_info.subsystem = device_name (i);
		     dev_stat_info.port = d451_dev_table.port (i);
		     dev_stat_info.ca = d451_dev_table.ca (i);
		     if dev_stat_info.ca = 0
		     then k = 0;
		     else k = 16;

		     dev_stat_info.model = ddev_model (ca_port_table.ddev_type (dev_stat_info.port + k));
		     dev_stat_info.opi = d451_dev_table.opi (i);
		     do j = 1 to 16;
			dev_stat_info.stat (j) = dstat.stat (i, j);
		     end;
next_disk1:
		end;
		end;
	     else if mpc_data.model >= 600 then do;
		dual_personality, cross_barred = "0"b;	/* not used on this mpc */
		call decode_disk_config;
		ca_port_tablep = addr (image (101000000b));
		disk_dev_tablep = addr (image (10000000b));
		do i = 1 to 64;

		     if ^d601_dev_table.opi (i) then do;/* If not powered on, see if any stats */
			do j = 1 to 16;
			     if dstat.stat (i, j) ^= 0 then go to use_d601;
			end;
			end;

		     if device_name (i) ^= ""
		     then do j = 1 to 16;
			if dstat.stat (i, j) ^= 0 then go to use_d601;
		     end;

		     go to next_disk2;

use_d601:
		     ndev, mpc_stat_info.ndev = ndev + 1;
		     dev_stat_infop = addr (mpc_stat_info.dev_info (ndev));
		     dev_stat_info.driveno = device_driveno (i);
		     dev_stat_info.subsystem = device_name (i);
		     dev_stat_info.port = d601_dev_table.port (i);
		     dev_stat_info.ca = d601_dev_table.ca (i);
		     if dev_stat_info.ca = 0
		     then k = 0;
		     else k = 16;

		     dev_stat_info.model = ddev_model (ca_port_table.ddev_type (dev_stat_info.port + k));
		     dev_stat_info.opi = d601_dev_table.opi (i);
		     do j = 1 to 16;
			dev_stat_info.stat (j) = dstat.stat (i, j);
		     end;
next_disk2:
		end;
		end;
	     else go to bad_dev;
	     end;


	else if (mpc_data.type = "urp" & ^eurc_sw) then do;
	     mpc_stat_info.error_data = urp_err_data;
	     mpc_stat_info.error_data.intar = mpc_stat_info.error_data.auxar;
	     mpc_stat_info.error_data.auxar = "0"b;
	     mpc_stat_info.ndev = 0;
	     end;


	else do;
bad_dev:
	     if return_info then do;
		arg_code = error_table_$incorrect_device_type;
		return;
		end;
	     else call ioa_$ioa_switch (sw, "^5/^2-How to decode statistics for mpc ^a model ^d not known.",
		     mpc_data.name, mpc_data.model);
	     return;
	     end;


/* *******************************************************************
   *   Now fill the poll_mpc_data structure so it can be displayed   *
   ******************************************************************* */

fill_poll_mpc:
	poll_mpc_data_n_devices = mpc_stat_info.ndev;
	poll_mpc_data_n_stats = 0;
	do i = 1 to mpc_stat_info.ndev;
	     dev_stat_infop = addr (mpc_stat_info.dev_info (i));
	     do j = 1 to hbound (dev_stat_info.stat, 1);
		if dev_stat_info.stat (j) ^= 0 then poll_mpc_data_n_stats = poll_mpc_data_n_stats + 1;
	     end;
	end;
	if ^return_info then call get_temp_segment_ ("stat_mpc_", poll_mpc_datap, code);
	poll_mpc_specp = addr (poll_mpc_data.specific);
	poll_mpc_data.version = poll_mpc_data_version_2;
	poll_mpc_data.name = mpc_stat_info.mpc_name;
	poll_mpc_data.model = mpc_data.model;
	if eurc_sw then do;				/* EURC? */
	     poll_eurc_data.uptime_clock = mpc_stat_info.uptime_clock;
	     poll_eurc_data.core = mpc_stat_info.core;
	     poll_eurc_data.iom = mpc_stat_info.iom;
	     poll_eurc_data.special_controller = mpc_stat_info.special_controller;
	     poll_eurc_data.link_edit = mpc_stat_info.link_edit;
	     poll_eurc_data.pdsi_application = mpc_stat_info.pdsi_application;
	     poll_eurc_data.self_test = mpc_stat_info.self_test;
	     poll_eurc_data.dai_application = mpc_stat_info.dai_application;
	     poll_mpc_data.n_words = size (poll_eurc_data) + 4;
	     end;
	else if dau_sw then do;			/* DAU? (msp800) */
	     poll_dau_data.n_devices = poll_mpc_data_n_devices;
	     poll_dau_data.n_stats = poll_mpc_data_n_stats;
	     poll_dau_data.fw_rev = mpc_data.fw_rev;
	     poll_dau_data.hw_rev = mpc_data.dau_rev;
	     poll_dau_data.ci_0_online = dau_stats.ci_0_online;
	     poll_dau_data.ci_1_online = dau_stats.ci_1_online;
	     poll_dau_data.psi0_2trip = dau_stats.psi0_2trip;
	     poll_dau_data.psi1_2trip = dau_stats.psi1_2trip;
	     poll_dau_data.psi2_2trip = dau_stats.psi2_2trip;
	     poll_dau_data.psi3_2trip = dau_stats.psi3_2trip;
	     poll_dau_data.err_interrupts = dau_stats.err_interrupts;
	     poll_dau_data.psi_cntr (*) = dau_stats.psi_cntr (*);
	     if dau_stats.err_interrupts > 0 then do;
		poll_dau_data.ext_size = 72;
		poll_dau_data.err_info (*) = dau_stats.ext_dau_info (*);
		end;
	     else poll_dau_data.ext_size = 0;
	     poll_mpc_data.n_words = size (poll_dau_data) + 4;
	     end;
	else if (mpc_data.type = "urp" & ^eurc_sw) then do;
						/* old URP */
	     poll_urp_data.interrupt_counter = mpc_stat_info.error_data.int_counter;
	     poll_urp_data.register = mpc_stat_info.error_data.register;
	     poll_urp_data.INTAR = mpc_stat_info.error_data.intar;
	     poll_mpc_data.n_words = size (poll_urp_data) + 4;
	     end;
	else do;					/* old disk & tape */
	     poll_mtp_data.config_sw = mpc_data.config_sw;
	     poll_mtp_data.pad = "0"b;
	     poll_mtp_data.firmware_rev = mpc_data.fw_rev;
	     poll_mtp_data.n_devices = poll_mpc_data_n_devices;
	     poll_mtp_data.n_stats = poll_mpc_data_n_stats;
	     poll_mtp_data.polled_stat_counters = mpc_stat_info.stat_counters;
	     poll_mtp_data.polled_error_data = mpc_stat_info.error_data;
	     poll_mpc_data.n_words = size (poll_mtp_data) + 4;
	     end;

	if mpc_only then go to display_mpc;

	statx = 1;
	do i = 1 to mpc_stat_info.ndev;
	     dev_stat_infop = addr (mpc_stat_info.dev_info (i));
	     if eurc_sw then do;
		poll_eurc_data.subsystem (i) = substr (dev_stat_info.subsystem, 4, 1);
		poll_eurc_data.driveno (i) = dev_stat_info.driveno;
		poll_eurc_data.opi (i) = dev_stat_info.opi;
		poll_eurc_data.ca (i) = dev_stat_info.ca;
		poll_eurc_data.port (i) = dev_stat_info.port;
		poll_eurc_data.dev_model (i) = dev_stat_info.model;
		poll_eurc_data.dev_name (i) = dev_stat_info.subsystem;
		do j = 1 to 16;
		     if dev_stat_info.stat (j) ^= 0 then do;
			poll_eurc_data.dev_index (statx) = i;
			poll_eurc_data.stat_index (statx) = j;
			poll_eurc_data.value (statx) = dev_stat_info.stat (j);
			statx = statx + 1;
			end;
		end;
		poll_mpc_data.n_words = size (poll_eurc_data) + 4;
		end;
	     else if dau_sw then do;
		poll_dau_data.subsystem (i) = substr (dev_stat_info.subsystem, 4, 1);
		poll_dau_data.driveno (i) = dev_stat_info.driveno;
		poll_dau_data.opi (i) = dev_stat_info.opi;
		poll_dau_data.ca (i) = 0;
		poll_dau_data.port (i) = dev_stat_info.port;
		poll_dau_data.dev_model (i) = dev_stat_info.model;
		poll_dau_data.dev_name (i) = dev_stat_info.subsystem;
		do j = 1 to 16;
		     if dev_stat_info.stat (j) ^= 0 then do;
			poll_dau_data.dev_index (statx) = i;
			poll_dau_data.stat_index (statx) = j;
			poll_dau_data.value (statx) = dev_stat_info.stat (j);
			statx = statx + 1;
			end;
		end;
		poll_mpc_data.n_words = size (poll_dau_data) + 4;
		end;
	     else if mpc_data.type = "msp" |		/* old style */
		     mpc_data.type = "mtp" then do;	/* disk or tape */
		poll_mtp_data.subsystem (i) = substr (dev_stat_info.subsystem, 4, 1);
		poll_mtp_data.driveno (i) = dev_stat_info.driveno;
		poll_mtp_data.opi (i) = dev_stat_info.opi;
		poll_mtp_data.ca (i) = dev_stat_info.ca;
		poll_mtp_data.port (i) = dev_stat_info.port;
		poll_mtp_data.dev_model (i) = dev_stat_info.model;
		poll_mtp_data.dev_name (i) = "";
		do j = 1 to 16;
		     if dev_stat_info.stat (j) ^= 0 then do;
			poll_mtp_data.dev_index (statx) = i;
			poll_mtp_data.stat_index (statx) = j;
			poll_mtp_data.value (statx) = dev_stat_info.stat (j);
			statx = statx + 1;
			end;
		end;
		poll_mpc_data.n_words = size (poll_mtp_data) + 4;
		end;
	end;

	if return_info then do;			/* return data */
	     arg_code = 0;
	     return;
	     end;


/* ****************************************************
   *   Now go display the data or place it in a seg    *
   **************************************************** */


	call display_mpc_data_ (poll_mpc_datap, sw, short_sw);
	poll_mpc_specp = null ();
	call release_temp_segment_ ("stat_mpc_", poll_mpc_datap, code);
	return;

display_mpc:
	call display_mpc_data_$display_mpc_ (poll_mpc_datap, sw, short_sw);
	poll_mpc_specp = null ();
	call release_temp_segment_ ("stat_mpc_", poll_mpc_datap, code);
	return;


return_mpc_data:
     entry (image_ptr, arg_poll_mpc_datap, mpc_datap, arg_eurc_sw, arg_code);

	return_info = "1"b;
	poll_mpc_datap = arg_poll_mpc_datap;
	short_sw = "0"b;
	eurc_sw = arg_eurc_sw;
	go to join;

mpc_stats_:
     entry (image_ptr, sw, mpc_datap, arg_short_sw);

	mpc_only = "1"b;
	go to start;

eurc:
     entry (image_ptr, sw, mpc_datap, arg_short_sw);

	eurc_sw = "1"b;
	go to start;

dau_stats_:
     entry (image_ptr, sw, mpc_datap, arg_short_sw);

	mpc_only = "1"b;
	dau_sw = "1"b;
	go to start;

dau:
     entry (image_ptr, sw, mpc_datap, arg_short_sw);

	dau_sw = "1"b;
	go to start;

return_dau_data:
     entry (image_ptr, arg_poll_mpc_datap, mpc_datap, arg_code);

	return_info = "1"b;
	poll_mpc_datap = arg_poll_mpc_datap;
	short_sw = "0"b;
	dau_sw = "1"b;
	go to join;

%page;
/* Procedure to figure out which devices are configured on a EURC and relate
   them to a logical channel on the EURC */

decode_eurc_config:
     proc;

dcl  la fixed bin;
dcl  chan fixed bin (6);

	call config_$find_2 ("mpc", substr (mpc_data.name, 1, 4), mpc_cardp);
	if mpc_cardp = null () then return;
	la = 0;
	eurc_lc_model (*) = 0;
	do chan = mpc_card.chan (1) to (mpc_card.chan (1) + mpc_card.nchan (1) - 1);
	     call find_config_card_$prph_for_channel ((mpc_card.iom (1)), chan, prph_cardp);
	     if prph_cardp ^= null () then do;
		LC (la) = prph_card.name;
		eurc_lc_model (la) = prph_card.model;
		end;
	     la = la + 1;
	end;
	return;

     end decode_eurc_config;

%page;


/* Procedure to figure out what disks are connected to a disk mpc */

decode_disk_config:
     proc;

dcl  la fixed bin;
dcl  drive fixed bin;
dcl  chan fixed bin (6);
dcl  (i, j) fixed bin;

	if processed_mpc () then return;
	do i = 1 to 64;
	     if dual_personality | cross_barred
	     then device_driveno (i) = mod (i - 1, 16) + 1;
	     else device_driveno (i) = i;
	end;

	call config_$find_2 ("mpc", substr (mpc_data.name, 1, 4), mpc_cardp);
	if mpc_cardp = null () then return;
	do la = 1 to 2 while (mpc_card.iom (la) ^= -1);	/* Chase channels on each la */
	     do chan = mpc_card.chan (la) to (mpc_card.chan (la) + mpc_card.nchan (la) - 1);
		call find_config_card_$prph_for_channel ((mpc_card.iom (la)), chan, prph_dsk_cardp);
		if prph_dsk_cardp = null () then go to next_channel;
		if substr (prph_dsk_card.name, 1, 3) ^= "dsk" then go to next_channel;
		drive = 1;
		do i = 1 to hbound (prph_dsk_card.group, 1) while (prph_dsk_card.model (i) ^= -1);
		     do j = 1 to prph_dsk_card.ndrives (i);
			if prph_dsk_card.model (i) ^= 0 then do;
			     if cross_barred then do;
				device_name (drive), device_name (drive + 16) = prph_dsk_card.name;
				end;
			     else if dual_personality then do;
				device_name (16 * (la - 1) + drive) = prph_dsk_card.name;
				end;
			     else do;
				device_name (drive) = prph_dsk_card.name;
				end;
			     end;
			drive = drive + 1;
		     end;
		end;
next_channel:
	     end;
	end;
	return;

     end decode_disk_config;
%page;
decode_tape_config:
     proc;

dcl  la fixed bin;
dcl  drive fixed bin;
dcl  chan fixed bin (6);
dcl  (i, j) fixed bin;

	if processed_mpc () then return;
	call config_$find_2 ("mpc", substr (mpc_data.name, 1, 4), mpc_cardp);
	if mpc_cardp = null () then return;
	do la = 1 to 2 while (mpc_card.iom (la) ^= -1);
	     do chan = mpc_card.chan (la) to (mpc_card.chan (la) + mpc_card.nchan (la) - 1);
		call find_config_card_$prph_for_channel ((mpc_card.iom (la)), chan, prph_tap_cardp);
		if prph_tap_cardp = null () then go to next_channel;
		if substr (prph_tap_card.name, 1, 3) ^= "tap" then go to next_channel;
		drive = 1;
		do i = 1 to hbound (prph_tap_card.group, 1) while (prph_tap_card.model (i) ^= -1);
		     do j = 1 to prph_tap_card.ndrives (i);
			if prph_tap_card.model (i) ^= 0 then do;
			     device_name (drive) = prph_tap_card.name;
			     device_driveno (drive) = drive;
			     end;
			drive = drive + 1;
		     end;
		end;
next_channel:
	     end;
	end;
	return;

     end decode_tape_config;
%page;
processed_mpc:
     proc returns (bit (1));

dcl  i fixed bin;

	do i = 1 to nmpcs;				/* See if already analyzed */
	     if mpc_data.name = mpc_names (i) then do;
		device_namep = mpc_device_names (i);
		device_modelp = mpc_device_models (i);
		device_drivenop = mpc_device_drivenos (i);
		return ("1"b);
		end;
	end;
	allocate device_name;
	allocate device_model;
	allocate device_driveno;
	if nmpcs < hbound (mpc_names, 1) then do;
	     nmpcs = nmpcs + 1;
	     mpc_names (nmpcs) = substr (mpc_data.name, 1, 4);
	     mpc_device_names (nmpcs) = device_namep;
	     mpc_device_models (nmpcs) = device_modelp;
	     mpc_device_drivenos (nmpcs) = device_drivenop;
	     end;

	device_name (*) = "";
	device_model (*) = 0;
	device_driveno (*) = 0;
	return ("0"b);

     end processed_mpc;
%page;
%include config_mpc_card;
%page;
%include config_prph_card;
%page;
%include config_prph_dsk_card;
%page;
%include config_prph_tap_card;
%page;
%include dump_mpc_data;
%page;
%include poll_mpc_data;

     end stat_mpc_;




		    trace_mpc_.pl1                  01/03/85  1514.9rew 01/03/85  1428.8      235188



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */
/* TRACE_MPC_ - Print Trace Table for MPC.
   coded 7/8/75 by Noel I. Morris       */
/* Modified April 1982 by Rich Coppola to add EURC support and fix some bugs */
/* Modified Oct 1982 by Rich Coppola to correct trace of EURC */
/* Modified Jan 1983 by Rich Coppola to correctly translate MPC specials */
/*
   Modified June 1984 by Paul Farley for DAU support and to use a pointer
   parameter to reference the MPC memory image.
   Modified Halloween 1984 by Paul Farley for enhancments to the DAU trace.
*/

/* format: style4,delnl,insnl,ifthenstmt,indnoniterend */

/* ******************************************************
   *                                                    *
   *                                                    *
   * Copyright (c) 1972 by Massachusetts Institute of   *
   * Technology and Honeywell Information Systems, Inc. *
   *                                                    *
   *                                                    *
   ****************************************************** */


trace_mpc_:
     proc (image_ptr, sw, mpc_datap);

dcl  image_ptr ptr parameter;
dcl  image (0:4095) bit (16) unal based (image_ptr);	/* MPC memory image */
dcl  sw ptr;					/* IOX_ switch for output */

dcl  p ptr,					/* Pointer to trace word */
     eurc_trace_ptr ptr,				/* Pointer to EURC trace */
     word bit (16) aligned,				/* Trace word */
     loc fixed bin (16),				/* Current location in trace */
     dt char (24);					/* Current date and time */

dcl  1 mword based (p) aligned,			/* MPC trace word format */
       (
       2 st bit (1),				/* "1"b if status word */
       2 a bit (7),					/* First half info */
       2 type bit (2),				/* Trace word type */
       2 b bit (6)
       ) unal;					/* Second half info */

dcl  1 uword based (p) aligned,			/* URMPC trace word format */
       (
       2 type bit (2),				/* Trace word type */
       2 code bit (6),				/* Info */
       2 device bit (4),				/* Device number */
       2 pad bit (4)
       ) unal;

dcl  1 spec_uword based (p) aligned,
       (
       2 type bit (8),				/* SPECIAL TYPE */
       2 opi bit (4),				/* mux port opi change */
       2 opic bit (4)
       ) unal;					/* mux port opi-C */

dcl  1 eurc_trace (0:15) based (eurc_trace_ptr) unal,
       (
       2 module bit (4),				/* The calling module */
       2 pad1 bit (2),
       2 LCN bit (2),
       2 reason bit (8),
       2 pad2 bit (1),
       2 command bit (3),
       2 major_status bit (4),
       2 pad3 bit (2),
       2 minor_status bit (6),
       2 pad4 bit (2),
       2 chan_status bit (6),
       2 card_state bit (4),
       2 card_substate bit (4),
       2 print_state bit (4),
       2 print_substate bit (4),
       2 iom_state bit (4),
       2 iom_substate bit (4),
       2 tnd_state bit (4),
       2 tnd_substate bit (4),
       2 queue_id bit (4),
       2 link_status bit (4),
       2 pad5 bit (2),
       2 idcw_op bit (6),
       2 pad6 bit (2),
       2 idcw_dev bit (6),
       2 pad7 bit (2),
       2 idcw_add_ext bit (6),
       2 pad8 bit (2),
       2 idcw_flags bit (6),
       2 pad9 bit (2),
       2 idcw_chan_inst bit (6),
       2 pad10 bit (2),
       2 idcw_rec_tly bit (6)
       ) unal;


dcl  ioa_$ioa_switch entry options (variable);
dcl  date_time_ entry (fixed bin (52), char (*));
dcl  urp_sw bit (1) init ("0"b);
dcl  STR char (25) var init ("");
dcl  i fixed bin;
dcl  (addr, clock, substr, bin, bit, fixed, length) builtin;

dcl  mth_spec_type (7) char (15) var int static options (constant)
	init ("REWIND COMPLETE", "UNLOAD COMPLETE", "MTH READY", "MTH in STANDBY", "STANDBY LOADED", "RELEASED",
	"MTH MALFUNCTION");

dcl  urc_svc_codes (0:15) char (45) var int static options (constant)
	init ("PRT WENT FROM HALT TO READY.", "PRINT ONE LINE OR CRZ/CPZ READY.",
	"FWD SPACE ONE LINE OR CRZ/CPZ RELEASED.", "FWD SPACE TO T.O.P.", "INVALID LINE.",
	"OPERATOR KILLED THIS REPORT.", "BACKUP ONE LINE & REPRINT.", "BACKUP ONE PAGE & REPRINT.", "UNDEFINED",
	"UNDEFINED", "UNDEFINED", "UNDEFINED", "UNDEFINED", "TERMINATE THIS CHANNEL PROGRAM.", "UNDEFINED", "UNDEFINED")
	;

dcl  eurc_module (0:15) char (15) var int static options (constant)
	init ("CORE", "UNDEFINED", "PR54", "CARD", "IOM", "PR71", "PR54", "UNDEFINED", "LINK", "UNDEFINED", "UNDEFINED",
	"UNDEFINED", "UNDEFINED", "SCC", "FIRMWARE ERROR", "UNDEFINED");
%page;

	p = addr (word);				/* Get pointer to trace word. */

	call date_time_ (clock (), dt);		/* Get current date and time. */

	if substr (mpc_data.type, 1, 3) = "urp" then urp_sw = "1"b;

	call ioa_$ioa_switch (sw, "^|^5xTrace of ^a controller. ^[FW Rev. ^a^;^s^]^3x^a^/", mpc_data.name, ^urp_sw,
	     mpc_data.fw_rev, dt);


	do loc = mpc_data.trace_start to (mpc_data.trace_start + mpc_data.trace_size - 1);
						/* Iterate through the trace table. */
	     if loc = mpc_data.trace_cur
	     then					/* If at current position of trace ... */
		call ioa_$ioa_switch (sw, "**************************************************");

	     word = image (loc);			/* Get word from trace. */
	     if word = "0"b then go to skip_zeroes;

	     if word = "ffff"b4 then do;
		call ioa_$ioa_switch (sw, "^4.4b^-Unknown trace type (FFFF).");
		go to skip_zeroes;
		end;

	     if mpc_data.type = "urp" then do;		/* If tracing URMPC ... */
		if spec_uword.type = "fe"b4
		then call ioa_$ioa_switch (sw, "^4.4b^-DEVICE POWER CHANGE^-^[OPI CHANGED on MUX PORT=^4b^]", word,
			spec_uword.opic, spec_uword.opic);

		else if spec_uword.type = "ff"b4 then call ioa_$ioa_switch (sw, "^4.4b^-OPI DROPPED", word);

		else if spec_uword.type = "7f"b4 then call ioa_$ioa_switch (sw, "^4.4b^-MPC ERROR INTERRUPT", word);

		else if uword.type = "00"b
		then				/* Type 00 = COMMAND */
		     call ioa_$ioa_switch (sw, "^4.4b^-COMMAND^-OPCODE=^2.3b^2-DEVICE PORT=^4b", word, uword.code,
			uword.device);
		else if uword.type = "01"b
		then				/* Type 01 = STATUS */
		     call ioa_$ioa_switch (sw, "^4.4b^-TERMINATE STATUS^-MAJOR=^2.3b^-DEVICE PORT=^4b^/", word,
			uword.code, uword.device);
		else if uword.type = "10"b
		then				/* Type 10 = SPECIAL */
		     call ioa_$ioa_switch (sw,
			"^4.4b^-SPECIAL INTERRUPT STORED^-LA=^1b,PSI=^1b,LOG-CHAN=^3b,DEVICE PORT=^4b", word,
			substr (uword.code, 2, 1), substr (uword.code, 3, 1), substr (uword.code, 4, 3),
			uword.device);
		else if uword.type = "11"b
		then				/* Type 11 = INTERRUPT */
		     call ioa_$ioa_switch (sw, "^4.4b^-INTERRUPT^-SERVICE CODE=^4b^-DEVICE PORT=^4b^/^-^a", word,
			substr (uword.code, 3), uword.device, urc_svc_codes (bin (substr (uword.code, 3, 4), 4)));
		go to skip_zeroes;
		end;


	     else if ((substr (mpc_data.type, 1, 3) = "mtp") & mpc_data.model = 610) then do;
						/* If MTP610 */
		if mword.st then do;		/* IIW STATUS */
		     if mword.type = "10"b
		     then call ioa_$ioa_switch (sw,
			     "^4.4b^-IIW STATUS^-FAULT BYTE=^2.4b^-TCA=^1b,PSI=^1b,LOG-CHAN=^1b^/", word,
			     substr (word, 7, 2) || substr (word, 11, 6), substr (word, 2, 1), substr (word, 3, 1),
			     substr (word, 4, 1));
		     else if mword.type = "11"b then do;/* either MPC or dev special status */
			if mword.b = "0"b
			then			/* MPC special */
			     call ioa_$ioa_switch (sw,
				"^4.4b^-MPC SPECIAL STATUS TYPE=^[SUSPEND^]^[RELEASE^]^-TCA=^1b,PSI=^1b,LOG-CHAN=^1b^/"
				, word, substr (word, 8, 1), substr (word, 7, 1), substr (word, 2, 1),
				substr (word, 3, 1), substr (word, 4, 1));
			else do;			/* DEVICE SPECIAL STATUS */
			     STR = "";
			     do i = 1 to 7 while (STR = "");
				if substr (word, i + 1, 1) then STR = mth_spec_type (i);
			     end;
			     call ioa_$ioa_switch (sw, "^4.4b^-SPECIAL^-TYPE=^8b^-DEVICE=^2.3b (^a)", word,
				substr (word, 1, 8), mword.b, STR);
			     end;
			end;
		     end;

/* This must be checked TWICE as bit 0 'mword.st' may or may not be on for this
   trace type */

		if (mword.type = "11"b & mword.b ^= "0"b) then do;
						/* DEVICE SPECIAL STATUS */
		     STR = "";
		     do i = 1 to 7 while (STR = "");
			if substr (word, i + 1, 1) then STR = mth_spec_type (i);
		     end;
		     call ioa_$ioa_switch (sw, "^4.4b^-SPECIAL^-TYPE=^8b^-DEVICE=^2.3b (^a)", word,
			substr (word, 1, 8), mword.b, STR);
		     end;

		if mword.type = "00"b
		then				/* INCOMING IDCW */
		     call ioa_$ioa_switch (sw, "^4.4b^-INCOMING IDCW^2-DEVICE=^2.3b^-TCA=^1b,PSI=^1b,LOG-CHAN=^1b",
			word, mword.b, substr (word, 2, 1), substr (word, 3, 1), substr (word, 4, 1));

		else if mword.type = "01"b
		then				/* EXECUTION IDCW */
		     call ioa_$ioa_switch (sw, "^4.4b^-IDCW EXECUTION^-OP=^2.3b^-DEVICE=^2.3b", word,
			substr (word, 3, 6), mword.b);

		else if mword.type = "10"b
		then				/* TERM STATUS */
		     call ioa_$ioa_switch (sw,
			"^4.4b^-TERMINATE STATUS^-MAJOR=^2.3b^-SUB=^2.3b^-TCA=^1b,PSI=^1b,LOG-CHAN=^1b^/", word,
			"00"b || substr (word, 5, 4), mword.b, substr (word, 2, 1), substr (word, 3, 1),
			substr (word, 4, 1));
		go to skip_zeroes;
		end;				/* If not URMPC or MTP610 ... */
	     if mword.st
	     then					/* If status ... */
		call ioa_$ioa_switch (sw,
		     "^4.4b^-TERMINATE STATUS^-MAJOR=^2.3b^-SUB=^2.3b^-LA=^1b,PSI=^1b,LOG-CHAN=^.3b^/", word,
		     "00"b || substr (word, 7, 4), mword.b, substr (mword.a, 1, 1), substr (mword.a, 2, 1),
		     substr (mword.a, 3, 3));
	     else					/* If not status ... */
		if mword.type = "00"b
	     then					/* Type 00 = COMMAND */
		call ioa_$ioa_switch (sw, "^4.4b^-COMMAND^2-OP=^2.3b^-DEVICE=^2.3b", word, substr (mword.a, 2, 6),
		     mword.b);


	     else if mword.type = "10"b
	     then					/* Type 10 = IDCW */
		call ioa_$ioa_switch (sw, "^4.4b^-IDCW^3-DEVICE=^2.3b^-LA=^1b,PSI=^1b,LOG-CHAN=^.3b", word, mword.b,
		     substr (mword.a, 1, 1), substr (mword.a, 2, 1), substr (mword.a, 3, 3));
	     else if mword.type = "11"b then do;	/* Type 11 = SPECIAL */
		if substr (mpc_data.type, 1, 3) = "mtp" then do;
		     STR = "";
		     do i = 1 to 7 while (STR = "");
			if substr (mword.a, i + 1, 1) = "1"b then STR = mth_spec_type (i);
		     end;

		     call ioa_$ioa_switch (sw, "^4.4b^-SPECIAL^-TYPE=^8b^-DEVICE=^2.3b^/^a", word, mword.a, mword.b,
			STR);
		     end;

		else do;
		     if substr (word, 9, 3) = "111"b
		     then				/* RPS TYPE */
			call ioa_$ioa_switch (sw, "^4.4b^-RPS FLAG^3-DEVICE=^2.3b", word, "0"b || substr (word, 12))
			     ;

		     else call ioa_$ioa_switch (sw,
			     "^4.4b^-SPECIAL^-TYPE=^2b^2-DEVICE=^2.3b^-LA=^1b,PSI=^1b,LOG-CHAN=^.3b", word,
			     substr (mword.a, 6, 2), mword.b, substr (mword.a, 1, 1), substr (mword.a, 2, 1),
			     substr (mword.a, 3, 3));
		     end;
		end;

	     else if mword.type = "01"b
	     then					/* Type 01 = POLLING */
		if substr (mpc_data.type, 1, 3) = "msp"
		then call ioa_$ioa_switch (sw, "^4.4b^-POLLING^2-CA=^2b", word, substr (mword.b, 5));


skip_zeroes:
	end;
	return;

trace_mpc_$eurc:
     entry (image_ptr, sw, mpc_datap);

	call date_time_ (clock (), dt);		/* Get current date and time. */
	call ioa_$ioa_switch (sw, "^|^5xTrace of ^a controller.^3x^a^/", mpc_data.name, dt);

	eurc_trace_ptr = image_ptr;

	do loc = 0 to 15;				/* 16 entries, 16 bytes each */
	     call ioa_$ioa_switch (sw, "^2.4b^-MODULE=^a^-LOG-CHAN=^.2b",
		eurc_trace (loc).module || eurc_trace (loc).pad1 || eurc_trace (loc).LCN,
		eurc_module (bin (eurc_trace (loc).module, 4)), eurc_trace (loc).LCN);
	     call ioa_$ioa_switch (sw, "^2.4b^-REASON=^2.4b", eurc_trace (loc).reason, eurc_trace (loc).reason);
	     call ioa_$ioa_switch (sw, "^2.4b^-COMMAND=^.3b^2-^2xMAJOR STATUS=^2.3b",
		eurc_trace (loc).pad2 || eurc_trace (loc).command || eurc_trace (loc).major_status,
		eurc_trace (loc).command, "00"b || eurc_trace (loc).major_status);
	     call ioa_$ioa_switch (sw, "^2.4b^3-^4xSUB STATUS=^2.3b",
		eurc_trace (loc).pad3 || eurc_trace (loc).minor_status, eurc_trace (loc).minor_status);
	     call ioa_$ioa_switch (sw, "^2.4b^3-CHANNEL STATUS=^2.3b",
		eurc_trace (loc).pad4 || eurc_trace (loc).chan_status, eurc_trace (loc).chan_status);
	     call ioa_$ioa_switch (sw, "^2.4b^-CARD STATE=^.4b^-SUBSTATE=^.4b",
		eurc_trace (loc).card_state || eurc_trace (loc).card_substate, eurc_trace (loc).card_state,
		eurc_trace (loc).card_substate);
	     call ioa_$ioa_switch (sw, "^2.4b^-PRINT STATE=^.4b^-SUBSTATE=^.4b",
		eurc_trace (loc).print_state || eurc_trace (loc).print_substate, eurc_trace (loc).print_state,
		eurc_trace (loc).print_substate);
	     call ioa_$ioa_switch (sw, "^2.4b^-IOM STATE=^.4b^-SUBSTATE=^.4b",
		eurc_trace (loc).iom_state || eurc_trace (loc).iom_substate, eurc_trace (loc).iom_state,
		eurc_trace (loc).iom_substate);
	     call ioa_$ioa_switch (sw, "^2.4b^-TND STATE=^.4b^-SUBSTATE=^.4b",
		eurc_trace (loc).tnd_state || eurc_trace (loc).tnd_substate, eurc_trace (loc).tnd_state,
		eurc_trace (loc).tnd_substate);
	     call ioa_$ioa_switch (sw, "^2.4b^-QUEUE ID=^.4b^-LINK STATUS=^.4b",
		eurc_trace (loc).queue_id || eurc_trace (loc).link_status, eurc_trace (loc).queue_id,
		eurc_trace (loc).link_status);
	     call ioa_$ioa_switch (sw, "^2.4b^-IDCW OP CODE^-^2.3b^/^2.4b^-IDCW DEVICE ADDRESS^-^2.3b",
		eurc_trace (loc).pad5 || eurc_trace (loc).idcw_op, eurc_trace (loc).idcw_op,
		eurc_trace (loc).pad6 || eurc_trace (loc).idcw_dev, eurc_trace (loc).idcw_dev);
	     call ioa_$ioa_switch (sw, "^2.4b^-IDCW ADDR EXTENSION^-^o^/^2.4b^-IDCW FLAGS^-^6b",
		eurc_trace (loc).pad7 || eurc_trace (loc).idcw_add_ext, eurc_trace (loc).idcw_add_ext,
		eurc_trace (loc).pad8 || eurc_trace (loc).idcw_flags, eurc_trace (loc).idcw_flags);
	     call ioa_$ioa_switch (sw, "^2.4b^-IDCW CHAN INSTR^-^2.3b^/^2.4b^-IDCW RECORD TALLY^-^2.3b",
		eurc_trace (loc).pad9 || eurc_trace (loc).idcw_chan_inst, eurc_trace (loc).idcw_chan_inst,
		eurc_trace (loc).pad10 || eurc_trace (loc).idcw_rec_tly, eurc_trace (loc).idcw_rec_tly);

	     call ioa_$ioa_switch (sw, "----------------------------------------------------------------------------");
	end;
	return;
%page;
trace_mpc_$dau:
     entry (image_ptr, sw, mpc_datap);

dcl  dau_image (0:127) bit (16) unal based (image_ptr);	/* DAU trace table */
dcl  dau_image_for_eight (8) bit (16) unal based (eight_ptr);
dcl  DH (6) bit (16) unal;
dcl  (hold_idx, poll_rpt_cnt) fixed bin;
dcl  spec_mess char (80) var;
dcl  dau_addr fixed bin (8) uns;
dcl  (eight_ptr, key_ptr) ptr;
dcl  1 key unal based (key_ptr),
       2 F bit (4),
       2 Index fixed bin (4) uns unal,
       2 mbz bit (2),
       2 PSI fixed bin (2) uns unal,
       2 mbz1 bit (1),
       2 LC fixed bin (3) uns unal;

	call date_time_ (clock (), dt);		/* Get current date and time. */
	call ioa_$ioa_switch (sw, "^|^5xTrace of ^a controller.^3x^a^/", mpc_data.name, dt);
	hold_idx = 0;
	do loc = 0 to 127;
	     if substr (dau_image (loc), 1, 4) = "f"b4 then do;
		key_ptr = addr (dau_image (loc));
		goto Ftype (key.Index);
		end;
stow_away:
	     if hold_idx > 0
	     then do i = hold_idx to 1 by -1;		/* move data down */
		DH (i + 1) = DH (i);
	     end;
	     DH (1) = dau_image (loc);		/* save data */
	     hold_idx = hold_idx + 1;			/* update index */
next_loc:
	end;

	call ioa_$ioa_switch (sw, "^/^60(=^)^2/^5xRaw Trace Table Data^/");

	dau_addr = 0;
	do loc = 0 to 127 by 8;
	     eight_ptr = addr (dau_image (loc));
	     call ioa_$ioa_switch (sw, "^10x^2.4b ^8(  ^4.4b^)", bit (dau_addr, 8), dau_image_for_eight);
	     if loc ^= 120 then dau_addr = dau_addr + 16;
	end;

	return;					/* All done! */

Ftype (0):
	if key.mbz ^= "0"b |			/* Check KEY */
	     key.mbz1 ^= "0"b
	then goto stow_away;
	if hold_idx < 2 then do;			/* Not enough! */
	     if hold_idx = 0
	     then call ioa_$ioa_switch (sw, "(PSI-^d, LC-^d) Initial IDCW Recieved. [BOTH DATA WORDS MISSING!]",
		     key.PSI, key.LC);
	     else call ioa_$ioa_switch (sw,
		     "(PSI-^d, LC-^d) Initial IDCW Recieved. OP Code= ^1.3b^1.3b, Device= ^2.3b [LAST DATA WORD MISSING!]"
		     , key.PSI, key.LC, substr (DH (1), 2, 3), substr (DH (1), 6, 3), substr (DH (1), 11, 6));
	     hold_idx = 0;
	     goto next_loc;
	     end;
	call ioa_$ioa_switch (sw,
	     "(PSI-^d, LC-^d) Initial IDCW Recieved. OP Code= ^1.3b^1.3b, Device= ^2.3b^[^[^/^36x^]^[ (Marker)^; (Continue)^; (Continue-Marker)^]^[ (Channel inst.=^2.3b)^]^]"
	     , key.PSI, key.LC, substr (DH (1), 2, 3), substr (DH (1), 6, 3), substr (DH (1), 11, 6),
	     (substr (DH (2), 9, 8) ^= "0"b), (substr (DH (2), 11, 6) ^= "0"b & substr (DH (2), 9, 2) ^= "0"b),
	     fixed (substr (DH (2), 9, 2)), (substr (DH (2), 11, 6) ^= "0"b), substr (DH (2), 11, 6));
	hold_idx = 0;
	goto next_loc;

Ftype (1):
	if key.mbz ^= "0"b |			/* Check KEY */
	     key.mbz1 ^= "0"b
	then goto stow_away;
	if hold_idx ^= 0 then goto stow_away;		/* Should be ZERO */
	call ioa_$ioa_switch (sw, "(PSI-^d, LC-^d) Initial IDCW Initiated (from CPW Queue).", key.PSI, key.LC);
	goto next_loc;

Ftype (2):
	if key.mbz ^= "0"b |			/* Check KEY */
	     key.mbz1 ^= "0"b
	then goto stow_away;
	if hold_idx < 1 then do;			/* Not enough! */
	     call ioa_$ioa_switch (sw, "(PSI-^d, LC-^d) Seek Command Initiated. [DATA WORD MISSING!]", key.PSI, key.LC);
	     hold_idx = 0;
	     goto next_loc;
	     end;
	call ioa_$ioa_switch (sw, "(PSI-^d, LC-^d) Seek Command Initiated. Cylinder/Head= ^d/^d", key.PSI, key.LC,
	     fixed (substr (DH (1), 9, 2) || substr (DH (1), 1, 8)), fixed (substr (DH (1), 11, 6)));
	hold_idx = 0;
	goto next_loc;

Ftype (3):
	if key.mbz ^= "0"b |			/* Check KEY */
	     key.mbz1 ^= "0"b
	then goto stow_away;
	if hold_idx < 1 then do;			/* Not enough! */
	     call ioa_$ioa_switch (sw, "(PSI-^d, LC-^d) Continue IDCW Initiated. [DATA WORD MISSING!]", key.PSI, key.LC)
		;
	     hold_idx = 0;
	     goto next_loc;
	     end;
	call ioa_$ioa_switch (sw,
	     "(PSI-^d, LC-^d) Continue IDCW Initiated. OP Code= ^1.3b^1.3b^[^[^/^38x^]^[ (Marker)^; (Continue)^; (Continue-Marker)^]^[ (Channel inst.=^2.3b)^]^]"
	     , key.PSI, key.LC, substr (DH (1), 2, 3), substr (DH (1), 6, 3), (substr (DH (1), 9, 8) ^= "0"b),
	     (substr (DH (1), 11, 6) ^= "0"b & substr (DH (1), 9, 2) ^= "0"b), fixed (substr (DH (1), 9, 2)),
	     (substr (DH (1), 11, 6) ^= "0"b), substr (DH (1), 11, 6));
	hold_idx = 0;
	goto next_loc;

Ftype (4):
	if key.mbz ^= "0"b |			/* Check KEY */
	     key.mbz1 ^= "0"b
	then goto stow_away;
	if hold_idx < 1 then do;			/* Not enough! */
	     call ioa_$ioa_switch (sw, "(PSI-^d, LC-^d) Read Operation Started. [DATA WORD MISSING!]", key.PSI, key.LC);
	     hold_idx = 0;
	     goto next_loc;
	     end;
	call ioa_$ioa_switch (sw, "(PSI-^d, LC-^d) Read Operation Started. ^d Record^[^;s^] Transfered.", key.PSI,
	     key.LC, fixed (DH (1)), (fixed (DH (1)) = 1));
	hold_idx = 0;
	goto next_loc;

Ftype (5):
	if key.mbz ^= "0"b |			/* Check KEY */
	     key.mbz1 ^= "0"b
	then goto stow_away;
	if hold_idx < 1 then do;			/* Not enough! */
	     call ioa_$ioa_switch (sw, "(PSI-^d, LC-^d) Write Operation Started. [DATA WORD MISSING!]", key.PSI, key.LC)
		;
	     hold_idx = 0;
	     goto next_loc;
	     end;
	call ioa_$ioa_switch (sw, "(PSI-^d, LC-^d) Write Operation Started. ^d Record^[^;s^] Transfered.", key.PSI,
	     key.LC, fixed (DH (1)), (fixed (DH (1)) = 1));
	hold_idx = 0;
	goto next_loc;

Ftype (6):
	if key.mbz ^= "0"b |			/* Check KEY */
	     key.mbz1 ^= "0"b
	then goto stow_away;
	if hold_idx < 1 then do;			/* Not enough! */
	     call ioa_$ioa_switch (sw, "(PSI-^d, LC-^d) Termination Status. [DATA WORD MISSING!]", key.PSI, key.LC);
	     hold_idx = 0;
	     goto next_loc;
	     end;
	call ioa_$ioa_switch (sw, "(PSI-^d, LC-^d) Termination Status (^1.3b^1.3b/^1.3b^1.3b).", key.PSI, key.LC,
	     substr (DH (1), 2, 3), substr (DH (1), 6, 3), substr (DH (1), 10, 3), substr (DH (1), 14, 3));
	hold_idx = 0;
	goto next_loc;

Ftype (7):
	if key.mbz ^= "0"b |			/* Check KEY */
	     key.mbz1 ^= "0"b
	then goto stow_away;
	if hold_idx ^= 0 then goto stow_away;		/* Should be ZERO */
	call ioa_$ioa_switch (sw, "(PSI-^d, LC-^d) Device Released.", key.PSI, key.LC);
	goto next_loc;

Ftype (8):
Ftype (9):
	goto stow_away;				/* Must be data */

Ftype (10):
	if key.mbz ^= "0"b | key.mbz1 ^= "0"b |		/* Check KEY */
	     key.LC ^= 0
	then goto stow_away;
	if hold_idx < 1 then do;			/* Not enough! */
	     call ioa_$ioa_switch (sw, "^4x(PSI-^d)^3xAbort Status. [DATA WORD MISSING!]", key.PSI);
	     hold_idx = 0;
	     goto next_loc;
	     end;
	call ioa_$ioa_switch (sw,
	     "^4x(PSI-^d)^3xAbort Status (^[Channel/IOM status= ^1.3b/^1.3b^4s^;^2sMaj/Sub status= ^1.3b^1.3b/^1.3b^1.3b^])."
	     , key.PSI, (substr (DH (1), 1, 8) = "0"b), substr (DH (1), 10, 3), substr (DH (1), 14, 3),
	     substr (DH (1), 2, 3), substr (DH (1), 6, 3), substr (DH (1), 10, 3), substr (DH (1), 14, 3));
	hold_idx = 0;
	goto next_loc;

Ftype (11):
	if key.mbz ^= "0"b | key.mbz1 ^= "0"b |		/* Check KEY */
	     key.LC ^= 0
	then goto stow_away;
	if hold_idx < 1 then do;			/* Not enough! */
	     call ioa_$ioa_switch (sw, "^4x(PSI-^d)^3xIIW Processing Initiated. [DATA WORD MISSING!]", key.PSI);
	     hold_idx = 0;
	     goto next_loc;
	     end;
	call ioa_$ioa_switch (sw, "^4x(PSI-^d)^3xIIW Processing Initiated. Fault Byte= ^2.4b, Device= ^2.3b", key.PSI,
	     substr (DH (1), 1, 8), substr (DH (1), 11, 6));
	hold_idx = 0;
	goto next_loc;

Ftype (12):
	if key.mbz ^= "0"b | key.mbz1 ^= "0"b |		/* Check KEY */
	     key.LC ^= 0
	then goto stow_away;
	if hold_idx ^= 0 then goto stow_away;		/* Should be ZERO */
	call ioa_$ioa_switch (sw, "^4x(PSI-^d)^3xDrop of OPerational In (OPI).", key.PSI);
	goto next_loc;

Ftype (13):
	if key.mbz ^= "0"b | key.mbz1 ^= "0"b |		/* Check KEY */
	     key.LC ^= 0
	then goto stow_away;
	if hold_idx < 1 then do;			/* Not enough! */
	     call ioa_$ioa_switch (sw, "^4x(PSI-^d)^3xSpecial Interrupt. [DATA WORD MISSING!]", key.PSI);
	     hold_idx = 0;
	     goto next_loc;
	     end;
	call ioa_$ioa_switch (sw, "^4x(PSI-^d)^3xSpecial Interrupt. Special Type= ^2.4b, Device= ^2.3b", key.PSI,
	     substr (DH (1), 1, 8), substr (DH (1), 11, 6));
	spec_mess = "";
	if substr (DH (1), 1, 1) then spec_mess = spec_mess || "Alt Channel in Control, ";
	if substr (DH (1), 8, 1) then spec_mess = spec_mess || "Disc Powered ON/Suspend, ";
	if substr (DH (1), 7, 1) then spec_mess = spec_mess || "Device Released, ";
	if substr (DH (1), 6, 1) then spec_mess = spec_mess || "Disc Powered OFF, ";
	if spec_mess ^= "" then call ioa_$ioa_switch (sw, "^33x(^a)", substr (spec_mess, 1, length (spec_mess) - 2));
	hold_idx = 0;
	goto next_loc;

Ftype (14):
	if key.mbz ^= "0"b | key.mbz1 ^= "0"b |		/* Check KEY */
	     key.LC ^= 0
	then goto stow_away;
	if hold_idx < 5 then do;			/* Not enough! */
	     if hold_idx = 0
	     then call ioa_$ioa_switch (sw, "^4x(PSI-^d)^3xHardware Interrupt. [ALL FIVE DATA WORDS MISSING!]", key.PSI)
		     ;
	     else if hold_idx = 1
	     then call ioa_$ioa_switch (sw,
		     "^4x(PSI-^d)^3xHardware Interrupt. Instruction PTR= ^4.4b. [FOUR DATA WORDS MISSING!]", key.PSI,
		     DH (1));
	     else if hold_idx = 2
	     then call ioa_$ioa_switch (sw,
		     "^4x(PSI-^d)^3xHardware Interrupt. Instruction PTR= ^4.4b, OP Code= ^1.3b^1.3b, Device= ^2.3b. [THREE DATA WORDS MISSING!]"
		     , key.PSI, DH (1), substr (DH (2), 2, 3), substr (DH (2), 6, 3), substr (DH (2), 11, 6));
	     else if hold_idx = 3 then do;
		call ioa_$ioa_switch (sw,
		     "^4x(PSI-^d)^3xHardware Interrupt. Instruction PTR= ^4.4b, OP Code= ^1.3b^1.3b, Device= ^2.3b",
		     key.PSI, DH (1), substr (DH (2), 2, 3), substr (DH (2), 6, 3), substr (DH (2), 11, 6));
		call ioa_$ioa_switch (sw, "^35xci_status= ^2.4b, psi_status= ^2.4b. [TWO DATA WORDS MISSING!]",
		     substr (DH (3), 1, 8), substr (DH (3), 9, 8));
		end;
	     else do;
		call ioa_$ioa_switch (sw,
		     "^4x(PSI-^d)^3xHardware Interrupt. Instruction PTR= ^4.4b, OP Code= ^1.3b^1.3b, Device= ^2.3b",
		     key.PSI, DH (1), substr (DH (2), 2, 3), substr (DH (2), 6, 3), substr (DH (2), 11, 6));
		call ioa_$ioa_switch (sw, "^35xci_status= ^2.4b, psi_status= ^2.4b, seq_status= ^2.4b",
		     substr (DH (3), 1, 8), substr (DH (3), 9, 8), substr (DH (4), 1, 8));
		call ioa_$ioa_switch (sw, "^35xseq_s1= ^2.4b. [LAST DATA WORD MISSING!]", substr (DH (4), 9, 8));
		end;
	     hold_idx = 0;
	     goto next_loc;
	     end;
	call ioa_$ioa_switch (sw,
	     "^4x(PSI-^d)^3xHardware Interrupt. Instruction PTR= ^4.4b, OP Code= ^1.3b^1.3b, Device= ^2.3b", key.PSI,
	     DH (1), substr (DH (2), 2, 3), substr (DH (2), 6, 3), substr (DH (2), 11, 6));
	call ioa_$ioa_switch (sw, "^35xci_status= ^2.4b, psi_status= ^2.4b, seq_status= ^2.4b", substr (DH (3), 1, 8),
	     substr (DH (3), 9, 8), substr (DH (4), 1, 8));
	call ioa_$ioa_switch (sw, "^35xseq_s1= ^2.4b, buf_status= ^2.4b, mp_status= ^2.4b", substr (DH (4), 9, 8),
	     substr (DH (5), 1, 8), substr (DH (5), 9, 8));
	hold_idx = 0;
	goto next_loc;

Ftype (15):
	if hold_idx ^= 0 then do;			/* Should be ZERO */
	     if hold_idx = 1 & DH (1) = ""b
	     then hold_idx = 0;			/* ignore */
	     else goto stow_away;			/* save */
	     end;
	if substr (dau_image (loc), 9, 8) = "ff"b4 then do;
	     poll_rpt_cnt = 0;
	     do loc = loc to 126 while (dau_image (loc + 1) = "ffff"b4);
						/* count multiples */
		poll_rpt_cnt = poll_rpt_cnt + 1;
	     end;
	     call ioa_$ioa_switch (sw, "^4x-------^3x***** DAU Initialization *****^[ (Repeats ^d time^[s^])^]",
		(poll_rpt_cnt ^= 0), poll_rpt_cnt, (poll_rpt_cnt > 1));
	     goto next_loc;
	     end;
	if dau_image (loc) ^= "fffe"b4 then goto stow_away;
						/* must be data */
	poll_rpt_cnt = 0;
	do loc = loc to 126 while (dau_image (loc + 1) = "fffe"b4);
						/* count multiples */
	     poll_rpt_cnt = poll_rpt_cnt + 1;
	end;
	call ioa_$ioa_switch (sw, "^4x-------^3xDevice Polling^[ (Repeats ^d time^[s^])^]", (poll_rpt_cnt ^= 0),
	     poll_rpt_cnt, (poll_rpt_cnt > 1));
	goto next_loc;
%page;
%include dump_mpc_data;


     end trace_mpc_;




		    bull_copyright_notice.txt       08/30/05  1008.4r   08/30/05  1007.3    00020025

                                          -----------------------------------------------------------


Historical Background

This edition of the Multics software materials and documentation is provided and donated
to Massachusetts Institute of Technology by Group Bull including Bull HN Information Systems Inc. 
as a contribution to computer science knowledge.  
This donation is made also to give evidence of the common contributions of Massachusetts Institute of Technology,
Bell Laboratories, General Electric, Honeywell Information Systems Inc., Honeywell Bull Inc., Groupe Bull
and Bull HN Information Systems Inc. to the development of this operating system. 
Multics development was initiated by Massachusetts Institute of Technology Project MAC (1963-1970),
renamed the MIT Laboratory for Computer Science and Artificial Intelligence in the mid 1970s, under the leadership
of Professor Fernando Jose Corbato.Users consider that Multics provided the best software architecture for 
managing computer hardware properly and for executing programs. Many subsequent operating systems
incorporated Multics principles.
Multics was distributed in 1975 to 2000 by Group Bull in Europe , and in the U.S. by Bull HN Information Systems Inc., 
as successor in interest by change in name only to Honeywell Bull Inc. and Honeywell Information Systems Inc. .

                                          -----------------------------------------------------------

Permission to use, copy, modify, and distribute these programs and their documentation for any purpose and without
fee is hereby granted,provided that the below copyright notice and historical background appear in all copies
and that both the copyright notice and historical background and this permission notice appear in supporting
documentation, and that the names of MIT, HIS, Bull or Bull HN not be used in advertising or publicity pertaining
to distribution of the programs without specific prior written permission.
    Copyright 1972 by Massachusetts Institute of Technology and Honeywell Information Systems Inc.
    Copyright 2006 by Bull HN Information Systems Inc.
    Copyright 2006 by Bull SAS
    All Rights Reserved