


		    alarm_clock_meters.pl1          01/26/85  1313.5r w 01/22/85  1307.6       32571


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


/* This procedure prints out information about the functioning
   of the simulated alarm clock in the traffic controller.

   Originally coded by R. J. Feiertag on March 1972.
   Updated by Alan Bier on March 1974.
   Last modified, 04/01/80 W. Olin Sibert, to fix zerodivide problems.
   Modified November 1984 by M. Pandolf to include hc_lock
   */

alarm_clock_meters: acm: proc;

dcl  code fixed bin,				/* error code */
     time float bin,				/* real time metered */
     i fixed bin,					/* index */
     n_simulations fixed bin, 			/* number of simulations in metering interval */
     argptr ptr,					/* points to argument */
     arglen fixed bin,				/* number of chars in argument */
     arg char (arglen) based (argptr),			/* argument */
    (repsw, rsw) bit (1) init ("0"b);			/* action indicators */

dcl  init bit (1) internal static init ("0"b),		/* 1 if  has been initialized */
     unique_index fixed bin internal static,		/* unique number for meter_util_ */
    (sstp1, sstp2, tcmp1, tcmp2) ptr internal static,	/* pointers to ring 0 info */
     name char (18) internal static options (constant) init ("alarm_clock_meters");

dcl  float builtin;

dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin),
     cu_$arg_count entry returns (fixed bin),
     meter_util_$get_buffers entry (fixed bin, ptr, ptr, ptr, ptr, fixed bin),
     meter_util_$fill_buffers entry (fixed bin),
     meter_util_$time entry (fixed bin, float bin),
     meter_util_$reset entry (fixed bin),
     com_err_ entry options (variable),
     ioa_ entry options (variable);

%include tcm;
%include hc_lock;
/*  */
	do i = 1 to cu_$arg_count ();
	     call cu_$arg_ptr (1, argptr, arglen, code);	/* obtain optional single argument */
	     if arglen = 0 | code ^= 0 then go to print_out;
	     if arg = "-reset" | arg = "-rs" then rsw = "1"b;
	     else if arg = "-report_reset" | arg = "-rr" then rsw, repsw = "1"b;
	     else call com_err_ (0, name, "unrecognized control argument ""^a"" ignored.", arg);
	end;

print_out: if ^rsw then repsw = "1"b;			/* report is default value */
	if ^init then do;				/* must initialize */
	     call meter_util_$get_buffers (unique_index, sstp1, sstp2, tcmp1, tcmp2, code);
						/* initialize ring 0 info buffers */
	     if code ^= 0 then do;
		call com_err_ (code, name, "tc_data");
		return;
	     end;
	     init = "1"b;				/* initialization complete */
	end;
	call meter_util_$fill_buffers (unique_index);	/* get ring 0 data */
	call meter_util_$time (unique_index, time);	/* print out metering time */
	if repsw then do;
	     n_simulations = tcmp2 -> tcm.clock_simulations - tcmp1 -> tcm.clock_simulations;
	     call ioa_ ("No. alarm clock sims.^7d", n_simulations);
	     if n_simulations > 0 then call ioa_ ("Simulation lag^10x^8.3f msecs.",
		float (tcmp2 -> tcm.total_clock_lag - tcmp1 -> tcm.total_clock_lag, 27) /
		(1000e0 * float (n_simulations, 27)));
	     call ioa_ ("Max. lag^16x^8.3f msecs.^/",
		float (tcmp2 -> tcm.max_clock_lag, 27) / 1000e0);
	end;

	if rsw then call meter_util_$reset (unique_index); /* copy current ring 0 info */
     end;
 



		    cache_meters.pl1                04/26/84  1327.2r   04/26/84  1319.8      109134


/* ***********************************************************
   *						 *
   * 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,ifthendo,ifthen,^thendo */

/*   Written October 1983 by R. Coppola to display cache error counters */
/*   Modified: 2/15/84 by Greg Texada to add cache_meters_$for_monitor  */

cache_meters:
     proc;

/* Automatic */

dcl  INX fixed bin;
dcl  (all_sw, subroutine) bit (1);
dcl  argc fixed bin (21);				/* character index into current arg */
dcl  argl fixed bin (21);
dcl  argp ptr;
dcl  brief_sw bit (1);
dcl  code fixed bin (35);
dcl  cpu_string bit (MAX_CPUS) aligned;
dcl  (cur_ptr, prev_ptr) (1) ptr;
dcl  meter_cur (1) ptr;
dcl  1 cache_counters (MAX_CPUS) aligned,
       2 cpu_tag fixed bin (35),
       2 cache_type fixed bin (35),			/* 0 = L68, no cache
						   1 = L68, 2K
						   2 = DPS8, 8k
						   3 = VSSC, 8k
						   4 = VSSC, 16k
						   5 = VSSC, 32k */
       2 cache_err_ctrs (17) fixed bin (35);
dcl  do_totals bit (1);
dcl  field_count fixed bin (35);
dcl  formatted_time (MAX_CPUS) char (10);
dcl  found_name bit (1);
dcl  got_cpu (MAX_CPUS + 1) bit (1);
dcl  had_output bit (1);
dcl  have_ctrs bit (1);
dcl  (i, ii) fixed bin;
dcl  j fixed bin;
dcl  k fixed bin;
dcl  l fixed bin;
dcl  1 line unal,
       2 title char (31),
       2 field (9) char (12);
dcl  line_length fixed bin (17);
dcl  long bit (1);
dcl  meter_time (MAX_CPUS) fixed bin (71);
dcl  nargs fixed bin;
dcl  ncpus fixed bin;
dcl  nprint fixed bin;
dcl  pic12 picture "zzzzzzzzzzz9";
dcl  meter_prev (1) ptr;
dcl  print_fault (32) bit (1);
dcl  report bit (1);
dcl  reset bit (1);
dcl  single_fault_index fixed bin;
dcl  sort bit (1);
dcl  temp_sw bit (1) init ("0"b);
dcl  total_err_ctrs (17) fixed bin (35);
dcl  total_sw bit (1);
dcl  totals_only bit (1);


/* Static */

dcl  CPU_TAGS char (16) int static options (constant) init ("ABCDEFGHabcdefgh");
dcl  meter_unique (8) fixed bin int static init (0, 0, 0, 0, 0, 0, 0, 0);

dcl  my_name char (12) init ("cache_meters") int static options (constant);
dcl  entry_names (8) char (25) int static options (constant)
	init ("cpu_a_cache_err_ctr_array", "cpu_b_cache_err_ctr_array", "cpu_c_cache_err_ctr_array",
	"cpu_d_cache_err_ctr_array", "cpu_e_cache_err_ctr_array", "cpu_f_cache_err_ctr_array",
	"cpu_g_cache_err_ctr_array", "cpu_h_cache_err_ctr_array");

/* Based */

dcl  arg char (argl) based (argp);

dcl  1 prev_cache_ctrs (1) like cur_cache_ctrs based (prev_ptr (1)),
     1 cur_cache_ctrs (1) based (cur_ptr (1)),
       2 cache_type fixed bin (35),			/* 0 = L68, no cache
						   1 = L68, 2K
						   2 = DPS8, 8k
						   3 = VSSC, 8k
						   4 = VSSC, 16k
						   5 = VSSC, 32k */
       2 cache_err_ctrs (17) fixed bin (35);


/* Entry */

dcl  com_err_ entry options (variable);
dcl  cu_$arg_count entry (fixed bin);
dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
dcl  get_line_length_$switch entry (ptr, fixed bin (35)) returns (fixed bin);
dcl  ioa_ entry options (variable);
dcl  metering_util_$define_regions entry options (variable);
dcl  metering_util_$fill_buffers entry (fixed bin, fixed bin (71), char (*), (*) ptr, (*) ptr, fixed bin (35));
dcl  metering_util_$reset entry (fixed bin, fixed bin (35));

/* External */

dcl  error_table_$bad_arg fixed bin (35) external;
dcl  error_table_$badopt fixed bin (35) external;
%page;


/* Pick up and validate each argument			  */

	ncpus = 0;
	totals_only, total_sw = "1"b;			/* default */
	subroutine, all_sw, brief_sw, cpu_string, do_totals, had_output, long, report, reset, sort, got_cpu (*) = "0"b;
	call cu_$arg_count (nargs);
	do i = 1 to nargs;
	     call cu_$arg_ptr (i, argp, argl, code);

	     if arg = "-report" then report = "1"b;
	     else if arg = "-reset" | arg = "-rs" then reset = "1"b;
	     else if arg = "-report_reset" | arg = "-rr" then do;
		report = "1"b;
		reset = "1"b;
		end;

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

	     else if arg = "-tt" | arg = "-total" then do_totals = "1"b;

	     else if arg = "-cpu" then do;
		call cu_$arg_ptr (i + 1, argp, argl, code);
		if code ^= 0 then do;
		     if (i + 1) > nargs then do;	/* user wants ALL cpus */
do_all_cpus:
			do j = 1 to MAX_CPUS;
			     substr (cpu_string, j, 1) = "1"b;
			end;
			go to done_cpu_arg;
			end;

		     else do;
			call com_err_ (code, my_name, "");
			return;
			end;
		     end;
		else if substr (arg, 1, 1) = "-" then goto do_all_cpus;

		i = i + 1;

		if argl > 8 then do;
		     call com_err_ (0, my_name, "Too many CPUs specified (^a).", arg);
		     return;
		     end;

		if verify (arg, CPU_TAGS) ^= 0 then do;
		     call com_err_ (0, my_name, "Invalid CPU Tag(s) ^a", arg);
		     return;
		     end;
		do argc = 1 to argl;
		     substr (cpu_string, mod (index (CPU_TAGS, substr (arg, argc, 1)) - 1, 8) + 1, 1) = "1"b;
		end;
done_cpu_arg:
		totals_only = "0"b;
		total_sw = "0"b;
		end;

	     else do;
		call com_err_ (error_table_$badopt, my_name, arg);
		return;
		end;
	end;
	code = 0;
	call init (meter_unique);
	if code ^= 0 then return;

	if ^report & ^reset then report = "1"b;		/* default is -report			*/
	if do_totals then total_sw = "1"b;

	if report then do;				/* how many CPUs per line? */
	     line_length = get_line_length_$switch (null (), code);
	     if line_length < 132 then
		line_length = 4;
	     else line_length = 9;
	     if code ^= 0 then line_length = 9;
	     code = 0;
	     call accum_meters (meter_unique);
	     if code ^= 0 then return;

	     if total_sw then do;			/* fill in TOTALs array */
		if ^totals_only then ncpus = ncpus + 1;
		cache_counters (ncpus).cpu_tag = MAX_CPUS + 1;
		cache_counters (ncpus).cache_type = 0;
		do i = 1 to 17;
		     cache_counters (ncpus).cache_err_ctrs (i) = total_err_ctrs (i);
		     if total_err_ctrs (i) ^= 0 then got_cpu (ncpus) = "1"b;
		end;
		end;
	     call ioa_ ("^/Total Metering Time:^-^a^/", formatted_time (1));

	     do i = 1 to ncpus + 1 by line_length;	/* max of 4/9 cpus per screen */
		nprint = min (line_length, ncpus + 1 - i);
		if i >= nprint then
		     l = ncpus;
		else l = nprint;
		have_ctrs = "0"b;
		do j = i to l while (have_ctrs = "0"b);
		     if got_cpu (j) then have_ctrs = "1"b;
		end;
		if ^have_ctrs then goto try_next_set;
		had_output = "1"b;			/* printed something */
		string (line) = "";
		line.title = "CPU Tag";
		do j = 1 to nprint;
		     INX = (i + j - 1);
		     if cache_counters (INX).cpu_tag ^= MAX_CPUS + 1 then
			line.field (j) = "           " || CPU_NAMES (cache_counters (INX).cpu_tag);
		     else line.field (j) = "         ALL";
		end;
		call ioa_ ("^a", string (line));
		string (line) = "";

		line.title = "Cache Type";
		do j = 1 to nprint;
		     INX = (i + j - 1);
		     if cache_counters (INX).cpu_tag ^= MAX_CPUS + 1 then
			line.field (j) = "    " || CACHE_TYPES (cache_counters (INX).cache_type);
		     else line.field (j) = "";
		end;
		call ioa_ ("^a", string (line));

		do k = 1 to NO_CACHE_ERR_TYPES;
		     string (line) = "";
		     field_count = 0;
		     if k = 2 then do;
			line.title = "DPS8 Write Notify Counters";
			call ioa_ ("^/^a", string (line));
			end;

		     line.title = CACHE_ERROR_NAME (k);

		     do j = 1 to nprint;
			INX = (i + j - 1);
			field_count = field_count + cache_counters (INX).cache_err_ctrs (k);
			pic12 = cache_counters (INX).cache_err_ctrs (k);
			line.field (j) = pic12;
		     end;
		     if brief_sw = "1"b then
			if field_count = 0 then go to skip_it;
		     call ioa_ ("^a", string (line));
skip_it:
		end;
		call ioa_ ("^/");
try_next_set:
	     end;
	     if ^had_output then
		call ioa_ ("^/All cache counters ^[for selected CPU'S ^]were equal to zero.", ^totals_only);
	     end;

	if reset then do;
	     do i = 1 to MAX_CPUS;
		call metering_util_$reset (meter_unique (i), code);
		if code ^= 0 then call com_err_ (code, my_name, "Resetting");
	     end;
	     end;
	return;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/


cache_meters_$for_monitor:
     entry (a_cache_counters_ptr, a_ncpus, a_code);


/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*									*/
/* This entry provides a method for monitor_cache to get the cache memory errors that	*/
/* occured between calls.							*/
/*									*/
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */


dcl  a_cache_counters_ptr ptr,
     a_ncpus fixed bin,
     a_code fixed bin (35),
     (
     monitor_cur (1),
     monitor_prev (1)
     ) ptr,
     monitor_unique (8) fixed bin int static init (0, 0, 0, 0, 0, 0, 0, 0),
     1 a_cache_counters (MAX_CPUS) like cache_counters aligned based (a_cache_counters_ptr);

	a_ncpus, ncpus, code, a_code = 0;
	subroutine = "1"b;
	cpu_string = (8)"1"b;			/* do em all				*/
	totals_only = "0"b;
	call init (monitor_unique);
	if code ^= 0 then goto RETURN;
	call accum_meters (monitor_unique);
	if code ^= 0 then goto RETURN;
	if a_cache_counters_ptr ^= null () then do;	/* if null, then is first "init" call		*/
	     a_cache_counters (*) = cache_counters (*);	/* give caller the data			*/
	     a_ncpus = ncpus;
	     end;
	do i = 1 to MAX_CPUS;			/* reset for interval calls			*/
	     call metering_util_$reset (monitor_unique (i), (0));
	end;
RETURN:
	a_code = code;
	return;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/


init:
     proc (munique);

/* Initialize if this is the first call			  */

dcl  munique (8) fixed bin parameter;

	do i = 1 to MAX_CPUS;
	     if munique (i) = 0 then do;
		call metering_util_$define_regions (munique (i), code, "wired_hardcore_data", entry_names (i), 18);
		if code ^= 0 then
		     if ^subroutine then call com_err_ (code, my_name, "Initializing");
		end;
	end;
     end init;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/


accum_meters:
     proc (munique);

dcl  munique (8) fixed bin parameter;


	total_err_ctrs (*) = 0;

	if totals_only then ncpus = 1;
	do i = 1 to MAX_CPUS;
	     call metering_util_$fill_buffers (munique (i), meter_time (i), formatted_time (i), cur_ptr, prev_ptr, code)
		;
	     if code ^= 0 then do;
		if ^subroutine then call com_err_ (code, my_name, "Filling buffers");
		return;
		end;

	     if cur_cache_ctrs (1).cache_type = L68_NONE then goto try_next_cpu;
	     if (^subroutine)
		& (sum (cur_cache_ctrs (1).cache_err_ctrs (*)) - sum (prev_cache_ctrs (1).cache_err_ctrs (*)) = 0)
	     then					/* the subroutine needs ALL data, even zero counters */
		goto try_next_cpu;
	     if substr (cpu_string, i, 1) | total_sw then do;
		if ^totals_only then ncpus = ncpus + 1;
		got_cpu (ncpus) = "1"b;
		cache_counters (ncpus).cpu_tag = i;
		cache_counters (ncpus).cache_type = cur_cache_ctrs (1).cache_type;

		do j = 1 to 17;
		     cache_counters (ncpus).cache_err_ctrs (j) =
			cur_cache_ctrs (1).cache_err_ctrs (j) - prev_cache_ctrs (1).cache_err_ctrs (j);

		     total_err_ctrs (j) = total_err_ctrs (j) + cache_counters (ncpus).cache_err_ctrs (j);
		end;
		if (^totals_only) & (^subroutine) then	/* the subroutine needs ALL data, even zero counters */
		     if substr (cpu_string, i, 1) = "0"b then do;
						/* if this wasn't selected, undo it */
			ncpus = ncpus - 1;
			got_cpu (ncpus) = "0"b;
			end;
		end;
try_next_cpu:
	end;

     end accum_meters;
%page;
%include fim_meters;
%page;

     end cache_meters;
  



		    disk_meters.pl1                 08/08/88  1129.1r w 08/08/88  1115.1      295506


/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Limited, 1984                  *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        *********************************************************** */


/****^  HISTORY COMMENTS:
  1) change(86-01-16,Fawcett), approve(86-04-10,MCR7383),
     audit(86-05-27,Wallman), install(86-07-18,MR12.0-1098):
     Add support for subvolumes, 3380 and 3390.
  2) change(86-11-10,Fawcett), approve(86-11-10,MCR7125),
     audit(87-01-08,Farley), install(87-01-09,MR12.0-1266):
     Changed by Tom Oke to call get_vol_list as per documentation.
  3) change(86-11-10,Fawcett), approve(86-11-10,MCR7547),
     audit(87-01-08,Farley), install(87-01-09,MR12.0-1266):
     Changed to display subvolume devices correctly.
                                                   END HISTORY COMMENTS */


/* Disk meter for optimizing disk system. */

/* Rewritten Spring 1984 by Tom Oke. */
/* Cleaned up for installation August 1984 by Chris Jones. */
/* Format modifications and statistics correction October 1984 by Tom Oke. */
/* Skip IO types without seeks in long mode. November 1984 by T. Oke. */
/* November 1984 by T. Oke, major changes to printing and device selection to
   utilize get_vol_list_ routine and select by logical, physical, drive and
   subsystem.  */

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

disk_meters:
dskm:
     proc;

dcl	areas		   area based;
dcl	arg		   char (arg_len) based (arg_ptr);
dcl	arg_count		   fixed bin;
dcl	arg_index		   fixed bin;
dcl	arg_len		   fixed bin (21);
dcl	arg_list_ptr	   ptr;
dcl	arg_ptr		   ptr;

dcl	ave_queue		   float bin (63);
dcl	ave_seek		   float bin (63);
dcl	buddy_pic		   picture "99";
dcl	channel_sum	   float bin (63);
dcl	channel_time	   float bin (63);
dcl	code		   fixed bin (35);
dcl	copy_size		   fixed bin (19) static;
dcl	date_time		   char (24);
dcl	delta		   fixed bin (71);
dcl	dev		   fixed bin;
dcl	dev_pic		   picture "99";
dcl	disk_segp		   ptr static;
dcl	disksp_static	   ptr static;
dcl	edac_errors	   fixed bin;
dcl	errors		   fixed bin;
dcl	fdelta		   float bin (63);
dcl	ferrors		   fixed bin;
dcl	float_seconds	   float bin (27);
dcl	float_seek	   float bin (63);
dcl	i		   fixed bin;
dcl	i_minutes		   fixed bin;
dcl	i_seconds		   fixed bin;
dcl	io_per_second	   float bin (27);
dcl	io_per_second_per_drive
			   float bin (27);
dcl	io_per_second_per_subsystem
			   float bin (27);
dcl	j		   fixed bin;
dcl	lv_ptr		   ptr static initial (null ());
dcl	MYNAME		   char (11) static options (constant) initial ("disk_meters");
dcl	odiskp		   ptr;
dcl	odisksp		   ptr;
dcl	odp		   ptr;
dcl	old_clock		   fixed bin (71) static init (0);
dcl	old_dev		   fixed bin;
dcl	old_sx		   fixed bin;
dcl	print_busy	   bit (1);
dcl	print_channels	   bit (1);
dcl	print_detail	   bit (1);
dcl	print_drive	   bit (1);
dcl	print_header	   bit (1);		/*  header */
dcl	print_io_rate	   bit (1);
dcl	print_queue	   bit (1);
dcl	print_subsys	   (32) bit (1);
dcl	print_system	   bit (1);
dcl	pv		   fixed bin;
dcl	pv_name_max_space	   fixed bin;
dcl	pv_ptr		   ptr static initial (null ());
dcl	queue_sum		   float bin (63);
dcl	reset		   bit (1);
dcl	rrset		   bit (1);
dcl	save_clock	   fixed bin (71);
dcl	seek_to_time	   float bin (63);
dcl	seeks		   fixed bin (35);
dcl	seek_sum		   float bin (63);
dcl	selected_drive	   bit (1);		/* true if any drive selected */
dcl	small_code	   fixed bin;
dcl	sub_sys_limit	   fixed bin static;	/* defined sub-sys */
dcl	subsys_name	   char (4);
dcl	sx		   fixed bin;
dcl	temp_segp		   ptr static initial (null ());
						/* pointer to temp seg */
dcl	total_seek	   float bin (63);

dcl	io_name		   (0:6) char (6) static options (constant)
			   initial ("PageRd", "PageWt", "VtocRd", "VtocWt", "Test  ", "BootRd", "BootWt");

/* Name matching structures. */

dcl	match_count	   fixed bin;
dcl	match_type	   fixed bin;		/* type of name */
dcl	1 match		   (64),
	  2 type		   fixed bin,
	  2 name		   char (32);

dcl	PV		   fixed bin static options (constant) initial (1);
						/* physical volume */
dcl	LV		   fixed bin static options (constant) initial (2);
						/* logical volume */
dcl	DV		   fixed bin static options (constant) initial (3);
						/* drive */
dcl	SY		   fixed bin static options (constant) initial (4);
						/* subsys */

dcl	match_keys	   (4) char (16) static options (constant)
			   initial ("-logical_volume", "-physical_volume", "-device", "-subsystem");


dcl	seconds		   pic "99";
dcl	minutes		   pic "99";
dcl	hours		   pic "zzzzz9";

/* Storage overlay of base of tempseg used to create initial "0" reading. */

dcl	seg_overlay	   (copy_size) bit (36) based (temp_segp);

dcl	sys_info$max_seg_size  fixed bin (35) ext static;

dcl	error_table_$bad_arg   fixed bin (35) ext;
dcl	error_table_$badstar   fixed bin (35) ext;
dcl	error_table_$noarg	   fixed bin (35) ext;
dcl	error_table_$too_many_names
			   fixed bin (35) ext;
dcl	check_star_name_$entry entry (char (*), fixed bin (35));
dcl	clock_		   entry returns (fixed bin (71));
dcl	com_err_		   entry () options (variable);
dcl	cu_$arg_count_rel	   entry (fixed bin, ptr, fixed bin (35));
dcl	cu_$arg_list_ptr	   entry (ptr);
dcl	cu_$arg_ptr_rel	   entry (fixed bin, ptr, fixed bin (21), fixed bin (35), ptr);
dcl	date_time_	   entry (fixed bin (71), char (*));
dcl	get_temp_segment_	   entry (char (*), ptr, fixed bin (35));
dcl	get_vol_list_	   entry (ptr, ptr, ptr, char (8), fixed bin (35));
dcl	ioa_		   entry () options (variable);
dcl	ioa_$nnl		   entry () options (variable);
dcl	match_star_name_	   entry (char (*), char (*), fixed bin (35));
dcl	release_temp_segment_  entry (char (*), ptr, fixed bin (35));
dcl	ring_zero_peek_	   entry (ptr, ptr, fixed bin (19), fixed bin (35));
dcl	ring0_get_$segptr	   entry (char (*), char (*), ptr, fixed bin);
dcl	system_info_$timeup	   entry (fixed bin (71));

dcl	(addr, addrel, bin, divide, float, hbound, index, null, ptr, rel, size, substr, unspec)
			   builtin;
%page;

/* initialize first time, or everytime. */

	print_busy, print_channels, print_detail, print_drive, print_header, print_io_rate = "0"b;
	reset, rrset, print_queue, print_subsys, print_system = "0"b;


	call cu_$arg_list_ptr (arg_list_ptr);
	call init_args;

	if temp_segp = null ()			/* no tempseg */
	then do;
	     call get_temp_segment_ (MYNAME, temp_segp, code);
	     if code ^= 0 then do;
		call com_err_ (code, MYNAME, "Getting temp segment");
		return;
	     end;

	     odisksp = temp_segp;
	     call ring0_get_$segptr ("", "disk_seg", disk_segp, small_code);
	     if small_code ^= 0 then do;
		code = small_code;
RELEASE_RETURN:
		call com_err_ (code, MYNAME, "disk_seg");
release_quit:
		call release_temp_segment_ (MYNAME, temp_segp, code);
		temp_segp = null ();
		old_clock = 0;			/* reset clock too. */
		if lv_ptr ^= null () then do;
		     lv_list_ptr = lv_ptr;
		     free lv_list in (lv_list.area_ptr -> areas);
		     lv_ptr = null ();
		end;
		if pv_ptr ^= null () then do;
		     pv_list_ptr = pv_ptr;
		     free pv_list in (pv_list.area_ptr -> areas);
		     pv_ptr = null ();
		end;
		return;
	     end;

	     call ring_zero_peek_ (disk_segp, temp_segp, size (disk_data), code);
	     if code ^= 0 then
		goto RELEASE_RETURN;

	     copy_size = bin (odisksp -> disk_data.free_offset, 19);
	     sub_sys_limit = odisksp -> disk_data.subsystems;
	     if 2 * copy_size > sys_info$max_seg_size then do;
		call com_err_ (0, MYNAME, "disk_seg is too big to be metered.");
		goto RELEASE_RETURN;
	     end;
	     disksp_static = ptr (temp_segp, odisksp -> disk_data.free_offset);
	     unspec (seg_overlay) = "0"b;		/* clear old copy */
	end;
	else odisksp = temp_segp;

	disksp = disksp_static;
%page;
/* Get arguments. */

	match_count = 0;

	do while (get_next_arg ());
parse_loop:
	     if index (arg, "-") = 1 then do;
		if arg = "-rl" | arg = "-release" then
		     goto release_quit;
		else if arg = "-chn" | arg = "-channels" then
		     print_channels = "1"b;
		else if arg = "-dtl" | arg = "-detail" then
		     print_detail, print_busy = "1"b;
		else if arg = "-q" | arg = "-queue" then
		     print_queue = "1"b;
		else if arg = "-sys" | arg = "-system" then
		     print_system = "1"b;

		else if arg = "-lg" | arg = "-long" then do;
		     print_channels, print_queue, print_system = "1"b;
		     print_detail, print_busy, print_io_rate = "1"b;
		     print_header, print_drive = "1"b;
		end;

		else if arg = "-he" | arg = "-header" then
		     print_header = "1"b;

		else if arg = "-drv" | arg = "-drive" then
		     print_drive = "1"b;

		else if arg = "-busy" then
		     print_busy = "1"b;

		else if arg = "-rate" then
		     print_io_rate = "1"b;

		else if arg = "-rs" | arg = "-reset" then
		     reset = "1"b;
		else if arg = "-rr" | arg = "-report_reset" then
		     rrset = "1"b;
		else if arg = "-lv" | arg = "-logical_volume" then do;
		     match_type = LV;
		     goto get_match_names;
		end;
		else if arg = "-dv" | arg = "-device" then do;
		     match_type = DV;
		     goto get_match_names;
		end;
		else if arg = "-sub" | arg = "-subsystem" then do;
		     match_type = SY;
		     goto get_match_names;
		end;
		else if arg = "-pv" | arg = "-physical_volume" then do;
		     match_type = PV;
		     goto get_match_names;
		end;
		else do;				/* bad argument */
		     call com_err_ (error_table_$bad_arg, MYNAME, arg);
		     return;
		end;
	     end;
	     else do;				/* presume subsys */
		match_type = SY;
		goto match_name_loop;

get_match_names:
		if ^get_next_arg () then do;
		     call com_err_ (error_table_$noarg, MYNAME, "Name missing after ^a.", match_keys (match_type));
		     return;
		end;

match_name_loop:
		call check_star_name_$entry (arg, code);
		if code = error_table_$badstar then do;
		     call com_err_ (code, MYNAME, arg);
		     return;
		end;

		if match_count < hbound (match, 1) then do;
		     match_count = match_count + 1;
		     match (match_count).name = arg;
		     match (match_count).type = match_type;
		end;
		else do;
		     call com_err_ (error_table_$too_many_names, MYNAME, arg);
		     return;
		end;
		if ^get_next_arg () then
		     goto end_parse_loop;
		if index (arg, "-") = 1 then
		     goto parse_loop;
		goto match_name_loop;
	     end;
end_parse_loop:
	end;

/* setup  listing defaults */

	if print_channels = "0"b & print_drive = "0"b & print_system = "0"b & print_header = "0"b then
	     print_drive, print_header = "1"b;
%page;
/* Read current meters. */

	call ring_zero_peek_ (disk_segp, disksp, copy_size, code);
	if code ^= 0 then
	     goto ERROR_RETURN;

	call get_vol_list_ (pv_ptr, lv_ptr, null (), get_vol_list_version, code);
	if code ^= 0 then
	     goto ERROR_RETURN;

	lv_list_ptr = lv_ptr;
	pv_list_ptr = pv_ptr;
	pv_name_max_space = pv_list.pv_name_max_length;

/* determine which sub-systems and drives have been selected. */
/* At end of loop pv_list.pv_info.used will be on for selected drives
   and print_subsys (sx) will be set for sub-systems with drives selected.
   The sx of the drive will be stored in pv_list.pv_info.device_type.

   If a secondary device is selected, the primary device will also be
   selected. */

	print_subsys = "0"b;
	selected_drive = "0"b;

	do i = 1 to pv_list.pv_name_count;
	     if ^pv_list.pv_info (i).used then
		goto end_accept_loop;
	     if match_count = 0 then
		goto drive_accept;			/* Default */
	     do j = 1 to match_count;
		goto match_case (match (j).type);

match_case (1):					/* PV */
		call match_star_name_ ((pv_list.pv_info (i).pvname), match (j).name, code);
		if code = 0 then
		     goto drive_accept;
		goto drive_no_match;

match_case (2):					/* LV */
		call match_star_name_ ((lv_list.lv_info (pv_list.pv_info (i).lvx).lvname), match (j).name, code);
		if code = 0 then
		     goto drive_accept;
		goto drive_no_match;

match_case (3):					/* DV */
		call match_star_name_ ((pv_list.pv_info (i).drive_name), match (j).name, code);
		if code = 0 then
		     goto drive_accept;
		goto drive_no_match;

match_case (4):					/* SY */
		call match_star_name_ (substr (pv_list.pv_info (i).drive_name, 1, 4), match (j).name, code);
		if code = 0 then
		     goto drive_accept;
		goto drive_no_match;
drive_no_match:
	     end;
	     goto drive_skip;

/* Accept drive and flag sub-system as ready for stats */

drive_accept:
	     selected_drive = "1"b;
	     do sx = 1 to disk_data.subsystems;
		if substr (pv_list.pv_info (i).drive_name, 1, 4) = disk_data.array (sx).name then
		     goto sub_sys_accept;
	     end;
	     call com_err_ (0, MYNAME, "disk_table/disk_seg inconsistency.");
	     return;

sub_sys_accept:
	     pv_list.pv_info (i).device_type = sx;
	     print_subsys (sx) = "1"b;

	     dev = bin (substr (pv_list.pv_info (i).drive_name, 6, 2));
	     diskp = addrel (disksp, disk_data.array (sx).offset);
	     dp = addr (disktab.devtab (dev));
	     if devtab.pdi ^= dev & devtab.pdi ^= 0 then do;
		pv_list.pv_info (disktab.devtab (devtab.pdi).pvtx).device_type = sx;
		pv_list.pv_info (disktab.devtab (devtab.pdi).pvtx).used = "1"b;
	     end;
	     goto end_accept_loop;

drive_skip:
	     pv_list.pv_info (i).used = "0"b;		/* skip drive */
end_accept_loop:
	end;

	if ^selected_drive then do;
	     call com_err_ (error_table_$bad_arg, MYNAME, "No selection matches.");
	     return;
	end;
%page;

	save_clock = clock_ ();
	if old_clock = 0 then do;
	     call system_info_$timeup (old_clock);
	end;
	delta = save_clock - old_clock;
	fdelta = float (delta);
	float_seconds = fdelta / 1000000.0;
	i_seconds = divide (delta, 1000000, 17, 0);
	i_minutes = divide (i_seconds, 60, 17, 0);
	hours = divide (i_minutes, 60, 17, 0);
	seconds = i_seconds - (i_minutes * 60);
	minutes = i_minutes - (hours * 60);

	call ioa_ ("^2-Metering Time: ^a:^a:^a", hours, minutes, seconds);

/* Process output */

	if reset then
	     goto reset_meter;


	if print_system then do;
	     call print_q_stats ("FREE", addr (odisksp -> disk_data.free_q), "1"b);

	     call ioa_ ("^-Stagnate time ^.3f seconds, ^i PL/1 interrupt service^[s^].",
		float (disk_data.stagnate_time) / 1000000.0, disk_data.bail_outs - odisksp -> disk_data.bail_outs,
		disk_data.bail_outs - odisksp -> disk_data.bail_outs ^= 1);

	     call date_time_ (disk_data.max_depth_reset_time, date_time);
	     call ioa_ ("^-Maximum Depth Meters reset at: ^a", date_time);

	     do i = 0 to MAX_IO_TYPE;
		do j = 0 to MAX_IO_TYPE;
		     if rel (addr (odisksp -> disk_data.sys_info (j))) = disk_data.sys_info (i).depth_map then
			goto mapped;
		end;
		call ioa_ ("Bad depth mapping!!.");
		j = TEST;

mapped:
		if i ^= TEST then
		     call ioa_ ("    ^6a   Max Load ^4i, Depth ^3i (^a), Fraction ^6.4f", io_name (i),
			disk_data.sys_info (i).max_depth, disk_data.sys_info (i).depth, io_name (j),
			disk_data.sys_info (i).fraction);
	     end;
	end;
%page;

	io_per_second = 0.0;


/* Print per subsystem. */

	if print_header then
	     do sx = 1 to disk_data.subsystems;
	     subsys_name = disk_data.array (sx).name;
	     if print_subsys (sx) then do;
		diskp = addrel (disksp, disk_data.array (sx).offset);
		odiskp = addrel (odisksp, disk_data.array (sx).offset);
		errors = disktab.errors - odiskp -> disktab.errors;
		ferrors = disktab.ferrors - odiskp -> disktab.ferrors;
		edac_errors = disktab.edac_errors - odiskp -> disktab.edac_errors;
		call ioa_ (
		     "^/Subsystem  ^a:^[^s^; ^i Error^]^[s^]^[^s^; ^i Fatal Error^]^[s^]^[^s^; ^i EDAC Error^]^[s^]",
		     subsys_name, errors = 0, errors, errors > 1, ferrors = 0, ferrors, ferrors > 1, edac_errors = 0,
		     edac_errors, edac_errors > 1);
		call print_subsys_info;
	     end;
	end;

	if print_drive & ^print_detail then do;
	     call ioa_ ("^/ Drive    ^va                    Ave     ATB     ATB        ATB", pv_name_max_space, "  PV");
	     call ioa_ ("          ^vx   Reads   Writes  Seek    Reads   Writes      I/O^/", pv_name_max_space);
	end;


/* Print per drive. */

	old_sx = 0;
	old_dev = -1;
	do pv = 1 to pv_list.pv_name_count;
	     if ^pv_list.pv_info (pv).used then
		goto skip_drive;
	     sx = pv_list.pv_info (pv).device_type;	/* get sub-system */
	     if sx ^= old_sx then do;			/* sub-system changed */
		if old_sx ^= 0 then do;		/* cleanup old */
		     call print_channel_info;
		     io_per_second = io_per_second + io_per_second_per_subsystem;
		     if print_io_rate & io_per_second_per_subsystem > 0.0 then
			call ioa_ ("^-^a IO Rate ^6.1f", subsys_name, io_per_second_per_subsystem / float_seconds);
		end;
		io_per_second_per_subsystem = 0.0;
		subsys_name = disk_data.array (sx).name;
		diskp = addrel (disksp, disk_data.array (sx).offset);
		odiskp = addrel (odisksp, disk_data.array (sx).offset);
		old_sx = sx;
		old_dev = -1;
	     end;

	     dev = bin (substr (pv_list.pv_info (pv).drive_name, 6, 2));
	     if pv_list.pv_info (pv).is_sub_vol then
		if dev = old_dev then
		     goto skip_drive;
	     dp = addr (disktab.devtab (dev));
	     odp = addr (odiskp -> disktab.devtab (dev));
	     io_per_second_per_drive = 0.0;
	     if devtab.pdi = dev then
		call print_device;
	     io_per_second_per_subsystem = io_per_second_per_subsystem + io_per_second_per_drive;
skip_drive:
	     old_dev = dev;
	end;
	call print_channel_info;
	io_per_second = io_per_second + io_per_second_per_subsystem;
	if print_io_rate & io_per_second_per_subsystem > 0.0 then
	     call ioa_ ("^-^a IO Rate ^6.1f", subsys_name, io_per_second_per_subsystem / float_seconds);


	if print_io_rate & io_per_second > 0.0 then
	     call ioa_ ("^-Sum of Selected Drives ^6.1f IO/second.", io_per_second / float_seconds);

reset_meter:
	if reset | rrset then do;
	     unspec (temp_segp -> seg_overlay) = unspec (disksp -> seg_overlay);
	     old_clock = save_clock;
	end;
	return;

ERROR_RETURN:
	call com_err_ (code, MYNAME);
	return;
%page;
/* Routine to print information of drive (primary and buddy too). */

print_device:
     proc;

dcl	channel_wait_sum	   fixed bin (71);
dcl	(drive_lv, buddy_lv)   fixed bin;
dcl	(drive_pv, buddy_pv)   fixed bin;

	dev_pic = dev;
	drive_pv = disktab.devtab (dev).pvtx;
	drive_lv = pv_list.pv_info (drive_pv).lvx;

	if devtab.buddy ^= 0 & devtab.buddy ^= dev then do;
	     buddy_pic = devtab.buddy;
	     buddy_pv = disktab.devtab (devtab.buddy).pvtx;
	     buddy_lv = pv_list.pv_info (buddy_pv).lvx;
	end;
	else do;
	     buddy_pic = 0;
	     buddy_lv, buddy_pv = 0;
	end;

/* Determine if drive and buddy were busy. */

	channel_wait_sum = 0;
	do i = 0 to MAX_IO_TYPE;
	     channel_wait_sum =
		channel_wait_sum + devtab.opt_info (i).channel_wait - odp -> devtab.opt_info (i).channel_wait;
	end;

	if channel_wait_sum = 0 then
	     return;

	call print_dev (dev);
	if devtab.buddy ^= 0 then do;
	     call print_dev ((devtab.buddy));
	     call print_q_stats (subsys_name || "_" || dev_pic || "/" || buddy_pic,
		addr (odiskp -> disktab (dev).devtab.wq), print_queue);
	end;
	else call print_q_stats (subsys_name || "_" || dev_pic, addr (odiskp -> disktab (dev).devtab.wq), print_queue);

	if print_busy then
	     call ioa_ ("  Channels ^.2f% busy,  ^i Comb^[s^],  ^6.1f IO/second.", 100.0 * channel_wait_sum / fdelta,
		disktab (dev).devtab.comb - odiskp -> disktab (dev).devtab.comb,
		disktab (dev).devtab.comb - odiskp -> disktab (dev).devtab.comb ^= 1,
		io_per_second_per_drive / float_seconds);

	return;

print_dev:
	proc (dev);

/* Print individual device information. */

dcl	dev		   fixed bin;

dcl	buddyp		   ptr;			/* buddy devtab ptr */
dcl	buddy_seeks	   float bin (63);		/* seeks on buddy */
dcl	device_read_sum	   fixed bin (35);
dcl	device_seeks	   float bin (63);		/* total seeks on device */
dcl	device_total_io	   float bin (63);
dcl	device_write_sum	   fixed bin (35);
dcl	dp		   ptr;
dcl	need_buddy	   bit (1);		/* need to count buddy */
dcl	obuddyp		   ptr;			/* old buddy devtab */
dcl	odp		   ptr;
dcl	read_sum		   fixed bin (35);
dcl	total_io		   float bin (63);
dcl	total_read	   float bin (63);
dcl	total_write	   float bin (63);
dcl	write_sum		   fixed bin (35);

	     odp = addr (odiskp -> disktab.devtab (dev));
	     dp = addr (disktab.devtab (dev));
	     if dev = dp -> devtab.pdi & dp -> devtab.buddy ^= 0 then do;
		need_buddy = "1"b;
		buddyp = addr (disktab.devtab (dp -> devtab.buddy));
		obuddyp = addr (odiskp -> disktab.devtab (dp -> devtab.buddy));
	     end;
	     else need_buddy = "0"b;


	     seek_sum, buddy_seeks = 0.0;
	     do i = 0 to MAX_IO_TYPE;			/* determine if zero */
		if i ^= TEST then do;
		     seek_sum =
			seek_sum
			+ float (dp -> devtab.opt_info (i).seek_count - odp -> devtab.opt_info (i).seek_count);
		     if need_buddy then
			buddy_seeks =
			     buddy_seeks
			     +
			     float (buddyp -> devtab.opt_info (i).seek_count
			     - obuddyp -> devtab.opt_info (i).seek_count);
		end;
	     end;
	     if (seek_sum + buddy_seeks) = 0.0		/* no work */
		then
		return;

	     io_per_second_per_drive = io_per_second_per_drive + seek_sum;

	     if print_detail then do;
		if pv_list.pv_info (drive_pv).is_sub_vol then
		     call print_sv (drive_pv);
		else do;
		     if dev = dp -> devtab.pdi then
			call ioa_ (
			     "^/^a_^a:^-PV-^va^-of LV-^va^[ PDIR^;^]^/           #Seeks AveSeek Queue-wait Channel-wait  Queued Multiplier",
			     subsys_name, dev_pic, pv_list.pv_name_max_length, pv_list.pv_info (drive_pv).pvname,
			     lv_list.lv_name_max_length, lv_list.lv_info (drive_lv).lvname,
			     lv_list.lv_info (drive_lv).pdirs_ok);
		     else call ioa_ (
			     "^/^a_^a:^-PV-^va^-of LV-^va^[ PDIR^;^]^/           #Seeks AveSeek (Secondary Device)",
			     subsys_name, buddy_pic, pv_list.pv_name_max_length, pv_list.pv_info (buddy_pv).pvname,
			     lv_list.lv_name_max_length, lv_list.lv_info (buddy_lv).lvname,
			     lv_list.lv_info (buddy_lv).pdirs_ok);
		end;
	     end;
	     channel_sum, queue_sum = 0.0;
	     total_seek = 0.0;
	     read_sum, write_sum, device_read_sum, device_write_sum = 0;
	     do i = 0 to MAX_IO_TYPE;

/* Determine summations, and possibly print detail output. */

		if i = TEST then
		     if print_detail then
			call ioa_ ("   TEST   ^3i UNLOAD^[s^], ^3i TEST^[s^]",
			     dp -> devtab.opt_info (i).seek_sum - odp -> devtab.opt_info (i).seek_sum,
			     dp -> devtab.opt_info (i).seek_sum - odp -> devtab.opt_info (i).seek_sum ^= 1,
			     dp -> devtab.opt_info (i).seek_count - odp -> devtab.opt_info (i).seek_count,
			     dp -> devtab.opt_info (i).seek_count - odp -> devtab.opt_info (i).seek_count ^= 1);
		     else ;
		else do;
		     channel_time =
			float (dp -> devtab.opt_info (i).channel_wait - odp -> devtab.opt_info (i).channel_wait);
		     channel_sum = channel_sum + channel_time;

		     float_seek, device_seeks =
			float (dp -> devtab.opt_info (i).seek_count - odp -> devtab.opt_info (i).seek_count);

		     if need_buddy then
			device_seeks =
			     device_seeks
			     +
			     float (buddyp -> devtab.opt_info (i).seek_count
			     - obuddyp -> devtab.opt_info (i).seek_count);

		     seeks = dp -> devtab.opt_info (i).seek_count - odp -> devtab.opt_info (i).seek_count;

		     if write_map (i) then do;
			write_sum = write_sum + seeks;
			device_write_sum = device_write_sum + device_seeks;
		     end;
		     else do;
			read_sum = read_sum + seeks;
			device_read_sum = device_read_sum + device_seeks;
		     end;

		     if float_seek = 0.0 then
			float_seek = 1.0e30;
		     if device_seeks = 0.0 then
			device_seeks = 1.0e30;
		     seek_to_time = device_seeks * 1.0e3;
						/* milli secs */
		     ave_seek =
			float (dp -> devtab.opt_info (i).seek_sum - odp -> devtab.opt_info (i).seek_sum)
			/ float_seek;
		     total_seek =
			total_seek
			+ float (dp -> devtab.opt_info (i).seek_sum - odp -> devtab.opt_info (i).seek_sum);
		     ave_queue =
			float (dp -> devtab.opt_info (i).queue_wait - odp -> devtab.opt_info (i).queue_wait)
			/ seek_to_time;
		     queue_sum =
			queue_sum
			+ float (dp -> devtab.opt_info (i).queue_wait - odp -> devtab.opt_info (i).queue_wait);

		     if print_detail & print_drive & device_seeks < 1.0e29 then
			if dev = dp -> devtab.pdi then
			     call ioa_ ("   ^6a ^7i ^7.2f ^10.1f ^4.1f%^7.1f ^7i ^10.1f", io_name (i), seeks,
				ave_seek, ave_queue, (channel_time * 100.0) / fdelta, channel_time / seek_to_time,
				dp -> devtab.opt_info (i).depth, dp -> devtab.opt_info (i).multiplier);
			else call ioa_ ("   ^6a ^7i ^7.2f", io_name (i), seeks, ave_seek);

		end;
	     end;

/* output simple summation. */

	     if read_sum = 0 then
		total_read = 0.0;
	     else total_read = (0.001 * fdelta) / float (read_sum);
	     if write_sum = 0 then
		total_write = 0.0;
	     else total_write = (0.001 * fdelta) / float (write_sum);
	     total_io = read_sum + write_sum;
	     if total_io = 0.0 then
		total_io = 1.0e30;

	     device_total_io = device_read_sum + device_write_sum;
	     if device_total_io = 0.0 then
		device_total_io = 1.0e30;

	     if ^print_detail & print_drive then do;

		if pv_list.pv_info (drive_pv).is_sub_vol then
		     call print_sv (drive_pv);
		else do;
		     if dev = dp -> devtab.pdi then
			call ioa_ (
			     "^9a^va ^[^s^8x^;^8i^] ^[^s^8x^;^8i^]^[^s  Idle^;^6i^] ^[^s^8x^;^8i^] ^[^s^8x^;^8i^] ^[^s^;^8i^]",
			     pv_list.pv_info (drive_pv).drive_name, pv_name_max_space,
			     pv_list.pv_info (drive_pv).pvname, read_sum = 0, read_sum, write_sum = 0, write_sum,
			     total_io > 1.0e29, total_seek / total_io, total_read = 0.0, total_read,
			     total_write = 0.0, total_write, device_total_io > 1.0e29,
			     (0.001 * fdelta) / device_total_io);
		     else call ioa_ (
			     "^9a^va ^[^s^8x^;^8i^] ^[^s^8x^;^8i^]^[^s  Idle^;^6i^] ^[^s^8x^;^8i^] ^[^s^8x^;^8i^]",
			     pv_list.pv_info (buddy_pv).drive_name, pv_name_max_space,
			     pv_list.pv_info (buddy_pv).pvname, read_sum = 0, read_sum, write_sum = 0, write_sum,
			     total_io > 1.0e29, total_seek / total_io, total_read = 0.0, total_read,
			     total_write = 0.0, total_write);
		end;
	     end;


print_sv:
	     proc (pv_index);

dcl	pv_index		   fixed bin;
dcl	(sv_idx, f_sv_idx, l_sv_idx, lv_index)
			   fixed bin;

/**** find first subvol in pv_info for this dev */

		f_sv_idx = pv_index - (pv_list.pv_info (pv_index).sv_num);

/**** find last subvol in pv_info */

		l_sv_idx = f_sv_idx + (pv_list.pv_info (pv_index).num_of_sv - 1);

		do sv_idx = f_sv_idx to l_sv_idx;
		     lv_index = pv_list.pv_info (sv_idx).lvx;
		     if print_detail & print_drive then do;
			if pv_list.pv_info (sv_idx).used then
			     call ioa_$nnl (
				"^/^8a:^-PV-^va^-of LV-^va^[ PDIR^;^]^[^/           #Seeks AveSeek Queue-wait Channel-wait  Queued Multiplier^/^]",
				pv_list.pv_info (sv_idx).drive_name, pv_list.pv_name_max_length,
				pv_list.pv_info (sv_idx).pvname, lv_list.lv_name_max_length,
				lv_list.lv_info (lv_index).lvname, lv_list.lv_info (lv_index).pdirs_ok,
				(l_sv_idx = sv_idx));
			else call ioa_$nnl (
				"^/^8a:^-^3x^vx^-^6x^vx^[^/           #Seeks AveSeek Queue-wait Channel-wait  Queued Multiplier^/^]",
				pv_list.pv_info (sv_idx).drive_name, pv_list.pv_name_max_length,
				lv_list.lv_name_max_length, (l_sv_idx = sv_idx));
		     end;
		     else do;
			if (sv_idx ^= l_sv_idx) then do;
			     if pv_list.pv_info (sv_idx).used then
				call ioa_ ("^9a^va", pv_list.pv_info (sv_idx).drive_name, pv_name_max_space,
				     pv_list.pv_info (sv_idx).pvname);
			     else call ioa_ ("^9a", pv_list.pv_info (sv_idx).drive_name);
			end;
			else do;
			     call ioa_$nnl ("^9a^[^va^;^2s^vx^]", pv_list.pv_info (sv_idx).drive_name,
				pv_list.pv_info (sv_idx).used, pv_name_max_space, pv_list.pv_info (sv_idx).pvname,
				pv_name_max_space);
			     call ioa_ (
				" ^[^s^8x^;^8i^] ^[^s^8x^;^8i^]^[^s  Idle^;^6i^] ^[^s^8x^;^8i^] ^[^s^8x^;^8i^] ^[^s^;^8i^]",
				read_sum = 0, read_sum, write_sum = 0, write_sum, total_io > 1.0e29,
				total_seek / total_io, total_read = 0.0, total_read, total_write = 0.0,
				total_write, device_total_io > 1.0e29, (0.001 * fdelta) / device_total_io);
			end;
		     end;
		end;

/**** let the rest of print_dev print the last */

		pv_index = l_sv_idx;
	     end print_sv;

	end print_dev;

     end print_device;
%page;
print_q_stats:
     proc (drive_name, oqhtp, print);

/* pointer to qht is low area is passed, then the relative offset is correct
   for the other too. */

dcl	drive_name	   char (*);
dcl	oqhtp		   ptr;
dcl	print		   bit (1);

dcl	qhtp		   ptr;
dcl	1 q		   like qht based (qhtp);

	if ^print then
	     return;
	qhtp = addrel (disksp, rel (oqhtp));
	call ioa_ ("  ^a Queue: Ave ^5.1f,  Alloc ^i, Max Depth ^i/^i, Cur Depth ^i", drive_name,
	     float (q.sum - oqhtp -> q.sum) / (float (q.count - oqhtp -> q.count) + 1.0e-5), q.count - oqhtp -> q.count,
	     q.max_depth, disk_data.free_q_size, q.depth);
     end print_q_stats;
%page;
/* Print channel information. */

print_channel_info:
     proc;

/* pointer to disktab is low area is passed, then the relative
   offset is correct for the other too. */

dcl	ocp		   ptr;
dcl	headed		   bit (1);		/* header printed */
dcl	1 c		   like chantab based (ocp);

	if ^print_channels then
	     return;
	headed = "0"b;
	do i = 1 to disktab.nchan;
	     ocp = addr (addrel (odisksp, diskp -> disktab.channels) -> disk_channel_table (i));
	     cp = addr (addrel (disksp, diskp -> disktab.channels) -> disk_channel_table (i));

/* Determine if this channel is to be printed */

	     if cp -> c.connects - ocp -> c.connects > 0 | (cp -> c.ioi_use | cp -> c.inop | cp -> c.broken) then do;
		if ^headed then do;
		     call ioa_ ("^/  ^a Channel Information
               Term by  Interrupt   get_io  Term w/o
     Connects    RUN    w/o term   w/o term  Active   Status", subsys_name);
		     headed = "1"b;
		end;
		call ioa_ (
		     "^2x^3a^8i^1x^[^8i^;^s^8x^]^2x^[^9i^;^s^9x^]^2x^[^8i^;^s^8x^]^1x^[^8i^;^s^8x^] ^[ IOI^]^[ INOP^]^[ BROKEN^]",
		     cp -> chantab.chanid, cp -> c.connects - ocp -> c.connects,
		     cp -> c.status_from_run - ocp -> c.status_from_run > 0,
		     cp -> c.status_from_run - ocp -> c.status_from_run,
		     cp -> c.no_status_terminate - ocp -> c.no_status_terminate > 0,
		     cp -> c.no_status_terminate - ocp -> c.no_status_terminate,
		     cp -> c.no_io_terminate - ocp -> c.no_io_terminate > 0,
		     cp -> c.no_io_terminate - ocp -> c.no_io_terminate,
		     cp -> c.terminate_not_active - ocp -> c.terminate_not_active > 0,
		     cp -> c.terminate_not_active - ocp -> c.terminate_not_active, cp -> c.ioi_use = "1"b,
		     cp -> c.inop = "1"b, cp -> c.broken = "1"b);
	     end;
	end;
	call ioa_ ();
	return;
     end print_channel_info;
%page;
print_subsys_info:
     proc;


/* Process per-subsystem locking info. */

	call ioa_ ("^14t     Locks   Waits    %Calls  Average      %CPU");
	call print_lock ("Call Lock", addr (odiskp -> disktab.call_lock_meters));
	call print_lock ("Run Lock", addr (odiskp -> disktab.run_lock_meters));
	call print_lock ("Int Lock", addr (odiskp -> disktab.int_lock_meters));
	call print_lock ("Alloc Lock", addr (odiskp -> disktab.alloc_wait_meters));
	return;

print_lock:
	proc (lock_name, odlp);

/* pointer to disk_lock_meters is low area is passed, then the relative
   offset is correct for the other too. */

dcl	lock_name		   char (*);
dcl	odlp		   ptr;

dcl	dlp		   ptr;
dcl	lockings		   float bin (63);
dcl	waitings		   float bin (63);
dcl	1 l		   like disk_lock_meters based (dlp);

	     dlp = addrel (disksp, rel (odlp));
	     lockings = float (l.count - odlp -> l.count);
	     if lockings = 0.0 then
		return;
	     waitings = float (l.waits - odlp -> l.waits);
	     if waitings = 0.0 then
		waitings = 1.0;
	     call ioa_ ("  ^a:^14t^10i^8i ^8.4f% ^8.3f ^9.5f%", lock_name, l.count - odlp -> l.count,
		l.waits - odlp -> l.waits, 100.0 * float (l.waits - odlp -> l.waits) / lockings,
		0.001 * float (l.wait_time - odlp -> l.wait_time) / waitings,
		100.0 * float (l.wait_time - odlp -> l.wait_time) / fdelta);
	end print_lock;
     end print_subsys_info;
%page;
/* initialize argument processing. */

init_args:
     proc;

dcl	code		   fixed bin (35);

	arg_index = 1;
	call cu_$arg_count_rel (arg_count, arg_list_ptr, code);
	if code ^= 0 then
	     goto ERROR_RETURN;
	return;

/* Get next arguments.  Returns "0"b if failure. */

get_next_arg:
     entry returns (bit (1));

	if arg_index <= arg_count then do;
	     call cu_$arg_ptr_rel (arg_index, arg_ptr, arg_len, code, arg_list_ptr);
	     if code = 0 then do;
		arg_index = arg_index + 1;
		return ("1"b);			/* success */
	     end;
	end;
	return ("0"b);				/* no argument */

     end init_args;
%page;
%include get_vol_list_;
%include dskdcl;
     end disk_meters;
  



		    file_system_meters.pl1          01/26/85  1313.5r w 01/22/85  1306.6      172179


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

/*

   Last modified:

   4/14/76 by R. Bratt for demand deactivate
   10/17/76 by B. Greenberg for activations
   12/20/78 by REM for MR7
   10/08/80 by C. Hornig for new get_aste meters
   01/26/81 by E. N. Kittlitz for makeknown_activations
   03/10/81 by E. N. Kittlitz for new page skip counters & format
            changed erroneous fixed bin dcls to proper length
   07/15/81 by J. Bongiovanni for seg_fault_calls
   03/26/82 by J. Bongiovanni for volmap_seg, cleanup format
   11/08/82 by J. Bongiovanni for synch activations, force retries
   84-01-19 by BIM for segment mover meters.
   85-01-15 by Keith Loepere for covert channel meters.
*/

file_system_meters:
fsm:
   procedure options (separate_static);

      dcl	    argl		       fixed bin (21);
      dcl	    argp		       ptr;
      dcl	    argc		       fixed bin;
      dcl	    argx		       fixed bin;
      dcl	    code		       fixed bin (35);
      dcl	    faults	       float bin;
      dcl	    formatted_time	       char (10);
      dcl	    i		       float bin;
      dcl	    j		       fixed bin (35);
      dcl	    k		       float bin;
      dcl	    meter_time	       float bin;
      dcl	    meter_time_fixed       fixed bin (71);
      dcl	    seg_state_change_audit fixed bin (35);
      dcl	    seg_state_change_delay fixed bin (35);
      dcl	    sf		       fixed bin (35);
      dcl	    steps		       fixed bin (35);
      dcl	    stf		       fixed bin (35);
      dcl	    t0		       (0:3) fixed bin;
      dcl	    t1		       (0:3) fixed bin;
      dcl	    t2		       (0:3) fixed bin;
      dcl	    t3		       (0:3) float bin;
      dcl	    t4		       (0:3) fixed bin;
      dcl	    t5		       (0:3) float bin;
      dcl	    targ		       char (argl) based (argp);
      dcl	    unique	       fixed bin static init (0);
      dcl	    (as_ehs, as_level, as_init, aste_steps, as_skips, as_synch)
			       fixed bin (35);
      dcl	    (deacts, deactas, acts, mkacts, sfacts, bkacts, sfcalls, synchacts)
			       fixed bin (35);
      dcl	    (pagesw, briefsw, astsw, rsw)
			       bit (1) init ("0"b);
      dcl	    (ps_wired, ps_used, ps_mod, ps_os, ps_fc_pin, ps_cl_pin, ps_skips)
			       fixed bin (35);
      dcl	    (f_acts, f_as_skips, f_ps_skips)
			       float bin;
      dcl	    (sstp1, sstp2, tcdp1, tcdp2)
			       ptr static;
      dcl	    (a_sstp1, a_sstp2)     (1) ptr;

      dcl	    com_err_	       entry options (variable);
      dcl	    cu_$arg_count	       entry returns (fixed bin);
      dcl	    cu_$arg_ptr	       entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
      dcl	    ioa_		       entry options (variable);
      dcl	    metering_util_$define_regions
			       entry options (variable);
      dcl	    metering_util_$fill_buffers
			       entry (fixed bin, fixed bin (71), char (*), (*) ptr, (*) ptr, fixed bin (35));
      dcl	    metering_util_$reset   entry (fixed bin, fixed bin (35));
      dcl	    error_table_$noarg     ext fixed bin;
      dcl	    error_table_$badopt    fixed bin (35) ext static;

      dcl	    (max, fixed, float)    builtin;

      if unique = 0
      then
         do;					/* initialize metering_util_ */
	  call metering_util_$define_regions (unique, code, "sst_seg", 0, size (sst));
	  if code ^= 0
	  then go to error;
         end;

      argc = cu_$arg_count ();
      do argx = 1 to argc;
         call cu_$arg_ptr (argx, argp, argl, code);
         if code = error_table_$noarg | argl = 0
         then go to endarg;
         if targ = "-reset" | targ = "-rs"
         then rsw = "1"b;				/* set RESET switch */
         else if targ = "-page" | targ = "-pg"
         then pagesw = "1"b;				/* set PAGE switch */
         else if targ = "-ast"
         then astsw = "1"b;				/* set AST switch */
         else if targ = "-brief" | targ = "-bf"
         then briefsw = "1"b;				/* set BRIEF switch */
         else if targ = "-report_reset" | targ = "-rr"
         then rsw, astsw, pagesw = "1"b;
         else
	  do;
	     call com_err_ (error_table_$badopt, "file_system_meters", targ);
	     return;
	  end;
      end;

endarg:
      if argc = 0
      then astsw, pagesw = "1"b;
      if briefsw & ^pagesw & ^astsw
      then astsw, pagesw = "1"b;

      call metering_util_$fill_buffers (unique, meter_time_fixed, formatted_time, a_sstp2, a_sstp1, code);
      if code ^= 0
      then go to error;
      sstp1 = a_sstp1 (1);				/* we've only got 1 element arrays, */
      sstp2 = a_sstp2 (1);				/* so move those pointers to handy places */
      meter_time = meter_time_fixed;			/* convert to floating point variable */
      call ioa_ ("^/Total metering time^-^a^/", formatted_time);

      if astsw
      then
         do;
	  acts = sstp2 -> sst.activations - sstp1 -> sst.activations;
	  mkacts = sstp2 -> sst.makeknown_activations - sstp1 -> sst.makeknown_activations;
	  bkacts = sstp2 -> sst.backup_activations - sstp1 -> sst.backup_activations;
	  synchacts = sstp2 -> synch_activations - sstp1 -> sst.synch_activations;
	  sfacts = acts - mkacts - bkacts;
	  f_acts = max (1, acts) / 1e2;		/* setup for percentages */

	  call ioa_ ("^/^-^-   #^-     ATB");
	  call ioa_ ("^/Activations    ^10d^12.3f sec.", acts, mtb_sec (acts));

	  if sfacts ^= 0
	  then call ioa_ ("   segfault    ^10d^12.3f sec. ^7.3f% of all", sfacts, mtb_sec (sfacts), sfacts / f_acts);

	  if mkacts ^= 0
	  then call ioa_ ("   makeknown   ^10d^12.3f sec. ^7.3f% of all", mkacts, mtb_sec (mkacts), mkacts / f_acts);

	  if bkacts ^= 0
	  then call ioa_ ("   backup      ^10d^12.3f sec. ^7.3f% of all", bkacts, mtb_sec (bkacts), bkacts / f_acts);

	  j = sstp2 -> sst.dir_activations - sstp1 -> sst.dir_activations;
	  if j ^= 0
	  then call ioa_ ("   directories ^10d^12.3f sec. ^7.3f% of all", j, mtb_sec (j), j / f_acts);

	  if synchacts ^= 0
	  then call ioa_ ("   synch      ^10d^12.3f sec. ^7.3f% of all", synchacts, mtb_sec (synchacts),
		  synchacts / f_acts);

	  deacts = sstp2 -> sst.deact_count - sstp1 -> sst.deact_count;

	  call ioa_ ("Deactivations  ^10d^12.3f sec.", deacts, mtb_sec (deacts));
	  call ioa_ ("Demand deactivate");

	  deactas = sstp2 -> sst.demand_deact_attempts - sstp1 -> sst.demand_deact_attempts;
	  if deactas ^= 0
	  then call ioa_ ("   attempts    ^10d^12.3f sec.", deactas, mtb_sec (deactas));

	  j = sstp2 -> sst.demand_deactivations - sstp1 -> sst.demand_deactivations;
	  if j ^= 0
	  then call ioa_ ("   successes   ^10d^12.3f sec. ^7.3f%, ^7.3f% of total", j, mtb_sec (j),
		  (j * 100.) / max (deactas, 1), (j * 100.) / max (deacts, 1));

	  sf = sstp2 -> sst.total_sf + sstp2 -> sst.seg_fault_calls - sstp1 -> sst.total_sf
	       - sstp1 -> sst.seg_fault_calls;
	  call ioa_ ("Seg Faults     ^10d^12.3f sec.", sf, mtb_sec (sf));

	  if sf > 0
	  then
	     do;
	        j = sstp2 -> sst.total_sf - sstp1 -> sst.total_sf;
	        call ioa_ ("   fault       ^10d^12.3f sec. ^7.3f% of Seg Faults", j, mtb_sec (j),
		   float (j) * 1.0e2 / sf);
	        j = sstp2 -> sst.seg_fault_calls - sstp1 -> sst.seg_fault_calls;
	        call ioa_ ("   call        ^10d^12.3f sec. ^7.3f% of Seg Faults", j, mtb_sec (j),
		   float (j) * 1.0e2 / sf);
	        call ioa_ ("   activations ^10d^12.3f sec. ^7.3f% of Seg Faults", sfacts, mtb_sec (sfacts),
		   float (sfacts) * 1.0e2 / sf);
	     end;

	  j = sstp2 -> sst.total_bf - sstp1 -> sst.total_bf;
	  call ioa_ ("Bound Faults ^12d^12.3f sec.", j, mtb_sec (j));

	  if ^briefsw
	  then
	     do;
	        stf = sstp2 -> sst.setfaults_all - sstp1 -> sst.setfaults_all;
	        call ioa_ ("Setfaults      ^10d^12.3f msec.", stf, mtb_msec (stf));

	        if stf > 0
	        then
		 do;
		    j = sstp2 -> sst.setfaults_acc - sstp1 -> sst.setfaults_acc;
		    call ioa_ ("   access      ^10d^12.3f sec. ^7.3f% of setfaults", j, mtb_sec (j),
		         float (j) * 1.0e2 / stf);
		 end;

	        j = sstp2 -> sst.updates - sstp1 -> sst.updates;
	        call ioa_ ("ASTE Trickle   ^10d^12.3f sec.", j, mtb_sec (j));

/**** Segment_mover meters */

	        k = sstp2 -> sst.sgm_time - sstp1 -> sst.sgm_time;
	        k = k / 1e3;			/* msec */
	        j = sstp2 -> sst.sgm_pf - sstp1 -> sst.sgm_pf;
	        i = (sstp2 -> sst.good_sgms + sstp2 -> sst.bad_sgms) - (sstp1 -> sst.good_sgms + sstp1 -> sst.bad_sgms);
	        if i > 0
	        then
		 do;
		    call ioa_ ("Segment moves  ^10d", i);
		    call ioa_ ("   vcpu        ^12.3f", k);
		    call ioa_ ("   good        ^10d", sstp2 -> sst.good_sgms - sstp1 -> sst.good_sgms);
		    call ioa_ ("   bad         ^10d", sstp2 -> sst.bad_sgms - sstp1 -> sst.bad_sgms);
		    call ioa_ ("   reads       ^10d", sstp2 -> sst.segmove_n_reads - sstp1 -> sst.segmove_n_reads);
		    call ioa_ ("   max retries ^10d", sstp2 -> sst.segmove_max_tries - sstp1 -> sst.segmove_max_tries)
		         ;
		    call ioa_ ("   page_faults ^10d", sstp2 -> sst.sgm_pf - sstp1 -> sst.sgm_pf);
		    call ioa_ ("   seg_faults  ^10d", sstp2 -> sst.sgm_sgft - sstp1 -> sst.sgm_sgft);
		 end;

	        aste_steps = sstp2 -> sst.stepsa - sstp1 -> sst.stepsa;
	        call ioa_ ("Steps	     ^10d^12.3f msec.", aste_steps, mtb_msec (aste_steps));

	        as_ehs = sstp2 -> sst.askipsehs - sstp1 -> sst.askipsehs;
	        as_level = sstp2 -> sst.askipslevel - sstp1 -> sst.askipslevel;
	        as_init = sstp2 -> sst.askipsinit - sstp1 -> sst.askipsinit;
	        as_synch = sstp2 -> sst.synch_skips - sstp1 -> sst.synch_skips;

	        as_skips = as_ehs + as_level + as_init + as_synch;

	        call ioa_ ("Skips          ^10d^12.3f sec. ^7.3f% of Steps", as_skips, mtb_sec (as_skips),
		   (as_skips * 1e2) / max (1, aste_steps));

	        f_as_skips = max (as_skips, 1) / 1e2;	/* setup for percentages */

	        if as_ehs ^= 0
	        then call ioa_ ("   ehs         ^10d^12.3f sec. ^7.3f% of Skips", as_ehs, mtb_sec (as_ehs),
		        as_ehs / f_as_skips);

	        if as_level ^= 0
	        then call ioa_ ("   mem         ^10d^12.3f sec. ^7.3f% of Skips", as_level, mtb_sec (as_level),
		        as_level / f_as_skips);

	        if as_init ^= 0
	        then call ioa_ ("   init        ^10d^12.3f sec. ^7.3f% of Skips", as_init, mtb_sec (as_init),
		        as_init / f_as_skips);

	        if as_synch ^= 0
	        then call ioa_ ("   synch       ^10d^12.3f sec. ^7.3f% of Skips", as_synch, mtb_sec (as_synch),
		        as_synch / f_as_skips);

	        j = sstp2 -> sst.asearches - sstp1 -> sst.asearches;
	        call ioa_ ("Searches       ^10d^12.3f sec. ^[^7.3f Average cost^;^s^]", j, mtb_sec (j), (j > 0),
		   float (sstp2 -> sst.acost - sstp1 -> sst.acost) / max (j, 1));
	     end;

	  j = sstp2 -> sst.cleanup_count - sstp1 -> sst.cleanup_count;
	  k = sstp2 -> sst.cleanup_real_time - sstp1 -> sst.cleanup_real_time;
	  k = k * 1e2 / max (1e0, meter_time);
	  call ioa_ ("Cleanups^-^15d^12.3f sec. ^5.1f % of real time", j, mtb_sec (j), k);


	  j = sstp2 -> sst.force_swrites - sstp1 -> sst.force_swrites;
	  call ioa_ ("Force writes      ^7d^12.3f sec.", j, mtb_sec (j));
	  if j ^= 0
	  then
	     do;					/* only print details if any fw */
	        i = j * 1e3;
	        j = sstp2 -> sst.fw_none - sstp1 -> sst.fw_none;
	        i = i - j * 1e3;
	        if j ^= 0
	        then call ioa_ ("   without pwrites^7d^12.3f sec.", j, mtb_sec (j));

	        j = sstp2 -> sst.force_pwrites - sstp1 -> sst.force_pwrites;
	        if j ^= 0
	        then call ioa_ ("   pages written ^8d^12.3f sec.", j, mtb_sec (j));

	        j = sstp2 -> sst.force_updatevs - sstp1 -> sst.force_updatevs;
	        if j ^= 0
	        then call ioa_ ("   force updatev ^8d^12.3f sec.", j, mtb_sec (j));
	        j = sstp2 -> sst.fw_retries - sstp1 -> sst.fw_retries;
	        if j ^= 0
	        then call ioa_ ("   force retries ^8d^12.3f sec.", j, mtb_sec (j));
	     end;

	  j = sstp2 -> sst.ast_locking_count - sstp1 -> sst.ast_locking_count;
	  call ioa_ ("Lock AST       ^10d^12.3f sec.", j, mtb_sec (j));
	  call ioa_ (" ");				/* Breakout AST lock meters */
	  call ioa_ ("^-^- AVE/lock^-      %");

	  k = sstp2 -> sst.ast_locked_total_time - sstp1 -> sst.ast_locked_total_time;
	  j = sstp2 -> sst.ast_locking_count - sstp1 -> sst.ast_locking_count;

	  if j > 0
	  then i = 1e-3 * k / j;
	  else i = 0e0;				/* ave msec locked */

	  k = 1e2 * k / max (meter_time, 1e0);
	  call ioa_ ("AST locked      ^9.3f msec.^6.1f", i, k);

	  k = sstp2 -> sst.ast_lock_wait_time - sstp1 -> sst.ast_lock_wait_time;
	  if j > 0e0
	  then i = 1e-3 * k / j;
	  else i = 0e0;				/* ave msec wait */

	  k = 1e2 * k / max (meter_time, 1e0);
	  call ioa_ ("AST lock waiting^9.3f msec.^6.1f", i, k);

	  do j = 0 to 3;
	     t0 (j) = sstp2 -> sst.pts (j);
	     t1 (j) = sstp2 -> sst.asteps (j) - sstp1 -> sst.asteps (j);
	     t2 (j) = sstp2 -> sst.aneedsize (j) - sstp1 -> sst.aneedsize (j);
	     t3 (j) = float (t1 (j)) / max (1e0, float (t2 (j)));
	     t4 (j) = fixed (sstp2 -> sst.no_aste (j));
	     t5 (j) = (t4 (j) / max (1e0, t1 (j))) * meter_time * 1e-6;
	  end;

	  call ioa_ ("^/AST Sizes    ^10d^10d^10d^10d", t0 (0), t0 (1), t0 (2), t0 (3));
	  call ioa_ ("Number       ^10d^10d^10d^10d", t4 (0), t4 (1), t4 (2), t4 (3));
	  call ioa_ ("Need         ^10d^10d^10d^10d", t2 (0), t2 (1), t2 (2), t2 (3));
	  call ioa_ ("Steps        ^10d^10d^10d^10d", t1 (0), t1 (1), t1 (2), t1 (3));
	  call ioa_ ("Ave Steps    ^10.1f^10.1f^10.1f^10.1f", t3 (0), t3 (1), t3 (2), t3 (3));
	  call ioa_ ("Lap Time(sec)^10.1f^10.1f^10.1f^10.1f", t5 (0), t5 (1), t5 (2), t5 (3));
         end;

      if pagesw
      then
         do;
	  call ioa_ ("^/^-       #^-^-ATB^/");
	  j, faults = sstp2 -> sst.needc - sstp1 -> sst.needc;

	  call ioa_ ("Needc     ^10d^12.3f msec.", j, mtb_msec (j));

	  j = sstp2 -> sst.ceiling - sstp1 -> sst.ceiling;
	  if j ^= 0
	  then call ioa_ ("Ceiling   ^10d^12.3f min.", j, mtb_sec (60 * j));

	  j = sstp2 -> sst.claim_runs - sstp1 -> sst.claim_runs;
	  if j ^= 0
	  then call ioa_ ("Claim runs^10d^12.3f min.", j, mtb_sec (60 * j));

	  if faults ^= 0e0
	  then
	     do;
	        call ioa_ ("Ring 0 faults^-^12.3f %",
		   float (sstp2 -> sst.ring_0_page_faults - sstp1 -> sst.ring_0_page_faults) * 1e2 / faults);
	        call ioa_ ("PDIR faults^-^12.3f %",
		   float (sstp2 -> sst.pdir_page_faults - sstp1 -> sst.pdir_page_faults) * 1e2 / faults);
	        call ioa_ ("Level 2 faults^-^12.3f %",
		   float (sstp2 -> sst.level_1_page_faults - sstp1 -> sst.level_1_page_faults) * 1e2 / faults);
	        call ioa_ ("DIR faults^-^12.3f %",
		   float (sstp2 -> sst.dir_page_faults - sstp1 -> sst.dir_page_faults) * 1e2 / faults);
	        call ioa_ ("New Pages^-^-^12.3f %",
		   float (sstp2 -> sst.new_pages - sstp1 -> sst.new_pages) * 1e2 / faults);

	        i = (sstp2 -> sst.oopv - sstp1 -> sst.oopv);
	        if i > 0
	        then call ioa_ ("OOPV      ^10d^12.3f %", i, float (i) * 1e2 / faults);
	     end;

	  j = sstp2 -> sst.volmap_seg_page_faults - sstp2 -> sst.volmap_seg_page_faults;
	  call ioa_ ("Volmap_seg^10d^12.3f msec.", j, mtb_msec (j));

	  j = sstp2 -> sst.zero_pages - sstp1 -> sst.zero_pages;
	  call ioa_ ("Zero pages^10d^12.3f msec.", j, mtb_msec (j));

	  seg_state_change_delay = sstp2 -> sst.delayed_seg_state_chg - sstp1 -> sst.delayed_seg_state_chg;
	  seg_state_change_audit = sstp2 -> sst.audit_seg_state_chg - sstp1 -> sst.audit_seg_state_chg;

	  if seg_state_change_delay > 0 | seg_state_change_audit > 0
	  then
	     do;
	        call ioa_ ("Seg state chg.");
	        if seg_state_change_delay > 0
	        then
		 do;
		    k = sstp2 -> sst.seg_state_chg_delay - sstp1 -> sst.seg_state_chg_delay;
		    i = 1e-6 * k / seg_state_change_delay;
		    call ioa_ ("   delayed^10d^12.3f sec.  ^7.3f sec. avg. delay", seg_state_change_delay,
		         mtb_sec (seg_state_change_delay), i);
		 end;
	        if seg_state_change_audit > 0
	        then call ioa_ ("   audited^10d^12.3f sec.", seg_state_change_audit, mtb_sec (seg_state_change_audit));
	     end;

	  steps = sstp2 -> sst.steps - sstp1 -> sst.steps;
	  j = steps / sstp2 -> sst.nused;
	  call ioa_ ("Laps      ^10d^12.3f sec.", j, mtb_sec (j));

	  if ^briefsw
	  then
	     do;
	        call ioa_ ("Steps	^10d^12.3f msec.", steps, mtb_msec (steps));
	        ps_wired = sstp2 -> sst.skipw - sstp1 -> sst.skipw;
	        ps_used = sstp2 -> sst.skipu - sstp1 -> sst.skipu;
	        ps_mod = sstp2 -> sst.skipm - sstp1 -> sst.skipm;
	        ps_os = sstp2 -> sst.skipos - sstp1 -> sst.skipos;
	        ps_fc_pin = sstp2 -> sst.fc_skips_pinned - sstp1 -> sst.fc_skips_pinned;
	        ps_cl_pin = sstp2 -> sst.cl_skips_pinned - sstp1 -> sst.cl_skips_pinned;
	        ps_skips = ps_wired + ps_used + ps_mod + ps_os + ps_fc_pin + ps_cl_pin;

	        call ioa_ ("Skip      ^10d^12.3f msec. ^7.3f% of Steps", ps_skips, mtb_msec (ps_skips),
		   (ps_skips * 1e2) / max (1, steps));

	        f_ps_skips = max (ps_skips, 1) / 1e2;	/* setup for percentages */
	        if ps_wired ^= 0
	        then call ioa_ ("   wired  ^10d^12.3f msec. ^7.3f% of Skip", ps_wired, mtb_msec (ps_wired),
		        ps_wired / f_ps_skips);

	        if ps_used ^= 0
	        then call ioa_ ("   used   ^10d^12.3f msec. ^7.3f% of Skip", ps_used, mtb_msec (ps_used),
		        ps_used / f_ps_skips);

	        if ps_mod ^= 0
	        then call ioa_ ("   mod    ^10d^12.3f msec. ^7.3f% of Skip", ps_mod, mtb_msec (ps_mod),
		        ps_mod / f_ps_skips);

	        if ps_os ^= 0
	        then call ioa_ ("   os     ^10d^12.3f msec. ^7.3f% of Skip", ps_os, mtb_msec (ps_os),
		        ps_os / f_ps_skips);

	        if ps_fc_pin ^= 0
	        then call ioa_ ("   fc pin ^10d^12.3f msec. ^7.3f% of Skip", ps_fc_pin, mtb_msec (ps_fc_pin),
		        ps_fc_pin / f_ps_skips);

	        if ps_cl_pin ^= 0
	        then call ioa_ ("   cl pin ^10d^12.3f msec. ^7.3f% of Skip", ps_cl_pin, mtb_msec (ps_cl_pin),
		        ps_cl_pin / f_ps_skips);
	     end;

	  call ioa_ ("^/^d pages, ^d wired.", sstp2 -> sst.nused, sstp2 -> sst.wired);
	  call ioa_ ("Average steps ^12.3f", steps / max (faults, 1e0));
         end;

      if rsw
      then call metering_util_$reset (unique, code);
      if code ^= 0
      then go to error;

      call ioa_ (" ");
      return;

error:
      call com_err_ (code, "file_system_meters");
      return;


mtb_sec:
   proc (x) returns (float bin);

      dcl	    x		       fixed bin (35);

      if x = 0
      then return (0e0);
      else return (meter_time / (x * 1e6));

   end;


mtb_msec:
   proc (x) returns (float bin);

      dcl	    x		       fixed bin (35);

      if x = 0
      then return (0e0);
      else return (meter_time / (x * 1e3));

   end;
%page;
%include sst;

   end;
 



		    fim_meters.pl1                  12/12/83  1627.1r w 12/12/83  1559.5      140067


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

fim_meters:
     proc;


/* Program to print per-system count of faults by fault type,
   which is accumulated in wired_hardcore_data by ring-0 fault
   processing (fim, wired_fim, page_fault).

   Written January 1981 by J. Bongiovanni
   Modified July 1981 by J. Bongiovanni for -reset fix
   Modified October 1983 by R. Coppola for per-cpu fault counters
*/

/* Automatic */

dcl	CPU		fixed bin;
dcl	DISPLAY_SIZE	fixed bin;
dcl	INX		fixed bin;
dcl	argl		fixed bin (21);
dcl	argc		fixed bin (21);		/* character index into current arg */
dcl	argp		ptr;
dcl	ccp		(1) ptr;
dcl	code		fixed bin (35);
dcl	cpu		bit (1);
dcl	cpu_index		fixed bin;
dcl	cpu_string	bit (8) aligned;
dcl	1 cur_per_cpu_ctrs	(MAX_CPUS) aligned,
	  2 fault_counters	(NO_TOTAL_FAULTS) fixed bin (35);
dcl	1 prev_per_cpu_ctrs (MAX_CPUS) aligned,
	  2 fault_counters	(NO_TOTAL_FAULTS) fixed bin (35);
dcl	cur_ptr		(MAX_CPUS) ptr;
dcl	default_to_all	bit (1);
dcl	display_cpu	(9) fixed bin;
dcl	got_cpu		(MAX_CPUS + 1) bit (1);
dcl	formatted_time	(MAX_CPUS) char (10);
dcl	found_name	bit (1);
dcl	i		fixed bin;
dcl	j		fixed bin;
dcl	k		fixed bin;
dcl	l		fixed bin;
dcl	1 line		unal,
	  2 title		char (26),
	  2 field		(8) char (13);
dcl	line_length	fixed bin (17);
dcl	long		bit (1);
dcl	meter_time	(MAX_CPUS) fixed bin (71);
dcl	meters_printed	fixed bin;
dcl	nargs		fixed bin;
dcl	ncpus_selected	fixed bin;
dcl	ncpus_to_do	fixed bin;
dcl	order		(32) fixed bin;
dcl	pcp		(1) ptr;
dcl	pic13		picture "zzzzzzzzzzzz9";
dcl	prev_ptr		(MAX_CPUS) ptr;
dcl	print_fault	(32) bit (1);
dcl	report		bit (1);
dcl	reset		bit (1);
dcl	single_fault_index	fixed bin;
dcl	sort		bit (1);
dcl	sub_order		(NO_TOTAL_FAULTS) fixed bin;
dcl	temp_sw		bit (1);
dcl	total		bit (1);
dcl	total_sw		bit (1);
dcl	totals_only	bit (1);
dcl	total_flt_ctrs	(NO_TOTAL_FAULTS) fixed bin (35);


/* Static */

dcl	unique		(8) fixed bin int static init (0, 0, 0, 0, 0, 0, 0, 0);

dcl	ALL_CPUS		bit (8) int static options (constant) init ("11111111"b);

dcl	CPU_TAGS		char (16) int static options (constant) init ("ABCDEFGHabcdefgh");

dcl	my_name		char (10) init ("fim_meters") int static options (constant);
dcl	entry_names	(8) char (19) int static options (constant)
			init ("cpu_a_flt_ctr_array", "cpu_b_flt_ctr_array", "cpu_c_flt_ctr_array",
			"cpu_d_flt_ctr_array", "cpu_e_flt_ctr_array", "cpu_f_flt_ctr_array", "cpu_g_flt_ctr_array",
			"cpu_h_flt_ctr_array");


/* Based */

dcl	arg		char (argl) based (argp);
dcl	cur_fault_count	(NO_TOTAL_FAULTS) fixed bin (35) based (ccp (1));
dcl	prev_fault_count	(NO_TOTAL_FAULTS) fixed bin (35) based (pcp (1));

/* Entry */

dcl	com_err_		entry options (variable);
dcl	cu_$arg_count	entry (fixed bin);
dcl	cu_$arg_ptr	entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
dcl	get_line_length_$switch
			entry (ptr, fixed bin (35)) returns (fixed bin);
dcl	ioa_		entry options (variable);
dcl	ioa_$rsnnl	entry () options (variable);
dcl	metering_util_$define_regions
			entry options (variable);
dcl	metering_util_$fill_buffers
			entry (fixed bin, fixed bin (71), char (*), (*) ptr, (*) ptr, fixed bin (35));
dcl	metering_util_$reset
			entry (fixed bin, fixed bin (35));

/* External */

dcl	error_table_$bad_arg
			fixed bin (35) external;
dcl	error_table_$badopt fixed bin (35) external;
dcl	error_table_$inconsistent
			fixed bin (35) external;
dcl	error_table_$noarg	fixed bin (35) external;
%page;
%include fim_meters;
%page;

/* Pick up and validate each argument								*/


	ncpus_selected, single_fault_index = 0;
	totals_only, total_sw = "1"b;			/* default */
	cpu_string, cpu, default_to_all, long, report, reset, sort, total, got_cpu (*) = "0"b;
	call cu_$arg_count (nargs);
	do i = 1 to nargs;
	     call cu_$arg_ptr (i, argp, argl, code);
	     if substr (arg, 1, 1) ^= "-" & i = 1 & nargs = 1
	     then do;				/* arg is fault name			*/
		     do j = 1 to NO_HARDWARE_FAULTS while (single_fault_index = 0);
						/*  look for name in tables	*/
			if arg = LONG_FAULT_NAME (j) | arg = SHORT_FAULT_NAME (j)
			then single_fault_index = j;
		     end;
		     if single_fault_index = 0
		     then do j = NO_HARDWARE_FAULTS + 1 to NO_TOTAL_FAULTS while (single_fault_index = 0);
			     if arg = LONG_FAULT_NAME (j)
			     then single_fault_index = j;
			end;
		     if single_fault_index = 0
		     then do;			/* invalid fault name			*/
			     call com_err_ (error_table_$bad_arg, my_name, "Invalid fault name. ^a", arg);
			     return;
			end;
		end;
	     else if arg = "-report"
	     then report = "1"b;
	     else if arg = "-reset" | arg = "-rs"
	     then reset = "1"b;
	     else if arg = "-report_reset" | arg = "-rr"
	     then do;
		     report = "1"b;
		     reset = "1"b;
		end;
	     else if arg = "-long" | arg = "-lg"
	     then long = "1"b;

	     else if arg = "-tt" | arg = "total"
	     then total = "1"b;

	     else if arg = "-sort"
	     then do;
		     sort = "1"b;			/* sort by count is default			*/
		     call cu_$arg_ptr (i + 1, argp, argl, code);
						/* check for sort string			*/
		     if code = 0
		     then /* argument exists				*/
			if substr (arg, 1, 1) ^= "-"
			then do;			/* not control argument			*/
				if arg = "number"
				then sort = "0"b;	/* sort by fault number (no sort, really)	*/
				else if arg = "count"
				then sort = "1"b;	/* sort by count of faults		*/
				else do;		/* invalid sort string			*/
					call com_err_ (error_table_$bad_arg, my_name, "Invalid sort string. ^a",
					     arg);
					return;
				     end;
				i = i + 1;	/* adjust argument number			*/
			     end;
		end;

	     else if arg = "-cpu"
	     then do;
		     cpu = "1"b;
		     totals_only = "0"b;
		     if i = nargs
		     then default_to_all = "1"b;
		     else do;
			     call cu_$arg_ptr (i + 1, argp, argl, code);
			     if char (arg, 1) = "-"
			     then default_to_all = "1"b;
			end;

		     if default_to_all
		     then do;			/* No cpu_list, defaults to all cpus */
			     substr (cpu_string, 1, MAX_CPUS) = ALL_CPUS;
			     ncpus_selected = MAX_CPUS;
			end;

		     else do;			/* cpus specified by tag */
			     i = i + 1;		/* update index */
			     if argl > 8
			     then do;
				     call com_err_ (0, my_name, "Too many CPUs specified (^a).", arg);
				     return;
				end;

			     if verify (arg, CPU_TAGS) ^= 0
			     then do;
				     call com_err_ (0, my_name, "Invalid CPU Tag(s) ^a", arg);
				     return;
				end;
			     do argc = 1 to argl;
				substr (cpu_string, mod (index (CPU_TAGS, substr (arg, argc, 1)) - 1, 8) + 1, 1) =
				     "1"b;
				ncpus_selected = ncpus_selected + 1;
			     end;
			end;
		end;


	     else do;
		     call com_err_ (error_table_$badopt, my_name, arg);
		     return;
		end;
	end;


	if cpu & sort
	then do;
		call com_err_ (error_table_$inconsistent, my_name, "Incompatible args selected, -cpu & -sort.");
		return;
	     end;

	if ^report & ^reset
	then report = "1"b;				/* default is -report			*/

/* Initialize if this is the first call */

	do i = 1 to MAX_CPUS;
	     if unique (i) = 0
	     then do;
		     call metering_util_$define_regions (unique (i), code, "wired_hardcore_data", entry_names (i),
			NO_TOTAL_FAULTS);
		     if code ^= 0
		     then call com_err_ (code, my_name, "Initializing");
		end;
	end;


/* Set flags to print all existent faults 							*/

		do i = 1 to NO_HARDWARE_FAULTS;
		     print_fault (i) = EXTANT_FAULT (i);
		end;

		total_flt_ctrs (*) = 0;
		do i = 1 to MAX_CPUS;
		     call metering_util_$fill_buffers (unique (i), meter_time (i), formatted_time (i), ccp, pcp, code)
			;
		     if code ^= 0
		     then do;
			     call com_err_ (code, my_name, "Filling buffers");
			     return;
			end;
		     cur_ptr (i) = ccp (1);
		     prev_ptr (i) = pcp (1);
		     cur_per_cpu_ctrs (i).fault_counters (*) = cur_fault_count (*);
		     prev_per_cpu_ctrs (i).fault_counters (*) = prev_fault_count (*);
		     if substr (cpu_string, i, 1)
		     then got_cpu (i) = "1"b;		/* for printing purposes		*/
		     if sum (cur_fault_count (*)) - sum (prev_fault_count (*)) = 0
		     then got_cpu (i) = "0"b;		/* this cpu has never been on-line */


		     do INX = 1 to NO_TOTAL_FAULTS;	/* keep track of total faults */
			total_flt_ctrs (INX) =
			     total_flt_ctrs (INX)
			     + (cur_per_cpu_ctrs (i).fault_counters (INX)
			     - prev_per_cpu_ctrs (i).fault_counters (INX));
		     end;

		end;

/* Now have all totals per cpu and for all cpus, time to print everything */

	if report
	then do;

		line_length = get_line_length_$switch (null (), code);
		if line_length < 132
		then DISPLAY_SIZE = 4;
		else DISPLAY_SIZE = 8;
		if code ^= 0
		then DISPLAY_SIZE = 8;


		call ioa_ ("^/Total Metering Time:^-^a", formatted_time (1));
		if totals_only
		then do;
			call print_totals_only ();
		     end;
		else do;
			display_cpu (*) = 0;
			cpu_index = 1;
			call get_cpus_to_display ();
			if ncpus_selected > DISPLAY_SIZE
			then do;
				call print_cpu_meters ("0"b);
				display_cpu (*) = 0;
				call get_cpus_to_display ();
			     end;
			call print_cpu_meters (total);
		     end;
	     end;

	if reset then do;
	do i = 1 to MAX_CPUS;
		call metering_util_$reset (unique (i), code);
		if code ^= 0
		then call com_err_ (code, my_name, "Resetting");
	     end;
	  total_flt_ctrs (*) = 0;
	  end;
         call ioa_ ("^/");
%page;
/* Internal procedure to sort an array of indices by count of faults					*/

bubble_sort:
     proc (N, array);

dcl	array		(*) fixed bin;		/* array of indices				*/
dcl	N		fixed bin;

dcl	i		fixed bin;
dcl	j		fixed bin;
dcl	k		fixed bin;


	do i = 1 to N - 1;
	     do j = i + 1 to N;
		if total_flt_ctrs (array (i)) < total_flt_ctrs (array (j))
		then do;
			k = array (i);
			array (i) = array (j);
			array (j) = k;
		     end;
	     end;
	end;

     end bubble_sort;
%page;
/* Internal procedure */
get_cpus_to_display:
     proc ();

dcl	(i, j)		fixed bin;

	j = 0;
	do i = cpu_index to MAX_CPUS while (j < DISPLAY_SIZE);
	     if got_cpu (i)
	     then do;
		     j = j + 1;
		     display_cpu (j) = i;
		end;
	end;
	cpu_index = i;				/* set up for next call */

     end get_cpus_to_display;
%page;
/* Internal procedure to print meters                      						*/

print_hw_fault:
     proc (sub_order_sw, ifault, totals_too);

dcl	(icpu, ifault, j)	fixed bin;
dcl	totals_too	bit (1);
dcl	output		char (132) var;
dcl	(ignore, k)	fixed bin;
dcl	sub_order_sw	bit (1);
dcl	totals_position	fixed bin;
dcl	first_zero	bit (1);
dcl	non_zero		bit (1);

	non_zero = "0"b;
	output = "";
	totals_position = DISPLAY_SIZE;
	first_zero = "1"b;

	do j = 1 to DISPLAY_SIZE while (non_zero = "0"b);
	     if display_cpu (j) > 0
	     then do;
		     if ^sub_order_sw
		     then do;
			     if (cur_per_cpu_ctrs (display_cpu (j)).fault_counters (ifault)
				- prev_per_cpu_ctrs (display_cpu (j)).fault_counters (ifault)) ^= 0
			     then non_zero = "1"b;
			end;
		     else do;
			     if cur_per_cpu_ctrs (display_cpu (j)).fault_counters (sub_order (ifault))
				- prev_per_cpu_ctrs (display_cpu (j)).fault_counters (sub_order (ifault)) ^= 0
			     then non_zero = "1"b;
			end;

		end;
	end;
	if ^non_zero
	then return;				/* dont display all zero lines */

	string (line) = "";				/* clear the display line */
	if ^sub_order_sw
	then call ioa_$rsnnl ("^30a", output, ignore, LONG_FAULT_NAME (ifault));
	else call ioa_$rsnnl ("^3t^30a", output, ignore, LONG_FAULT_NAME (sub_order (ifault)));
	line.title = rtrim (output);

	k = 0;
	do j = 1 to DISPLAY_SIZE;
	     if display_cpu (j) > 0
	     then do;
		     k = k + 1;
		     if ^sub_order_sw
		     then do;
			     pic13 = cur_per_cpu_ctrs (display_cpu (j)).fault_counters (ifault)
				- prev_per_cpu_ctrs (display_cpu (j)).fault_counters (ifault);
			     line.field (k) = pic13;
			end;

		     else do;
			     pic13 = cur_per_cpu_ctrs (display_cpu (j)).fault_counters (sub_order (ifault))
				- prev_per_cpu_ctrs (display_cpu (j)).fault_counters (sub_order (ifault));
			     line.field (k) = pic13;
			end;
		end;
	     else do;
		     if first_zero
		     then do;
			     totals_position = j;
			     first_zero = "0"b;
			end;
		end;
	end;

	if totals_too
	then do;
		k = k + 1;
		if ^sub_order_sw
		then do;
			pic13 = total_flt_ctrs (ifault);
			line.field (k) = pic13;
		     end;
		else do;
			pic13 = total_flt_ctrs (sub_order (ifault));
			line.field (k) = pic13;
		     end;
	     end;

	call ioa_ ("^a", string (line));

     end print_hw_fault;
%page;
/* Internal procedure to print meters                      						*/

print_cpu_meters:
     proc (totals_too);

dcl	totals_too	bit (1) parameter;
dcl	(i, j, k, l)	fixed bin;
dcl	ignore		fixed bin;


	string (line) = "";
	line.title = "Fault Type";
	k = 0;
	do j = 1 to DISPLAY_SIZE;
	     if display_cpu (j) > 0
	     then do;
		     k = k + 1;
		     line.field (k) = "        CPU " || CPU_NAMES (display_cpu (j));
		end;
	end;

	if totals_too
	then do;
		k = k + 1;
		line.field (k) = "       TOTALS";
	     end;
	call ioa_ ("^/^a", string (line));


	do i = 1 to NO_HARDWARE_FAULTS;

	     if LONG_FAULT_NAME (i) = "<invalid>"
	     then goto SKIP_IT;
	     call print_hw_fault ("0"b, i, totals_too);
	     if long
	     then do;				/* print subordinate fault info		*/
		     k = 0;
		     j = i;
		     do while (THREAD_FAULT (j) ^= 0);
			k = k + 1;
			sub_order (k) = THREAD_FAULT (j);
			j = THREAD_FAULT (j);
		     end;

		     if k > 0
		     then do;
			     do l = 1 to k;
				call print_hw_fault ("1"b, l, totals_too);
			     end;
			end;
		end;
SKIP_IT:
	end;


     end print_cpu_meters;
%page;
/* Internal procedure to print total meters                      						*/

print_totals_only:
     proc ();

	call ioa_ ("^/Fault Type^29tTotal Fault Count");

	if single_fault_index = 0
	then do;
		do i = 1 to NO_HARDWARE_FAULTS;
		     order (i) = i;
		     if total_flt_ctrs (i) = 0
		     then print_fault (i) = "0"b;	/* eliminate zeroes */
		end;
		if sort
		then call bubble_sort (NO_HARDWARE_FAULTS, order);
						/* sort by count of faults		*/

		do i = 1 to NO_HARDWARE_FAULTS;
		     if print_fault (order (i))
		     then do;
			     call ioa_ ("^30a^33t^13d", LONG_FAULT_NAME (order (i)), total_flt_ctrs (order (i)));

			     if long
			     then do;		/* print subordinate fault info		*/
				     k = 0;
				     j = order (i);

				     do while (THREAD_FAULT (j) ^= 0);
					if total_flt_ctrs (THREAD_FAULT (j)) ^= 0
					then temp_sw = "1"b;

					if ^sort | temp_sw
					then do;
						k = k + 1;
						sub_order (k) = THREAD_FAULT (j);
					     end;
					j = THREAD_FAULT (j);
				     end;
				     if k > 0
				     then do;
					     if sort
					     then call bubble_sort (k, sub_order);
					     do l = 1 to k;
						if total_flt_ctrs (sub_order (l)) ^= 0
						then call ioa_ ("^3x^30a^33t^13d",
							LONG_FAULT_NAME (sub_order (l)),
							total_flt_ctrs (sub_order (l)));
					     end;
					end;
				end;
			end;
		end;
	     end;

	else call ioa_ ("^30a^33t^13d", LONG_FAULT_NAME (single_fault_index), total_flt_ctrs (single_fault_index));

     end print_totals_only;


     end fim_meters;
 



		    hc_pf_meters.pl1                01/26/85  1313.5r w 01/22/85  1307.7      102168


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


/* format: style3 */
hc_pf_meters:
     proc;

/*  Program to print page faults by hardcore segments

    Written December 1981 by J. Bongiovanni
    Modified July 1984 by Keith Loepere to understand a paged sst.
*/

/*  Automatic  */

dcl	argl		fixed bin (21);
dcl	argp		ptr;
dcl	arg_no		fixed bin;
dcl	code		fixed bin (35);
dcl	cur_time		fixed bin (71);
dcl	hr		fixed bin;
dcl	HR		pic "zzz9";
dcl	init_temp_segp	(4) ptr;
dcl	metering_time	fixed bin (71);
dcl	minute		fixed bin (35);
dcl	MINUTE		pic "99";
dcl	1 my_seg_aste	aligned like seg_aste;
dcl	n_args		fixed bin;
dcl	n_to_print	fixed bin (35);
dcl	pct_pf		float;
dcl	pt_relp		fixed bin (24);
dcl	report_sw		bit (1);
dcl	reset_sw		bit (1);
dcl	sec		fixed bin (35);
dcl	SEC		pic "99";
dcl	seg_entryp	ptr;
dcl	segn		fixed bin;
dcl	segx		fixed bin;
dcl	sort_sw		bit (1);
dcl	sst_size		fixed bin (19);
dcl	sstadd		fixed bin (24);
dcl	sstp		ptr;
dcl	stack_no		pic "999";
dcl	total_pf		fixed bin (35);
dcl	unpaged_page_tables_header
			(8) bit (36) aligned;	/* should be big enough */

/*  Static  */

dcl	init		bit (1) int static init ("0"b);
dcl	last_time		fixed bin (71) int static init (0);
dcl	temp_segp		(2) ptr int static;
dcl	MYNAME		char (12) int static options (constant) init ("hc_pf_meters");

/*  Based  */

dcl	arg		char (argl) based (argp);
dcl	1 seg_info	aligned based (temp_segp (1)),
	  2 n_segs	fixed bin,
	  2 seg		(0 refer (seg_info.n_segs)) aligned like seg_entry;
dcl	1 seg_entry	aligned based (seg_entryp),
	  2 name		char (32) unaligned,
	  2 rel_astep	fixed bin (18),
	  2 prev_pf	fixed bin (35),
	  2 cur_pf	fixed bin (35),
	  2 delta_pf	fixed bin (35);
dcl	1 sort_array	aligned based (temp_segp (2)),
	  2 n		fixed bin (24),
	  2 p		(0 refer (sort_array.n)) ptr unal;

/*  Entry  */

dcl	com_err_		entry options (variable);
dcl	cu_$arg_count	entry (fixed bin, fixed bin (35));
dcl	cu_$arg_ptr	entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
dcl	cv_dec_check_	entry (char (*), fixed bin (35)) returns (fixed bin (35));
dcl	get_temp_segments_	entry (char (*), (*) ptr, fixed bin (35));
dcl	ioa_		entry options (variable);
dcl	release_temp_segments_
			entry (char (*), (*) ptr, fixed bin (35));
dcl	ring0_get_$segptr	entry (char (*), char (*), ptr, fixed bin (35));
dcl	ring_zero_peek_$by_name
			entry (char (*), fixed bin (18), ptr, fixed bin (19), fixed bin (35));
dcl	ring_zero_peek_$get_max_length
			entry (char (*), fixed bin (19), fixed bin (35));
dcl	sort_items_$general entry (ptr, entry);

/*  External  */

dcl	error_table_$badopt fixed bin (35) external;
dcl	sys_info$time_of_bootload
			fixed bin (71) external;

/*  Builtin  */

dcl	addr		builtin;
dcl	baseno		builtin;
dcl	bin		builtin;
dcl	bit		builtin;
dcl	clock		builtin;
dcl	divide		builtin;
dcl	min		builtin;
dcl	mod		builtin;
dcl	ptr		builtin;
dcl	size		builtin;
%page;
	report_sw, reset_sw, sort_sw = "0"b;
	n_to_print = 262143;
	call cu_$arg_count (n_args, code);
	if code ^= 0
	then do;
		call com_err_ (code, MYNAME);
		return;
	     end;

	do arg_no = 1 to n_args;			/* The usual argument parsing */
	     call cu_$arg_ptr (arg_no, argp, argl, code);
	     if arg = "-report"
	     then report_sw = "1"b;
	     else if arg = "-reset" | arg = "-rs"
	     then reset_sw = "1"b;
	     else if arg = "-report_reset" | arg = "-rr"
	     then report_sw, reset_sw = "1"b;
	     else if arg = "-sort"
	     then sort_sw = "1"b;
	     else if arg = "-first" | arg = "-ft"
	     then do;
		     arg_no = arg_no + 1;
		     call cu_$arg_ptr (arg_no, argp, argl, code);
		     if code ^= 0
		     then do;
			     call com_err_ (code, MYNAME, "Number to print");
			     return;
			end;
		     n_to_print = cv_dec_check_ (arg, code);
		     if code ^= 0
		     then do;
BAD_N_TO_PRINT:
			     call com_err_ (0, MYNAME, "Invalid number to print ^a", arg);
			     return;
			end;
		     if n_to_print <= 0
		     then goto BAD_N_TO_PRINT;
		     sort_sw = "1"b;
		end;
	     else do;
		     call com_err_ (error_table_$badopt, MYNAME, arg);
		     return;
		end;
	end;

	if ^report_sw & ^reset_sw
	then report_sw = "1"b;
%page;
	if ^init
	then do;

/* First time through, copy out some (per-bootload) static data.
This includes dseg, so we can find the page table (from the sdw) for
a given segment so we can find its aste, the slt so we can determine if
a given segment is hardcore and interesting, the name_table to find the 
name of a segment, and stack_0_data so we can find out about the 
(pre-allocated) ring 0 stacks floating around.  We also get the sst
starting absolute address from unpaged_page_tables so we know where the
sst is; and, in particular, whether a given page table address (from and
sdw) describes a page table within the sst (=> capable of taking page 
faults.) */

		call get_temp_segments_ (MYNAME, temp_segp, code);
		if code ^= 0
		then do;
			call com_err_ (code, MYNAME, "Getting Temp Segs");
			return;
		     end;
		call get_temp_segments_ (MYNAME, init_temp_segp, code);
		if code ^= 0
		then do;
			call com_err_ (code, MYNAME, "Getting Temp Segs");
			call release_temp_segments_ (MYNAME, temp_segp, code);
			return;
		     end;

		call copy_ring0_seg ("dseg", init_temp_segp (1), sdwp, code);
		if code ^= 0
		then do;
			call com_err_ (code, MYNAME, "dseg");
CLEAN_UP_INIT:
			call release_temp_segments_ (MYNAME, temp_segp, code);
			call release_temp_segments_ (MYNAME, init_temp_segp, code);
			return;
		     end;
		call copy_ring0_seg ("slt", init_temp_segp (2), sltp, code);
		if code ^= 0
		then do;
			call com_err_ (code, MYNAME, "slt");
			goto CLEAN_UP_INIT;
		     end;
		call copy_ring0_seg ("name_table", init_temp_segp (3), names_ptr, code);
		if code ^= 0
		then do;
			call com_err_ (code, MYNAME, "name_table");
			goto CLEAN_UP_INIT;
		     end;
		call copy_ring0_seg ("stack_0_data", init_temp_segp (4), sdtp, code);
		if code ^= 0
		then do;
			call com_err_ (code, MYNAME, "stack_0_data");
			goto CLEAN_UP_INIT;
		     end;
		call ring0_get_$segptr ("", "sst", sstp, code);
		if code ^= 0
		then do;
SST_ERR:
			call com_err_ (code, MYNAME, "sst");
			goto CLEAN_UP_INIT;
		     end;
		call ring_zero_peek_$get_max_length ("sst", sst_size, code);
		if code ^= 0
		then goto SST_ERR;
		upt_ptr = addr (unpaged_page_tables_header);
		call ring_zero_peek_$by_name ("unpaged_page_tables", 0, upt_ptr, size (unpaged_page_tables_header),
		     code);
		if code ^= 0
		then go to SST_ERR;
		sstadd = upt.sst_absloc;

/* Determine what hardcore segments are interesting (which can take page 
faults). */

		segx = 0;
		do segn = 0 to slt.last_sup_seg;
		     sltep = addr (slt.seg (segn));
		     if ^slte.abs_seg & ^slte.wired & ^slte.per_process & slte.paged & ^slte.init_seg & ^slte.temp_seg
		     then do;			/* normal, most likely pagable hardcore segment */
			     pt_relp = bin (sdwa (segn).add, 24) - sstadd;
			     if sdwa (segn).add ^= "0"b & ^sdwa (segn).unpaged & sdwa (segn).df & pt_relp > 0
				& pt_relp < sst_size
			     then do;		/* sdw is valid and page table address for segment is within the bounds of sst */
				     segx = segx + 1;
						/* remember segment id */
				     seg_info.seg (segx).rel_astep = pt_relp - size (aste);
				     seg_info.seg (segx).prev_pf, seg_info.seg (segx).delta_pf = 0;
				     seg_info.seg (segx).name =
					ptr (names_ptr, slte.names_ptr) -> segnam.names (1).name;
				end;
			end;
		end;

		do segn = 1 to sdt.num_stacks;	/* remember set of ring 0 stacks (automatically pagable); 
						list doesn't change across bootloads */
		     stack_no = segn;
		     sdtep = addr (sdt.stacks (segn));
		     segx = segx + 1;
		     seg_info.seg (segx).rel_astep = bin (sdte.astep);
		     seg_info.seg (segx).prev_pf, seg_info.seg (segx).delta_pf = 0;
		     seg_info.seg (segx).name = "stack_0." || stack_no;
		end;

		call release_temp_segments_ (MYNAME, init_temp_segp, code);
		last_time = sys_info$time_of_bootload;
		seg_info.n_segs = segx;
		init = "1"b;
	     end;
%page;
	cur_time = clock ();
	metering_time = cur_time - last_time;

	sec = divide (metering_time, 1000000, 35);
	minute = divide (sec, 60, 35);
	hr = divide (minute, 60, 17);
	sec = mod (sec, 60);
	minute = mod (minute, 60);
	HR = hr;
	MINUTE = minute;
	SEC = sec;
	call ioa_ ("^/Total metering time^-^a^/", HR || ":" || MINUTE || ":" || SEC);


	total_pf = 0;
	sort_array.n = seg_info.n_segs;
	do segx = 1 to seg_info.n_segs;
	     call ring_zero_peek_$by_name ("sst", seg_info.seg (segx).rel_astep, addr (my_seg_aste), size (my_seg_aste),
		code);				/* get aste for hardcore segment */
	     if code ^= 0
	     then do;
		     call com_err_ (code, MYNAME, "sst|^o", seg_info.seg (segx).rel_astep);
		     return;
		end;
	     seg_info.seg (segx).cur_pf = my_seg_aste.usage;
						/* extract page fault data from aste */
	     sort_array.p (segx) = addr (seg_info.seg (segx));
	     seg_info.seg (segx).delta_pf = my_seg_aste.usage - seg_info.seg (segx).prev_pf;
	     total_pf = total_pf + seg_info.seg (segx).delta_pf;
	end;

%page;
	if report_sw
	then do;					/* report sorting and generation */

		call sort_items_$general (temp_segp (2), order_entries);

		call ioa_ ("Segment^26xPage Faults  % Total^/");

		do segx = 1 to min (seg_info.n_segs, n_to_print);
		     seg_entryp = sort_array (segx).p;
		     if total_pf = 0
		     then pct_pf = 0.;
		     else pct_pf = seg_entry.delta_pf * 100.0 / total_pf;
		     if seg_entry.delta_pf ^= 0
		     then call ioa_ ("^32a ^8d     ^6.2f", seg_entry.name, seg_entry.delta_pf, pct_pf);
		end;

		call ioa_ ("^/Total Hardcore Page Faults^7x^8d^/", total_pf);

	     end;
%page;
	if reset_sw
	then do;

		last_time = cur_time;

		do segx = 1 to seg_info.n_segs;
		     seg_info.seg (segx).prev_pf = seg_info.seg (segx).cur_pf;
		end;

	     end;

	return;
%page;
copy_ring0_seg:
     proc (segname, seg_ptr, seg_ptr_1, code);

dcl	segname		char (*);
dcl	seg_ptr		ptr;
dcl	seg_ptr_1		ptr;
dcl	code		fixed bin (35);

dcl	seg_size		fixed bin (19);


	call ring_zero_peek_$get_max_length (segname, seg_size, code);
	if code ^= 0
	then return;

	call ring_zero_peek_$by_name (segname, 0, seg_ptr, seg_size, code);
	seg_ptr_1 = seg_ptr;

     end copy_ring0_seg;
%page;
order_entries:
     proc (p1, p2) returns (fixed bin (1));

dcl	p1		ptr unal;
dcl	p2		ptr unal;
dcl	1 seg1		aligned like seg_entry based (p1);
dcl	1 seg2		aligned like seg_entry based (p2);

	if sort_sw
	then do;
		if seg1.delta_pf < seg2.delta_pf
		then return (1);
		else if seg1.delta_pf > seg2.delta_pf
		then return (-1);
		else return (0);
	     end;
	else do;
		if seg1.name < seg2.name
		then return (-1);
		else if seg1.name > seg2.name
		then return (1);
		else return (0);
	     end;

     end order_entries;


%page;
%include aste;
%page;
%include sdw;
%page;
%include slt;
%page;
%include slte;
%page;
%include stack_0_data;
%page;
%include unpaged_page_tables;
     end hc_pf_meters;



		    interrupt_meters.pl1            03/14/85  0839.8r w 03/13/85  1027.1       83457


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


/* format: style4,delnl,insnl,tree,ifthenstmt,indnoniterend */
interrupt_meters:
intm:
     procedure options (variable, separate_static);

/* IOM_INTERRUPT_METERS - Program to Print Out Channel Interrupt Meters.
   coded 2/20/74 by N. I. Morris					*/

/* Modified  November 1978 by Larry Johnson to print names of the channels */
/* Modified  September 1980 by Warren Johnson to parse all fields on CHNL cards */
/* Modified  May 1981 by C. Hornig for new I/O system */
/* Modified August 1981, W. Olin Sibert, for decimal channel printout */
/* Modified August 1981 by J. Bongiovanni for metering_util_ */
/* Modified November 1984 by M. Pandolf to include hc_lock. */

dcl  argno fixed bin;
dcl  nargs fixed bin;
dcl  argptr ptr;
dcl  arglen fixed bin (21);
dcl  argument char (arglen) based (argptr);

dcl  (iom_no, first_iom, last_iom) fixed bin (3);
dcl  (channel_no, first_channel, last_channel) fixed bin (8);
dcl  rcode fixed bin (35);
dcl  (i, j) fixed bin;
dcl  dtx fixed bin (9);
dcl  (rs_sw, rr_sw, tt_sw, channel_sw, iom_sw) bit (1) aligned init ("0"b);

dcl  meter_time fixed bin (71);
dcl  formatted_meter_time char (10);
dcl  count fixed bin;
dcl  cput float bin (63);
dcl  ptime float bin (63);
dcl  itime float bin (63);
dcl  tm fixed bin (71);
dcl  total_count fixed bin;
dcl  total_time fixed bin (71);
dcl  other_count fixed bin;
dcl  other_time fixed bin (71);
dcl  iom_count fixed bin;
dcl  iom_time fixed bin (71);
dcl  iom_data_length fixed bin (19);
dcl  cur_ptrs (N_REGIONS) ptr;
dcl  prev_ptrs (N_REGIONS) ptr;
dcl  channel_name char (32);

dcl  unique fixed bin internal static init (0);
dcl  N_REGIONS fixed bin internal static options (constant) init (2);

dcl  1 cur_iom_data aligned like iom_data based (cur_ptrs (1));
dcl  1 prev_iom_data aligned like iom_data based (prev_ptrs (1));
dcl  1 cur_tcm aligned like tcm based (cur_ptrs (2));
dcl  1 prev_tcm aligned like tcm based (prev_ptrs (2));


dcl  error_table_$badopt fixed bin (35) external static;
dcl  error_table_$bad_arg fixed bin (35) external static;
dcl  error_table_$noarg fixed bin (35) external static;

dcl  com_err_ entry options (variable);
dcl  cu_$arg_count entry (fixed bin, fixed bin (35));
dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
dcl  identify_io_channel_ entry (pointer, fixed bin (3), fixed bin (8), char (*), fixed bin (35));
dcl  ioa_ entry options (variable);
dcl  metering_util_$define_regions entry options (variable);
dcl  metering_util_$fill_buffers entry (fixed bin, fixed bin (71), char (*), (*) ptr, (*) ptr, fixed bin (35));
dcl  metering_util_$reset entry (fixed bin, fixed bin (35));
dcl  parse_io_channel_name_ entry (char (*), fixed bin (3), fixed bin (8), fixed bin (35));
dcl  ring_zero_peek_$get_max_length entry (char (*), fixed bin (19), fixed bin (35));


dcl  WHOAMI char (32) internal static options (constant) init ("interrupt_meters");

dcl  (char, float, hbound, index, lbound, length, null, size, substr) builtin;

/**/

	if unique = 0 then do;			/* first time ... */
	     call ring_zero_peek_$get_max_length ("iom_data", iom_data_length, rcode);
	     if rcode ^= 0 then do;
		call com_err_ (rcode, WHOAMI, "iom_data");
		return;
		end;
	     call metering_util_$define_regions (unique, rcode, "iom_data", 0, iom_data_length, "tc_data", 0,
		size (tcm));
	     if rcode ^= 0 then do;
		call com_err_ (rcode, WHOAMI, "metering_util_$define_regions");
		return;
		end;
	     end;


	call cu_$arg_count (nargs, rcode);
	if rcode ^= 0 then do;
	     call com_err_ (rcode, WHOAMI);
	     return;
	     end;

	do argno = 1 to nargs;			/* Loop through arguments */
	     call cu_$arg_ptr (argno, argptr, arglen, (0));

	     if /* case */ (argument = "-rs") | (argument = "-reset") then rs_sw = "1"b;
	     else if (argument = "-report_reset") | (argument = "-reset_report") | (argument = "-rr") then rr_sw = "1"b;
	     else if (argument = "-totals") | (argument = "-total") | (argument = "-tt") then tt_sw = "1"b;
	     else if argument = "-iom" then do;		/* Examine specified IOM. */
		if argno = nargs then do;
ARG_MISSING:
		     call com_err_ (error_table_$noarg, WHOAMI, "After ^a", argument);
		     return;
		     end;

		argno = argno + 1;
		call cu_$arg_ptr (argno, argptr, arglen, (0));

		if length (argument) ^= 1 then do;
BAD_IOM_ARG:
		     call com_err_ (0, WHOAMI, "Invalid IOM tag: ^a", argument);
		     return;
		     end;

		if index ("ABCD", argument) ^= 0
		then iom_no = index ("ABCD", argument);
		else if index ("1234", argument) ^= 0
		     then iom_no = index ("1234", argument);
		     else goto BAD_IOM_ARG;

		iom_sw = "1"b;
		end;

	     else if (argument = "-channel") | (argument = "-chn") then do;
						/* Examine specified channel. */
		if argno = nargs then goto ARG_MISSING;
		argno = argno + 1;
		call cu_$arg_ptr (argno, argptr, arglen, (0));
		call parse_io_channel_name_ (argument, iom_no, channel_no, rcode);
		if rcode ^= 0 then do;
		     call com_err_ (rcode, WHOAMI, "Channel ^a", argument);
		     return;
		     end;
		channel_sw = "1"b;
		iom_sw = "1"b;
		end;

	     else do;				/* Bad argument */
		if char (argument, 1) = "-"
		then rcode = error_table_$badopt;
		else rcode = error_table_$bad_arg;
		call com_err_ (rcode, WHOAMI, "^a", argument);
		return;
		end;
	end;					/* Of loop through arguments */
%page;
	call metering_util_$fill_buffers (unique, meter_time, formatted_meter_time, cur_ptrs, prev_ptrs, rcode);
	if rcode ^= 0 then do;
	     call com_err_ (rcode, WHOAMI, "metering_util_$fill_buffers");
	     return;
	     end;

	ptime = cur_tcm.processor_time - prev_tcm.processor_time;
	itime = cur_tcm.idle - prev_tcm.idle;		/* This command used to compute interrupt time as */
	cput = ptime;				/* interrupt time taken in non-idle process. REM */
%page;
	call ioa_ ("^/Total metering time^-^a^/", formatted_meter_time);


	if ^rs_sw
	then call ioa_ (" IOM Ch     Int  Avg Time  % CPU  Name^/");
	else go to reset;

	if iom_sw
	then					/* If IOM was specified ... */
	     first_iom, last_iom = iom_no;
	else do;
	     first_iom = lbound (cur_iom_data.per_iom, 1);
	     last_iom = hbound (cur_iom_data.per_iom, 1);
	     end;

	if channel_sw
	then first_channel, last_channel = channel_no;
	else do;
	     first_channel = lbound (cur_iom_data.per_iom.chantab, 2);
	     last_channel = hbound (cur_iom_data.per_iom.chantab, 2);
	     end;

	iom_count, iom_time = 0;			/* Reset totals. */
	do i = first_iom to last_iom;			/* Iterate through IOM's. */
	     do j = first_channel to last_channel;	/* Iterate through channels. */
		dtx = cur_iom_data.per_iom (i).chantab (j);
		if dtx ^= 0 then do;
		     count = cur_iom_data.per_device (dtx).interrupts - prev_iom_data.per_device (dtx).interrupts;
		     tm = cur_iom_data.per_device (dtx).interrupt_time
			- prev_iom_data.per_device (dtx).interrupt_time;
		     end;
		else count, tm = 0;

		if ((count ^= 0) & ^tt_sw) | channel_sw then do;
		     call identify_io_channel_ (null (), (i), (j), channel_name, (0));
		     call ioa_ ("^x^1a^4d.^8d^8.3f^9.2f  ^a", substr ("ABCDEFGH", i, 1), j, count, cavg (tm, count),
			cpcnt (tm, cput), channel_name);
		     end;

		iom_count = iom_count + count;	/* Count totals. */
		iom_time = iom_time + tm;
	     end;
	end;

	if ^(channel_sw | iom_sw) | tt_sw then do;	/* If printing totals... */
	     total_count = cur_tcm.interrupt_count - prev_tcm.interrupt_count;
	     total_time = cur_tcm.interrupt_time - prev_tcm.interrupt_time;
	     other_count = total_count;
	     other_time = total_time - iom_time;

	     call ioa_ ("");

/* Sum of channel data */
	     call ioa_ ("^7a^8d^8.3f^9.2f", "Chan   ", iom_count, cavg (iom_time, iom_count), cpcnt (iom_time, cput));

/* Time in ii & iom_manager not metered per channel */
	     call ioa_ ("^7a^8d^8.3f^9.2f", "Ovhd   ", other_count, cavg (other_time, other_count),
		cpcnt (other_time, cput));

/* Total interrupt time, like ttm.interrupt_time, per actual interrupt */
	     call ioa_ ("^7a^8d^8.3f^9.2f", "Total  ", total_count, cavg (total_time, total_count),
		cpcnt (total_time, cput));
	     end;

reset:
	if rs_sw | rr_sw then do;
	     call metering_util_$reset (unique, rcode);
	     if rcode ^= 0 then do;
		call com_err_ (rcode, WHOAMI, "metering_util_$reset");
		return;
		end;
	     end;

	call ioa_ ("");

return_to_caller:
	return;
%page;
cavg:
     proc (t, c) returns (float bin);

dcl  t fixed bin (71),
     c fixed bin;


	if c = 0
	then return (0.e0);
	else return (float (t, 27) / c * 1.e-3);


     end cavg;


cpcnt:
     proc (t, c) returns (float bin);

dcl  t fixed bin (71),
     c float bin (63);

	return (float (t, 27) / c * 1.e2);

     end cpcnt;

%page;
%include tcm;
%page;
%include hc_lock;
%page;
%include iom_data;

     end interrupt_meters;
   



		    link_meters.pl1                 11/15/82  1843.0rew 11/15/82  1512.5       45243


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


/*   link_meters
     Program to print per-process meters on linkage fault
     processing, which are maintained in the pds by
     link_snap.
*/

/*   Updated by Alan Bier - March 1974. */
/*   Cleaned up substantially by J. Bongiovanni - December 80 */

link_meters: lkm: proc;

/*  Automatic */

dcl  argl fixed bin (21);
dcl  argp ptr;
dcl  cnt fixed bin (35);
dcl  code fixed bin (35);
dcl  cur_buf_ptrs (3) ptr;
dcl  formatted_meter_time char(10);
dcl  i fixed bin;
dcl  meter_time fixed bin (71);
dcl  nargs fixed bin;
dcl  prev_buf_ptrs (3) ptr;
dcl  repsw bit (1) init ("0"b);
dcl  rsw bit (1) init ("0"b);
dcl  tcnt fixed bin (35);
dcl  total_count fixed bin (35);
dcl  total_page_faults fixed bin (35);
dcl  total_time fixed bin (35);	        
dcl  ttim fixed bin (35);

/*  Static */

dcl  our_name char (11) init ("link_meters")  int static options (constant);
dcl  slot (0:3) char (10) internal static
     init ("<25", "25-50", "50-75", ">75") options (constant);
dcl unique fixed bin int static init (0);

/*  Based */

dcl  arg char (argl) based (argp);
dcl  count (0:3) fixed bin (17) based (cur_buf_ptrs (1));
dcl  o_count (0:3) fixed bin (17) based (prev_buf_ptrs (1));
dcl  o_page_faults (0:3) fixed bin (35) based (prev_buf_ptrs (3));
dcl  o_time (0:3) fixed bin (35) based (prev_buf_ptrs (2));
dcl  page_faults (0:3) fixed bin (35) based (cur_buf_ptrs (3));
dcl  time (0:3) fixed bin (35) based (cur_buf_ptrs (2));
	        
/*  External */

dcl  error_table_$badopt fixed bin (35) external;

/*  Entry */

dcl  com_err_ entry options (variable);
dcl  cu_$arg_count entry (fixed bin);
dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin(21), fixed bin(35));
dcl  ioa_ entry options (variable);
dcl  metering_util_$define_regions entry options (variable);
dcl  metering_util_$fill_buffers entry (fixed bin, fixed bin (71), char (*),
	        (*) ptr, (*) ptr, fixed bin (35));
dcl  metering_util_$reset entry (fixed bin, fixed bin (35));
	        
/*  Builtin */

dcl  float builtin;

/*  */
          call cu_$arg_count (nargs);

	do i = 1 to nargs;
	     call cu_$arg_ptr (i, argp, argl, code);
	     if arg = "-reset" | arg = "-rs" then rsw = "1"b;
	     else if arg = "-report_reset" | arg = "-rr" then repsw, rsw = "1"b;
	     else do;
                    call com_err_ (error_table_$badopt, our_name, arg);
                    return;
	     end;
	end;                    
						
          if ^rsw then repsw = "1"b;			/* report is the default			*/
	
          if unique=0 then do;			/* not initialized yet			*/
	     call metering_util_$define_regions (unique, code,
		"pds", "link_meters_bins", 4,
		"pds", "link_meters_times", 4,
		"pds", "link_meters_pgwaits", 4);
	     if code^=0 then do;
init_err:		call com_err_ (code, our_name, "Initializing");
		return;
	     end;
          end;
          
          if repsw then do;				/* report option				*/
	     call ioa_ ("^/Linkage Meters:^/");
	     call metering_util_$fill_buffers (unique, meter_time, formatted_meter_time,
		cur_buf_ptrs, prev_buf_ptrs, code);
	     if code^=0 then do;
		call com_err_ (code, our_name, "Filling buffers.");
		return;
	     end;

	     total_time = 0;
	     total_count = 0;
	     total_page_faults = 0;
	     do i = 0 to 3;
		total_time = total_time + time (i) - o_time (i);
		total_count = total_count + count (i) - o_count (i);
		total_page_faults = total_page_faults + page_faults (i)
		     - o_page_faults (i);
	     end;

	     if total_time = 0			/* set ttim, tcmt to avoid zerodivide problems	*/
		then ttim = 1;
	     else ttim = total_time;
	     if total_count = 0
		then tcnt = 1;
	     else tcnt = total_count;
	     
	     call ioa_ ("^/slot    calls  avg time  avg pf  tot time  % time^/");

	     do i = 0 to 3;
						/* Print out one output line for each slot */
		cnt = count (i) - o_count (i);		/* Necessary to correct for zerodivide condition */
		if cnt = 0 then cnt = 1;
		call ioa_ ("^8a^5d^10.3f^8.1f^10.3f^8.1f", slot (i), count (i)-o_count (i),
		     ((time (i)-o_time (i))*1.0e-3)/cnt, float (page_faults (i)-o_page_faults (i))/cnt,
		     (time (i)-o_time (i))*1.0e-6, ((time (i)-o_time (i))*1.0e2)/ ttim);
	     end;

/* Print out totals on all relevant figures */
	     call ioa_ ("        -----  --------   -----   -------");
	     call ioa_ ("Total  ^6d^10.3f^8.1f^10.3f^/", total_count,
		total_time*1.0e-3/tcnt, float (total_page_faults)/tcnt,
		total_time*1.0e-6);
	end;
	

reset:	if rsw then call metering_util_$reset (unique, code);

	return;
     end link_meters;
 



		    meter_gate.pl1                  01/26/85  1313.5r w 01/22/85  1307.7      119583


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


/* format: style2,idind30,indcomtxt */

/**** * METER_GATE - Print Out Metering Info from Gate Segment.

      Date Last Modified and Reason

      841113 MAP to include hc_lock.
      831107 BIM for ring_alarms.
      06/24/81 by J. Bongiovanni to eliminate restriction on number of gates
      09/15/76 by Noel I. Morris to work with combined defs.
      07/08/75 by S. Webber to work with combined linkage and to add reset capability
      06/14/74 by R. A. Roach to eliminate calls to phcs_.
      05/07/74 by R. B. Snyder to change arguments to meter_gate_.
      11/27/73 by R. B. Snyder to add entry meter_gate_
      10/27/73 Steve Webber to work with call limiter type gates
      Originally written 1/27/70 by N. I. Morris
*/

meter_gate:
mg:
     procedure options (variable);

/* Static */

	dcl     tcdp0		        ptr static init (null ());
						/* pointer to tc_data in ring 0 */
	dcl     tempp		        (2) ptr int static init ((2) null ());
						/* pointer to temp segments */
	dcl     itimep0		        ptr static; /* pointer to tcm.initialize_time */
	dcl     ptimep0		        ptr static; /* pointer to tcm.processor_time */
	dcl     ltimep0		        ptr static; /* pointer to tcm.idle */
	dcl     who_it_is		        char (10) int static options (constant) init ("meter_gate");

/* Automatic */

	dcl     argno		        fixed bin;
	dcl     gi		        fixed bin;	/* index to gate_info for gate of interest */
	dcl     avg		        float bin (27);
	dcl     reset_sw		        bit (1) aligned;
	dcl     no_report		        bit (1) aligned,
	        namep		        ptr,	/* pointer to entry name */
	        namel		        fixed bin,	/* length of entry name */
	        code		        fixed bin (35),
						/* error code */
	        argp		        ptr,	/* pointer to argument */
	        arglen		        fixed bin,	/* length of argument */
	        segname		        char (32),	/* name of segment */
	        entry		        char (32),	/* name of desired entry */
	        sort		        fixed bin,	/* sorting function code */
	        argument		        char (arglen) based (argp),
						/* based argument */
	        (i, j)		        fixed bin,	/* indices */
	        nentries		        fixed bin,	/* number of gate entries */
	        calls		        fixed bin,	/* number of calls to entry */
	        totcalls		        fixed bin,	/* total calls through gate */
	        itime		        fixed bin (71),
						/* time Multics came up */
	        timnow		        fixed bin (71),
						/* time now */
	        citime		        char (24),	/* converted system up time */
	        ctimnow		        char (24),	/* converted current time */
	        tottim		        fixed bin (71),
						/* total time spent inside gate */
	        total_ring_alarms	        fixed bin (35),
						/* total polled ring alarms */
	        hr		        fixed bin,	/* hours, for conversion */
	        mn		        fixed bin,	/* minutes, for conversion */
	        sc		        fixed bin,	/* seconds, for conversion */
	        charged_time	        fixed bin (71),
						/* total charged time */
	        idle_time		        fixed bin (71),
						/* total idle time */
	        ctime		        fixed bin (71),
	        ptime		        float bin,	/* time percentage */
	        ppage		        float bin;	/* page waits per call */

	dcl     1 table		        (512) aligned,
						/* table pointing to info */
		2 gate		        like gate_table aligned,
						/* gate entry info */
		2 avg		        float bin (27);
						/* average time spent in entry */

	dcl     1 temp_table	        like table aligned;
						/* temporary for interchange sort */

/* Entries */

	dcl     com_err_		        entry options (variable);
	dcl     cu_$arg_ptr		        ext entry (fixed bin, ptr, fixed bin, fixed bin (35));
	dcl     ring_zero_peek_	        ext entry (ptr, ptr, fixed bin (18), fixed bin (35));
	dcl     ring0_get_$segptr	        ext entry (char (*), char (*), ptr, fixed bin (35));
	dcl     ioa_		        ext entry options (variable);
	dcl     clock_		        ext entry returns (fixed bin (71));
	dcl     date_time_		        ext entry (fixed bin (71), char (*));
	dcl     cu_$arg_count	        entry returns (fixed bin);
	dcl     get_gate_data_	        entry (char (*), 1 dim (*) like gate_table aligned, fixed bin, ptr,
				        bit (1) aligned, fixed bin (35));
	dcl     get_temp_segments_	        entry (char (*), dim (*) ptr, fixed bin (35));


	dcl     1 gate_info_struct	        aligned based (tempp (2)),
						/* structure of gates we're metering		*/
		2 max_gates	        fixed bin,	/* number of gates				*/
		2 gate_info	        (0 refer (max_gates)),
		  3 name		        char (32),	/* name of gate */
		  3 old_time	        fixed bin (71),
						/* charged time at time of last reset */
		  3 old_charged	        fixed bin (71);
						/* charged time at time of last reset */

	dcl     entryname		        char (namel) based (namep);
						/* gate entry name */

/* Builtin */

	dcl     (addr, divide, float, mod, null)
				        builtin;


/**/

%include gate_data;

/**/

%include tcm;


%include hc_lock;


	sort = 0;					/* default is not to sort */

/* Pick up all arguments. */

	call cu_$arg_ptr (1, argp, arglen, code);	/* Grab first argument. */
	if code ^= 0
	then do;
		call com_err_ (code, who_it_is, "Gate name");
		return;
	     end;


	segname = argument;				/* Get name of gate segment. */
	no_report = "0"b;
	reset_sw = "0"b;

	do argno = 2 to cu_$arg_count ();		/* pick up control args */
	     call cu_$arg_ptr (argno, argp, arglen, code);/* Grab second argument. */
	     if argument = "-call" | argument = "-cl"
	     then sort = 1;				/* sort by number of calls */
	     else if argument = "-time" | argument = "-tm"
	     then sort = 2;				/* sort by time used */
	     else if argument = "-average" | argument = "-av"
	     then sort = 3;				/* sort by average number of calls */
	     else if argument = "-page" | argument = "-pg"
	     then sort = 4;				/* sort by number of page faults */
	     else if argument = "-reset" | argument = "-rs"
	     then no_report, reset_sw = "1"b;		/* reset requested */
	     else if argument = "-report_reset" | argument = "-rr"
	     then reset_sw = "1"b;
	     else do;
		     entry = argument;
		     sort = 5;			/* search for this entry */
		end;
	end;


/* Check to see if we've set up our static variables */

	if tcdp0 = null
	then do;					/* not yet... */
		call ring0_get_$segptr ("", "tc_data", tcdp0, code);
		if code ^= 0
		then do;
			call com_err_ (code, who_it_is, "Cannot find tc_data");
			return;
		     end;
		itimep0 = addr (tcdp0 -> tcm.initialize_time);
		ptimep0 = addr (tcdp0 -> tcm.processor_time);
		ltimep0 = addr (tcdp0 -> tcm.idle);
		call get_temp_segments_ (who_it_is, tempp, code);
		if code ^= 0
		then do;
			call com_err_ (code, who_it_is, "Getting temp segs");
			return;
		     end;
	     end;

/* Fill in static data for gate. */

	do gi = 1 to max_gates;
	     if gate_info (gi).name = segname
	     then go to got_gate;
	end;

	max_gates = gi;
	gate_info (gi).name = segname;
	gate_info (gi).old_time = 0;
	gate_info (gi).old_charged = 0;
got_gate:						/* Now get data for gate. */
	call get_gate_data_ (segname, table.gate, nentries, tempp (1), reset_sw, code);
	if code ^= 0
	then do;
		call com_err_ (code, who_it_is, "Getting gate data");
		return;
	     end;


/*  Now get current clock readings */

	call ring_zero_peek_ (itimep0, addr (itime), 2, code);
	call ring_zero_peek_ (ptimep0, addr (charged_time), 2, code);
	call ring_zero_peek_ (ltimep0, addr (idle_time), 2, code);

	charged_time = charged_time - idle_time;
	if gate_info (gi).old_time > 0
	then itime = gate_info (gi).old_time;
	ctime = charged_time - gate_info (gi).old_charged;

	timnow = clock_ ();				/* Get current time */

	if ^no_report
	then do;					/* only do the work if we have to */
		i = 0;				/* Count iterations. */
		tottim = 0;			/* Initialize total time count. */
		totcalls = 0;			/* Initialize count of total calls. */
		total_ring_alarms = 0;		/* Initialize RA count */


/* Major information handling and sorting loop. */

		do i = 1 to nentries;
		     gate_datap = table (i).datap;	/* Copy the pointer. */
		     namep = table (i).entryp;
		     namel = table (i).entryl;

		     calls = gate_entry_data.calls;	/* Extract count of calls to entry. */
		     if calls ^= 0
		     then /* Compute average and save. */
			avg = float (gate_entry_data.vcpu_time, 27) / (1.e3 * float (gate_entry_data.calls, 27));
		     else avg = 0.e0;
		     table (i).avg = avg;

		     if sort = 5
		     then do;			/* if only want selected entry */
			     if entryname = entry
			     then do;		/* in single entry mode - match? */
				     j = i;	/* Set loop variable */
				     call print;	/* Go print the poop */
				     go to finish;
				end;
			     else go to next;	/* Skip the sorting crap */
			end;

		     totcalls = totcalls + calls;	/* Compute total number of calls. */
		     tottim = tottim + gate_entry_data.vcpu_time;
						/* Compute total time spent inside gate. */
		     total_ring_alarms = total_ring_alarms + gate_entry_data.ring_alarms;

/* Perform sorting. */

		     if sort ^= 0
		     then do j = i - 1 to 1 by -1;	/* If sorting specified ... */

			     if sort = 1
			     then /* If sorting on number of calls ... */
				if table (j).datap -> gate_entry_data.calls < gate_entry_data.calls
				then go to next;
				else ;

			     else if sort = 2
			     then /* If sorting on total time ... */
				if table (j).datap -> gate_entry_data.vcpu_time < gate_entry_data.vcpu_time
				then go to next;
				else ;

			     else if sort = 3
			     then /* If sorting on average time ... */
				if table (j).avg < avg
				then go to next;
				else ;

			     else if sort = 4
			     then /* If sorting on page waits ... */
				if table (j).datap -> gate_entry_data.page_waits < gate_entry_data.page_waits
				then go to next;
				else ;

			     temp_table = table (j + 1);
			     table (j + 1) = table (j);
			     table (j) = temp_table;

			end;

next:
		end;


/* Print out the accumulated and sorted information. */

		if sort = 5
		then do;				/* If searching for specific entry ... */
			call ioa_ ("Entry ^a not found or not metered in gate ^a.", entry, segname);
			return;
		     end;

		call date_time_ (itime, citime);
		call date_time_ (timnow, ctimnow);


		call comp_time (ctime);		/* Break down charged time. */

		call ioa_ ("^/Metering since ^a.^/Total non-idle time at ^a = ^d hr. ^d min. ^d sec.", citime,
		     ctimnow, hr, mn, sc);

		if totcalls > 0
		then do;				/* we have something to meter */

			call ioa_ ("^/Gate meters for ^a: total calls = ^d, total ring alarms polled = ^d.", segname, totcalls, total_ring_alarms);
						/* Print header. */

			if ctime > 0
			then ptime = (float (tottim, 63) / float (ctime, 63)) * 1.e2;
						/* Compute percentage. */
			else ptime = 0e0;
			call comp_time (tottim);	/* Break down total time in gate. */

			call ioa_ ("^d hr. ^d min. ^d sec. or ^6.3f% spent in calls through gate.", hr, mn, sc,
			     ptime);

			call ioa_ ("^/            ring                    page");
			call ioa_ ("  calls   alarms   pcnt     avg   faults  entry name^/");

			do j = nentries by -1 to 1;	/* Loop through information. */
			     call print;
			end;
		     end;
		else call ioa_ ("No calls through this gate.");

		call ioa_ ("^/");
	     end;

finish:
	if reset_sw
	then do;
		gate_info (gi).old_time = timnow;
		gate_info (gi).old_charged = charged_time;
	     end;


	return;					/* Bye-bye. */


/* Internal Procedure to Print Output Line. */

print:
     proc;

	gate_datap = table (j).datap;			/* Extract pointers. */
	namep = table (j).entryp;			/* .. */
	namel = table (j).entryl;			/* .. */
	avg = table (j).avg;			/* .. */
	if gate_entry_data.calls > 0
	then do;
		if ctime <= 0
		then ptime = 0e0;			/* ctime may be zero .. */
		else ptime = (float (gate_entry_data.vcpu_time, 63) / float (ctime, 63)) * 1.e2;
						/* Compute percentage. */
		ppage = float (gate_entry_data.page_waits, 27) / float (gate_entry_data.calls, 27);
						/* Compute page waits per call. */
		call ioa_ ("^7d  ^7d  ^5.2f ^8.2f  ^6.2f  ^a", gate_entry_data.calls, gate_entry_data.ring_alarms,
		     ptime, avg, ppage, entryname);
	     end;


     end;


/* Internal Procedure to compute hours, minutes, and seconds. */

comp_time:
     proc (a);

	dcl     a			        fixed bin (71);
						/* time in miscrseconds */


	sc = divide (a, 1000000, 17, 0);		/* Compute seconds of time. */
	mn = divide (sc, 60, 17, 0);			/* Compute minutes of time. */
	hr = divide (mn, 60, 17, 0);			/* Compute hours of time. */
	sc = mod (sc, 60);				/* Round the seconds. */
	mn = mod (mn, 60);				/* And the minutes. */

	return;


     end;


     end;
 



		    meter_rcp.pl1                   03/25/86  1120.1rew 03/25/86  1119.8      214965


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


meter_rcp: procedure;

/*	This program is a command that meters device data copied from RCP.
   *	It also meters the locks used for rcp_data and rcp_com_seg.
   *	Created on 01/02/75 by Bill Silver.
   *	Modified on 01/31/79 by Michael R. Jordan
   *
   *	To use this command one must have access to the gate rcp_priv_.
   *	If this command is called with no arguments it will type out the meters
   *	obtained from RCP for all devices of all types.  This command does
   *	not work correctly if called recursively.  Valid arguments are:
   *
   *	(-all)		(-a)	Type all available meters.
   *	(-lock)			Type meters for both RCPD and RCS locks.
   *	(-long)		(-lg)	Type all meters available for device or device type.
   *	(-reset)		(-rs)	Reset, save current meters.
   *	(-report_reset)	(-rr)	Reset but first output meters.
   *	(-type)		(-tp)	Type info about all devices of this one type.
   *	(-device)		(-dv)	Type info about this one mdevice.
*/

/*		AUTOMATIC  DATA		*/

dcl  arg_len fixed bin;				/* Length of argument. */
dcl  arg_ptr ptr;					/* Pointer to current argument. */
dcl  argx fixed bin;				/* Number  of current argument. */
dcl  dtypex fixed bin;				/* Device type index. */
dcl  device_flag bit (1);				/* ON => user wants device meters. */
dcl  device_name char (32);				/* Device name. */
dcl  device_type char (32);				/* Device type name. */
dcl  ecode fixed bin (35);				/* error_table_ code. */
dcl  hours fixed bin;
dcl (i, j) fixed bin;				/* Work variables. */
dcl  histox fixed bin;				/* Index of current histogram slot. */
dcl  lock_flag bit (1);				/* ON => user wants lock meters. */
dcl  long_flag bit (1);				/* ON => type everything we can. */
dcl  meter_index fixed bin;				/* Used to determine which meters to process. */
dcl  meter_time fixed bin (71);			/* The metering time interval. */
dcl  minutes fixed bin;
dcl  num_args fixed bin;				/* Number of command arguments. */
dcl  omdevice_ptr ptr;				/* Pointer to old device entry. */
dcl  olock_info_ptr ptr;				/* Pointer to old lock_info data. */
dcl  option char (16);				/* Command option name. */
dcl  option_code fixed bin;				/* Used to describe option's value argument. */
dcl  ormi_ptr ptr;					/* Pointer to old meter info. */
dcl  reset_flag bit (1);				/* ON => user wants meters saved. */
dcl  time_assigned fixed bin (71);			/* Time assigned device assigned. */
dcl  seconds fixed bin;
dcl  work fixed bin (35);				/* Work variable. */
dcl (x, y, z) fixed bin;				/* Used to output histogram. */


/*		BASED  DATA		*/

dcl  argument char (arg_len) based (arg_ptr);		/* Used to reference command argument. */

dcl 1 mrs based (mrs_ptr) aligned,			/* Structure of meter_rcp_seg. */
    2 reset_flag bit (1),				/* ON => reset has been done. */
    2 rmi_size fixed bin (19),			/* Size of current one meter area. */
    2 rmi_bound fixed bin,				/* Num of double words in an RMI area. */
    2 tot_mdevices fixed bin,				/* Total number of device being metered. */
    2 rmi_ptr ptr,					/* Points to mrs.new_rmi. */
    2 ormi_ptr ptr,					/* Points to mrs.old_rmi. */
    2 starting_time fixed bin (71),			/* Meters calculated from this time. */
    2 new_rmi (0 refer (mrs.rmi_bound)) fixed bin (71),	/* Where we copy meter info each time. */
    2 old_rmi (0 refer (mrs.rmi_bound)) fixed bin (71),	/* Where we save reset meter data. */
    2 histox (0 refer (mrs.tot_mdevices));		/* Index of adjusted histogram index. */

dcl 1 olock_info based (olock_info_ptr) aligned like lock_info;

dcl 1 omdevice based (omdevice_ptr) aligned like mdevice;


/*		INTERNAL STATIC DATA	*/

dcl  mrs_ptr ptr					/* Pointer to meter_rcp_seg. */
     internal static init (null ());

dcl  brief_options (7) char (8)			/* Brief form of command options. */
     internal static init ("-a", "-lock", "-lg", "-rs",
     "-rr", "-tp", "-dv");

dcl  long_options (7) char (16)			/* Long form of command options. */
     internal static init ("-all", "-lock", "-long", "-reset",
     "-report_reset", "-type", "-device");

dcl  option_codes (7) fixed bin			/* 0 => no value arg,  1 => value_arg. */
     internal static init (0, 0, 0, 0, 0, 1, 1);

/*		EXTERNAL ENTRIES CALLED	*/

dcl (addr, divide, fixed, hbound, null, rel, clock, substr) builtin;

dcl (error_table_$bad_arg,
     error_table_$badopt,
     error_table_$name_not_found,
     error_table_$odd_no_of_args,
     error_table_$wrong_no_of_args) fixed bin (35) external;

dcl  com_err_ entry options (variable);
dcl  cu_$arg_count entry (fixed bin);
dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl  hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35));
dcl  ioa_ entry options (variable);
dcl  rcp_priv_$copy_meters entry (ptr, fixed bin (19), fixed bin (35));
						/* 	*/
%include rcp_device_types;
/* 	*/
%include rcp_meter_info;
/* 	*/
%include rcp_com_seg;
/* 	*/
/*	Beginning of meter_rcp command.
*/
	ecode,					/* Initialize. */
	     meter_index = 0;
	device_flag = "1"b;
	lock_flag,
	     long_flag,
	     reset_flag = "0"b;

	if mrs_ptr = null ()			/* Do we have a meter_rcp_seg yet? */
	then do;					/* No. */
	     call INIT_MRS;				/* Initialize this temporary work segment. */
	     if ecode ^= 0
	     then return;
	end;

	call cu_$arg_count (num_args);		/* Get number of command arguments. */

	do argx = 1 to num_args;			/* Look at each one of them. */
	     call PROCESS_ARG;			/* Go process this argument. */
	     if ecode ^= 0				/* Was there an error with this argument? */
	     then return;				/* Yes, abort the command. */
	end;

	call GET_METERS;				/* Get the meter data from RCP. */
	if ecode ^= 0				/* Any errors? */
	then return;

	if (device_flag) | (lock_flag)		/* Are we reporting any meters? */
	then call OUTPUT_TIME (meter_time, "Total time metered");

	if device_flag				/* Does user want device meters? */
	then call METER_DEVICES;			/* Yes. */

	if lock_flag				/* Does user want lock meters? */
	then do;					/* Yes, give him meters from both locks. */
	     call METER_LOCK (1);			/* RCS lock. */
	     call METER_LOCK (2);			/* RCPD lock. */
	end;

	if reset_flag				/* Should we save these meters? */
	then call RESET;				/* Yes, future calculations based on this data. */

	return;
						/* 	*/
PROCESS_ARG: procedure;

/*	This procedure is called to process one command option argument.
   *	If this option argument is followed by a value argument then we
   *	we process that argument also.
*/
	     call cu_$arg_ptr (argx, arg_ptr, arg_len, ecode);
	     if ecode ^= 0				/* Did we get a pointer to this argument? */
	     then do;				/* No. */
		call com_err_ (ecode, "meter_rcp", "Error getting argument ^d", argx);
		return;
	     end;

	     option = argument;			/* Save command option argument. */

	     do i = 1 to hbound (long_options, 1);	/* See if command option is valid. */
		if (option = brief_options (i)) |	/* Is it this brief option name? */
		(option = long_options (i))		/* Or this long option name? */
		then do;				/* Yes, one of them. */
		     call GET_VALUE (i);		/* Get any accompanying value argument. */
		     if ecode ^= 0			/* Check for errors. */
		     then return;
		     goto OPTION (i);		/* Go process this option. */
		end;
	     end;

	     ecode = error_table_$badopt;		/* Option is not known. */
	     call com_err_ (ecode, "meter_rcp", "Control argument: ^a", option);
	     return;

OPTION (1):					/* "-a" or "-all" */
	     lock_flag = "1"b;			/* User wants lock meters, devices metered by default. */
	     return;

OPTION (2):					/* "-lock" */
	     lock_flag = "1"b;			/* User wants only lock meters. */
	     device_flag = "0"b;			/* He doesn't want device meters. */
	     return;

OPTION (3):					/* "lg" or "-long" */
	     long_flag = "1"b;			/* User wants long output format. */
	     return;

OPTION (4):					/* "-rs" or "-reset" */
	     lock_flag,				/* No meters typed. */
		device_flag = "0"b;

OPTION (5):					/* "-rr" */
	     reset_flag = "1"b;			/* Reset meter data. */
	     return;

OPTION (6):					/* "-tp" or "-type" */
	     meter_index = 1;			/* 1 => list one device type. */
	     device_type = argument;			/* Get specified device type. */
	     do i = 1 to hbound (device_types, 1);	/* See if this is a valid device type. */
		if device_type = device_types (i)	/* Is it this one? */
		then return;			/* Yes, it is valid. */
	     end;
	     ecode = error_table_$bad_arg;		/* Device type is invalid. */
	     call com_err_ (ecode, "meter_rcp", "Unknown device type: ^a", device_type);
	     return;

OPTION (7):					/* "-dv" or "-device" */
	     meter_index = 2;			/* 2 => list one mdevice. */
	     device_name = argument;			/* Get specified device name. */
	     return;

	end PROCESS_ARG;
						/* 	*/
GET_VALUE: procedure (option_num);

/*	This procedure is called to get any value argument associated with this option.
   *	Processing of the value argument depends upon the option code value associated
   *	with this option.  The option code values are:
   *	     0.	This option argument has no accompanying value argument.
   *	     1.	This option argument has a string type value argument.
*/
dcl  option_num fixed bin;				/* Number that identifies this option. */

	     option_code = option_codes (option_num);	/* Get code value for this option. */

	     if option_code = 0			/* Is there an accompanying argument value? */
	     then return;				/* No, nothing else to do. */

/* Get accompanying argument value. */
	     if argx = num_args			/* Is this the last argument? */
	     then do;				/* Yes, value argument missing. */
		ecode = error_table_$odd_no_of_args;
		call com_err_ (ecode, "meter_rcp", "No value argument for ^a", option);
		return;
	     end;

	     argx = argx + 1;			/* Get the next argument. */
	     call cu_$arg_ptr (argx, arg_ptr, arg_len, ecode);
	     if ecode ^= 0
	     then do;
		call com_err_ (ecode, "meter_rcp", "Error getting argument ^d", argx);
		return;
	     end;

	     if substr (argument, 1, 1) = "-"		/* Is next argument a control option? */
	     then do;				/* Yes, value argument is missing. */
		ecode = error_table_$wrong_no_of_args;
		call com_err_ (ecode, "meter_rcp", "No value argument for ^a", option);
		return;
	     end;

	end GET_VALUE;
						/* 	*/
GET_METERS: procedure;

/*	This procedure is called to get the meter information from RCP.
   *	We will put it in the new meter info.  If we have done a reset
   *	then we will adjust the new meters based on the meter data that we
   *	have previously saved in the old meters area.
*/
	     rmi_ptr = mrs.rmi_ptr;			/* Get pointer to where new structure will go. */
	     rmi.head.version_num = 1;
	     call rcp_priv_$copy_meters (rmi_ptr, mrs.rmi_size, ecode);
	     if ecode ^= 0
	     then do;
		call com_err_ (ecode, "meter_rcp", "Error copying RCP meters.");
		return;
	     end;

	     meter_time = clock () - mrs.starting_time;

	     do i = 1 to rmi.head.tot_mdevices;		/* Adjust meters for assigned devices. */
		mdevice_ptr = addr (rmi.mdevices (i));
		if mdevice.time_assigned ^= 0
		then call ADD_ASSIGNED_METERS;
		else histox = 0;
		mrs.histox (i) = histox;		/* Save current histogram index. */
	     end;

	     if ^mrs.reset_flag			/* Have we done a reset? */
	     then return;				/* No, use data as is. */

	     ormi_ptr = mrs.ormi_ptr;			/* Get pointer to old meter info. */
	     do i = 1 to rmi.head.tot_mdevices;		/* Adjust meters for all devices. */
		mdevice_ptr = addr (rmi.mdevices (i));
		omdevice_ptr = addr (ormi_ptr -> rmi.mdevices (i));
		mdevice.error_count = mdevice.error_count - omdevice.error_count;
		mdevice.num_assigns = mdevice.num_assigns - omdevice.num_assigns;
		mdevice.tot_assign_time = mdevice.tot_assign_time - omdevice.tot_assign_time;
		do j = 1 to 4;
		     mdevice.histogram (j) = mdevice.histogram (j) - omdevice.histogram (j);
		end;
	     end;

	     lock_info_ptr = addr (rmi.rcs_lock_info);	/* Adjust RCS lock meters. */
	     olock_info_ptr = addr (ormi_ptr -> rmi.rcs_lock_info);
	     do i = 1 to 2;				/* Adjust both lock meters. */
		lock_info.num_locks = lock_info.num_locks - olock_info.num_locks;
		lock_info.num_lock_waits = lock_info.num_lock_waits - olock_info.num_lock_waits;
		lock_info.tot_lock_time = lock_info.tot_lock_time - olock_info.tot_lock_time;
		lock_info.tot_wait_time = lock_info.tot_wait_time - olock_info.tot_wait_time;
		lock_info_ptr = addr (rmi.rcpd_lock_info); /* Now adjust RCPD lock meters. */
		olock_info_ptr = addr (ormi_ptr -> rmi.rcpd_lock_info);
	     end;

	end GET_METERS;
						/* 	*/
ADD_ASSIGNED_METERS: procedure;

/*	This procedure is called to meter a device that is currently assigned.
   *	The real meters are updated only when a device is unassigned.
   *	Thus they will not reflect the status of a device that is assigned.
   *	This procedure will adjust the meter data returned about this device
   *	so that it will include information about the assigned device.
*/

	     mdevice.num_assigns = mdevice.num_assigns + 1;
	     mdevice.tot_assign_time = mdevice.tot_assign_time + mdevice.time_assigned;
	     if mdevice.time_assigned > meter_time	/* If assigned before reset use reset time. */
	     then time_assigned = meter_time;
	     else time_assigned = mdevice.time_assigned;
	     seconds = divide (time_assigned, 1000000, 71, 0);
	     mdtype_ptr = addr (rmi.mdtypes (mdevice.dtypex));
	     do j = 1 to hbound (mdtype.histo_times, 1);
		if seconds < mdtype.histo_times (j)
		then do;
		     histox = j;			/* Save histogram slot that matches. */
		     goto ADD_HISTO;
		end;
	     end;
	     histox = hbound (mdevice.histogram, 1);	/* Save histogram slot that matches. */

ADD_HISTO:
	     mdevice.histogram (histox) = mdevice.histogram (histox) + 1;

	end ADD_ASSIGNED_METERS;
						/* 	*/
METER_DEVICES: procedure;

/*	This procedure is called to meter the devices controlled by RCP.
   *	The meter_index variable is used to determine which devices are
   *	to have their meters reported.
*/
	     rmi_ptr = mrs.rmi_ptr;			/* Report RCPD device meters. */
	     goto METER (meter_index);		/* Go to routine that will process correct devices. */

METER (0):					/* Meter all devices. */
	     call ioa_ ("^/Meters for all devices:");
	     if long_flag
	     then call ioa_ ("Number of devices^-=  ^d", rmi.head.tot_mdevices);
	     do dtypex = 1 to rmi.head.tot_mdtypes;	/* Process all device types. */
		mdtype_ptr = addr (rmi.mdtypes (dtypex)); /* Get pointer to device type info. */
		call METER_DTYPE;			/* Report meters for this device type. */
	     end;
	     return;

METER (1):					/* Meter all devices of this type. */
	     do dtypex = 1 to rmi.head.tot_mdtypes;	/* Look for specified device type. */
		mdtype_ptr = addr (rmi.mdtypes (dtypex));
		if mdtype.device_type = device_type	/* Is this the specified device type? */
		then do;				/* Yes. */
		     call METER_DTYPE;		/* Process all devices of this type. */
		     return;
		end;
	     end;
	     ecode = error_table_$name_not_found;
	     call com_err_ (ecode, "meter_rcp", "Device type = ^a", device_type);
	     return;

METER (2):					/* Meter specified mdevice. */
	     do i = 1 to rmi.head.tot_mdevices;		/* Look for device name. */
		mdevice_ptr = addr (rmi.mdevices (i));
		if mdevice.device_name = device_name	/* Is this the specified device? */
		then do;				/* Yes. */
		     call METER_DEVICE;
		     return;
		end;
	     end;
	     ecode = error_table_$name_not_found;
	     call com_err_ (ecode, "meter_rcp", "Device name = ^a", device_name);

	end METER_DEVICES;
						/* 	*/
METER_DTYPE: procedure;

/*	This procedure is called to process the meters of all of the
   *	devices of the specified type.   Note, the offsets of the
   *	dtype and device entries are relative to the base of RCPD.
   *	We must change them to be relative to our RCPD structure
   *	in meter_rcp_seg.
*/
	     if mdtype.num_devices = 0		/* Are there any devices of this type? */
	     then return;				/* No. */

	     call ioa_ ("^/Meters for device type ^a:", mdtype.device_type);

	     do i = 1 to rmi.head.tot_mdevices;		/* Check each device entry. */
		mdevice_ptr = addr (rmi.mdevices (i));	/* Get pointer to device entry. */
		if mdevice.dtypex = dtypex		/* Is device of this type? */
		then call METER_DEVICE;		/* Yes, report its meters. */
	     end;

	end METER_DTYPE;


METER_DEVICE: procedure;

/*	This procedure is called to calculate and output the meter data about
   *	a specific mdevice.
*/
	     call ioa_ ("^5xMeters for ^a", mdevice.device_name);

	     call ioa_ ("^-Total assignments^-= ^4d", mdevice.num_assigns);
	     call ioa_ ("^-Total errors^-= ^4d", mdevice.error_count);
	     call OUTPUT_TIME (mdevice.tot_assign_time, "	Total time assigned");
	     work = divide (mdevice.tot_assign_time*100, meter_time, 35, 0);
	     call ioa_ ("^-% time assigned^-= ^4d %", work);

	     if ^long_flag
	     then return;

	     mdtype_ptr = addr (rmi.mdtypes (mdevice.dtypex));
	     x = mdtype.histo_times (1) / 60;		/* Convert to minutes. */
	     y = mdtype.histo_times (2) / 60;
	     z = mdtype.histo_times (3) / 60;

	     call ioa_ ("^-Assignment Histogram:");
	     call ioa_ ("^-Minutes:  0  - ^3d^-=>^4d", x, mdevice.histogram (1));
	     call ioa_ ("^-^8x^3d  - ^3d^-=>^4d", x, y, mdevice.histogram (2));
	     call ioa_ ("^-^8x^3d  - ^3d^-=>^4d", y, z, mdevice.histogram (3));
	     call ioa_ ("^-^8x^3d  -   ?^-=>^4d", z, mdevice.histogram (4));

	end METER_DEVICE;
						/* 	*/
METER_LOCK: procedure (lock_number);

/*	This procedure is called to calculate and output the meter data
   *	for a given RCP lock.  The argument specifies which lock.
*/
dcl  lock_number fixed bin;				/* 1 => RCS,  2 => RCPD. */

	     rmi_ptr = mrs.rmi_ptr;			/* Get pointer to meter info. */

	     if lock_number = 1			/* Which lock are we metering? */
	     then do;				/* RCPD's lock. */
		call ioa_ ("^/Lock meters for rcp_com_seg:");
		lock_info_ptr = addr (rmi.rcs_lock_info);
	     end;
	     else do;				/* RCS's lock. */
		call ioa_ ("^/Lock meters for rcp_data:");
		lock_info_ptr = addr (rmi.rcpd_lock_info);
	     end;

	     work = divide ((lock_info.tot_lock_time*100), meter_time, 35, 0);
	     call ioa_ ("% time locked^-= ^4d %", work);

	     work = divide ((lock_info.tot_wait_time*100), meter_time, 35, 0);
	     call ioa_ ("% time waiting^-= ^4d %", work);

	     if lock_info.num_locks = 0
	     then work = 0;
	     else work = divide ((lock_info.num_lock_waits)*100, lock_info.num_locks, 35, 0);
	     call ioa_ ("% number of waits^-= ^4d %", work);

	     if ^long_flag				/* Does user want all lock info? */
	     then return;				/* No. */

	     call ioa_ ("Total num of locks^-= ^4d", lock_info.num_locks);
	     call ioa_ ("Total num of waits^-= ^4d", lock_info.num_lock_waits);

	     call OUTPUT_TIME (lock_info.tot_lock_time, "Total time locked");
	     call OUTPUT_TIME (lock_info.tot_wait_time, "Total time waiting");

	end METER_LOCK;
						/* 	*/
OUTPUT_TIME: procedure (work_time, comment);

/*	This procedure is called to convert a fixed bin time value into
   *	hours, minutes, and seconds.  These values will be typed along
   *	with a specified comment.
*/
dcl  comment char (*);				/* Comment describing time. */
dcl  work_time fixed bin (71);			/* Time value to be converted. */

	     seconds = divide (work_time, 1000000, 35, 0); /* Convert to total seconds. */
	     minutes = divide (seconds, 60, 35, 0);	/* Now to total minutes. */
	     hours = divide (minutes, 60, 35, 0);	/* Now to total hours. */

	     seconds = seconds - minutes * 60;		/* Number of seconds in last minute. */
	     minutes = minutes - hours * 60;		/* Number of minutes in last minute. */

	     call ioa_ ("^a^-=  ^3d hours, ^2d minutes, ^2d seconds",
		comment, hours, minutes, seconds);

	end OUTPUT_TIME;
						/* 	*/
RESET:	procedure;

/*	This procedure is called to save the current meter values.
   *	They will be saved in mrs.ormi_ptr->rmi.  Since the data in
   *	mrs.rmi has been changed and made relative to the old data we
   *	must add the two together to get the original data.
*/
	     rmi_ptr = mrs.rmi_ptr;			/* Get pointers to device meters. */
	     ormi_ptr = mrs.ormi_ptr;
	     do i = 1 to rmi.head.tot_mdevices;		/* Save data for each mdevice. */
		mdevice_ptr = addr (rmi.mdevices (i));	/* Get pointer to new device entry. */
		if mrs.histox (i) ^= 0		/* Did we adjust for an assigned device? */
		then do;				/* Yes, subtract meters for assigned device. */
		     histox = mrs.histox (i);
		     mrs.histox (i) = 0;
		     mdevice.num_assigns = mdevice.num_assigns - 1;
		     mdevice.histogram (histox) = mdevice.histogram (histox) - 1;
		end;
		omdevice_ptr = addr (ormi_ptr -> rmi.mdevices (i)); /* Get pointer to old device entry. */
		omdevice.error_count = omdevice.error_count + mdevice.error_count;
		omdevice.num_assigns = omdevice.num_assigns + mdevice.num_assigns;
		omdevice.tot_assign_time = omdevice.tot_assign_time + mdevice.tot_assign_time;
		do j = 1 to 4;
		     omdevice.histogram (j) = omdevice.histogram (j) + mdevice.histogram (j);
		end;
	     end;

	     lock_info_ptr = addr (rmi.rcs_lock_info);	/* Now save lock meters. */
	     olock_info_ptr = addr (ormi_ptr -> rmi.rcs_lock_info); /* RCS lock first. */
	     do i = 1 to 2;				/* Save calculations for both locks. */
		olock_info.num_locks = olock_info.num_locks + lock_info.num_locks;
		olock_info.num_lock_waits = olock_info.num_lock_waits + lock_info.num_lock_waits;
		olock_info.tot_lock_time = olock_info.tot_lock_time + lock_info.tot_lock_time;
		olock_info.tot_wait_time = olock_info.tot_wait_time + lock_info.tot_wait_time;
		lock_info_ptr = addr (rmi.rcpd_lock_info); /* Next do RCPD lock meters. */
		olock_info_ptr = addr (ormi_ptr -> rmi.rcpd_lock_info);
	     end;

	     mrs.reset_flag = "1"b;			/* Make sure we know we have reset. */
	     mrs.starting_time = mrs.starting_time + meter_time;

	end RESET;
						/* 	*/
INIT_MRS:	procedure;

/*	This procedure is called to initialize the meter_rcp_seg work segment.
   *	We will create a work segment in the user's process directory.
   *	In order to find the size of the meter data (since the number of
   *	device entries is not known) we must call RCP to copy out the meters.
*/
	     call hcs_$make_seg ("", "meter_rcp_seg", "", 01010b, mrs_ptr, ecode);
	     if ecode ^= 0				/* There should be no problems. */
	     then do;				/* But there is. */
		call com_err_ (ecode, "meter_rcp", "Error making meter_rcp_seg.");
		return;
	     end;

	     rmi_ptr = addr (mrs.new_rmi);		/* Initially use some very large size. */
	     rmi.head.version_num = 1;		/* Must set version number. */
	     call rcp_priv_$copy_meters (rmi_ptr, 63*1024, ecode);
	     if ecode ^= 0				/* Can't go on if any trouble. */
	     then do;
		call com_err_ (ecode, "meter_rcp", "Error copying RCP meters.");
		return;
	     end;

	     mrs.reset_flag = "0"b;			/* Set up MRS header data. */
	     mrs.rmi_size = fixed (rel (addr (rmi.end)), 18) - fixed (rel (rmi_ptr), 18);
	     mrs.rmi_bound = ((mrs.rmi_size + 1) / 2) * 2;
	     mrs.rmi_ptr = rmi_ptr;			/* Save pointers to new and old areas. */
	     mrs.ormi_ptr = addr (mrs.old_rmi);
	     mrs.tot_mdevices = rmi.head.tot_mdevices;
	     do i = 1 to rmi.head.tot_mdevices;
		mrs.histox (i) = 0;
	     end;
	     mrs.starting_time = rmi.rcpd_lock_info.starting_time;

	end INIT_MRS;

     end meter_rcp;
   



		    monitor_cache.pl1               03/01/88  1333.1rew 03/01/88  1330.0      202293


/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1988                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1984 *
        *                                                         *
        *********************************************************** */


/****^  HISTORY COMMENTS:
  1) change(87-11-25,Fawcett), approve(87-11-25,MCR7798),
     audit(88-02-22,Parisek), install(88-03-01,MR12.2-1031):
     Change to initialize the variable fact_dividend to the default value of
     15.
                                                   END HISTORY COMMENTS */


monitor_cache: proc ();

/* format: style1,ind2,^inddcls,ifthenstmt,dclind2,declareind2,ifthendo,ifthen*/


/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * *

          Name:	monitor_cache
          
          The monitor_cache command initiates and controls automatic monitoring of
          cache memory error data saved during normal fault processing.  This command
          should be used to constantly monitor the cache memory error data to provide
          a warning when error rates become excessive.  Error rate threshold values
          are compared against a per system, using the -priv control argument
          described below, or a per process threshold.  See "Changing the Threshold
          Values", below for information pertaining to changing the per-system
          defaults and for setting up per-process values that are different from the
          per-system defaults.  The current threshold values may be displayed using
          the display_cache_treshold command.
          
          Usage:	monitor_cache {list} {-control_arguments}
          
          where:
          
          1. list	is a list of cpu tags whose cache error rates should be monitored.
          	If list is not provided, then all possible cpu's will be monitored.
          
          2. -control_arguments may be chosen from the following:
          
             -brief, -bf
                    suppresses the "Cpu cpu_tag below cache error threshold." message
          	when the error rate is within the specified threshold limits. This
          	does not suppress the warning when the error rate is above the
          	threshold values. This is the default.
          
             -long, -lg
          	emits a "Cpu cpu_tag below cache error threshold." message on
          	the user_output i/o switch.
          
             -cpu   cpu_list
          	an alternate method of specifying list, above.
          
             -priv  causes  warning messages of "Cache above error threshold for cpu
          	cpu_tag." to be written into the syserr_log and output to the
          	operator console with an audible alarm. The use of this control
          	argument uses the per system threshold values in
          	>tools>cache_threshold_defaults_. The use of this control argument
          	causes the polling message described under -long above to be
          	put into the syserr_log instead of the user_output i/o switch.
          	The use of this control argument requires re access to the hphcs_ 
          	gate.
          
             -stop, -sp
          	stops monitoring for the cpu's in the list argument or the operands
          	of the -cpu control argument. If no cpu tags have been specified,
          	then monitoring for all cpus is terminated.
          
             -start, -sr
          	resumes monitoring for cpu's specified by the list argument or the
          	operands of the -cpu control argument. Monitoring will continue with
          	the next scheduled cycle.
          
             -time N, -tm N
          	specifies the monitoring interval in minutes. The default time is 15
          	minutes.
          
          Notes:
          
          Use of this command requires re access to the phcs_ gate.
          
          The monitor interval is closely associated with the threshold values
          in that the threshold is specified in terms of an acceptable error
          rate N in X time.  
          	
          Changing the Threshold Values:
          
          The per-system and per-process default threshold values are defined in
          >system_library_tools>cache_threshold_defaults_.  This segment is created by
          a cds source segment of the same name.  In order to change the system
          default values, it is necessary to change this source segment, recompile and
          install the generated object in >tools.  A per-process threshold that is
          different from the per-system values may be created by performing the same
          operations, except that it should be found in the process' object search
          rules before >tools or it may be specifically initiated.
                    	
       Status:
         	0) Created:     2/84 by GA Texada

*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

dcl cache_meters_$for_monitor entry (ptr, fixed bin, fixed bin (35)),
  com_err_	     entry () options (variable),
  cu_$arg_count	     entry (fixed bin, fixed bin (35)),
  cu_$arg_ptr	     entry (fixed bin, ptr, fixed bin (21), fixed bin (35)),
  hcs_$get_user_effmode  entry (char (*), char (*), char (*), fixed bin, fixed bin (5),
		     fixed bin (35)),
  hcs_$initiate	     entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr,
		     fixed bin (35)),
  hcs_$make_ptr	     entry (ptr, char (*), char (*), ptr, fixed bin (35)),
  hcs_$terminate_noname  entry (ptr, fixed bin (35)),
  hphcs_$syserr	     entry options (variable),
  get_temp_segment_	     entry (char (*), ptr, fixed bin (35)),
  release_temp_segment_  entry (char (*), ptr, fixed bin (35)),
  ioa_		     entry () options (variable),
  ipc_$create_ev_chn     entry (fixed bin (71), fixed bin (35)),
  ipc_$decl_ev_call_chn  entry (fixed bin (71), entry, ptr, fixed bin, fixed bin (35)),
  timer_manager_$alarm_wakeup entry (fixed bin (71), bit (2), fixed bin (71)),
  timer_manager_$reset_alarm_wakeup entry (fixed bin (71));

dcl (error_table_$bad_arg,
  error_table_$badcall,
  error_table_$bad_conversion,
  error_table_$badopt,
  error_table_$inconsistent,
  error_table_$not_privileged) fixed bin (35) ext static;

dcl CPU_TAGS	     char (16) int static init ("ABCDEFGHabcdefgh") options (constant),
  DEFAULT_INTERVAL	     fixed bin int static init (15) options (constant),
						/* 15 minutes is default interval		*/
  DEFAULT_SET	     bit (8) int static init ((8)"1"b) options (constant),
						/* all cpus				*/
  TRUE		     bit (1) int static init ("1"b) options (constant),
  FALSE		     bit (1) int static init ("0"b) options (constant),
  myname		     char (13) init ("monitor_cache") int static options (constant);

dcl ap		     ptr,
  Arg		     char (al) based (ap),
  (Nargs, ncpus, i, j)   fixed bin,
  al		     fixed bin (21),
  (countersp, static_threshold_ptr) ptr int static init (null ()),
  (brief, inited, priv)  bit (1) init static init ("0"b),
  (error_found, got_a_cpu, interval, start, stop) bit (1),
  code		     fixed bin (35),
  acpu_list	     bit (8) init ((8)"0"b),
  cpu_list	     bit (8) int static init ((8)"0"b),
  factor_dividend	     fixed dec (30, 2),
  factor		     fixed dec (30, 2) int static init (0),
  monitor_interval	     fixed bin (71) int static init (0),
  monitor_wakeup_chn     fixed bin (71) int static init (-1),
  (amonitor_interval, start_hack) fixed bin (71);

dcl 1 cache_counters     (MAX_CPUS) aligned based (countersp),
    2 cpu_tag	     fixed bin (35),
    2 cache_type	     fixed bin (35),
    2 cache_err_ctrs     (17) fixed bin (35);

dcl cleanup	     condition;

dcl (clock, divide, fixed, index, mod, null, substr, verify) builtin;


	call check_phcs_access (code);		/* if he doesn't have this then forget trying	*/
	if code ^= 0 then do;			/* because we can't get the meter data		*/
	    call com_err_ (code, myname, "Access to phcs_ is required.");
						/* from cache_meters_$for_monitor		*/
	    return;
	  end;
	if ^inited then do;
	    brief = TRUE;
	    priv = FALSE;
	  end;
          factor_dividend = DEFAULT_INTERVAL;
	amonitor_interval = DEFAULT_INTERVAL * 60000000;
						/* make it microseconds			*/
	got_a_cpu, interval, start, stop = FALSE;
	call cu_$arg_count (Nargs, code);
	if code ^= 0 then do;
	    call com_err_ (code, myname);
	    return;
	  end;
	if Nargs <= 0 then do;
	    if inited then goto recursive_invocation;
	  end;
	else do i = 1 to Nargs;
	    call cu_$arg_ptr (i, ap, al, code);
	    if code ^= 0 then do;
	        call com_err_ (code, myname);
	        call janitor (TRUE);
	        return;
	      end;
	    if substr (Arg, 1, 1) ^= "-" then do;	/* must be cpu tag or cpu list		*/
	        if verify (Arg, CPU_TAGS) ^= 0 then goto cpu_list_error;
	        call mark_cpu;
	      end;
	    else do;
have_next_arg:    if Arg = "-brief" | Arg = "-bf" then brief = TRUE;
	        else if Arg = "-long" | Arg = "-lg" then brief = FALSE;
	        else if Arg = "-priv" then do;
		  call check_hphcs_access (code);	/* might as well do it now...			*/
		  if code ^= 0 then do;
		      call com_err_ (code, myname, "hphcs_");
		      call janitor (TRUE);
		      return;
		    end;
		  else priv = TRUE;
		end;
	        else if Arg = "-stop" | Arg = "-sp" then stop = TRUE;
	        else if Arg = "-start" | Arg = "-sr" then start = TRUE;
	        else if Arg = "-time" | Arg = "-tm" then do;
		  call get_next_arg (TRUE);
		  if code ^= 0 then do;
		      call com_err_ (code, myname, "Missing monitor interval.");
		      call janitor (^inited);
		      return;
		    end;
		  if verify (Arg, "0123456789") ^= 0 then do;
						/* not a valid number			*/
		      call com_err_ (error_table_$bad_conversion, myname, "^a is not a valid number.", Arg);
		      call janitor (^inited);
		      return;
		    end;
		  amonitor_interval = fixed (Arg);
		  factor_dividend = fixed (Arg, 30, 2);
		  if amonitor_interval < 1 then do;
		      call com_err_ (0, myname, "The interval time must be greater than or equal to 1 minute.");
		      call janitor (^inited);
		      return;
		    end;
		  interval = TRUE;
		  amonitor_interval = amonitor_interval * 60000000;
						/* make it microseconds			*/
		end;
	        else if Arg = "-cpu" then do;		/* just monitor these			*/
		  do while (TRUE);
		    call get_next_arg (TRUE);
		    if ap = null () then do;
		        if ^got_a_cpu then do;
			  call com_err_ (code, myname, "Processing -cpu");
			  call janitor (^inited);
			  return;
			end;
		        else goto finished_args;
		      end;
		    if substr (Arg, 1, 1) = "-" then do;
		        if got_a_cpu then goto have_next_arg;
		        else goto cpu_list_error;
		      end;
		    if verify (Arg, CPU_TAGS) ^= 0 then do;
cpu_list_error:	        call com_err_ (error_table_$bad_arg, myname, "^a contains an invalid cpu tag.", Arg);
		        call janitor (^inited);
		        return;
		      end;
		    got_a_cpu = TRUE;
		    call mark_cpu ();
		  end;
		end;
	        else do;				/* hmm, don't know this ctl arg		*/
		  call com_err_ (error_table_$badopt, myname, "^a.", Arg);
		  call janitor (^inited);
		  return;
		end;
	      end;				/* must have been a ctl arg			*/
finished_args:
	  end;					/* all done with arguments			*/

	if ^inited then
	     if (stop) then do;			/* can't do this until we have started monitoring */
	         call com_err_ (error_table_$badcall, myname, "Monitoring has not been started, -stop ignored.");
	         return;
	       end;

	if inited then do;
	    if ^(start | stop) then do;
recursive_invocation:
	        call com_err_ (error_table_$badcall, myname,
		"Monitoring has already been invoked. Use the -stop control argument.");
	        call janitor (FALSE);
	        return;
	      end;
	    if interval then do;
	        call com_err_ (0, myname, "The monitoring interval may not be changed during monitoring.");
	        return;
	      end;
	    if (start & stop) then do;
	        call com_err_ (error_table_$inconsistent, myname, "Both ""-start"" and ""-stop"" specified.");
	        return;
	      end;
	    if start then do;			/* turn some back ON			*/
	        if acpu_list = (8)"0"b then do;
		  call com_err_ (0, myname, "No cpu list found for -start control argument.");
		  call janitor (FALSE);
		  return;
		end;
	        else do;
		  do i = 1 to MAX_CPUS;
		    if (substr (acpu_list, i, 1)) then substr (cpu_list, i, 1) = TRUE;
		  end;
		end;
	      end;
	    else if stop then do;			/* turn off if we have a list			*/
	        if acpu_list ^= (8)"0"b then do;
		  do i = 1 to MAX_CPUS;
		    if (substr (acpu_list, i, 1)) then substr (cpu_list, i, 1) = FALSE;
		  end;
		end;
	        else do;				/* ok stop all monitoring			*/
		  call janitor (TRUE);		/* cleanup and quit				*/
		  return;
		end;
	      end;
	  end;
	if ^inited then do;
	    on cleanup call janitor (TRUE);
	    cache_threshold_datap = null ();
	    if priv then call use_tools_for_defaults ();	/* always use >tools for priv			*/
	    else do;
	        call find_defaults ();
	        if cache_threshold_datap = null () then call use_tools_for_defaults ();
	      end;
	    if cache_threshold_datap = null () then do;
	        call com_err_ (code, myname, "Unable to find the cache threshold defaults.");
	        call janitor (TRUE);
	        return;
	      end;

	    static_threshold_ptr = cache_threshold_datap; /* save this				*/
	    call cache_meters_$for_monitor (null (), ncpus, code);
						/* null ptr tells of initial call to reset per process*/
	    if code ^= 0 then do;			/* meter data				*/
	        call com_err_ (code, myname, "Initial cache_meters_ call to reset counters.");
	        call janitor (TRUE);
	        return;
	      end;
	    call get_temp_segment_ (myname, countersp, code);
	    if code ^= 0 then do;
	        call com_err_ (code, myname, "Attempting to get a temporary segment.");
	        call janitor (TRUE);
	        return;
	      end;
	    if acpu_list = (8)"0"b then acpu_list = DEFAULT_SET;
						/* no cpu's specified, do 'em all		*/
	    call set_interval_and_factor ();
	    cpu_list = acpu_list;
	    call ipc_$create_ev_chn (monitor_wakeup_chn, code);
	    if code ^= 0 then do;
	        call com_err_ (code, myname, "Creating event channel.");
	        call janitor (TRUE);
	        return;
	      end;
	    call ipc_$decl_ev_call_chn (monitor_wakeup_chn, wakeup_monitor, null (), 1, code);
	    if code ^= 0 then do;
	        call com_err_ (code, myname, "Creating event call channel.");
	        call janitor (TRUE);
	        return;
	      end;
	    start_hack = clock ();
	    call timer_manager_$alarm_wakeup (start_hack + monitor_interval, "00"b, monitor_wakeup_chn);
	    inited = TRUE;
	  end;
	return;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

display_cache_threshold: entry ();


/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*									*/
/* This entry uses the current cache threshold data segment (if one is found via the	*/
/* search rules, or the default one in >tools.					*/
/*									*/
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

dcl di		     fixed bin;

	if static_threshold_ptr ^= null () then cache_threshold_datap = static_threshold_ptr;
						/* use this if we have one inited		*/
	else do;
	    call find_defaults ();
	    if cache_threshold_datap = null () then call use_tools_for_defaults;
	    if cache_threshold_datap = null () then do;
	        call com_err_ (code, "display_cache_threshold", "Unable to find the cache threshold defaults.");
	        return;
	      end;
	  end;
	call ioa_ ("	 Error Name	      Allowable per hour
-------------------------------------------------------");
	do di = 1 to NO_CACHE_ERR_TYPES;
	  call ioa_ ("^2x^32a^10x^d", CACHE_ERROR_NAME (di), cache_threshold_data_array (di));
	end;
	return;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/


wakeup_monitor:
     entry ();

	call timer_manager_$reset_alarm_wakeup (monitor_wakeup_chn);
	start_hack = clock ();
	call cache_meters_$for_monitor (countersp, ncpus, code);
	if code ^= 0 then do;
	    call com_err_ (code, myname);
	  end;

	else do;
	    if cpu_list = FALSE then ;		/* no checking done				*/
	    else do;
	        cache_threshold_datap = static_threshold_ptr;
	        do i = 1 to ncpus;
		error_found = FALSE;
		if (substr (cpu_list, cache_counters (i).cpu_tag)) then do;
		    do j = 1 to NO_CACHE_ERR_TYPES;
		      if cache_counters.cache_err_ctrs (i, j) >
		        (cache_threshold_data_array (j) * factor) then do;
			error_found = TRUE;		/* some kind kind of over threshold		*/
			call announce (TRUE, i, j, (cache_counters.cache_err_ctrs (i, j)));
						/* announce the error			*/
		        end;
		    end;
		    if (^error_found) & (substr (cpu_list, i, 1)) then call announce (FALSE, i, 0, 0);
						/* just in case			*/
		  end;				/* end if cpu is being monitored		*/
	        end;
	      end;
	  end;
	call timer_manager_$alarm_wakeup (start_hack + monitor_interval, "00"b, monitor_wakeup_chn);
	call janitor (FALSE);			/* we are done				*/
	return;


/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

check_phcs_access: proc (code);

dcl code		     fixed bin (35),
  mode		     fixed bin (5);

    call hcs_$get_user_effmode (">sl1", "phcs_", "", 0, mode, code);
    if code ^= 0 then return;
    if (mode >= RE_ACCESS_BIN) then ;
    else code = error_table_$not_privileged;
    return;
  end check_phcs_access;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

check_hphcs_access: proc (code);

dcl code		     fixed bin (35),
  mode		     fixed bin (5);

    call hcs_$get_user_effmode (">sl1", "hphcs_", "", 0, mode, code);
    if code ^= 0 then return;
    if (mode >= RE_ACCESS_BIN) then ;
    else code = error_table_$not_privileged;
    return;
  end check_hphcs_access;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/


get_next_arg: proc (required_arg);

dcl required_arg	     bit (1) parameter;

    i = i + 1;					/* set to next arg				*/
    call cu_$arg_ptr (i, ap, al, code);
    if ap = null () then do;
      end;
  end get_next_arg;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/


mark_cpu: proc ();

dcl i		     fixed bin;

    do i = 1 to al;					/* now mark the tag as interested		*/
      substr (acpu_list, mod (index (CPU_TAGS, substr (Arg, i, 1)) - 1, 8) + 1, 1) = TRUE;
    end;
  end mark_cpu;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

announce:
  proc (error, cputag, error_number, how_many);

dcl error		     bit (1) parameter,
  (cputag, error_number, how_many) fixed bin parameter;

    if error then do;
        if priv then
	   call hphcs_$syserr (BEEP, "monitor_cache:  Cpu ^a is above the cache error threshold for ^a. ^d during this interval.",
	     CPU_NAMES (cache_counters.cpu_tag (cputag)), CACHE_ERROR_NAME (error_number), how_many);
        else call ioa_ (myname || ": Cpu ^a is above the cache error threshold for ^a. ^d during this interval.",
	     CPU_NAMES (cache_counters.cpu_tag (cputag)), CACHE_ERROR_NAME (error_number), how_many);
      end;
    else do;					/* no error, announce monitoring if applicable	*/
        if priv then call hphcs_$syserr (LOG, "monitor_cache:  Cpu ^a below cache error threshold.",
	     CPU_NAMES (cache_counters.cpu_tag (cputag)));
        else if ^brief then call ioa_ (myname || ":  Cpu ^a is below cache error threshold.",
	     CPU_NAMES (cache_counters.cpu_tag (cputag)));
      end;

  end announce;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

set_interval_and_factor: proc ();

    monitor_interval = amonitor_interval;		/* calculate the factor viv a vis 1 hour	*/
    factor = divide (factor_dividend, 60.0, 30, 2);
    if factor <= 0 then factor = 1;
  end set_interval_and_factor;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

janitor: proc (finish);

dcl finish	     bit (1) parameter;

    if finish then do;				/* stop all monitoring			*/
        if countersp ^= null () then do;		/* then finish up				*/
	  call release_temp_segment_ (myname, countersp, (0));
	  countersp = null ();
	end;
        if monitor_wakeup_chn ^= -1 then call timer_manager_$reset_alarm_wakeup (monitor_wakeup_chn);
        if static_threshold_ptr ^= null () then call hcs_$terminate_noname (static_threshold_ptr, (0));
        static_threshold_ptr = null ();
        inited = FALSE;
      end;
  end janitor;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

find_defaults: proc ();


    call hcs_$make_ptr (null (), "cache_threshold_defaults_", "", cache_threshold_datap, code);

  end find_defaults;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/


use_tools_for_defaults: proc ();

    call hcs_$initiate (">system_library_tools", "cache_threshold_defaults_", "", 0, 0,
      cache_threshold_datap, code);
  end use_tools_for_defaults;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/


%include cache_threshold_data;

%include fim_meters;

%include access_mode_values;

%include syserr_constants;
     end monitor_cache;
   



		    post_purge_meters.pl1           01/26/85  1313.5r w 01/22/85  1307.7       32652


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


post_purge_meters: ppm: proc;

/* Entries */

dcl  cu_$arg_count entry returns (fixed bin);
dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl  meter_util_$get_buffers entry (fixed bin, ptr, ptr, ptr, ptr, fixed bin (35));
dcl  meter_util_$fill_buffers entry (fixed bin);
dcl  meter_util_$time entry (fixed bin, float bin);
dcl  meter_util_$reset entry (fixed bin);
dcl  ioa_ entry options (variable);
dcl  com_err_ entry options (variable);

/* Automatic */

dcl (i, count, list_size, ws_size, thrash, in_core, purges) fixed bin;
dcl (reset_sw, rps) bit (1) init ("0"b);
dcl  code fixed bin (35);
dcl  tc fixed bin;
dcl  tp ptr;
dcl  time fixed bin (71);
dcl  ftime float bin;
dcl (pc, ave, ave_time) float bin;

/* Static */

dcl  myname char (17) static init ("post_purge_meters");
dcl (sstp1, sstp2, tcdp1, tcdp2) ptr static;
dcl  unique fixed bin static init (0);

/* Based */

dcl  targ char (tc) based (tp);

	do i = 1 to cu_$arg_count ();
	     call cu_$arg_ptr (i, tp, tc, code);
	     if targ = "-report_reset" | targ = "-rr" then reset_sw, rps = "1"b;
	     else if targ = "-reset" | targ = "-rs" then reset_sw = "1"b;
	     else call com_err_ (0, (myname), "Unrecognized option ^a ignored", targ);
	end;

	if ^reset_sw then rps = "1"b;

	if unique = 0 then do;
	     call meter_util_$get_buffers (unique, sstp1, sstp2, tcdp1, tcdp2, code);
	     if code ^= 0 then do;
		call com_err_ (0, (myname), "Cannot get buffers.");
		return;
	     end;
	end;

	call meter_util_$fill_buffers (unique);
	call meter_util_$time (unique, ftime);
	ftime = tcdp2 -> tcm.processor_time - tcdp1 -> tcm.processor_time;

	if rps then do;
	     time = sstp2 -> sst.post_purge_time - sstp1 -> sst.post_purge_time;
	     count = sstp2 -> sst.post_purge_calls - sstp1 -> sst.post_purge_calls;
	     if count > 0 then do;
		ave_time = 1e-3*time/count;
		pc = 1e2*time/ftime;
		call ioa_ ("^/Post purge time^-^8.2f msec. (^.2f% of system)", ave_time, pc);
		list_size = sstp2 -> sst.post_list_size - sstp1 -> sst.post_list_size;
		ave = list_size/count;
		call ioa_ ("Ave list size^-^8.2f entries", ave);

		ws_size = sstp2 -> sst.pre_page_size - sstp1 -> sst.pre_page_size;
		ave = ws_size/count;
		call ioa_ ("Ave working set^-^8.2f pages", ave);

		call ioa_ ("Working set factor^-^8.2f", tcdp2 -> tcm.working_set_factor);

		call ioa_ ("Working set addend^-^8d", tcdp2 -> tcm.working_set_addend);

		thrash = sstp2 -> sst.thrashing - sstp1 -> sst.thrashing;
		ave = 1e2*thrash/list_size;
		call ioa_ ("Thrashing percentage^8.2f %", ave);

		in_core = sstp2 -> sst.post_in_core - sstp1 -> sst.post_in_core;
		ave = in_core/count;
		call ioa_ ("Ave post in core^-^8.2f       (^.2f %)", ave, 1e2*in_core/list_size);

		purges = sstp2 -> sst.post_purgings - sstp1 -> sst.post_purgings;
		ave = purges/count;
		if purges > 0 then call ioa_ ("Ave post purges^-^8.2f       (^.2f %)", ave, 1e2*purges/list_size);
	     end;
	     else call ioa_ ("^/No activity.");
	end;

	call ioa_ (" ");

	if reset_sw then call meter_util_$reset (unique);
	return;

/*  */

%include sst;
%include tcm;
%include hc_lock;
     end;



		    response_meters.pl1             08/04/87  1504.7rew 08/04/87  1222.5      163809


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

/* format: style4 */
response_meters:
     proc;

/*  response_meters

   Program to print response time data, summarized by work class.
   Sufficient access is required to copy out the tc_data header.
   If the user also has R access to the MGT and the answer table,
   work class names are printed.

   Written May 1981 by J. Bongiovanni								*/
/* 81-12-08 Modified by E. N. Kittlitz.  user_table_entry conversion. */
/* Modified November 1984 by M. Pandolf to include hc_lock. */


/****^  HISTORY COMMENTS:
  1) change(87-04-26,GDixon), approve(87-07-13,MCR7741),
     audit(87-07-27,Hartogs), install(87-08-04,MR12.1-1055):
     Upgraded for change to answer_table.incl.pl1.
                                                   END HISTORY COMMENTS */


/* Automatic */

dcl  arg_len fixed bin (21);				/* length of input argument			*/
dcl  arg_no fixed bin;				/* current argument number			*/
dcl  arg_ptr ptr;					/* pointer to current argument		*/
dcl  code fixed bin (35);				/* standard error code			*/
dcl  cur_ptrs (1) ptr;				/* from metering_util_			*/
dcl  1 cur_total_wcte aligned like wct_entry;		/* dummy WCTE for current totals		*/
dcl  formatted_meter_time char (10);			/* total metering time HHHH:MM:SS		*/
dcl  lcg (0:MAX_WORK_CLASS) char (32) varying;		/* Load Control Group Names by work class	*/
dcl  meter_calls fixed bin;				/* number of calls to meter_response_time	*/
dcl  meter_invalid fixed bin;				/* number invalid state transitions		*/
dcl  meter_ovhd float;				/* total metering overhead in sec.		*/
dcl  meter_ovhd_call float;				/* metering ovrhead per call in msec.		*/
dcl  meter_time fixed bin (71);			/* total metering time in microseconds		*/
dcl  n_args fixed bin;				/* number of arguments			*/
dcl  prev_ptrs (1) ptr;				/* from metering_util_			*/
dcl  1 prev_total_wcte aligned like wct_entry;		/* dummy WCTE for previous totals		*/
dcl  range_no fixed bin;				/* vcpu range index				*/
dcl  report_sw bit (1);				/* true if report option specified		*/
dcl  reset_sw bit (1);				/* true if reset option specified		*/
dcl  tcmp1 ptr;					/* pointer to previous copy of tc_data		*/
dcl  tcmp2 ptr;					/* pointer to current copy of tc_data		*/
dcl  tt_arg bit (1);				/* ON => -total argument given		*/
dcl  wc_alph pic "zz9";				/* work class number for printing		*/
dcl  wc_arg bit (1);				/* ON => -work_class argument given		*/
dcl  wc_arg_num fixed bin;				/* work class number from -work_class arg	*/
dcl  wc_num fixed bin;				/* current work class number			*/

/* Static */

dcl  ANSWER_TABLE char (12) int static options (constant)
	init ("answer_table");			/* segment name of answer table		*/
dcl  CONTROL_DIR char (17) int static options (constant)
	init (">system_control_1");			/* directory where answer_table and MGT live	*/
dcl  init_sw bit (1) int static init ("0"b);		/* true if already initialized		*/
dcl  MAX_FLOAT float int static options (constant)
	init (99.99);				/* maximum floating point number we print	*/
dcl  MAX_WORK_CLASS fixed bin int static options (constant)
	init (16);				/* maximum work class allowed by system		*/
dcl  MGT char (3) int static options (constant)
	init ("mgt");				/* segment name of the MGT			*/
dcl  mgtp ptr int static init (null ());		/* pointer to MGT				*/
dcl  MYNAME char (15) int static options (constant)
	init ("response_meters");
dcl  static_ansp ptr int static init (null ());		/* pointer to answer table			*/
dcl  unique fixed bin int static init (0);		/* instance number for metering_util_		*/


/* Based */

dcl  arg char (arg_len) based (arg_ptr);		/* current argument				*/

%page;

/* External */

dcl  error_table_$bad_arg fixed bin (35) external;
dcl  error_table_$badopt fixed bin (35) external;
dcl  error_table_$inconsistent fixed bin (35) external;

/* Entry */

dcl  com_err_ entry options (variable);
dcl  cu_$arg_count entry (fixed bin, fixed bin (35));
dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
dcl  hcs_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35));
dcl  ioa_ entry options (variable);
dcl  metering_util_$define_regions entry options (variable);
dcl  metering_util_$fill_buffers entry (fixed bin, fixed bin (71), char (*), (*) ptr, (*) ptr, fixed bin (35));
dcl  metering_util_$reset entry (fixed bin, fixed bin (35));

/* Condition */

dcl  conversion condition;

/* Builtin */

dcl  addr builtin;
dcl  fixed builtin;
dcl  min builtin;
dcl  null builtin;
dcl  rtrim builtin;

%page;

/* Pick up and validate arguments.  If none "-report" assumed.					*/

	report_sw,
	     reset_sw,
	     tt_arg,
	     wc_arg = "0"b;

	call cu_$arg_count (n_args, code);
	if code ^= 0 then do;
	     call com_err_ (code, MYNAME);
	     return;
	end;

	if n_args = 0
	then report_sw = "1"b;
	else do arg_no = 1 to n_args;
	     call cu_$arg_ptr (arg_no, arg_ptr, arg_len, code);
	     if arg = "-report" then report_sw = "1"b;
	     else if arg = "-reset" | arg = "-rs" then reset_sw = "1"b;
	     else if arg = "-report_reset" | arg = "-rr" then do;
		report_sw = "1"b;
		reset_sw = "1"b;
	     end;
	     else if arg = "-work_class" | arg = "-wc" then do;
		wc_arg = "1"b;
		arg_no = arg_no + 1;
		call cu_$arg_ptr (arg_no, arg_ptr, arg_len, code);
		if code ^= 0 then do;
		     call com_err_ (code, MYNAME, "Work Class Number");
		     return;
		end;
		on conversion goto invalid_work_class;
		wc_arg_num = fixed (arg);
		revert conversion;
		if wc_arg_num < 0 | wc_arg_num > MAX_WORK_CLASS then do;
invalid_work_class:	     call com_err_ (error_table_$bad_arg, MYNAME, arg);
		     return;
		end;
	     end;
	     else if arg = "-total" | arg = "-tt" | arg = "-totals"
	     then tt_arg = "1"b;
	     else do;
		call com_err_ (error_table_$badopt, MYNAME, arg);
		return;
	     end;
	end;

	if ^reset_sw then report_sw = "1"b;
	if wc_arg & tt_arg then do;
	     call com_err_ (error_table_$inconsistent, MYNAME, "-work_class and -total");
	     return;
	end;
	if ^report_sw & (tt_arg | wc_arg) then do;
	     call com_err_ (error_table_$inconsistent, MYNAME, "Report options without -report");
	     return;
	end;


%page;

/* Initialize if not done already 								*/

	if ^init_sw then do;
	     call metering_util_$define_regions (unique, code,
		"tc_data", 0, "apt");
	     if code ^= 0 then do;
		call com_err_ (code, MYNAME, "Defining regions.");
		return;
	     end;
	     init_sw = "1"b;
	end;
	call metering_util_$fill_buffers (unique, meter_time,
	     formatted_meter_time, cur_ptrs, prev_ptrs, code);
	if code ^= 0 then do;
	     call com_err_ (code, MYNAME, "Filling buffers.");
	     return;
	end;

	call ioa_ ("^/Total metering time^-^a^/", formatted_meter_time);
%page;


/* Print the report if requested */

	if report_sw then do;

	     tcmp1 = prev_ptrs (1);			/* prev copy of tc_data			*/
	     tcmp2 = cur_ptrs (1);			/* current copy of tc_data			*/


	     prev_total_wcte.number_thinks,
		prev_total_wcte.number_queues,
		prev_total_wcte.total_think_time,
		prev_total_wcte.total_queue_time = 0;
	     cur_total_wcte.number_thinks,
		cur_total_wcte.number_queues,
		cur_total_wcte.total_think_time,
		cur_total_wcte.total_queue_time = 0;
	     do range_no = 1 to VCPU_RESPONSE_BOUNDS + 1;
		prev_total_wcte.number_processing (range_no),
		     prev_total_wcte.total_processing_time (range_no),
		     prev_total_wcte.total_vcpu_time (range_no) = 0;
		cur_total_wcte.number_processing (range_no),
		     cur_total_wcte.total_processing_time (range_no),
		     cur_total_wcte.total_vcpu_time (range_no) = 0;
	     end;


	     call fill_lcg;				/* pick up Load Control Group IDs		*/
	     call ioa_ ("WC  ---Thinks/--    ----Response Times by VCPU Range----  Load Control Group");
	     call ioa_ ("^4x---Queues---    -VCPU Range-     #  Avg   Avg   Resp");
	     call ioa_ ("^9x#  Avg      From    To    Int  VCPU   RT   Fact");

/* Print report type specified by arguments							*/

	     if wc_arg then do;			/* report on specified work class		*/
		wc_alph = wc_arg_num;
		call stats_for_work_class (addr (tcmp2 -> tcm.wcte (wc_arg_num)),
		     addr (tcmp1 -> tcm.wcte (wc_arg_num)), (wc_alph), lcg (wc_arg_num));
	     end;
	     else do;				/* all work classes or totals			*/

		do wc_num = 0 to MAX_WORK_CLASS;

		     if tcmp2 -> tcm.wcte (wc_num).defined then do;
			wc_alph = wc_num;
			if ^tt_arg then
			     call stats_for_work_class (addr (tcmp2 -> tcm.wcte (wc_num)),
				addr (tcmp1 -> tcm.wcte (wc_num)), (wc_alph), lcg (wc_num));

			cur_total_wcte.number_thinks
			     = cur_total_wcte.number_thinks + tcmp2 -> tcm.wcte (wc_num).number_thinks;
			cur_total_wcte.number_queues
			     = cur_total_wcte.number_queues + tcmp2 -> tcm.wcte (wc_num).number_queues;
			cur_total_wcte.total_think_time
			     = cur_total_wcte.total_think_time + tcmp2 -> tcm.wcte (wc_num).total_think_time;
			cur_total_wcte.total_queue_time
			     = cur_total_wcte.total_queue_time + tcmp2 -> tcm.wcte (wc_num).total_queue_time;
			do range_no = 1 to VCPU_RESPONSE_BOUNDS + 1;
			     cur_total_wcte.number_processing (range_no)
				= cur_total_wcte.number_processing (range_no)
				+ tcmp2 -> tcm.wcte (wc_num).number_processing (range_no);
			     cur_total_wcte.total_processing_time (range_no)
				= cur_total_wcte.total_processing_time (range_no)
				+ tcmp2 -> tcm.wcte (wc_num).total_processing_time (range_no);
			     cur_total_wcte.total_vcpu_time (range_no)
				= cur_total_wcte.total_vcpu_time (range_no)
				+ tcmp2 -> tcm.wcte (wc_num).total_vcpu_time (range_no);
			end;

			prev_total_wcte.number_thinks
			     = prev_total_wcte.number_thinks + tcmp1 -> tcm.wcte (wc_num).number_thinks;
			prev_total_wcte.number_queues
			     = prev_total_wcte.number_queues + tcmp1 -> tcm.wcte (wc_num).number_queues;
			prev_total_wcte.total_think_time
			     = prev_total_wcte.total_think_time + tcmp1 -> tcm.wcte (wc_num).total_think_time;
			prev_total_wcte.total_queue_time
			     = prev_total_wcte.total_queue_time + tcmp1 -> tcm.wcte (wc_num).total_queue_time;
			do range_no = 1 to VCPU_RESPONSE_BOUNDS + 1;
			     prev_total_wcte.number_processing (range_no)
				= prev_total_wcte.number_processing (range_no)
				+ tcmp1 -> tcm.wcte (wc_num).number_processing (range_no);
			     prev_total_wcte.total_processing_time (range_no)
				= prev_total_wcte.total_processing_time (range_no)
				+ tcmp1 -> tcm.wcte (wc_num).total_processing_time (range_no);
			     prev_total_wcte.total_vcpu_time (range_no)
				= prev_total_wcte.total_vcpu_time (range_no)
				+ tcmp1 -> tcm.wcte (wc_num).total_vcpu_time (range_no);
			end;


		     end;
		end;
		call stats_for_work_class (addr (cur_total_wcte), addr (prev_total_wcte),
		     "All", "");
	     end;


	     meter_calls = tcmp2 -> tcm.meter_response_time_calls
		- tcmp1 -> tcm.meter_response_time_calls;
	     meter_invalid = tcmp2 -> tcm.meter_response_time_invalid
		- tcmp1 -> tcm.meter_response_time_invalid;
	     meter_ovhd = (tcmp2 -> tcm.meter_response_time_overhead
		- tcmp1 -> tcm.meter_response_time_overhead);
	     if meter_calls = 0 then do;
		meter_ovhd_call = 0.0;
		meter_ovhd = 0.0;
	     end;
	     else do;
		meter_ovhd_call = meter_ovhd * 1.0e-3 / meter_calls;
		meter_ovhd = meter_ovhd * 1.0e2 / (tcmp2 -> tcm.processor_time - tcmp1 -> tcm.processor_time);
	     end;
	     call ioa_ ("^/^10d calls to meter_response_time ^10d invalid transitions.^/^11xOverhead = ^6.2f% (^7.3f ms./call)^/",
		meter_calls, meter_invalid, meter_ovhd, meter_ovhd_call);

	end;
%page;

/* Reset if requested 									*/

	if reset_sw then do;
	     call metering_util_$reset (unique, code);
	     if code ^= 0 then do;
		call com_err_ (code, MYNAME, "Resetting.");
		return;
	     end;
	end;

	return;
%page;

/* Internal Procedure to fill the array "lgc" with Load Control Group
   IDs corresponding to Work Classes								*/

fill_lcg: proc;

dcl  curshift fixed bin;
dcl  mgt_ix fixed bin;


	lcg (*) = "";
	lcg (0) = "Init";

	if mgtp = null () then do;
	     call hcs_$initiate (CONTROL_DIR, MGT, "", 0, 1, mgtp, code);
	     if mgtp = null () then return;
	end;

	if static_ansp = null () then do;
	     call hcs_$initiate (CONTROL_DIR, ANSWER_TABLE, "", 0, 1, static_ansp, code);
	     if static_ansp = null () then return;
	end;
	ansp = static_ansp;

	curshift = anstbl.shift;

	do mgt_ix = MAX_WORK_CLASS + 1 to mgt.current_size;
	     mgtep = addr (mgt.entry (mgt_ix));
	     lcg (group.int_wc (curshift)) =
		lcg (group.int_wc (curshift)) ||
		rtrim (group.group_id) || " ";
	end;

     end fill_lcg;
%page;
/* Internal Procedure to compute statistics for one work class and
   print these statistics									*/

stats_for_work_class:
     proc (cur_wcp, prev_wcp, wc_number_alph, lcg_info);

/* Parameter */

dcl  cur_wcp ptr;					/* pointer to current copy of WCTE		*/
dcl  prev_wcp ptr;					/* pointer to previous copy of WCTE		*/
dcl  wc_number_alph char (*);				/* printable work class number		*/
dcl  lcg_info char (*) varying;			/* Load Control Group information		*/

/* Automatic */

dcl  avg_queue_rt float;				/* average (pro-rated) queue time / interaction	*/
dcl  avg_queue float;				/* average queue time			*/
dcl  avg_think float;				/* average think time			*/
dcl  line_no fixed bin;				/* current output line no w/i WC		*/
dcl  n_queue fixed bin;				/* number of queues				*/
dcl  n_resp fixed bin;				/* number of interactions			*/
dcl  n_resp_wc fixed bin;			/* number of interactions for current work class	*/
dcl  n_think fixed bin;				/* number of thinks				*/
dcl  range_from float;				/* begin of range in sec			*/
dcl  range_to float;				/* end of range in sec			*/
dcl  total_rt float;				/* sum of processing times			*/
dcl  total_rt_wc float;				/* sum of processing times for work class	*/
dcl  total_vcpu float;				/* sum of VCPU times			*/
dcl  total_vcpu_wc float;				/* sum of VCPU times for work class		*/


	n_resp_wc = 0;
	do range_no = 1 to VCPU_RESPONSE_BOUNDS + 1;
	     n_resp_wc = n_resp_wc + cur_wcp -> wct_entry.number_processing (range_no)
		- prev_wcp -> wct_entry.number_processing (range_no);
	end;
	if n_resp_wc <= 0 then return;
	total_rt_wc, total_vcpu_wc = 0;

	line_no = 1;

	n_think = cur_wcp -> wct_entry.number_thinks
	     - prev_wcp -> wct_entry.number_thinks;
	n_queue = cur_wcp -> wct_entry.number_queues
	     - prev_wcp -> wct_entry.number_queues;
	if n_think = 0
	then avg_think = 0.0;
	else do;
	     avg_think = (cur_wcp -> wct_entry.total_think_time
		- prev_wcp -> wct_entry.total_think_time) / 1.0e6;
	     avg_think = avg_think / n_think;
	end;
	if n_queue = 0
	then avg_queue = 0.0;
	else do;
	     avg_queue = (cur_wcp -> wct_entry.total_queue_time
		- prev_wcp -> wct_entry.total_queue_time) / 1.0e6;
	     avg_queue = avg_queue / n_queue;
	end;

	avg_queue_rt = avg_queue * min (n_queue, n_resp_wc) / n_resp_wc;

	if avg_think > MAX_FLOAT then avg_think = MAX_FLOAT;
	if avg_queue > MAX_FLOAT then avg_queue = MAX_FLOAT;

/* Go through the range of virtual cpu times for the work class					*/

	do range_no = 1 to VCPU_RESPONSE_BOUNDS + 1;
	     if range_no = 1
	     then range_from = 0.0;
	     else range_from = tcmp2 -> tcm.vcpu_response_bounds (range_no - 1) / 1.0e6;
	     if range_no = VCPU_RESPONSE_BOUNDS + 1
	     then range_to = MAX_FLOAT;
	     else range_to = tcmp2 -> tcm.vcpu_response_bounds (range_no) / 1.0e6;

	     n_resp = cur_wcp -> wct_entry.number_processing (range_no)
		- prev_wcp -> wct_entry.number_processing (range_no);
	     total_vcpu = (cur_wcp -> wct_entry.total_vcpu_time (range_no)
		- prev_wcp -> wct_entry.total_vcpu_time (range_no)) / 1.0e6;
	     total_vcpu_wc = total_vcpu_wc + total_vcpu;
	     total_rt = (cur_wcp -> wct_entry.total_processing_time (range_no)
		- prev_wcp -> wct_entry.total_processing_time (range_no)) / 1.0e6;
	     total_rt_wc = total_rt_wc + total_rt;
	     call print_stats (n_resp, total_rt, total_vcpu, "0"b);
	end;

	call print_stats (n_resp_wc, total_rt_wc, total_vcpu_wc, "1"b);
	return;


%page;
/* Internal Procedure to print one line of statistics						*/

print_stats:
	proc (N_resp, T_rt, T_vcpu, total_flag);

/* Parameter */

dcl  N_resp fixed bin;				/* number of interactions			*/
dcl  T_rt float;					/* sum of processing time			*/
dcl  T_vcpu float;					/* sum of virtual cpu time			*/
dcl  total_flag bit (1);				/* ON => printing total for work class		*/

/* Automatic */

dcl  avg_rt float;					/* average response time			*/
dcl  avg_vcpu float;				/* average virtual cpu time			*/
dcl  resp_fact float;				/* response factor = avg resp time/avg vcpu time	*/

	     if N_resp = 0 then do;
		avg_vcpu = 0.0;
		avg_rt = 0.0;
		resp_fact = 0.0;
	     end;
	     else do;
		avg_vcpu = T_vcpu / N_resp;
		avg_rt = T_rt / N_resp + avg_queue_rt;

		resp_fact = avg_rt / avg_vcpu;

		if avg_vcpu > MAX_FLOAT then avg_vcpu = MAX_FLOAT;
		if avg_rt > MAX_FLOAT then avg_rt = MAX_FLOAT;
		if resp_fact > MAX_FLOAT then resp_fact = MAX_FLOAT;
	     end;

	     if N_resp > 0 then do;
		call ioa_ ("^[^[^/^3a ^6d ^5.2f    ^2s^;^3s^4x^6d ^5.2f    ^]^;^6s^20x^]^[^2(----- ^)^2s^;^2(^5.2f ^)^]^6d ^3(^5.2f ^)^[ ^a^;^]",
		     (line_no <= 2), line_no, wc_number_alph, n_think, avg_think,
		     n_queue, avg_queue, total_flag, range_from, range_to,
		     N_resp, avg_vcpu, avg_rt, resp_fact,
		     (line_no = 1), lcg_info);
		line_no = line_no + 1;
	     end;

	end print_stats;


     end stats_for_work_class;


%page; %include answer_table;
%page; %include mgt;
%page; %include tcm;
%page; %include hc_lock;
%page; %include user_table_header;

     end response_meters;
   



		    system_link_meters.pl1          11/15/82  1843.0rew 11/15/82  1512.8       78840


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


/* Updated by Alan Bier  March 1974 */

/* Cleaned up substantially by J. Bongiovanni  December 80 */

system_link_meters: slm: proc;

/* Automatic */

dcl  arg_count fixed bin;
dcl  arglen fixed bin (21);
dcl  argptr ptr;
dcl  atime (4) char (12) aligned;
dcl  avgpf (4) float;
dcl  avgt (4) float;
dcl  code fixed bin (35);
dcl  count (4, 2) fixed bin (35);
dcl  cpu_time float;
dcl  cur_buff_ptrs (3) ptr;
dcl  cur_meters ptr;
dcl  formatted_meter_time char (10);
dcl  i fixed bin;
dcl  idle_time float;
dcl  j fixed bin;
dcl  meter_time fixed bin (71);
dcl  name (3) char (20) init ("Segment Search", "Get Linkage", "Definition Search");
dcl  pcc (4) float;
dcl  pct (4) float;
dcl  pc_lk_cpu_time float;
dcl  pc_linker_time float;
dcl  pgfault (4, 5) fixed bin (35);
dcl  prev_buff_ptrs (3) ptr;
dcl  prev_meters ptr;
dcl  repsw bit (1) init ("0"b);
dcl  rs char (12);
dcl  rsw bit (1) init ("0"b);
dcl  slot_count fixed bin (35);
dcl  slot_time fixed bin (35);
dcl  ti float;
dcl  time (4, 5) fixed bin (35);
dcl  total_counts fixed bin (35);
dcl  total_linker_time fixed bin (35);
dcl  total_time float;

/* Static */

dcl  our_name char (18) init ("system_link_meters") int static options (constant);
dcl  unique fixed bin int static init (0);

/* External */

dcl  error_table_$badopt fixed bin (35) external;

/* Based */

dcl  arg char(arglen) based (argptr);
dcl  cur_cpu_time fixed bin (71) based (cur_buff_ptrs (1));
dcl  cur_idle_time fixed bin (71) based (cur_buff_ptrs (2));
dcl  prev_cpu_time fixed bin (71) based (prev_buff_ptrs (1));
dcl  prev_idle_time fixed bin (71) based (prev_buff_ptrs (2));

% include link_meters;
		     
/* Entry */

dcl  com_err_ entry() options(variable);
dcl  cu_$arg_count entry (fixed bin);
dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin(21), fixed bin(35));
dcl  ioa_ entry entry options(variable);
dcl  metering_util_$define_regions entry options (variable);
dcl  metering_util_$fill_buffers entry (fixed bin, fixed bin (71), char (*), (*) ptr, (*) ptr, fixed bin (35));
dcl  metering_util_$reset entry (fixed bin, fixed bin (35));

/* Builtin */

dcl  divide builtin;
dcl  mod builtin;
dcl  size builtin;

/*  */


          call cu_$arg_count (arg_count);

	do i = 1 to arg_count;
	     call cu_$arg_ptr (i, argptr, arglen, code);
	     if code ^= 0 | arglen = 0 then go to start;
	     if arg = "-report_reset" | arg = "-rr" then rsw, repsw = "1"b;
	     else if arg = "-reset" | arg = "-rs" then rsw = "1"b;
               else do;
		call com_err_ (error_table_$badopt, our_name, arg);
		return;
               end;
           end;


start:	if ^rsw then repsw = "1"b;

          if unique=0 then do;			/* not initialized yet			*/
	     call metering_util_$define_regions (unique, code,
		"tc_data", "processor_time", 2,
		"tc_data", "idle", 2,
		"active_hardcore_data", "link_meters", size (link_meters));
	     if code^=0 then do;
		call com_err_ (code, our_name, "Error initializing");
		return;
	     end;
	end;
	

get_data:
	total_linker_time = 0;
	total_counts = 0;
	call metering_util_$fill_buffers (unique, meter_time, formatted_meter_time,
	     cur_buff_ptrs, prev_buff_ptrs, code);
	if code^=0 then do;
	     call com_err_(code, our_name, "Filling buffers");
	     return;
	end;
	cur_meters = cur_buff_ptrs (3);
	prev_meters = prev_buff_ptrs (3);

	do i = 1 to 4;
               count (i, 1) = cur_meters -> link_meters (i).total
                    - prev_meters -> link_meters (i).total;
	     count (i, 2) = cur_meters -> link_meters (i).total_others
                    - prev_meters -> link_meters (i).total_others;
	     pgfault (i, 5) = cur_meters -> link_meters (i).others_pf
                    - prev_meters -> link_meters (i).others_pf;
	     time (i, 5) = cur_meters -> link_meters (i).others_time
                    - prev_meters -> link_meters (i).others_time;
	     time (i, 1) = cur_meters -> link_meters (i).time
                    - prev_meters -> link_meters (i).time;
	     time (i, 2) = cur_meters -> link_meters (i).search_time
                    - prev_meters -> link_meters (i).search_time;
	     time (i, 3) = cur_meters -> link_meters (i).get_linkage_time
                    - prev_meters -> link_meters (i).get_linkage_time;
	     time (i, 4) = cur_meters -> link_meters (i).defsearch_time
                    - prev_meters -> link_meters (i).defsearch_time;
	     pgfault (i, 1) = cur_meters -> link_meters (i).pf
                    - prev_meters -> link_meters (i).pf;
	     pgfault (i, 2) = cur_meters -> link_meters (i).search_pf
                    - prev_meters -> link_meters (i).search_pf;
	     pgfault (i, 3) = cur_meters -> link_meters (i).get_linkage_pf
                    - prev_meters -> link_meters (i).get_linkage_pf;
	     pgfault (i, 4) = cur_meters -> link_meters (i).defsearch_pf
                    - prev_meters -> link_meters (i).defsearch_pf;
               
	     total_linker_time = total_linker_time + time (i, 1);
	     total_counts = total_counts + count (i, 1);
	end;

          if repsw then do;				/* user wants report			*/

	     idle_time = cur_idle_time - prev_idle_time;
	     cpu_time = cur_cpu_time - prev_cpu_time - idle_time;
	     
	     call ioa_ ("^/Linkage Meters:");
	     total_time = meter_time;
	   

	     if total_time = 0 then pc_linker_time = 0;
	     else pc_linker_time = (total_linker_time * 1e2/ total_time);
	     if cpu_time = 0 then pc_lk_cpu_time = 0;
	     else pc_lk_cpu_time = (total_linker_time * 1e2/ cpu_time);
     
	     call ioa_ ("CPU Metering time^-^-^-^a", formatted_meter_time);
	     
	     ti = total_linker_time;
	     call get_time;
	     if total_linker_time = 0 then total_linker_time = 1;
	     if total_counts = 0 then total_counts = 1;
	     call ioa_ ("^/Total time in linker^-^-^a", rs);
	     call ioa_ ("Average time per link^-^-^6.2f msec.", (total_linker_time * 1e-3/total_counts));
	     call ioa_ ("Percentage of real time in linker^-^6.2f", pc_linker_time);
	     call ioa_ ("Percentage of CPU time in linker^-^6.2f", pc_lk_cpu_time);
	     
	     call ioa_ ("^/Time slot (msec)^-^7x<25^10x25-50^10x50-75^12x>75");
     
	     call ioa_ ("^/Calls^-^-^10d     ^10d     ^10d     ^10d", count (1, 1), count (2, 1), count (3, 1), count (4, 1));
     
	     do i = 1 to 4;
		ti = time (i, 1);
		call get_time;
		atime (i) = rs;
		pcc (i) = (count (i, 1)*1e2/total_counts);
		if count (i, 1) = 0 then count (i, 1) = 1;
		avgt (i) = (time (i, 1)*1e-3/count (i, 1));
		avgpf (i) = (pgfault (i, 1)*1e0/count (i, 1));
		pct (i) = (time (i, 1)*1e2/total_linker_time);
	     end;

	     call ioa_ ("Total time in slot^-^a     ^12a   ^12a   ^12a",
		atime (1), atime (2), atime (3), atime (4));

	     call ioa_ ("Percent total time ^-^10.2f^15.2f^15.2f^15.2f",
		pct (1), pct (2), pct (3), pct (4));
	     call ioa_ ("Percent total calls^-^10.2f^15.2f^15.2f^15.2f",
		pcc (1), pcc (2), pcc (3), pcc (4));
	     call ioa_ ("Average time^-^10.2f^15.2f^15.2f^15.2f", avgt (1), avgt (2), avgt (3), avgt (4));
	     call ioa_ ("Average page faults^-^10.2f^15.2f^15.2f^15.2f", avgpf (1), avgpf (2), avgpf (3), avgpf (4));
		
	     do i = 2 to 4;
		call ioa_ ("^/^a", name (i-1));
		do j = 1 to 4;
		     slot_time = time (j, 1) - time (j, 5);
		     slot_count = count (j, 1) - count (j, 2);
		     if slot_count = 0 then slot_count = 1;
		     if slot_time = 0 then slot_time = 1;
		     avgt (j) = (time (j, i)*1e-3/slot_count);
		     avgpf (j) = (pgfault (j, i)*1e0/slot_count);
		     pct (j) = (time (j, i)*1e2/slot_time);
		end;
		call ioa_ (" Average time^-^10.2f^15.2f^15.2f^15.2f", avgt (1), avgt (2), avgt (3), avgt (4));
		call ioa_ (" Average page faults^10.2f^15.2f^15.2f^15.2f", avgpf (1), avgpf (2), avgpf (3), avgpf (4));
		call ioa_ (" Percent time in slot^9.2f^15.2f^15.2f^15.2f", pct (1), pct (2), pct (3), pct (4));
               end;
	end;

if rsw then call metering_util_$reset (unique, code);


	return;


get_time:	proc;

dcl  HR pic "zzz9";
dcl  min fixed bin;
dcl  MIN pic "99";
dcl  sec fixed bin;
dcl  SEC pic "99";
	

	     sec = ti*1e-6;
	     min = divide (sec, 60, 17, 0);
	     HR = divide (min, 60, 17, 0);
	     MIN = mod (min, 60);
	     SEC = mod (sec, 60);
	     rs = HR || ":" || MIN || ":" || SEC;
	     return;
	end;


     end;



		    total_time_meters.pl1           01/26/85  1313.5r w 01/22/85  1307.7       85932


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


/* Updated by Alan Bier - March 1974 */
/* Modified May 1980 by T. Casey to split Other into Virtual CPU Time and Other Overhead,
   -		         and to print a third column, %NI (percent of non-Idle) */
/* Modified April 1981 by J. Bongiovanni to print Other Fault and fix some errors */
/* Modified November 1984 by M. Pandolf to include hc_lock. */


ttm: total_time_meters: proc;

dcl (argp, sstp1, sstp2, tcdp1, tcdp2) ptr static;
dcl  com_err_ entry options (variable);
dcl (sum, ni_sum, ave_time, count, pc, ni_pc, time, meter_time, ni_meter_time, idle, fault_int_time) float bin;
dcl  metering_time fixed bin (71);
dcl  formatted_time char (10);
dcl  current_ptrs (2) ptr;
dcl  previous_ptrs (2) ptr;
dcl  cu_$arg_count entry returns (fixed bin);
dcl (argl, i) fixed bin;
dcl  code fixed bin (35);
dcl (rsw, repsw) bit (1) init ("0"b);
dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl  ioa_ entry options (variable);
dcl  arg char (argl) based (argp);
dcl  metering_util_$define_regions entry options(variable);
dcl  metering_util_$fill_buffers entry (fixed bin, fixed bin(71), char(*), (*) ptr, (*) ptr, fixed bin(35));
dcl  metering_util_$reset entry (fixed bin, fixed bin(35));
dcl  unique fixed bin static init (0);
dcl  prt_sw bit (1) aligned init ("1"b);
dcl  error_table_$badopt ext fixed bin (35);
dcl  MYNAME char (17) init ("total_time_meters") int static options (constant);
dcl  size builtin;
		    

/*  */

/* If we haven't yet allocated the static buffers, do so. */

	if unique = 0 then do;
	     call metering_util_$define_regions (unique, code,
		"tc_data", 0, "work_class_table",
		"sst", 0, size (sst));
	     if code ^= 0 then do;
		call com_err_ (code, MYNAME, "Defining metering regions.");
		return;
	     end;
	end;

/* Process arguments */

	do i = 1 to cu_$arg_count ();
	     call cu_$arg_ptr (i, argp, argl, code);
	     if code ^= 0 then go to endargs;
	     if arg = "-reset" | arg = "-rs" then rsw = "1"b;
	     else if arg = "-report_reset" | arg = "-rr" then rsw, repsw = "1"b;
	     else do;
		call com_err_ (error_table_$badopt, "ttm", arg);
		return;
	     end;
	end;

endargs:	if ^rsw then repsw = "1"b;

/* Initialize */

	call metering_util_$fill_buffers (unique, metering_time, formatted_time,
	     current_ptrs, previous_ptrs, code);
	if code^=0 then do;
	     call com_err_ (code, MYNAME, "Filling buffers.");
	     return;
	end;
	tcdp1 = previous_ptrs (1);
	sstp1 = previous_ptrs (2);
	tcdp2 = current_ptrs (1);
	sstp2 = current_ptrs (2);
	call ioa_ ("^/Total metering time ^a^/", formatted_time);

	if ^repsw then go to reset_code;

	meter_time = tcdp2 -> tcm.processor_time - tcdp1 -> tcm.processor_time; /* compute total processor time */

	call ioa_ ("^21t%^27t%NI^36tAVE^/");		/* print heading */

/* Compute idle now, for use in computing the values in the %NI column */

	idle = tcdp2 -> tcm.zero_idle - tcdp1 -> tcm.zero_idle; /* zero idle and NMP idle are true idle, while */
	idle = idle + tcdp2 -> tcm.nmp_idle - tcdp1 -> tcm.nmp_idle; /* loading idle and MP idle are really overhead */
	ni_meter_time = meter_time - idle;

	meter_time = meter_time/100e0;		/* easier than multiplying by 100 in each percent calculation */
	ni_meter_time = ni_meter_time/100e0;

	sum, ni_sum = 100e0;			/* initialize percents to 100; we'll deduct each that's printed,
						   and at the end, we'll print what's left as Other Overhead */

	fault_int_time = 0;			/* to be deducted from delta_vcpu		*/

/* Now calculate the page fault information */

	time = tcdp2 -> tcm.cpu_pf_time - tcdp1 -> tcm.cpu_pf_time;
	count = tcdp2 -> tcm.cpu_pf_count - tcdp1 -> tcm.cpu_pf_count;
	call prt ("Page Faults");
	fault_int_time = fault_int_time + time;

	time = sstp2 -> sst.loop_lock_time - sstp1 -> sst.loop_lock_time;
	count = sstp2 -> sst.loop_locks - sstp1 -> sst.loop_locks;
	if count > 0 then call prt_no_sum (" PC Loop Locks");

	time = sstp2 -> sst.pf_unlock_ptl_time - sstp1 -> sst.pf_unlock_ptl_time;
	count = sstp2 -> sst.pf_unlock_ptl_meterings - sstp1 -> sst.pf_unlock_ptl_meterings;
	if count > 0 then do;
	     call prt ("PC Queue");
	     fault_int_time = fault_int_time + time;
	end;


/* Now calculate the times for seg faults */

	time = sstp2 -> sst.cpu_sf_time - sstp1 -> sst.cpu_sf_time;
	count = sstp2 -> sst.total_sf - sstp1 -> sst.total_sf;
	call prt ("Seg Faults");
	fault_int_time = fault_int_time + time;

/* Now calculate the time for bound faults */

	time = sstp2 -> sst.cpu_bf_time - sstp1 -> sst.cpu_bf_time;
	count = sstp2 -> sst.total_bf - sstp1 -> sst.total_bf;
	call prt ("Bound Faults");
	fault_int_time = fault_int_time + time;

/* Now calculate the time for interrupts */

	time = tcdp2 -> tcm.interrupt_time - tcdp1 -> tcm.interrupt_time;
	count = tcdp2 -> tcm.interrupt_count - tcdp1 -> tcm.interrupt_count;
	call prt ("Interrupts");
	fault_int_time = fault_int_time + time;

/* At this point, we stop printing the AVE column. Tell the prt subroutine so, by setting count to -1. */

	count = -1e0;

/* Next compute unattributed fault overhead time.  This is time for handling
   connect faults and timer runout faults (primarily)						*/
	
	time = tcdp2 -> tcm.delta_vcpu - tcdp1 -> tcm.delta_vcpu;
	time = time - fault_int_time;
	call prt ("Other Fault");
	
/* Now calculate the time spent in get-work */

	time = tcdp2 -> tcm.getwork_time - tcdp1 -> tcm.getwork_time;
	count = tcdp2 -> tcm.getwork_count - tcdp1 -> tcm.getwork_count;
	call prt_no_sum (" Getwork");

	time = tcdp2 -> tcm.loop_lock_time - tcdp1 -> tcm.loop_lock_time;
	count = tcdp2 -> tcm.loop_locks - tcdp1 -> tcm.loop_locks;
	if count > 0 then call prt_no_sum (" TC Loop Locks");

	time = sstp2 -> sst.post_purge_time - sstp1 -> sst.post_purge_time;
	count = sstp2 -> sst.post_purge_calls - sstp1 -> sst.post_purge_calls;
	call prt_no_sum (" Post Purging");

/* Reset the printing of averages again */

	count = -1.0e0;

/* Now calculate the times spent idle */

	time = tcdp2 -> tcm.mp_idle - tcdp1 -> tcm.mp_idle;
	call prt ("MP Idle");

	time = tcdp2 -> tcm.work_class_idle - tcdp1 -> tcm.work_class_idle;
	call prt ("Work Class Idle");

	time = tcdp2 -> tcm.loading_idle - tcdp1 -> tcm.loading_idle;
	call prt ("Loading Idle");

	time = tcdp2 -> tcm.nmp_idle - tcdp1 -> tcm.nmp_idle;
	call prt ("NMP Idle");

	time = tcdp2 -> tcm.zero_idle - tcdp1 -> tcm.zero_idle;
	call prt ("Zero Idle");

/* Now calculate the useful virtual cpu time, without printing it. */

	prt_sw = ""b;				/* tell prt not to print */
	time = tcdp2 -> tcm.system_virtual_time - tcdp1 -> tcm.system_virtual_time;
	call prt ("Virtual CPU Time");

/* Now print the part that's unaccounted-for. */
	
	if sum < 0.0 then				/* won't be more than Planck's constant		*/
	     sum, ni_sum = 0.0;
	call ioa_ ("Other Overhead^17t^6.2f^7.2f", sum, ni_sum);

/* Now go back and print Virtual CPU Time. We want it to be last because the last line of ttm's output
   has always been the useful (non-idle, non-overhead) cpu time. */

	prt_sw = "1"b;
	call prt ("Virtual CPU Time");

reset_code:
	if rsw then do;
	     call metering_util_$reset (unique, code);
	     if code^=0 then do;
		call com_err_ (code, MYNAME, "Resetting.");
		return;
	     end;
	end;

	call ioa_ (" ");
	return;

/* **************************************** */

prt:	proc (name);				/* to calculate percent and print value */

dcl  name char (*);					/* name of value to be printed */
dcl  sum_sw bit (1) aligned;				/* whether or not to deduct this value from total percent */
dcl  avesw bit (1) aligned init ("1"b);			/* switch says "print the average column" when on */
dcl  nisw bit (1) aligned init ("1"b);			/* switch says "this is not idle" when on */

	     sum_sw = "1"b;				/* regular entry point: deduct the value from total percent */

prt_common:

	     if name = "Zero Idle" | name = "NMP Idle" then /* remember to treat the Idle figures differently */
		nisw = ""b;			/* by turning off the "this is not idle" switch */
	     if count = 0e0 then ave_time = 0e0;	/* if count is zero, don't try to divide by it */
	     else if count = -1e0 then avesw = ""b;	/* negative count means don't print the average column */
	     else ave_time = time/count;		/* otherwise compute the average time for this item */
	     pc = time/meter_time;			/* compute it's percent of total processor time */
	     ni_pc = time/ni_meter_time;		/* and it's percent of non-Idle processor time */
	     if sum_sw then do;			/* if this item should be deducted from percent */
		sum = sum - pc;			/* do so */
		if nisw then			/* if this is Idle */
		     ni_sum = ni_sum - ni_pc;		/* don't deduct it from the non-Idle percent */
	     end;
	     if prt_sw then				/* unless we're just calculating, print */
		call ioa_ ("^a^17t^6.2f^[^7.2f^;^s^]^[^12.3f^;^s^]", name, pc, nisw, ni_pc, avesw, ave_time);

	     return;

prt_no_sum:    entry (name);				/* alternate entry point to not deduct from percent */

	     sum_sw = ""b;
	     goto prt_common;

	end prt;


% include tcm;

% include hc_lock;

% include sst;
     end total_time_meters;



		    traffic_control_meters.pl1      01/26/85  1313.5r w 01/22/85  1306.6       83529


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

/* format: style3 */

traffic_control_meters:
tcm:
     proc;


/*  Traffic Control Metering Program

    Written by one of the Ancients (probably Webber)
    Cleaned up a bit, I/O boosts added, by J. Bongiovanni, August 1982
    Modified November 1984 by M. Pandolf to include hc_lock.
    Modified January 1985 by Keith Loepere to include pauses.
*/

/*  Automatic  */

dcl	arg_no		fixed bin;
dcl	argl		fixed bin (21);
dcl	argp		ptr;
dcl	atb		float bin;
dcl	c1		float bin;
dcl	code		fixed bin (35);
dcl	cpu		(16) float bin;
dcl	cpu_time		float bin;
dcl	cpusum		float bin;
dcl	counters_sw	bit (1) aligned;
dcl	cur_ptrs		(1) ptr;
dcl	delta		float bin;
dcl	formatted_time	char (10);
dcl	general_sw	bit (1) aligned;
dcl	i		fixed bin;
dcl	intc		float bin;
dcl	meter_time	float bin;
dcl	meter_time_micsec	fixed bin (71);
dcl	n_args		fixed bin;
dcl	numint		float bin;
dcl	p1		float bin;
dcl	pf		(16) float bin;
dcl	pfsum		float bin;
dcl	prev_ptrs		(1) ptr;
dcl	queue_sw		bit (1) aligned;
dcl	reset_sw		bit (1) aligned;
dcl	s1		float bin;
dcl	sc		(16) float bin;
dcl	scsum		float bin;
dcl	tbpf		(8) float bin;
dcl	tbs		(8) float bin;
dcl	total_notifies	fixed bin;
dcl	total_waits	fixed bin;

/*  Static  */

dcl	(
	MILLI		init ("1"b),
	SEC		init ("0"b),
	PER		init ("1"b),
	NOP		init ("0"b)
	)		bit (1) aligned int static options (constant);
dcl	MYNAME		char (22) int static options (constant) init ("traffic_control_meters");
dcl	unique		fixed bin int static init (0);

/*  Based  */

dcl	arg		char (argl) based (argp);
dcl	1 cur_tcm		aligned like tcm based (cur_ptrs (1));
dcl	1 prev_tcm	aligned like tcm based (prev_ptrs (1));

/*  External  */

dcl	error_table_$badopt fixed bin (35) external;


/*  Entry  */

dcl	com_err_		entry options (variable);
dcl	cu_$arg_count	entry (fixed bin, fixed bin (35));
dcl	cu_$arg_ptr	entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
dcl	ioa_		entry options (variable);
dcl	metering_util_$define_regions
			entry options (variable);
dcl	metering_util_$fill_buffers
			entry (fixed bin, fixed bin (71), char (*), (*) ptr, (*) ptr, fixed bin (35));
dcl	metering_util_$reset
			entry (fixed bin, fixed bin (35));


/*  Builtin  */

dcl	fixed		builtin;
dcl	float		builtin;
dcl	size		builtin;


%page;


	reset_sw, counters_sw, queue_sw, general_sw = "0"b;

	call cu_$arg_count (n_args, code);
	if code ^= 0
	then do;
		call com_err_ (code, MYNAME);
		return;
	     end;

	if unique = 0
	then do;
		call metering_util_$define_regions (unique, code, "tc_data", 0, size (tcm));
		if code ^= 0
		then do;
			call com_err_ (code, MYNAME, "Defining regions");
			unique = 0;
			return;
		     end;
	     end;


	do arg_no = 1 to n_args;
	     call cu_$arg_ptr (arg_no, argp, argl, code);
	     if arg = "-gen"
	     then general_sw = "1"b;
	     else if arg = "-rs" | arg = "-reset"
	     then reset_sw = "1"b;
	     else if arg = "-ct" | arg = "-counters"
	     then counters_sw = "1"b;
	     else if arg = "-qu" | arg = "-queue"
	     then queue_sw = "1"b;
	     else if arg = "-rr" | arg = "-report_reset"
	     then general_sw, counters_sw, reset_sw, queue_sw = "1"b;
	     else do;
		     call com_err_ (error_table_$badopt, MYNAME, arg);
		     return;
		end;
	end;

	if n_args = 0
	then general_sw, counters_sw, queue_sw = "1"b;

	call metering_util_$fill_buffers (unique, meter_time_micsec, formatted_time, cur_ptrs, prev_ptrs, code);
	if code ^= 0
	then do;
		call com_err_ (code, MYNAME, "Filling buffers");
		return;
	     end;

	call ioa_ ("^/Total metering time^-^a", formatted_time);

	cpu_time = cur_tcm.processor_time - prev_tcm.processor_time;
	meter_time = float (meter_time_micsec) / 1.0e2;	/* micro-seconds, percent */

	if general_sw
	then do;
		total_waits, total_notifies = 0;
		call ioa_ ("^/Ave queue length^9.2f", cur_tcm.avequeue * 1e0);
		call ioa_ ("Ave eligible    ^9.2f", cur_tcm.ave_eligible * 1e0);
		numint = cur_tcm.response_count - prev_tcm.response_count;
		delta = cur_tcm.response_time - prev_tcm.response_time;
		if numint = 0e0
		then atb = 0e0;
		else atb = 1e-6 * delta / numint;
		call ioa_ ("Response time    ^9.3f sec", atb);
	     end;
	if counters_sw
	then do;
		call ioa_ ("^/  COUNTER          TOTAL         ATB       #/INT^/");
		intc, delta = cur_tcm.response_count - prev_tcm.response_count;
		call print ("Interactions", SEC, NOP);
		delta = cur_tcm.loadings - prev_tcm.loadings;
		call print ("Loadings", SEC, PER);
		delta = cur_tcm.blocks - prev_tcm.blocks;
		call print ("Blocks", SEC, NOP);
		delta = cur_tcm.pauses - prev_tcm.pauses;
		if delta ^= 0
		then call print ("Pauses", SEC, NOP);
		delta = cur_tcm.wakeups - prev_tcm.wakeups;
		call print ("Wakeups", SEC, NOP);
		delta = cur_tcm.schedulings - prev_tcm.schedulings;
		call print ("Schedulings", SEC, PER);
		delta = cur_tcm.lost_priority - prev_tcm.lost_priority;
		call print ("Lost priority", SEC, NOP);
		delta = cur_tcm.boost_priority - prev_tcm.boost_priority;
		call print ("Priority boosts", SEC, NOP);
		delta = cur_tcm.realtime_priorities - prev_tcm.realtime_priorities;
		call print ("I/O boosts", SEC, NOP);
		delta = cur_tcm.waits - prev_tcm.waits;
		total_waits = total_waits + delta;
		call print ("Wait Page", MILLI, PER);
		delta = cur_tcm.ptl_waits - prev_tcm.ptl_waits;
		total_waits = total_waits + delta;
		if delta ^= 0
		then call print ("Wait PTL", MILLI, PER);
		delta = cur_tcm.te_wait - prev_tcm.te_wait;
		total_waits = total_waits + delta;
		call print ("Wait Other", MILLI, PER);
		delta = total_waits;
		call print ("Total Waits", MILLI, PER);
		delta = cur_tcm.page_notifies - prev_tcm.page_notifies;
		total_notifies = total_notifies + delta;
		call print ("Notify Page", MILLI, NOP);
		delta = cur_tcm.ptl_waits - prev_tcm.ptl_waits - (cur_tcm.stat (6) - prev_tcm.stat (6));
						/* ptlnfy = ptlwaits - waiters */
		total_notifies = total_notifies + delta;
		if delta ^= 0
		then call print ("Notify PTL", MILLI, NOP);
		delta = cur_tcm.notifies - prev_tcm.notifies;
		total_notifies = total_notifies + delta;
		call print ("Notify Other", MILLI, NOP);
		delta = total_notifies;
		call print ("Total Notifies", MILLI, NOP);
		delta = cur_tcm.gp_done_count - prev_tcm.gp_done_count;
		call print ("Get Processor", MILLI, NOP);
		delta = cur_tcm.te_pre_empt - prev_tcm.te_pre_empt;
		call print ("Pre-empts", MILLI, PER);
		delta = cur_tcm.depth_count - prev_tcm.depth_count;
		call print ("Getwork", MILLI, NOP);
		delta = cur_tcm.gw_gp_window_count - prev_tcm.gw_gp_window_count;
		if delta ^= 0
		then call print ("Retry getwork", SEC, NOP);
		delta = cur_tcm.notify_nobody_count - prev_tcm.notify_nobody_count;
		if delta ^= 0
		then do;
			call print ("Extra notifies", SEC, NOP);
			call ioa_ (" Last EN event    ^w", cur_tcm.notify_nobody_event);
		     end;
		delta = cur_tcm.nto_count - prev_tcm.nto_count;
		if delta ^= 0
		then do;
			call print ("Notify timeout", SEC, NOP);
			call ioa_ (" Last NTO event   ^w", cur_tcm.nto_event);
		     end;
	     end;
	if queue_sw
	then do;
		call ioa_ ("^/ DEPTH   %PF   TBPF   %GTW   TBS   %CPU^/");
		pfsum, scsum, cpusum = 0e0;
		do i = 1 to 8;
		     p1, pf (i) = cur_tcm.pfdepth (i) - prev_tcm.pfdepth (i);
		     pfsum = pfsum + p1;
		     s1, sc (i) = cur_tcm.depths (i) - prev_tcm.depths (i);
		     scsum = scsum + s1;
		     c1, cpu (i) = cur_tcm.tdepths (i) - prev_tcm.tdepths (i);
		     if p1 <= 1e-6
		     then p1 = 1e0;
		     if s1 <= 1e-6
		     then s1 = 1e0;
		     cpusum = cpusum + c1;
		     tbpf (i) = c1 * 1e-3 / p1;
		     tbs (i) = c1 * 1e-3 / s1;
		end;
		p1 = 2e0;
		do i = 1 to 8 while (p1 > 1e0);
		     if pfsum = 0e0
		     then p1 = 0e0;
		     else p1 = (pf (i) * 100e0) / pfsum;
		     if scsum = 0e0
		     then s1 = 0e0;
		     else s1 = (sc (i) * 100e0) / scsum;
		     if cpusum = 0e0
		     then c1 = 0e0;
		     else c1 = (cpu (i) * 100e0) / cpusum;
		     call ioa_ ("^4d^9.1f^6.1f^7.1f^7.1f^6.1f", i, p1, tbpf (i), s1, tbs (i), c1);
		end;
	     end;

	if reset_sw
	then do;
		call metering_util_$reset (unique, code);
		if code ^= 0
		then do;
			call com_err_ (code, MYNAME, "Resetting");
			return;
		     end;
	     end;

	call ioa_ (" ");
	return;


print:
     proc (name, milli, per);

dcl	name		char (*);
dcl	milli		bit (1) aligned;
dcl	per		bit (1) aligned;


dcl	units		char (4);


	if delta = 0e0
	then atb = 0e0;
	else atb = meter_time / (delta * 1e1);
	if ^milli
	then atb = atb / 1e3;

	if milli
	then units = "msec";
	else units = "sec";


	if per
	then do;
		if intc = 0e0
		then numint = 0e0;
		else numint = delta / intc;
		call ioa_ ("^16a^8d^11.3f ^4a^8.3f", name, fixed (delta), atb, units, numint);
	     end;
	else do;
		call ioa_ ("^16a^8d^11.3f ^4a", name, fixed (delta), atb, units);
	     end;

     end print;
%page;
%include tcm;
%page;
%include hc_lock;
     end;
   



		    vtoc_buffer_meters.pl1          07/18/86  1506.4rew 07/18/86  1235.1       68202


/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        *********************************************************** */


/****^  HISTORY COMMENTS:
  1) change(86-01-16,Fawcett), approve(86-04-10,MCR7383),
     audit(86-05-27,Wallman), install(86-07-18,MR12.0-1098):
     Add support for 512_WORD_IO devices.
                                                   END HISTORY COMMENTS */


/* format: style3 */
vtoc_buffer_meters:
     proc;

/*  Program to print metering data from vtoc_buffer_seg

    Rewritten for new VTOC buffer strategy, July 1982, J. Bongiovanni

*/

/*  Automatic  */

dcl	arg_no		fixed bin;
dcl	argl		fixed bin (21);
dcl	argp		ptr;
dcl	code		fixed bin (35);
dcl	cur_ptrs		(1) ptr;
dcl	formatted_time	char (10);
dcl	meter_time	fixed bin (71);
dcl	meter_time_sec	float;
dcl	n_args		fixed bin;
dcl	prev_ptrs		(1) ptr;
dcl	report_sw		bit (1) aligned;
dcl	reset_sw		bit (1) aligned;
dcl	skips		fixed bin (35);
dcl	steps		fixed bin (35);

/*  Static  */

dcl	init		bit (1) aligned int static init ("0"b);
dcl	MYNAME		char (18) int static options (constant) init ("vtoc_buffer_meters");
dcl	unique		fixed bin int static;

/*  Based  */

dcl	arg		char (argl) based (argp);
dcl	1 cur_vtoc_buffer	aligned like vtoc_buffer based (cur_ptrs (1));
dcl	1 prev_vtoc_buffer	aligned like vtoc_buffer based (prev_ptrs (1));

/*  External  */

dcl	error_table_$badopt fixed bin (35) external;

/*  Entry  */

dcl	com_err_		entry options (variable);
dcl	cu_$arg_count	entry (fixed bin, fixed bin (35));
dcl	cu_$arg_ptr	entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
dcl	ioa_		entry options (variable);
dcl	metering_util_$define_regions
			entry options (variable);
dcl	metering_util_$fill_buffers
			entry (fixed bin, fixed bin (71), char (*), (*) ptr, (*) ptr, fixed bin (35));
dcl	metering_util_$reset
			entry (fixed bin, fixed bin (35));

/*  Builtin  */

dcl	float		builtin;
dcl	size		builtin;

%page;
/*  Pick up and validate arguments  */

	call cu_$arg_count (n_args, code);
	if code ^= 0
	then do;
		call com_err_ (code, MYNAME);
		return;
	     end;

	report_sw, reset_sw = "0"b;

	do arg_no = 1 to n_args;
	     call cu_$arg_ptr (arg_no, argp, argl, code);
	     if arg = "-report"
	     then report_sw = "1"b;
	     else if arg = "-reset" | arg = "-rs"
	     then reset_sw = "1"b;
	     else if arg = "-report_reset" | arg = "-rr"
	     then report_sw, reset_sw = "1"b;
	     else do;
		     call com_err_ (error_table_$badopt, MYNAME, arg);
		     return;
		end;
	end;

	if ^report_sw & ^reset_sw
	then report_sw = "1"b;
%page;
/*  Initialize if this is the first time called this process   */

	if ^init
	then do;
		vtoc_buf_n_buffers, vtoc_buf_n_buckets = 1;

		call metering_util_$define_regions (unique, code, "vtoc_buffer_seg", 0, size (vtoc_buffer));
		if code ^= 0
		then do;
			call com_err_ (code, MYNAME, "From metering_util_$define_regions");
			return;
		     end;
		init = "1"b;
	     end;


/*  Get current buffers  */

	call metering_util_$fill_buffers (unique, meter_time, formatted_time, cur_ptrs, prev_ptrs, code);
	if code ^= 0
	then do;
		call com_err_ (code, MYNAME, "Filling buffers");
		return;
	     end;

	call ioa_ ("^/Total metering time:^-^a^/", formatted_time);
%page;
/*  Print report if requested  */

	if report_sw
	then do;

		meter_time_sec = float (meter_time) / 1.0e6;
		call ioa_ ("Routine^20x# calls ATB(sec)^/");

		call PRINT_CALL ("get_vtoce", cur_vtoc_buffer.meters.call_get - prev_vtoc_buffer.meters.call_get, "",
		     0);
		call PRINT_CALL ("put_vtoce", cur_vtoc_buffer.meters.call_put - prev_vtoc_buffer.meters.call_put, "",
		     0);
		call PRINT_CALL ("alloc_and_put_vtoce",
		     cur_vtoc_buffer.meters.call_alloc - prev_vtoc_buffer.meters.call_alloc, "", 0);
		call PRINT_CALL ("free_vtoce", cur_vtoc_buffer.meters.call_free - prev_vtoc_buffer.meters.call_free,
		     "", 0);
		call PRINT_CALL ("await_vtoce",
		     cur_vtoc_buffer.meters.call_await - prev_vtoc_buffer.meters.call_await, "", 0);
		call PRINT_CALL ("GET_BUFFERS",
		     cur_vtoc_buffer.meters.get_buffer_calls - prev_vtoc_buffer.meters.get_buffer_calls, "Hits",
		     cur_vtoc_buffer.meters.get_buffer_hits - prev_vtoc_buffer.meters.get_buffer_hits);
		call PRINT_CALL ("WAIT", cur_vtoc_buffer.meters.wait_calls - prev_vtoc_buffer.meters.wait_calls,
		     "TC Waits", cur_vtoc_buffer.meters.wait_os - prev_vtoc_buffer.meters.wait_os);

		call ioa_ ("^/Buffer Allocation^/^27x^6x# ATB(sec)^/");

		steps = cur_vtoc_buffer.meters.steps - prev_vtoc_buffer.meters.steps;
		skips = (cur_vtoc_buffer.meters.skip_os - prev_vtoc_buffer.meters.skip_os)
		     + (cur_vtoc_buffer.meters.skip_hot - prev_vtoc_buffer.meters.skip_hot)
		     + (cur_vtoc_buffer.meters.skip_wait - prev_vtoc_buffer.meters.skip_wait);

		call PRINT_STEPS ("Steps", steps, "", 0);
		call PRINT_STEPS ("Skips", skips, "steps", steps);
		call PRINT_STEPS ("  os", cur_vtoc_buffer.meters.skip_os - prev_vtoc_buffer.meters.skip_os, "skips",
		     skips);
		call PRINT_STEPS ("  hot", cur_vtoc_buffer.meters.skip_hot - prev_vtoc_buffer.meters.skip_hot,
		     "skips", skips);
		call PRINT_STEPS ("  wait", cur_vtoc_buffer.meters.skip_wait - prev_vtoc_buffer.meters.skip_wait,
		     "skips", skips);

		call ioa_ ("^/Disk I/Os^/^27x^6x# ATB(sec)^/");

		call PRINT_IO ("Reads", cur_vtoc_buffer.meters.disk_reads - prev_vtoc_buffer.meters.disk_reads);
		call PRINT_IO ("Writes", cur_vtoc_buffer.meters.disk_writes - prev_vtoc_buffer.meters.disk_writes);
		call PRINT_IO ("RAR", cur_vtoc_buffer.meters.soft_rar - prev_vtoc_buffer.meters.soft_rar);
		call ioa_ ("^/");

	     end;
%page;
/*  Reset buffers if requested  */

	if reset_sw
	then do;
		call metering_util_$reset (unique, code);
		if code ^= 0
		then do;
			call com_err_ (code, MYNAME, "Resetting");
			return;
		     end;
	     end;


	return;
%page;
/*  Internal Procedure to compute Average Time Between events in seconds  */

ATB:
     proc (N) returns (float);

dcl	N		fixed bin (35);

	if N = 0
	then return (0.0);
	else return (meter_time_sec / float (N));

     end ATB;
%page;
/*  Internal Procedures to print various lines  */

PRINT_CALL:
     proc (Routine, N_Calls, Extra_Name, N_Extra);

dcl	Routine		char (*);
dcl	N_Calls		fixed bin (35);
dcl	Extra_Name	char (*);
dcl	N_Extra		fixed bin (35);

dcl	pct_calls		float;

	if (Extra_Name ^= "")
	then do;
		if N_Calls = 0
		then pct_calls = 0.0;
		else pct_calls = (float (N_Extra) / float (N_Calls)) * 100.0;
	     end;

	call ioa_ ("^27a ^6d ^8.2f^[ ^6d ^8a (^5.1f% of calls)^;^3s^]", Routine, N_Calls, ATB (N_Calls),
	     (Extra_Name ^= ""), N_Extra, Extra_Name, pct_calls);

     end PRINT_CALL;


PRINT_STEPS:
     proc (Step_Name, N_Steps, Pct_Name, Pct_N);

dcl	Step_Name		char (*);
dcl	N_Steps		fixed bin (35);
dcl	Pct_Name		char (*);
dcl	Pct_N		fixed bin (35);

dcl	pct_steps		float;

	if (Pct_Name ^= "")
	then do;
		if Pct_N = 0
		then pct_steps = 0.0;
		else pct_steps = (float (N_Steps) / float (Pct_N)) * 100.0;
	     end;

	call ioa_ ("^27a ^6d ^8.2f^[ ^5.1f% of ^a^;^2s^]", Step_Name, N_Steps, ATB (N_Steps), (Pct_Name ^= ""),
	     pct_steps, Pct_Name);

     end PRINT_STEPS;


PRINT_IO:
     proc (IO_Name, IO_N);

dcl	IO_Name		char (*);
dcl	IO_N		fixed bin (35);

	call ioa_ ("^27a ^6d ^8.2f", IO_Name, IO_N, ATB (IO_N));

     end PRINT_IO;
%page;
%include vtoc_buffer;

     end vtoc_buffer_meters;
  



		    work_class_meters.pl1           08/04/87  1504.7rew 08/04/87  1222.0       97047


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

/* format: style4 */
wcm: work_class_meters: proc;

/* WORK_CLASS_METERS -- print metering information about work class scheduler.
   Probably written by Bob Mullen, some years back.
   Modified: 04/01/80 W. Olin Sibert to fix zerodivide fault problems.
   05/13/81 Matthew Pierret to print pin_weight.
   Cleanup up substantially and modified for governed work classes
   06/28/81 by J. Bongiovanni
   12/07/81 E. N. Kittlitz.  user_table_entry conversion.
   4/30/82 by J. Bongiovanni to print interactive q attribute
   11/13/84 by M. Pandolf to include hc_lock.
*/


/****^  HISTORY COMMENTS:
  1) change(87-04-26,GDixon), approve(87-07-13,MCR7741),
     audit(87-07-27,Hartogs), install(87-08-04,MR12.1-1055):
     Upgraded for change to answer_table.incl.pl1.
                                                   END HISTORY COMMENTS */


/* Automatic */

dcl  arg_no fixed bin;				/* current argument number			*/
dcl  argl fixed bin (21);				/* current argument length			*/
dcl  argp ptr;					/* current argument pointer			*/
dcl  code fixed bin (35);				/* standard error code			*/
dcl  cpu (0:16) float bin;				/* array of delta cpu by WC			*/
dcl  cur_ptrs (1) ptr;				/* pointer to current metering data		*/
dcl  curshift fixed bin;				/* current shift				*/
dcl  eligs (0:16) float bin;				/* array of eligibility counts		*/
dcl  formatted_meter_time char (10);			/* formatted metering interval		*/
dcl  g1 float bin;					/* percent guaranteed			*/
dcl  hr fixed bin;					/* hour					*/
dcl  HR pic "zzz9";					/* hour					*/
dcl  i fixed bin;					/* work class table index			*/
dcl  meter_interval fixed bin (71);			/* microseconds in metering interval		*/
dcl  meter_time float bin;				/* microseconds in metering interval		*/
dcl  min fixed bin;					/* minute					*/
dcl  MIN pic "99";					/* minute					*/
dcl  n_args fixed bin;				/* number of arguments			*/
dcl  pctcpu float bin;				/* percent of total cpu for this WC		*/
dcl  pctmx float bin;				/* max percent for a governed WC		*/
dcl  prev_ptrs (1) ptr;				/* pointer to previous metering data		*/
dcl  Q1 float bin;					/* quantun 1				*/
dcl  Q2 float bin;					/* quantum 2				*/
dcl  R1 float bin;					/* response 1				*/
dcl  R2 float bin;					/* response 2				*/
dcl  reporting bit (1);				/* ON => report argument given		*/
dcl  resetting bit (1);				/* ON => reset argument given			*/
dcl  sec fixed bin;					/* second					*/
dcl  SEC pic "99";					/* second					*/
dcl  sole_abs_wc fixed bin;				/* work class index of only absentee WC (if such) */
dcl  some_lcg (0:16) char (32) varying;			/* name of some load control group in wc */
dcl  time_now fixed bin (71);				/* current time				*/
dcl  total_cpu float bin;				/* total cpu time on system			*/
dcl  u1 float bin;					/* cpu time per eligibility for WC		*/


/* Static */

dcl  mgtp ptr static init (null ());			/* pointer to MGT				*/
dcl  MYNAME char (17) int static options (constant)
	init ("work_class_meters");
dcl  static_ansp ptr static init (null ());		/* pointer to answer_table			*/
dcl  time_reset fixed bin (71) static init (0);		/* time of last reset (implicit reset if WC redefined */
dcl  unique fixed bin static init (0);			/* unique index for metering_util_		*/

/* Based */

dcl  arg char (argl) based (argp);
dcl  1 tcm_cur aligned based (cur_ptrs (1)) like tcm;
dcl  1 tcm_prev aligned based (prev_ptrs (1)) like tcm;

/* %include anstbl       - see end of program							*/
/* %include mgt          - see end of program							*/
/* %include tcm          - see end of program							*/

/* Entry */

dcl  com_err_ entry options (variable);
dcl  cu_$arg_count entry (fixed bin, fixed bin (35));
dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
dcl  ioa_ entry options (variable);
dcl  hcs_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35));
dcl  metering_util_$define_regions entry options (variable);
dcl  metering_util_$fill_buffers entry (fixed bin, fixed bin (71), char (*), (*) ptr, (*) ptr, fixed bin (35));
dcl  metering_util_$reset entry (fixed bin, fixed bin (35));

/* External */

dcl  error_table_$badopt fixed bin (35) external;

/* Builtin */

dcl  addr builtin;
dcl  clock builtin;
dcl  divide builtin;
dcl  max builtin;
dcl  mod builtin;
dcl  null builtin;
dcl  reverse builtin;
dcl  size builtin;
dcl  substr builtin;
dcl  unspec builtin;
dcl  verify builtin;

%page;
	reporting = "0"b;
	resetting = "0"b;
	call cu_$arg_count (n_args, code);
	if code ^= 0 then do;
	     call com_err_ (code, MYNAME);
	     return;
	end;

	do arg_no = 1 to n_args;
	     call cu_$arg_ptr (arg_no, argp, argl, code);
	     if arg = "-report_reset" | arg = "-rr" then do;
		reporting = "1"b;
		resetting = "1"b;
	     end;
	     else if arg = "-reset" | arg = "-rs" then
		resetting = "1"b;
	     else do;
		call com_err_ (error_table_$badopt, MYNAME, arg);
		return;
	     end;
	end;

	if ^reporting & ^resetting then reporting = "1"b;

	if unique = 0 then do;			/* initialize				*/
	     call metering_util_$define_regions (unique, code, "tc_data", 0, size (tcm));
	     if code ^= 0 then do;
		call com_err_ (code, MYNAME, "Initializing");
		return;
	     end;
	end;

	call metering_util_$fill_buffers (unique, meter_interval, formatted_meter_time,
	     cur_ptrs, prev_ptrs, code);
	if code ^= 0 then do;
	     call com_err_ (code, MYNAME, "Filling buffers.");
	     return;
	end;


	total_cpu = tcm_cur.processor_time
	     - max (tcm_prev.processor_time, tcm_cur.processor_time_at_define_wc);

	if time_reset < tcm_cur.define_wc_time then do;
						/* save values are worthless */
						/* hardcore has reinitialized its meters */
	     unspec (tcm_prev) = ""b;			/* so reset our saved values */
	     time_reset = tcm_cur.define_wc_time;
	end;

	time_now = clock ();
	meter_time = time_now - time_reset;
	sec = meter_time * 1e-6;
	min = divide (sec, 60, 17, 0);
	hr = divide (min, 60, 17, 0);
	sec = mod (sec, 60);			/* get sec in last min */
	min = mod (min, 60);			/* get min in last hr */
	HR = hr;
	MIN = min;
	SEC = sec;
	formatted_meter_time = HR || ":" || MIN || ":" || SEC;
	call ioa_ ("^/Total metering time^-^a^/", formatted_meter_time);


	if reporting then do;

/* try to get some names assoc with workclasses */
	     call fill_lcg;
	     do i = 0 to 16;
		if tcm_cur.wcte (i).defined then do;
		     cpu (i) = tcm_cur.wcte (i).cpu_sum - tcm_prev.wcte (i).cpu_sum;
		     eligs (i) = tcm_cur.wcte (i).eligibilities - tcm_prev.wcte (i).eligibilities;
		end;
	     end;
	     call ioa_ ("WC %GUAR %MAX %TCP V/ELIG PW  IRESP IQUANT   RESP QUANT P M R I LCG^/");
	     do i = 0 to 16;
		if tcm_cur.wcte (i).defined then do;

		     if tcm_cur.credits_per_scatter = 0 then do;
			g1 = 0e0;
			pctmx = 0e0;
		     end;
		     else do;
			g1 = 1e2 * tcm_cur.wcte (i).minf / tcm_cur.credits_per_scatter;
			pctmx = 1e2 * tcm_cur.wcte (i).maxf / tcm_cur.credits_per_scatter;
		     end;


		     if eligs (i) = 0e0 then u1 = 0e0;
		     else u1 = 1e-6 * cpu (i) / eligs (i);

		     if total_cpu > 0e0 then
			pctcpu = 1e2 * cpu (i) / total_cpu;
		     R1 = 1e-6 * tcm_cur.wcte (i).resp1;
		     R2 = 1e-6 * tcm_cur.wcte (i).resp2;
		     Q1 = 1e-6 * tcm_cur.wcte (i).quantum1;
		     Q2 = 1e-6 * tcm_cur.wcte (i).quantum2;


		     if (g1 > 0e0) | (pctcpu > 0e0) then
			if tcm_cur.deadline_mode ^= 0 | tcm_cur.wcte (i).realtime ^= 0 then
			     call ioa_ ("^2d ^5x^5x^5.0f ^6.2f ^2d^7.2f^6.2f^8.2f^6.2f ^[P^; ^] ^d ^[R^; ^] ^[I^; ^] ^a",
				i, pctcpu, u1, tcm_cur.wcte (i).pin_weight,
				R1, Q1, R2, Q2, (tcm_cur.wcte (i).purging = 1),
				tcm_cur.wcte (i).maxel, (tcm_cur.wcte (i).realtime ^= 0), (tcm_cur.wcte (i).flags.interactive_q), some_lcg (i));

			else
			     call ioa_ ("^2d ^5.0f^[^5.0f^;^5x^1s^]^5.0f ^6.2f ^2d^27x ^[P^; ^] ^d ^[R^; ^] ^[I^; ^] ^a",
				i, g1, (tcm_cur.wcte (i).governed), pctmx, pctcpu, u1, tcm_cur.wcte (i).pin_weight,
				(tcm_cur.wcte (i).purging = 1), tcm_cur.wcte (i).maxel,
				(tcm_cur.wcte (i).realtime ^= 0), (tcm_cur.wcte (i).flags.interactive_q), some_lcg (i));
		end;
	     end;

	     call ioa_ ("^/^[TCPU percents (%GUAR)^;IREST, IQUANT, RESP, QUANT^] control non-realtime work_classes.^/",
		(tcm_cur.deadline_mode = 0));


	end;					/* END REPORTING */


	if resetting then do;
	     call metering_util_$reset (unique, code);
	     if code ^= 0 then do;
		call com_err_ (code, MYNAME, "Resetting");
		return;
	     end;
	     time_reset = time_now;
	end;

	return;
%page;
fill_lcg: proc;
dcl  j fixed bin;

	some_lcg (*) = "";
	some_lcg (0) = "Init";

	if mgtp = null () then do;
	     call hcs_$initiate (">system_control_1", "mgt", "", 0b, 1b, mgtp, code);
	     if mgtp = null () then do;
		call ioa_ ("Unable to access mgt.");
		return;
	     end;
	end;
	if static_ansp = null () then do;
	     call hcs_$initiate (">system_control_1", "answer_table", "", 0b, 1b, static_ansp, code);
	     if static_ansp = null () then do;
		call ioa_ ("Unable to access answer_table");
		return;
	     end;
	end;
	ansp = static_ansp;

	curshift = anstbl.shift;
						/* see if can suppress news about abs */
	sole_abs_wc = -1;
	do j = 17 to mgt.current_size;
	     mgtep = addr (mgt.entry (j));
	     if sole_abs_wc = -1 then sole_abs_wc = group.abs_wc (curshift);
	     else if sole_abs_wc ^= group.abs_wc (curshift) then sole_abs_wc = -2;
	end;
	do j = 17 to mgt.current_size;
	     mgtep = addr (mgt.entry (j));
	     some_lcg (group.int_wc (curshift)) = some_lcg (group.int_wc (curshift))
		|| substr (group.group_id, 1, 9 - verify (reverse (group.group_id), " "))
		|| " ";
	     if group.abs_wc (curshift) ^= group.int_wc (curshift) then
		if sole_abs_wc < 0 then
		     some_lcg (group.abs_wc (curshift)) = some_lcg (group.abs_wc (curshift))
			|| "("
			|| substr (group.group_id, 1, 9 - verify (reverse (group.group_id), " "))
			|| ") ";
	end;
	if sole_abs_wc > 0 then some_lcg (sole_abs_wc)
		= some_lcg (sole_abs_wc) || " (All absentee)";


     end fill_lcg;

%page; %include answer_table;
%page; %include hc_lock;
%page; %include mgt;
%page; %include tcm;
%page; %include user_table_header;

     end wcm;


		    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